summaryrefslogtreecommitdiff
path: root/guile/email-key-rotation/gandi.scm
blob: ae9cc841e38ec743c7978114b1b80de04768784e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
(define-module (email-key-rotation gandi)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (sxml match)
  #:use-module (web client)
  #:use-module (web uri)
  #:export (<gandi-configuration>
	    make-gandi-configuration
	    gandi-configuration?
	    api-key set-api-key
	    domain set-domain
	    sxml->configuration
	    configuration->sxml
	    gandi-livedns-request)
  #:declarative? #t)

(define-immutable-record-type <gandi-configuration>
  (make-gandi-configuration api-key domain)
  gandi-configuration?
  (api-key api-key set-api-key)
  (domain domain set-domain))

(define* (gandi-livedns-request configuration
				domain
				path-under-domain
				#:key
				(method 'GET)
				(headers '())
				(body #f)
				(http-request http-request))
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-exception-with-origin 'gandi-http-request)
	  (make-exception-with-irritants (list configuration
					       path-under-domain
					       headers
					       body))
	  (make-exception-with-message
	   "cannot request Gandi livedns.")
	  exn)))
    (lambda ()
      (unless (list? path-under-domain)
	(raise-exception
	 (make-exception
	  (make-error)
	  (make-exception-with-irritants (list path-under-domain))
	  (make-exception-with-message
	   "the PATH-UNDER-DOMAIN argument must be a list of path items."))))
      (let ((uri (build-uri
		  'https
		  #:host "api.gandi.net"
		  #:path
		  (string-append
		   "/"
		   (encode-and-join-uri-path
		    `("v5"
		      "livedns"
		      "domains"
		      ,domain
		      ,@path-under-domain)))))
	    (headers
	     `((Authorization
		. ,(string-append "ApiKey " (api-key configuration)))
	       ,@headers)))
	(http-request uri
		      #:method method
		      #:headers headers
		      #:body body)))))

(define (sxml->configuration sxml)
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-error)
	  (make-exception-with-origin 'sxml->configuration)
	  (make-exception-with-irritants (list sxml))
	  (make-exception-with-message
	   "cannot read the XML fragment as a gandi configuration.")
	  exn)))
    (lambda ()
      (sxml-match
       sxml
       ((https://planete-kraus.eu/ns/email-key-rotation:gandi-configuration
	 (@ (api-key ,api-key)
	    (domain ,domain)))
	(make-gandi-configuration api-key domain))))))

(define (configuration->sxml gandi)
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-exception-with-origin 'configuration->sxml)
	  (make-exception-with-irritants (list gandi))
	  (make-exception-with-message
	   "when converting a gandi configuration to SXML:")
	  exn)))
    (lambda ()
      (match gandi
	(($ <gandi-configuration> api-key domain)
	 `(gandi-configuration (@ (api-key ,api-key)
				  (domain ,domain))))))))