Rotate DKIM keys

11 files changed, 1009 insertions, 0 deletions

diff --git a/email-key-rotation.scm b/email-key-rotation.scm
new file mode 100644
index 0000000..8324cf2
--- /dev/null
+++ b/email-key-rotation.scm
@@ -0,0 +1,72 @@
+(define-module (email-key-rotation)
+  #:use-module (email-key-rotation state)
+  #:use-module (email-key-rotation dkimproxy)
+  #:use-module (email-key-rotation openssl)
+  #:use-module (email-key-rotation serialize)
+  #:use-module (email-key-rotation gandi)
+  #:use-module (email-key-rotation rotation)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:re-export (current-openssl-binary
+	       current-dkimproxy.out-binary)
+  #:export (initialize-keys
+	    rotate-keys
+	    run-dkimproxy.out)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define (initialize-keys state-file private-key-file selectors api-key domain)
+  (parameterize ((gandi-api-key api-key)
+		 (gandi-domain domain))
+    (with-exception-handler
+	(lambda (exn)
+	  (raise-exception
+	   (make-exception
+	    (make-exception-with-origin 'initialize-keys)
+	    (make-exception-with-irritants (list state-file private-key-file selectors))
+	    (make-exception-with-message
+	     (format #f "while initializing keys under ~s:" state-file))
+	    exn)))
+      (lambda ()
+	(let ((state (initialize-rotation private-key-file selectors)))
+	  (call-with-output-file state-file
+	    (lambda (port)
+	      (write-state state port)))
+	  (gandi-livedns state))))))
+
+(define (rotate-keys state-file api-key domain)
+  (parameterize ((gandi-api-key api-key)
+		 (gandi-domain domain))
+    (with-exception-handler
+	(lambda (exn)
+	  (raise-exception
+	   (make-exception
+	    (make-exception-with-origin 'rotate-keys)
+	    (make-exception-with-irritants (list state-file))
+	    (make-exception-with-message
+	     (format #f "while rotating keys under ~s:" state-file))
+	    exn)))
+      (lambda ()
+	(let* ((state (call-with-input-file state-file
+			read-state))
+	       (rotated (rotate-dkim-key state)))
+	  (call-with-output-file state-file
+	    (lambda (port)
+	      (write-state rotated port)))
+	  (gandi-livedns rotated))))))
+
+(define (run-dkimproxy.out state-file input-port relay-port domain)
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'run-dkimproxy.out)
+	  (make-exception-with-irritants (list state-file input-port relay-port domain))
+	  (make-exception-with-message
+	   (format #f "while running dkimproxy.out with ~s:" state-file))
+	  exn)))
+    (lambda ()
+      (let ((state (call-with-input-file state-file
+		     read-state)))
+	(run-dkimproxy state input-port relay-port domain)))))
diff --git a/email-key-rotation/dkimproxy.scm b/email-key-rotation/dkimproxy.scm
new file mode 100644
index 0000000..65d2e56
--- /dev/null
+++ b/email-key-rotation/dkimproxy.scm
@@ -0,0 +1,58 @@
+(define-module (email-key-rotation dkimproxy)
+  #:use-module (email-key-rotation state)
+  #:use-module (email-key-rotation prepare)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:export (current-dkimproxy.out-binary
+	    run-dkimproxy)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define current-dkimproxy.out-binary
+  (make-parameter "dkimproxy.out"))
+
+(define-method (run-dkimproxy (s <email-key-rotation-state>)
+			      input-port relay-port domain)
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'run-dkimproxy)
+	  (make-exception-with-irritants
+	   (list s input-port relay-port domain))
+	  (make-exception-with-message
+	   "cannot run dkimproxy.")
+	  exn)))
+    (lambda ()
+      (set! s (the-email-key-rotation-state s))
+      (prepare s)
+      (let ((dkimproxy.out (current-dkimproxy.out-binary)))
+	(with-exception-handler
+	    (lambda (exn)
+	      (raise-exception
+	       (make-exception
+		(make-exception-with-irritants (list dkimproxy.out))
+		(make-exception-with-message
+		 (format #f "the dkimproxy.out binary is ~s."
+			 dkimproxy.out))
+		exn)))
+	  (lambda ()
+	    (let* ((command-line
+		    (list dkimproxy.out
+			  (format #f "--listen=localhost:~a" input-port)
+			  (format #f "--relay=localhost:~a" relay-port)
+			  (format #f "--domain=~a" domain)
+			  (format #f "--keyfile=~a"
+				  (private-key-file s))
+			  (format #f "--selector=~a"
+				  (current-dkim-selector s))))
+		   (ret (apply system* command-line)))
+	      (unless (eqv? 0 (status:exit-val ret))
+		(raise-exception
+		 (make-exception
+		  (make-error)
+		  (make-exception-with-irritants
+		   (list command-line))
+		  (make-exception-with-message
+		   (format #f "cannot run dkimproxy.out"))))))))))))
diff --git a/email-key-rotation/dns.scm b/email-key-rotation/dns.scm
new file mode 100644
index 0000000..1a7d7cc
--- /dev/null
+++ b/email-key-rotation/dns.scm
@@ -0,0 +1,67 @@
+(define-module (email-key-rotation dns)
+  #:use-module (email-key-rotation state)
+  #:use-module (email-key-rotation openssl)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:export (dns-txt-records)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define (public-key->dkim-record public-key)
+  ;; Discard the first and last lines and remove newlines
+  (call-with-output-string
+    (lambda (out)
+      (format out "v=DKIM1; k=rsa; t=s; p=")
+      (call-with-input-string public-key
+	(lambda (port)
+	  (let collect-lines ((carry #f)
+			      (first? #t))
+	    (let ((next (read-line port)))
+	      (unless (eof-object? next)
+		(when carry
+		  (display carry out))
+		(collect-lines (if first? #f next)
+			       #f)))))))))
+
+(define-method (dns-txt-records (s <email-key-rotation-state>))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'dns-txt-record)
+	  (make-exception-with-irritants (list s))
+	  (make-exception-with-message
+	   "cannot generate the DNS TXT record.")
+	  exn)))
+    (lambda ()
+      (let ((s (the-email-key-rotation-state s)))
+	(let ((current-public-key
+	       (public-key->dkim-record
+		(private-key->public-key
+		 (current-dkim-private-key s))))
+	      (expired-public-key
+	       (let ((k (expired-dkim-private-key s)))
+		 (if k
+		     (public-key->dkim-record
+		      (private-key->public-key
+		       (expired-dkim-private-key s)))
+		     (public-key->dkim-record
+		      "NO PUBLIC KEY\nunavailable\nDONE")))))
+	  (let ((previous-selector
+		 (match (memq (current-dkim-selector s)
+			      (reverse (append (selectors s)
+					       (selectors s))))
+		   ((_ previous _ ...)
+		    (string-append (symbol->string previous)
+				   "._domainkey"))
+		   (_
+		    (error "impossible, (selectors s) is non-empty."))))
+		(current-selector
+		 (string-append
+		  (symbol->string (current-dkim-selector s))
+		  "._domainkey")))
+	    `((,current-selector "TXT" ,current-public-key)
+	      (,previous-selector "TXT" ,expired-public-key))))))))
diff --git a/email-key-rotation/gandi.scm b/email-key-rotation/gandi.scm
new file mode 100644
index 0000000..006fac4
--- /dev/null
+++ b/email-key-rotation/gandi.scm
@@ -0,0 +1,109 @@
+(define-module (email-key-rotation gandi)
+  #:use-module (email-key-rotation state)
+  #:use-module (email-key-rotation dns)
+  #:use-module (json)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web client)
+  #:use-module (oop goops)
+  #:export (current-http-request
+	    gandi-api-key
+	    gandi-domain
+	    gandi-livedns)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define gandi-api-key
+  (make-parameter #f))
+
+(define gandi-domain
+  (make-parameter #f))
+
+(define current-http-request
+  (make-parameter http-request))
+
+(define-method (gandi-livedns (s <email-key-rotation-state>))
+  (let ((api-key (gandi-api-key))
+	(domain (gandi-domain)))
+    (with-exception-handler
+	(lambda (exn)
+	  (raise-exception
+	   (make-exception
+	    (make-exception-with-origin 'gandi-livedns)
+	    (make-exception-with-irritants (list s domain))
+	    (make-exception-with-message
+	     "cannot update the Gandi livedns.")
+	    exn)))
+      (lambda ()
+	(unless (string? api-key)
+	  (raise-exception
+	   (make-exception
+	    (make-error)
+	    (make-exception-with-message
+	     "the API key is missing."))))
+	(unless (string? domain)
+	  (raise-exception
+	   (make-exception
+	    (make-error)
+	    (make-exception-with-message
+	     "the domain is missing."))))
+	(set! s (the-email-key-rotation-state s))
+	(let send-requests ((records (dns-txt-records s)))
+	  (match records
+	    (()
+	     #t)
+	    (((name type value) records ...)
+	     (let ((uri (build-uri
+			 'https
+			 #:host "api.gandi.net"
+			 #:path
+			 (string-append
+			  "/"
+			  (encode-and-join-uri-path
+			   `("v5"
+			     "livedns"
+			     "domains" ,domain
+			     "records" ,name
+			     ,type)))))
+		   (headers
+		    `((Authorization
+		       . ,(string-append "ApiKey " api-key))
+		      (content-type . (application/json))))
+		   (body
+		    (string->utf8
+		     (scm->json-string
+		      `((rrset_values
+			 . ,(list->vector (list value))))))))
+	       (receive (response response-body)
+		   ((current-http-request)
+		    uri
+		    #:method 'POST
+		    #:headers headers
+		    #:body body)
+		 (when (eqv? (response-code response) 409)
+		   ;; Retry with put
+		   (receive (put-response put-body)
+		       ((current-http-request)
+			uri
+			#:method 'PUT
+			#:headers headers
+			#:body body)
+		     (set! response put-response)
+		     (set! response-body put-body)))
+		 (unless (or (eqv? (response-code response) 200)
+                             (eqv? (response-code response) 201))
+		   (raise-exception
+		    (make-exception
+		     (make-exception-with-irritants (list response))
+		     (make-exception-with-message
+		      (format #f "the request failed with ~a ~a."
+			      (response-code response)
+			      (response-reason-phrase response)))))))
+	       (send-requests records)))))))))
diff --git a/email-key-rotation/openssl.scm b/email-key-rotation/openssl.scm
new file mode 100644
index 0000000..1d1935b
--- /dev/null
+++ b/email-key-rotation/openssl.scm
@@ -0,0 +1,93 @@
+(define-module (email-key-rotation openssl)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (oop goops)
+  #:export (current-openssl-binary
+	    generate-key
+	    private-key->public-key)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define current-openssl-binary
+  (make-parameter "openssl"))
+
+(define (generate-key rsa-strength)
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'generate-key)
+	  (make-exception-with-irritants (list rsa-strength))
+	  (make-exception-with-message
+	   "cannot generate a private key.")
+	  exn)))
+    (lambda ()
+      (let ((port (mkstemp "/tmp/generate-openssl-key-XXXXXX"))
+	    (openssl (current-openssl-binary)))
+	(dynamic-wind
+	  (lambda () #t)
+	  (lambda ()
+	    (chmod port #o600)
+	    (let ((ret (system* openssl
+				"genrsa"
+				"-out" (port-filename port)
+				(number->string rsa-strength))))
+	      (unless (eqv? 0 (status:exit-val ret))
+		(raise-exception
+		 (make-exception
+		  (make-error)
+		  (make-exception-with-origin 'generate-key)
+		  (make-exception-with-irritants
+		   (list openssl "genrsa" "-out" "<deleted>"
+			 (number->string rsa-strength)))
+		  (make-exception-with-message
+		   (format #f "openssl failed to generate a RSA key pair with strength ~s."
+			   (number->string rsa-strength)))))))
+	    (call-with-input-file (port-filename port) get-string-all))
+	  (lambda ()
+	    (delete-file (port-filename port))))))))
+
+(define (private-key->public-key key)
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'private-key->public-key)
+	  (make-exception-with-irritants (list key))
+	  (make-exception-with-message
+	   "cannot convert the private key to public key.")
+	  exn)))
+    (lambda ()
+      (let ((input-port (mkstemp "/tmp/openssl-private-key-XXXXXX"))
+	    (output-port (mkstemp "/tmp/openssl-public-key-XXXXXX"))
+	    (openssl (current-openssl-binary)))
+	(dynamic-wind
+	  (lambda () #t)
+	  (lambda ()
+	    (chmod input-port #o600)
+	    (chmod output-port #o600)
+	    (call-with-output-file (port-filename input-port)
+	      (lambda (init-port)
+		(display key init-port)))
+	    (let ((ret (system* openssl
+				"rsa"
+				"-in" (port-filename input-port)
+				"-out" (port-filename output-port)
+				"-pubout")))
+	      (unless (eqv? 0 (status:exit-val ret))
+		(raise-exception
+		 (make-exception
+		  (make-error)
+		  (make-exception-with-origin 'generate-key)
+		  (make-exception-with-irritants
+		   (list openssl "rsa"
+			 "-in" "<deleted>"
+			 "-out" "<deleted>"
+			 "-pubout"))
+		  (make-exception-with-message
+		   (format #f "openssl failed to extract the public key."))))))
+	    (call-with-input-file (port-filename output-port) get-string-all))
+	  (lambda ()
+	    (delete-file (port-filename input-port))
+	    (delete-file (port-filename output-port))))))))
diff --git a/email-key-rotation/prepare.scm b/email-key-rotation/prepare.scm
new file mode 100644
index 0000000..4d91693
--- /dev/null
+++ b/email-key-rotation/prepare.scm
@@ -0,0 +1,47 @@
+(define-module (email-key-rotation prepare)
+  #:use-module (email-key-rotation state)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:export (prepare)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define-method (prepare (s <email-key-rotation-state>))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'prepare)
+	  (make-exception-with-irritants (list s))
+	  (make-exception-with-message
+	   "cannot write the private key to file.")
+	  exn)))
+    (lambda ()
+      (set! s (the-email-key-rotation-state s))
+      (let ((key-file (private-key-file s)))
+	(with-exception-handler
+	    (lambda (exn)
+	      (raise-exception
+	       (make-exception
+		(make-exception-with-irritants (list key-file))
+		(make-exception-with-message
+		 (format #f
+			 "cannot write the private key to file ~s."
+			 key-file))
+		exn)))
+	  (lambda ()
+	    (unless (string? key-file)
+	      (raise-exception
+	       (make-exception
+		(make-error)
+		(make-exception-with-message
+		 "the key file is missing."))))
+	    (let ((private-key (current-dkim-private-key s)))
+	      (call-with-output-file key-file
+		(lambda (port)
+		  (chmod port #o600)
+		  (display private-key port))))))))))
diff --git a/email-key-rotation/rotation.scm b/email-key-rotation/rotation.scm
new file mode 100644
index 0000000..a34490f
--- /dev/null
+++ b/email-key-rotation/rotation.scm
@@ -0,0 +1,58 @@
+(define-module (email-key-rotation rotation)
+  #:use-module (email-key-rotation state)
+  #:use-module (email-key-rotation openssl)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:export (initialize-rotation rotate-dkim-key)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define (initialize-rotation private-key-file selectors)
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'initialize-dkim-key)
+	  (make-exception-with-irritants (list private-key-file selectors))
+	  (make-exception-with-message
+	   "cannot initialize the key rotation.")
+	  exn)))
+    (lambda ()
+      (the-email-key-rotation-state
+       (make <email-key-rotation-state>
+	 #:private-key-file private-key-file
+	 #:selectors selectors
+	 #:current-dkim-selector (car selectors)
+	 #:current-dkim-private-key
+	 (generate-key 2048))))))
+
+(define-method (rotate-dkim-key (s <email-key-rotation-state>))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'rotate-dkim-key)
+	  (make-exception-with-irritants (list s))
+	  (make-exception-with-message
+	   "cannot rotate the DKIM private key.")
+	  exn)))
+    (lambda ()
+      (let ((ret (shallow-clone (the-email-key-rotation-state s))))
+	(slot-set! ret 'expired-dkim-private-key
+		   (slot-ref s 'current-dkim-private-key))
+	(slot-set! ret 'current-dkim-private-key
+		   (generate-key 2048))
+	(slot-set!
+	 ret 'current-dkim-selector
+	 (match (memq (current-dkim-selector s)
+		      (selectors s))
+	   (#f
+	    (error "cannot happen, the state has been validated"))
+	   ((_)
+	    ;; The current selector is the last, start from the head
+	    ;; again.
+	    (car (selectors s)))
+	   ((_ next _ ...)
+	    next)))
+	ret))))
diff --git a/email-key-rotation/run-tests.scm b/email-key-rotation/run-tests.scm
new file mode 100644
index 0000000..d88cad3
--- /dev/null
+++ b/email-key-rotation/run-tests.scm
@@ -0,0 +1,5 @@
+(define-module (email-key-rotation run-tests)
+  #:use-module (email-key-rotation tests)
+  #:declarative? #t)
+
+(run-tests)
diff --git a/email-key-rotation/serialize.scm b/email-key-rotation/serialize.scm
new file mode 100644
index 0000000..e79d955
--- /dev/null
+++ b/email-key-rotation/serialize.scm
@@ -0,0 +1,60 @@
+(define-module (email-key-rotation serialize)
+  #:use-module (email-key-rotation state)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:export (read-state write-state)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define* (read-state #:optional (port (current-input-port)))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'read-state)
+	  (make-exception-with-irritants (list port))
+	  (make-exception-with-message
+	   "while reading the current state file:")
+	  exn)))
+    (lambda ()
+      (match (read port)
+	(('email-key-rotation-state
+	  private-key-file
+	  (selectors ...)
+	  selector
+	  current-key
+	  expired-key)
+	 (the-email-key-rotation-state
+	  (make <email-key-rotation-state>
+	    #:private-key-file private-key-file
+	    #:selectors selectors
+	    #:current-dkim-selector selector
+	    #:current-dkim-private-key current-key
+	    #:expired-dkim-private-key expired-key)))))))
+
+(define* (write-state state #:optional (port (current-output-port)))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-exception-with-origin 'write-state)
+	  (make-exception-with-irritants (list state port))
+	  (make-exception-with-message
+	   "cannot write the new state:")
+	  exn)))
+    (lambda ()
+      (when (file-port? port)
+	(chmod port #o600)
+	(let ((state (the-email-key-rotation-state state)))
+	  (write `(email-key-rotation-state
+		   ,(private-key-file state)
+		   (,@(selectors state))
+		   ,(current-dkim-selector state)
+		   ,(current-dkim-private-key state)
+		   ,(expired-dkim-private-key state))
+		 port))))))
diff --git a/email-key-rotation/state.scm b/email-key-rotation/state.scm
new file mode 100644
index 0000000..26d7fbe
--- /dev/null
+++ b/email-key-rotation/state.scm
@@ -0,0 +1,156 @@
+(define-module (email-key-rotation state)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:re-export (make)
+  #:export (<email-key-rotation-state>
+	    private-key-file
+	    selectors
+	    current-dkim-selector
+	    current-dkim-private-key
+	    expired-dkim-private-key
+	    set-private-key-file
+	    set-selectors
+	    set-current-dkim-selector
+	    set-current-dkim-private-key
+	    set-expired-dkim-private-key
+	    the-email-key-rotation-state)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define-class <email-key-rotation-state> ()
+  (private-key-file #:init-keyword #:private-key-file)
+  (selectors #:init-keyword #:selectors)
+  (current-dkim-selector #:init-keyword #:current-dkim-selector)
+  (current-dkim-private-key #:init-keyword #:current-dkim-private-key)
+  (expired-dkim-private-key #:init-keyword #:expired-dkim-private-key
+			    #:init-value #f))
+
+(define-method (private-key-file (s <email-key-rotation-state>))
+  (slot-ref s 'private-key-file))
+
+(define-method (selectors (s <email-key-rotation-state>))
+  (slot-ref s 'selectors))
+
+(define-method (current-dkim-selector (s <email-key-rotation-state>))
+  (slot-ref s 'current-dkim-selector))
+
+(define-method (current-dkim-private-key (s <email-key-rotation-state>))
+  (slot-ref s 'current-dkim-private-key))
+
+(define-method (expired-dkim-private-key (s <email-key-rotation-state>))
+  (slot-ref s 'expired-dkim-private-key))
+
+(define-method (set-private-key-file (s <email-key-rotation-state>) filename)
+  (let ((ret (shallow-clone s)))
+    (slot-set! ret 'private-key-file filename)
+    ret))
+
+(define-method (set-selectors (s <email-key-rotation-state>) selectors)
+  (let ((ret (shallow-clone s)))
+    (slot-set! ret 'selectors selectors)
+    ret))
+
+(define-method (set-current-dkim-selector (s <email-key-rotation-state>) selector)
+  (let ((ret (shallow-clone s)))
+    (slot-set! ret 'current-dkim-selector selector)
+    ret))
+
+(define-method (set-expired-dkim-private-key (s <email-key-rotation-state>) private-key)
+  (let ((ret (shallow-clone s)))
+    (slot-set! ret 'expired-dkim-private-key private-key)
+    ret))
+
+(define-method (the-email-key-rotation-state (s <email-key-rotation-state>))
+  (with-exception-handler
+      (lambda (exn)
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-origin 'the-email-key-rotation-state)
+	  (make-exception-with-irritants (list s))
+	  (make-exception-with-message
+	   (format #f "the email key rotation state is invalid."))
+	  exn)))
+    (lambda ()
+      (unless (slot-bound? s 'private-key-file)
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-message
+	   (format #f "the private key file name is not bound.")))))
+      (unless (string? (private-key-file s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (private-key-file s)))
+	  (make-exception-with-message
+	   (format #f "the private key file name is not a string.")))))
+      (unless (list? (selectors s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (selectors s)))
+	  (make-exception-with-message
+	   (format #f "the collection of selectors is not a list.")))))
+      (when (null? (selectors s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-message
+	   (format #f "the list of selectors is empty.")))))
+      (when (null? (cdr (selectors s)))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-message
+	   (format #f "the list of selectors has only 1 item, cannot rotate anything with that.")))))
+      (let check ((sel (selectors s))
+		  (i 0))
+	(match sel
+	  (() #t)
+	  (((? symbol? _) sel ...)
+	   (check sel (+ i 1)))
+	  ((not-a-symbol _ ...)
+	   (raise-exception
+	    (make-exception
+	     (make-error)
+	     (make-exception-with-irritants (list i not-a-symbol))
+	     (make-exception-with-message
+	      (format #f "at least one item of the list of selectors is not a symbol (first: ~a is ~s)."
+		      i not-a-symbol)))))))
+      (unless (symbol? (current-dkim-selector s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (current-dkim-selector s)))
+	  (make-exception-with-message
+	   (format #f "the current DKIM selector is not a symbol (~s)."
+		   (current-dkim-selector s))))))
+      (unless (memq (current-dkim-selector s)
+		    (selectors s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (current-dkim-selector s)
+					       (selectors s)))
+	  (make-exception-with-message
+	   (format #f "the current DKIM selector ~s is not part of the list of selectors ~s."
+		   (current-dkim-selector s)
+		   (selectors s))))))
+      (unless (string? (current-dkim-private-key s))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (current-dkim-private-key s)))
+	  (make-exception-with-message
+	   (format #f "the current DKIM private key is not a string.")))))
+      (unless (or (not (expired-dkim-private-key s))
+		  (string? (expired-dkim-private-key s)))
+	(raise-exception
+	 (make-exception
+	  (make-error)
+	  (make-exception-with-irritants (list (current-dkim-private-key s)))
+	  (make-exception-with-message
+	   (format #f "the expired DKIM private key is set, but not a string.")))))))
+  s)
diff --git a/email-key-rotation/tests.scm b/email-key-rotation/tests.scm
new file mode 100644
index 0000000..1243140
--- /dev/null
+++ b/email-key-rotation/tests.scm
@@ -0,0 +1,284 @@
+(define-module (email-key-rotation tests)
+  #:use-module (email-key-rotation)
+  #:use-module (email-key-rotation gandi)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 optargs)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:export (fake-openssl-binary-main
+	    fake-dkimproxy.out-main
+	    run-tests)
+  #:declarative? #t)
+
+(define (fake-openssl-binary-main seed)
+  (format (current-error-port) "Entering the fake openssl binary, with seed ~s...\n" seed)
+  (match (command-line)
+    ((_ "genrsa" "-out" output-file "2048")
+     (call-with-output-file output-file
+       (lambda (port)
+	 (format (current-error-port) "I am writing ~a with a fake private key with seed ~s.\n" output-file seed)
+	 (format port "BEGIN FAKE PRIVATE KEY
+blah blah private key with seed ~a
+END OF FAKE PRIVATE KEY"
+		 seed))))
+    ((_ "rsa" "-in" private-key-file "-out" public-key-file "-pubout")
+     (let ((private-key
+	    (call-with-input-file
+		private-key-file
+	      get-string-all))
+	   (prefx "BEGIN FAKE PRIVATE KEY
+blah blah private key with seed ")
+	   (suffx "
+END OF FAKE PRIVATE KEY"))
+       (unless (and (string-prefix? prefx private-key)
+		    (string-suffix? suffx private-key))
+	 (format (current-error-port) "The input file is:\n~a\n"
+		 private-key)
+	 (error "This is a fake openssl, I can only process fake private keys."))
+       (let ((seed
+	      (substring private-key
+			 (string-length prefx)
+			 (- (string-length private-key)
+			    (string-length suffx)))))
+	 (call-with-output-file public-key-file
+	   (lambda (port)
+	     (format port "BEGIN FAKE PUBLIC KEY
+blah blah public key
+blah blah blah with seed ~a
+END OF FAKE PUBLIC KEY"
+		     seed))))))
+    (cmdline
+     (format (current-error-port) "Command-line: ~s\n" cmdline)
+     (error "Wrong use of the fake openssl."))))
+
+(define (fake-dkimproxy.out-main seed expected-selector)
+  (format (current-error-port) "Starting the fake dkimproxy.out, expecting a private key with seed ~s and selector ~s\n" seed expected-selector)
+  (match (command-line)
+    ((_ "--listen=localhost:9000"
+	"--relay=localhost:9001"
+	"--domain=awesome-domain.net"
+	(? (cute string-prefix? "--keyfile=" <>)
+	   (= (cute substring <> (string-length "--keyfile="))
+	      private-key-file))
+	(? (cute equal? <>
+		 (format #f "--selector=~a" expected-selector))))
+     (begin
+       (call-with-input-file private-key-file
+	 (lambda (check-port)
+	   (let ((everything (get-string-all check-port)))
+	     (unless (equal? everything
+			     (format #f
+				     "BEGIN FAKE PRIVATE KEY
+blah blah private key with seed ~a
+END OF FAKE PRIVATE KEY"
+				     seed))
+	       (format (current-error-port) "The input file is:\n~a\n"
+		       everything)
+	       (error "The input key is unexpected for the fake dkimproxy.out.")))))
+       #t))
+    (cmdline
+     (format (current-error-port) "Command-line: ~s\n" cmdline)
+     (error "Wrong use of the fake dkimproxy.out."))))
+
+(define (fake-http-request possible-selectors when-done)
+  (lambda* (uri #:key method headers body)
+    (format (current-error-port) "Responding to ~a ~a (~s, ~s)...\n"
+	    method (uri->string uri)
+	    headers (utf8->string body))
+    (format (current-error-port) "Expecting: any of ~s\n"
+	    possible-selectors)
+    (let check-uri ((candidates possible-selectors))
+      (match candidates
+	(()
+	 (error "Unexpected gandi request URI"))
+	(((selector . seed) candidates ...)
+	 (let ((expected-uri
+		(string->uri
+		 (format #f
+			 "https://api.gandi.net/v5/livedns/domains/awesome-domain.net/records/~a._domainkey/TXT"
+			 selector)))
+	       (expected-body
+		(format #f
+			"{\"rrset_values\":[\"v=DKIM1; k=rsa; t=s; p=~a\"]}"
+			(if seed
+			    (format #f "blah blah public keyblah blah blah with seed ~a" seed)
+			    "unavailable"))))
+	   (if (and (equal? uri expected-uri)
+		    (equal? headers
+			    `((Authorization . "ApiKey letmein")
+			      (content-type . (application/json))))
+		    (equal? body (string->utf8 expected-body)))
+	       (begin
+		 (when-done selector)
+		 (values (build-response) ""))
+	       ;; Else:
+	       (begin
+		 (format (current-error-port) "Not this candidate: ~s ~s ~s\n"
+			 (uri->string expected-uri)
+			 headers
+			 expected-body)
+		 (check-uri candidates)))))))))
+
+(define (wrap-script script-name s-expr)
+  (call-with-output-file (string-append script-name ".real")
+    (lambda (port)
+      (format port "#! /usr/local/bin/guile -s
+!#
+
+~s
+(use-modules (email-key-rotation tests))
+~s"
+	      `(begin
+		 ,@(map
+		    (lambda (path)
+		      `(add-to-load-path ,path))
+		    (reverse %load-path)))
+	      s-expr)
+      (chmod port #o755)))
+  (call-with-output-file script-name
+    (lambda (port)
+      (format port "#!/bin/sh
+guile ~a.real \"$@\""
+	      script-name)
+      (chmod port #o755)))
+  script-name)
+
+(define (run-tests)
+  ;; The process is:
+  ;;
+  ;; 1. We generate a new key pair with seed 0.
+  ;; 2. We run dkimproxy.out, it expects seed 0.
+  ;; 3. We rotate the key pair, it now generates a seed 1.
+  ;; 4. We run dkimproxy.out again, it expects seed 1.
+  ;; 3. We rotate the key pair, it now generates a seed 2.
+  ;; 4. We run dkimproxy.out again, it expects seed 2.
+  ;;
+  ;; First step is to generate a new key pair.
+  (let ((dkimA-notified #f)
+	(dkimB-notified #f))
+    (parameterize ((current-openssl-binary
+		    (wrap-script
+		     "./fake-openssl-0"
+		     '(begin
+			(use-modules (email-key-rotation tests))
+			(fake-openssl-binary-main 0))))
+		   (current-http-request
+		    (fake-http-request
+		     `((dkimA . 0)
+		       (dkimB . #f))
+		     (match-lambda
+		       ('dkimA
+			(begin
+			  (when dkimA-notified
+			    (error "already done"))
+			  (set! dkimA-notified #t)))
+		       ('dkimB
+			(begin
+			  (when dkimB-notified
+			    (error "already done"))
+			  (set! dkimB-notified #t)))))))
+      (initialize-keys "current-state.scm"
+		       "current-private-key"
+		       '(dkimA dkimB)
+		       "letmein"
+		       "awesome-domain.net")
+      (unless (and dkimA-notified dkimB-notified)
+	(error "no gandi request"))))
+  ;; Then run dkimproxy.out
+  (parameterize
+      ((current-dkimproxy.out-binary
+	(wrap-script
+	 "./fake-dkimproxy.out-0"
+	 '(begin
+	    (use-modules (email-key-rotation tests))
+	    (fake-dkimproxy.out-main 0 'dkimA)))))
+    (run-dkimproxy.out "current-state.scm"
+		       9000
+		       9001
+		       "awesome-domain.net"))
+  ;; Then rotate
+  (let ((dkimA-notified #f)
+	(dkimB-notified #f))
+    (parameterize ((current-openssl-binary
+		    (wrap-script
+		     "./fake-openssl-1"
+		     '(begin
+			(use-modules (email-key-rotation tests))
+			(fake-openssl-binary-main 1))))
+		   (current-http-request
+		    (fake-http-request
+		     `((dkimA . 0)
+		       (dkimB . 1))
+		     (match-lambda
+		       ('dkimA
+			(begin
+			  (when dkimA-notified
+			    (error "already done"))
+			  (set! dkimA-notified #t)))
+		       ('dkimB
+			(begin
+			  (when dkimB-notified
+			    (error "already done"))
+			  (set! dkimB-notified #t)))))))
+      (rotate-keys "current-state.scm"
+		   "letmein"
+		   "awesome-domain.net")
+      (unless (and dkimA-notified dkimB-notified)
+	(error "no gandi request"))))
+  ;; Then run dkimproxy.out
+  (parameterize
+      ((current-dkimproxy.out-binary
+	(wrap-script
+	 "./fake-dkimproxy.out-1"
+	 '(begin
+	    (use-modules (email-key-rotation tests))
+	    (fake-dkimproxy.out-main 1 'dkimB)))))
+    (run-dkimproxy.out "current-state.scm"
+		       9000
+		       9001
+		       "awesome-domain.net"))
+  ;; Then rotate
+  (let ((dkimA-notified #f)
+	(dkimB-notified #f))
+    (parameterize ((current-openssl-binary
+		    (wrap-script
+		     "./fake-openssl-2"
+		     '(begin
+			(use-modules (email-key-rotation tests))
+			(fake-openssl-binary-main 2))))
+		   (current-http-request
+		    (fake-http-request
+		     `((dkimA . 2)
+		       (dkimB . 1))
+		     (match-lambda
+		       ('dkimA
+			(begin
+			  (when dkimA-notified
+			    (error "already done"))
+			  (set! dkimA-notified #t)))
+		       ('dkimB
+			(begin
+			  (when dkimB-notified
+			    (error "already done"))
+			  (set! dkimB-notified #t)))))))
+      (rotate-keys "current-state.scm"
+		   "letmein"
+		   "awesome-domain.net")
+      (unless (and dkimA-notified dkimB-notified)
+	(error "no gandi request"))))
+  ;; Then run dkimproxy.out
+  (parameterize
+      ((current-dkimproxy.out-binary
+	(wrap-script
+	 "./fake-dkimproxy.out-2"
+	 '(begin
+	    (use-modules (email-key-rotation tests))
+	    (fake-dkimproxy.out-main 2 'dkimA)))))
+    (run-dkimproxy.out "current-state.scm"
+		       9000
+		       9001
+		       "awesome-domain.net")))