From e057ade177360296c96b9edb43070d84771f0997 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Fri, 5 Jan 2024 22:43:45 +0100 Subject: Rotate DKIM keys --- email-key-rotation.scm | 72 ++++++++++ email-key-rotation/dkimproxy.scm | 58 ++++++++ email-key-rotation/dns.scm | 67 +++++++++ email-key-rotation/gandi.scm | 109 +++++++++++++++ email-key-rotation/openssl.scm | 93 +++++++++++++ email-key-rotation/prepare.scm | 47 +++++++ email-key-rotation/rotation.scm | 58 ++++++++ email-key-rotation/run-tests.scm | 5 + email-key-rotation/serialize.scm | 60 +++++++++ email-key-rotation/state.scm | 156 +++++++++++++++++++++ email-key-rotation/tests.scm | 284 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 1009 insertions(+) create mode 100644 email-key-rotation.scm create mode 100644 email-key-rotation/dkimproxy.scm create mode 100644 email-key-rotation/dns.scm create mode 100644 email-key-rotation/gandi.scm create mode 100644 email-key-rotation/openssl.scm create mode 100644 email-key-rotation/prepare.scm create mode 100644 email-key-rotation/rotation.scm create mode 100644 email-key-rotation/run-tests.scm create mode 100644 email-key-rotation/serialize.scm create mode 100644 email-key-rotation/state.scm create mode 100644 email-key-rotation/tests.scm 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 ) + 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 )) + (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 )) + (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" "" + (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" "" + "-out" "" + "-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 )) + (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 + #: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 )) + (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 + #: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 ( + 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 () + (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 )) + (slot-ref s 'private-key-file)) + +(define-method (selectors (s )) + (slot-ref s 'selectors)) + +(define-method (current-dkim-selector (s )) + (slot-ref s 'current-dkim-selector)) + +(define-method (current-dkim-private-key (s )) + (slot-ref s 'current-dkim-private-key)) + +(define-method (expired-dkim-private-key (s )) + (slot-ref s 'expired-dkim-private-key)) + +(define-method (set-private-key-file (s ) filename) + (let ((ret (shallow-clone s))) + (slot-set! ret 'private-key-file filename) + ret)) + +(define-method (set-selectors (s ) selectors) + (let ((ret (shallow-clone s))) + (slot-set! ret 'selectors selectors) + ret)) + +(define-method (set-current-dkim-selector (s ) selector) + (let ((ret (shallow-clone s))) + (slot-set! ret 'current-dkim-selector selector) + ret)) + +(define-method (set-expired-dkim-private-key (s ) 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 )) + (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"))) -- cgit v1.2.3