From 555b682bf4b25825c8d862a9f00570773e3906ee Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 8 Jan 2024 10:39:01 +0100 Subject: Rewrite in a purer style --- email-key-rotation.scm | 308 ++++++++++--- email-key-rotation/dkim.scm | 225 ++++++++++ email-key-rotation/dkimproxy.scm | 58 --- email-key-rotation/dns.scm | 122 +++--- email-key-rotation/gandi.scm | 197 ++++----- email-key-rotation/openssl.scm | 104 +++-- email-key-rotation/openstmpd.scm | 60 +++ email-key-rotation/prepare.scm | 85 ---- email-key-rotation/serialize.scm | 69 --- email-key-rotation/srs.scm | 122 ++++++ email-key-rotation/state.scm | 223 ---------- email-key-rotation/tests.scm | 557 +++++++++++------------- email-key-rotation/tests/fake-gandi-livedns.scm | 115 +++++ email-key-rotation/tests/fake-openssl.scm | 53 +++ 14 files changed, 1287 insertions(+), 1011 deletions(-) create mode 100644 email-key-rotation/dkim.scm delete mode 100644 email-key-rotation/dkimproxy.scm create mode 100644 email-key-rotation/openstmpd.scm delete mode 100644 email-key-rotation/prepare.scm delete mode 100644 email-key-rotation/serialize.scm create mode 100644 email-key-rotation/srs.scm delete mode 100644 email-key-rotation/state.scm create mode 100644 email-key-rotation/tests/fake-gandi-livedns.scm create mode 100644 email-key-rotation/tests/fake-openssl.scm diff --git a/email-key-rotation.scm b/email-key-rotation.scm index da6119e..686aafb 100644 --- a/email-key-rotation.scm +++ b/email-key-rotation.scm @@ -1,75 +1,259 @@ (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 (email-key-rotation prepare) + #:use-module ((email-key-rotation dkim) #:prefix dkim:) + #:use-module ((email-key-rotation srs) #:prefix srs:) + #:use-module ((email-key-rotation dns) #:prefix dns:) + #:use-module ((email-key-rotation gandi) #:prefix gandi:) + #:use-module ((email-key-rotation openssl) #:prefix openssl:) #: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)) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-9 gnu) + #:use-module (sxml match) + #:use-module (sxml simple) + #:use-module (web client) + #:export ( + make-configuration + configuration? + dkim-state + srs-state + private-opensmtpd-config-file + dkim-current-selector-file + dkim-current-key-file + gandi-configuration + set-dkim-state + set-srs-state + set-private-opensmtpd-config-file + set-dkim-current-selector-file + set-dkim-current-key-file + set-gandi-configuration + sxml->configuration + configuration->sxml + initialize + rotate + materialize) + #:declarative? #t) -(define (initialize-keys state-file private-key-file private-opensmtpd-config 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 private-opensmtpd-config selectors)) - (make-exception-with-message - (format #f "while initializing keys under ~s:" state-file)) - exn))) - (lambda () - (let ((state (initialize-rotation private-key-file private-opensmtpd-config selectors))) - (call-with-output-file state-file - (lambda (port) - (write-state state port))) - (prepare-opensmtpd-config state) - (gandi-livedns state)))))) +(define-immutable-record-type + (make-configuration dkim-state srs-state private-opensmtpd-config-file dkim-current-selector-file dkim-current-key-file gandi-configuration) + configuration? + (dkim-state dkim-state set-dkim-state) + (srs-state srs-state set-srs-state) + (private-opensmtpd-config-file private-opensmtpd-config-file set-private-opensmtpd-config-file) + (dkim-current-selector-file dkim-current-selector-file set-dkim-current-selector-file) + (dkim-current-key-file dkim-current-key-file set-dkim-current-key-file) + (gandi-configuration gandi-configuration set-gandi-configuration)) -(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-key state))) - (call-with-output-file state-file - (lambda (port) - (write-state rotated port))) - (prepare-opensmtpd-config rotated) - (gandi-livedns rotated)))))) +(define (refine-configuration/one subtree config) + (sxml-match + subtree + ((https://planete-kraus.eu/ns/email-key-rotation:with-dkim-state + ,dkim-state) + (set-dkim-state config (dkim:sxml->key dkim-state))) + ((https://planete-kraus.eu/ns/email-key-rotation:with-srs-state + ,srs-state) + (set-srs-state config (srs:sxml->key srs-state))) + ((https://planete-kraus.eu/ns/email-key-rotation:with-gandi-configuration + ,gandi-config) + (set-gandi-configuration config (gandi:sxml->configuration gandi-config))))) -(define (run-dkimproxy.out state-file input-port relay-port domain) +(define (refine-configuration subtrees config) + (match subtrees + (() config) + ((st rest ...) + (refine-configuration rest (refine-configuration/one st config))))) + +(define (essential-configuration-attributes tree) + (sxml-match + tree + ((https://planete-kraus.eu/ns/email-key-rotation:configuration + (@ . ,attributes) + ,state ...) + (values attributes (list state ...))) + ((*TOP* ,true-thing) + (essential-configuration-attributes true-thing)))) + +(define car-if-true + (match-lambda + ((x) x) + (_ #f))) + +(define (assoc-ref/one alist key) + (car-if-true (assoc-ref alist key))) + +(define (essential-configuration tree) + (receive (attributes subtrees) + (essential-configuration-attributes tree) + (let ((private-opensmtpd-config-file + (assoc-ref/one attributes + 'private-opensmtpd-config-file)) + (dkim-current-selector-file + (assoc-ref/one attributes + 'dkim-current-selector-file)) + (dkim-current-key-file + (assoc-ref/one attributes + 'dkim-current-key-file))) + (values + (make-configuration + #f #f + private-opensmtpd-config-file + dkim-current-selector-file + dkim-current-key-file + #f) + subtrees)))) + +(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 configuration.") + exn))) + (lambda () + (receive (essential extra-state) + (essential-configuration sxml) + (refine-configuration extra-state essential))))) + +(define (configuration->sxml config) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'configuration->sxml) + (make-exception-with-irritants (list config)) + (make-exception-with-message + "when converting a configuration to SXML:") + exn))) + (lambda () + (match config + (($ dkim-state srs-state + private-opensmtpd-config-file + dkim-current-selector-file + dkim-current-key-file + gandi-configuration) + `(configuration + (@ (xmlns "https://planete-kraus.eu/ns/email-key-rotation") + (private-opensmtpd-config-file ,private-opensmtpd-config-file) + (dkim-current-selector-file ,dkim-current-selector-file) + (dkim-current-key-file ,dkim-current-key-file)) + ,@(if dkim-state + `((with-dkim-state ,(dkim:key->sxml dkim-state))) + '()) + ,@(if srs-state + `((with-srs-state ,(srs:key->sxml srs-state))) + '()) + ,@(if gandi-configuration + `((with-gandi-configuration ,(gandi:configuration->sxml gandi-configuration))) + '()))))))) + +(define* (materialize config-file output-port #:key (http-request http-request)) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-irritants (list config-file)) + (make-exception-with-message + (format #f "when materializing the configuration file:")) + exn))) + (lambda () + (when (and (dkim-state config-file) + (dkim-current-key-file config-file)) + (call-with-output-file (dkim-current-key-file config-file) + (lambda (port) + (dkim:write-private-key (dkim-state config-file) port)))) + (when (and (dkim-state config-file) + (dkim-current-selector-file config-file)) + (call-with-output-file (dkim-current-selector-file config-file) + (lambda (port) + (dkim:write-current-selector (dkim-state config-file) port)))) + (when (and (dkim-state config-file) + (gandi-configuration config-file)) + (for-each + (lambda (dns-record) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-irritants (list dns-record)) + (make-exception-with-message + (format #f "when publishing ~a record for ~a:" + (dns:type dns-record) + (dns:name dns-record))) + exn))) + (lambda () + (dns:publish-gandi-livedns (gandi-configuration config-file) + dns-record + #:http-request http-request)))) + (dkim:dns-records (dkim-state config-file)))) + (when (and (srs-state config-file) + (private-opensmtpd-config-file config-file)) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-irritants (list config-file)) + (make-exception-with-message + (format #f "when writing the private opensmtpd configuration file:")) + exn))) + (lambda () + (call-with-output-file + (private-opensmtpd-config-file config-file) + (lambda (port) + (srs:write-private-opensmtpd-config (srs-state config-file) + port)))))) + (when (file-port? output-port) + (chmod output-port #o600)) + (seek output-port 0 SEEK_SET) + (sxml->xml + `(*TOP* ,(configuration->sxml config-file)) + output-port) + (truncate-file output-port)))) + +(define* (initialize selectors private-opensmtpd-config-file dkim-current-selector-file dkim-current-key-file gandi-api-key gandi-domain + #:key (openssl-binary (openssl:current-openssl-binary))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'initialize) + (make-exception-with-irritants (list selectors private-opensmtpd-config-file dkim-current-selector-file dkim-current-key-file gandi-api-key gandi-domain)) + (make-exception-with-message + "when creating a new config file") + exn))) + (lambda () + (parameterize + ((openssl:current-openssl-binary openssl-binary)) + (make-configuration + (dkim:initialize selectors) + (srs:initialize) + private-opensmtpd-config-file + dkim-current-selector-file + dkim-current-key-file + (gandi:make-gandi-configuration gandi-api-key gandi-domain)))))) + +(define* (rotate configuration + #:key (openssl-binary (openssl:current-openssl-binary))) (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-origin 'rotate) + (make-exception-with-irritants (list configuration)) (make-exception-with-message - (format #f "while running dkimproxy.out with ~s:" state-file)) + "when rotating a config file") exn))) (lambda () - (let ((state (call-with-input-file state-file - read-state))) - (run-dkimproxy state input-port relay-port domain))))) + (parameterize + ((openssl:current-openssl-binary openssl-binary)) + (set-dkim-state + ;; Rotate SRS key: + (set-srs-state + configuration + (and (srs-state configuration) + (srs:rotate (srs-state configuration)))) + ;; Done rotating SRS key, now do the DKIM key: + (and (dkim-state configuration) + (dkim:rotate (dkim-state configuration)))))))) diff --git a/email-key-rotation/dkim.scm b/email-key-rotation/dkim.scm new file mode 100644 index 0000000..7cc879d --- /dev/null +++ b/email-key-rotation/dkim.scm @@ -0,0 +1,225 @@ +(define-module (email-key-rotation dkim) + #:use-module ((email-key-rotation openssl) #:prefix openssl:) + #:use-module ((email-key-rotation dns) #:prefix dns:) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (web client) + #:use-module (json) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-9 gnu) + #:use-module (sxml match) + #:export ( + make-key + key? + current-selector + current-private-key + expired-private-key + sxml->key + key->sxml + initialize + rotate + write-private-key + write-current-selector + dns-records) + #:declarative? #t) + +(define-immutable-record-type + (make-key current-selector next-selectors current-private-key expired-private-key) + key? + (current-selector current-selector set-current-selector) + (next-selectors next-selectors set-next-selectors) + (current-private-key current-private-key set-current-private-key) + (expired-private-key expired-private-key set-expired-private-key)) + +(define (sxml->key sxml) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'sxml->key) + (make-exception-with-irritants (list sxml)) + (make-exception-with-message + "cannot read the XML fragment as a key.") + exn))) + (lambda () + (sxml-match + sxml + ((https://planete-kraus.eu/ns/email-key-rotation:key + (@ (current-selector ,current-selector) + (current-private-key ,current-private-key) + (expired-private-key ,expired-private-key)) + (https://planete-kraus.eu/ns/email-key-rotation:next-selector + (@ (name ,next-selectors))) ...) + (make-key (string->symbol current-selector) + (map string->symbol next-selectors) + current-private-key + expired-private-key)) + ((https://planete-kraus.eu/ns/email-key-rotation:key + (@ (current-selector ,current-selector) + (current-private-key ,current-private-key)) + (https://planete-kraus.eu/ns/email-key-rotation:next-selector + (@ (name ,next-selectors))) ...) + (make-key (string->symbol current-selector) + (map string->symbol next-selectors) + current-private-key + #f)))))) + +(define (key->sxml key) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'key->sxml) + (make-exception-with-irritants (list key)) + (make-exception-with-message + "when converting a DKIM key to SXML:") + exn))) + (lambda () + (match key + (($ current-selector next-selectors current-private-key expired-private-key) + (let ((current-selector (symbol->string current-selector)) + (next-selectors + (map + (lambda (s) + `(next-selector (@ (name ,(symbol->string s))))) + next-selectors))) + `(key (@ (current-selector ,current-selector) + (current-private-key ,current-private-key) + ,@(if expired-private-key + `((expired-private-key ,expired-private-key)) + '())) + ,@next-selectors))))))) + +(define (initialize selectors) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'initialize) + (make-exception-with-irritants (list selectors)) + (make-exception-with-message + "when initializing a new DKIM key:") + exn))) + (lambda () + (make-key (car selectors) + (cdr selectors) + (openssl:generate-key 2048) + #f)))) + +(define (rotate key) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'rotate) + (make-exception-with-irritants (list key)) + (make-exception-with-message + "when rotating a DKIM key:") + exn))) + (lambda () + (match key + (($ current-selector next-selectors current-private-key expired-private-key) + (make-key (car next-selectors) + `(,@(cdr next-selectors) ,current-selector) + (openssl:generate-key 2048) + current-private-key)))))) + +(define* (write-current-selector key #:optional (port (current-output-port))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'write-current-selector) + (make-exception-with-irritants (list key port)) + (make-exception-with-message + "when writing the DKIM selector to file:") + exn))) + (lambda () + (seek port 0 SEEK_SET) + (format port "~a\n" (current-selector key)) + (truncate-file port)))) + +(define* (write-private-key key #:optional (port (current-output-port))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'write-private-key) + (make-exception-with-irritants (list key port)) + (make-exception-with-message + "when saving a private DKIM key:") + exn))) + (lambda () + (unless (port? port) + (raise-exception + (make-exception + (make-error) + (make-exception-with-message + "the port to write must be a port object.")))) + (when (file-port? port) + (chmod port #o600)) + (seek port 0 SEEK_SET) + (match key + (($ _ _ key _) + (begin + (display key port) + (truncate-file port))))))) + +(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 (private-key->dkim-record key) + (public-key->dkim-record + (openssl:private-key->public-key key))) + +(define optional-private-key->dkim-record + (match-lambda + (#f "v=DKIM1; k=rsa; t=s; p=deleted") + (key + (private-key->dkim-record key)))) + +(define (dns-records key) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'dns-records) + (make-exception-with-irritants (list key)) + (make-exception-with-message + "when computing the DKIM DNS records:") + exn))) + (lambda () + (match key + (($ + (= symbol->string current-record) + (= reverse + (= car + (= symbol->string previous-record))) + (= private-key->dkim-record current) + (= optional-private-key->dkim-record expired)) + (list + (dns:make-dns-record + (string-append current-record "._domainkey") + "TXT" + current) + (dns:make-dns-record + (string-append previous-record "._domainkey") + "TXT" + expired))))))) diff --git a/email-key-rotation/dkimproxy.scm b/email-key-rotation/dkimproxy.scm deleted file mode 100644 index 65d2e56..0000000 --- a/email-key-rotation/dkimproxy.scm +++ /dev/null @@ -1,58 +0,0 @@ -(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 index 1a7d7cc..a5da1b2 100644 --- a/email-key-rotation/dns.scm +++ b/email-key-rotation/dns.scm @@ -1,67 +1,83 @@ (define-module (email-key-rotation dns) - #:use-module (email-key-rotation state) - #:use-module (email-key-rotation openssl) + #:use-module ((email-key-rotation gandi) #:prefix gandi:) #:use-module (ice-9 exceptions) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) #:use-module (srfi srfi-26) - #:use-module (oop goops) - #:export (dns-txt-records) - #:declarative? #t - #:duplicates (merge-generics)) + #:use-module (srfi srfi-9 gnu) + #:use-module (rnrs bytevectors) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (web client) + #:use-module (json) + #:export ( + make-dns-record + dns-record? + name set-name + type set-type + value set-value + publish-gandi-livedns) + #:declarative? #t) -(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-immutable-record-type + (make-dns-record name type value) + dns-record? + (name name set-name) + (type type set-type) + (value value set-value)) -(define-method (dns-txt-records (s )) +(define* (publish-gandi-livedns gandi-configuration + record + #:key + (http-request http-request)) (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-origin 'publish-gandi-livedns) + (make-exception-with-irritants (list gandi-configuration record)) (make-exception-with-message - "cannot generate the DNS TXT record.") + "cannot update the Gandi livedns.") 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)))))))) + (match record + (($ name type value) + (let ((path-under-domain `("records" ,name ,type)) + (headers `((content-type . (application/json)))) + (body + (string->utf8 + (scm->json-string + `((rrset_values + . ,(list->vector (list value)))))))) + (receive (response response-body) + (gandi:gandi-livedns-request + gandi-configuration + (gandi:domain gandi-configuration) + path-under-domain + #:headers headers + #:body body + #:http-request http-request) + (when (eqv? (response-code response) 409) + ;; Retry with put + (receive (put-response put-body) + (gandi:gandi-livedns-request + gandi-configuration + (gandi:domain gandi-configuration) + path-under-domain + #:headers headers + #:body body + #:http-request http-request) + (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))))))))))))) diff --git a/email-key-rotation/gandi.scm b/email-key-rotation/gandi.scm index 006fac4..2f89785 100644 --- a/email-key-rotation/gandi.scm +++ b/email-key-rotation/gandi.scm @@ -1,109 +1,104 @@ (define-module (email-key-rotation gandi) - #:use-module (email-key-rotation state) - #:use-module (email-key-rotation dns) - #:use-module (json) + #: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 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 (sxml match) #:use-module (web client) - #:use-module (oop goops) - #:export (current-http-request - gandi-api-key - gandi-domain - gandi-livedns) - #:declarative? #t - #:duplicates (merge-generics)) + #:use-module (web uri) + #:export ( + make-gandi-configuration + gandi-configuration? + api-key set-api-key + domain set-domain + sxml->configuration + configuration->sxml + gandi-livedns-request) + #:declarative? #t) -(define gandi-api-key - (make-parameter #f)) +(define-immutable-record-type + (make-gandi-configuration api-key domain) + gandi-configuration? + (api-key api-key set-api-key) + (domain domain set-domain)) -(define gandi-domain - (make-parameter #f)) +(define* (gandi-livedns-request configuration + domain + path-under-domain + #:key + (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 #:headers headers #:body body))))) -(define current-http-request - (make-parameter http-request)) +(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-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))))))))) +(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 + (($ api-key domain) + `(gandi-configuration (@ (api-key ,api-key) + (domain ,domain)))))))) diff --git a/email-key-rotation/openssl.scm b/email-key-rotation/openssl.scm index c37c6cf..40f09c3 100644 --- a/email-key-rotation/openssl.scm +++ b/email-key-rotation/openssl.scm @@ -2,7 +2,7 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 rdelim) #:use-module (ice-9 textual-ports) - #:use-module (oop goops) + #:use-module (ice-9 match) #:export (current-openssl-binary generate-key private-key->public-key @@ -11,7 +11,34 @@ #:duplicates (merge-generics)) (define current-openssl-binary - (make-parameter "openssl")) + (make-parameter + "openssl" + (match-lambda + ((? string? interpreter) + (lambda (arguments) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-irritants (list interpreter arguments)) + (make-exception-with-message + "cannot run openssl:") + exn))) + (lambda () + (let ((ret (apply system* interpreter arguments))) + (unless (eqv? 0 (status:exit-val ret)) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list (status:exit-val ret))) + (make-exception-with-message + (format #f "openssl failed with exit code ~s." + (status:exit-val ret))))))))))) + ((? procedure? p) + p)))) + +(define (call-openssl . args) + ((current-openssl-binary) args)) (define (generate-key rsa-strength) (with-exception-handler @@ -30,22 +57,12 @@ (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)) + (call-openssl + "genrsa" + "-out" (port-filename port) + (number->string rsa-strength)) + (call-with-input-file (port-filename port) + get-string-all)) (lambda () (delete-file (port-filename port)))))))) @@ -71,24 +88,13 @@ (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)) + (call-openssl + "rsa" + "-in" (port-filename input-port) + "-out" (port-filename output-port) + "-pubout") + (call-with-input-file (port-filename output-port) + get-string-all)) (lambda () (delete-file (port-filename input-port)) (delete-file (port-filename output-port)))))))) @@ -111,24 +117,12 @@ (lambda () #t) (lambda () (chmod output-port #o600) - (let ((ret (system* openssl - "rand" - "-out" (port-filename output-port) - "-hex" - (number->string nbytes)))) - (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 - "rand" - "-out" "" - "-hex" - (number->string nbytes))) - (make-exception-with-message - (format #f "openssl failed to generate random numbers.")))))) - (call-with-input-file (port-filename output-port) get-string-all)) + (call-openssl + "rand" + "-out" (port-filename output-port) + "-hex" + (number->string nbytes)) + (call-with-input-file (port-filename output-port) + get-string-all)) (lambda () (delete-file (port-filename output-port)))))))) diff --git a/email-key-rotation/openstmpd.scm b/email-key-rotation/openstmpd.scm new file mode 100644 index 0000000..9ca2fab --- /dev/null +++ b/email-key-rotation/openstmpd.scm @@ -0,0 +1,60 @@ +(define-module (email-key-rotation gandi) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 optargs) + #:export ( + make-openstmpd-configuration + opensmtpd-configuration? + api-key set-api-key + domain set-domain + gandi-livedns-request) + #:declarative? #t) + +(define-immutable-record-type + (make-gandi-configuration api-key domain) + gandi-configuration? + (api-key api-key set-api-key) + (domain domain set-domain)) + +(define* (gandi-livedns-request configuration + path-under-domain + #:key + (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-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 #:headers headers #:body body))))) diff --git a/email-key-rotation/prepare.scm b/email-key-rotation/prepare.scm deleted file mode 100644 index 0677237..0000000 --- a/email-key-rotation/prepare.scm +++ /dev/null @@ -1,85 +0,0 @@ -(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 prepare-opensmtpd-config) - #: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)))))))))) - -(define-method (prepare-opensmtpd-config (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 SRS secrets to the opensmtpd config file.") - exn))) - (lambda () - (set! s (the-email-key-rotation-state s)) - (let ((config (private-opensmtpd-config s))) - (with-exception-handler - (lambda (exn) - (raise-exception - (make-exception - (make-exception-with-irritants (list config)) - (make-exception-with-message - (format #f - "cannot write the private opensmtpd config file ~s." - config)) - exn))) - (lambda () - (let ((current-secret (current-srs-secret s)) - (previous-secret (expired-srs-secret s))) - (call-with-output-file config - (lambda (port) - (chmod port #o600) - (format port "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n -srs key ~s -" - current-secret) - (when previous-secret - (format port "srs key backup ~s -" - previous-secret))))))))))) diff --git a/email-key-rotation/serialize.scm b/email-key-rotation/serialize.scm deleted file mode 100644 index 1e27183..0000000 --- a/email-key-rotation/serialize.scm +++ /dev/null @@ -1,69 +0,0 @@ -(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 - private-opensmtpd-config - (selectors ...) - selector - current-key - expired-key - current-srs - expired-srs) - (the-email-key-rotation-state - (make - #:private-key-file private-key-file - #:private-opensmtpd-config private-opensmtpd-config - #:selectors selectors - #:current-dkim-selector selector - #:current-dkim-private-key current-key - #:expired-dkim-private-key expired-key - #:current-srs-secret current-srs - #:expired-srs-secret expired-srs))))))) - -(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) - ,(private-opensmtpd-config state) - (,@(selectors state)) - ,(current-dkim-selector state) - ,(current-dkim-private-key state) - ,(expired-dkim-private-key state) - ,(current-srs-secret state) - ,(expired-srs-secret state)) - port)))))) diff --git a/email-key-rotation/srs.scm b/email-key-rotation/srs.scm new file mode 100644 index 0000000..aadfc7d --- /dev/null +++ b/email-key-rotation/srs.scm @@ -0,0 +1,122 @@ +(define-module (email-key-rotation srs) + #:use-module ((email-key-rotation openssl) #:prefix openssl:) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9 gnu) + #:use-module (sxml match) + #:export ( + key? + current-secret + expired-secret + sxml->key + key->sxml + initialize + rotate + write-private-opensmtpd-config) + #:declarative? #t) + +(define-immutable-record-type + (make-key current-secret expired-secret) + key? + (current-secret current-secret set-current-secret) + (expired-secret expired-secret set-expired-secret)) + +(define (sxml->key sxml) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'sxml->key) + (make-exception-with-irritants (list sxml)) + (make-exception-with-message + "cannot read the XML fragment as a SRS key.") + exn))) + (lambda () + (sxml-match + sxml + ((https://planete-kraus.eu/ns/email-key-rotation:srs + (@ (current-secret ,current-secret) + (expired-secret ,expired-secret))) + (make-key current-secret expired-secret)) + ((https://planete-kraus.eu/ns/email-key-rotation:srs + (@ (current-secret ,current-secret))) + (make-key current-secret #f)))))) + +(define (key->sxml key) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'key->sxml) + (make-exception-with-irritants (list key)) + (make-exception-with-message + "when converting a SRS key to SXML:") + exn))) + (lambda () + (match key + (($ current-secret expired-secret) + `(srs (@ (current-secret ,current-secret) + ,@(if expired-secret + `((expired-secret ,expired-secret)) + '())))))))) + +(define (initialize) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'initialize) + (make-exception-with-message + "when initializing a new SRS key:") + exn))) + (lambda () + (make-key (openssl:random-hex 32) + #f)))) + +(define (rotate key) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'rotate) + (make-exception-with-irritants (list key)) + (make-exception-with-message + "when rotating a SRS key:") + exn))) + (lambda () + (match key + (($ current-secret expired-secret) + (make-key (openssl:random-hex 32) + current-secret)))))) + +(define* (write-private-opensmtpd-config key #:optional (port (current-output-port))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'write-private-opensmtpd-config) + (make-exception-with-irritants (list key port)) + (make-exception-with-message + "when saving a private SRS key:") + exn))) + (lambda () + (unless (port? port) + (raise-exception + (make-exception + (make-error) + (make-exception-with-message + "the port to write must be a port object.")))) + (when (file-port? port) + (chmod port #o600)) + (seek port 0 SEEK_SET) + (match key + (($ current expired) + (begin + (format port "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n +srs key ~s\n" + current) + (when expired + (format port "srs key backup ~s\n" + expired)) + (truncate-file port))))))) diff --git a/email-key-rotation/state.scm b/email-key-rotation/state.scm deleted file mode 100644 index bf567cb..0000000 --- a/email-key-rotation/state.scm +++ /dev/null @@ -1,223 +0,0 @@ -(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 - private-opensmtpd-config - selectors - current-dkim-selector - current-dkim-private-key - expired-dkim-private-key - current-srs-secret - expired-srs-secret - set-private-key-file - set-private-opensmtpd-config - set-selectors - set-current-dkim-selector - set-current-dkim-private-key - set-expired-dkim-private-key - set-current-srs-secret - set-expired-srs-secret - the-email-key-rotation-state) - #:declarative? #t - #:duplicates (merge-generics)) - -(define-class () - (private-key-file #:init-keyword #:private-key-file) - (private-opensmtpd-config #:init-keyword #:private-opensmtpd-config) - (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) - (current-srs-secret #:init-keyword #:current-srs-secret) - (expired-srs-secret #:init-keyword #:expired-srs-secret - #:init-value #f)) - -(define-method (private-key-file (s )) - (slot-ref s 'private-key-file)) - -(define-method (private-opensmtpd-config (s )) - (slot-ref s 'private-opensmtpd-config)) - -(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 (current-srs-secret (s )) - (slot-ref s 'current-srs-secret)) - -(define-method (expired-srs-secret (s )) - (slot-ref s 'expired-srs-secret)) - -(define-method (set-private-key-file (s ) filename) - (let ((ret (shallow-clone s))) - (slot-set! ret 'private-key-file filename) - ret)) - -(define-method (set-private-opensmtpd-config (s ) filename) - (let ((ret (shallow-clone s))) - (slot-set! ret 'private-opensmtpd-config 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-current-dkim-private-key (s ) private-key) - (let ((ret (shallow-clone s))) - (slot-set! ret 'current-dkim-private-key private-key) - 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 (set-current-srs-secret (s ) private-key) - (let ((ret (shallow-clone s))) - (slot-set! ret 'current-srs-secret private-key) - ret)) - -(define-method (set-expired-srs-secret (s ) private-key) - (let ((ret (shallow-clone s))) - (slot-set! ret 'expired-srs-secret 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 (slot-bound? s 'private-opensmtpd-config) - (raise-exception - (make-exception - (make-error) - (make-exception-with-message - (format #f "the private opensmtpd configuration file name is not bound."))))) - (unless (string? (private-opensmtpd-config s)) - (raise-exception - (make-exception - (make-error) - (make-exception-with-irritants (list (private-opensmtpd-config s))) - (make-exception-with-message - (format #f "the private opensmtpd configuration 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."))))) - (unless (string? (current-srs-secret s)) - (raise-exception - (make-exception - (make-error) - (make-exception-with-irritants (list (current-srs-secret s))) - (make-exception-with-message - (format #f "the current srs secret is not set."))))) - (unless (or (not (expired-srs-secret s)) - (string? (expired-srs-secret s))) - (raise-exception - (make-exception - (make-error) - (make-exception-with-irritants (list (expired-srs-secret s))) - (make-exception-with-message - (format #f "the expired srs secret is set, but not to a string."))))))) - s) diff --git a/email-key-rotation/tests.scm b/email-key-rotation/tests.scm index faba6af..f4eedd7 100644 --- a/email-key-rotation/tests.scm +++ b/email-key-rotation/tests.scm @@ -1,321 +1,268 @@ (define-module (email-key-rotation tests) #:use-module (email-key-rotation) - #:use-module (email-key-rotation gandi) + #:use-module (email-key-rotation tests fake-openssl) + #:use-module (email-key-rotation tests fake-gandi-livedns) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 textual-ports) #:use-module (ice-9 optargs) + #:use-module (ice-9 exceptions) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) + #:use-module (sxml simple) #:use-module (web uri) #:use-module (web response) - #:export (fake-openssl-binary-main - fake-dkimproxy.out-main - run-tests) + #:export (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)))))) - ((_ "rand" "-out" file "-hex" (= string->number n-bytes)) - (call-with-output-file file - (lambda (port) - (format port "hexdatawithseed~a" 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 (reload config) + (let* ((sxml (configuration->sxml config)) + (xml (call-with-output-string + (lambda (port) + (sxml->xml sxml port)))) + (sxml-back + (call-with-input-string xml xml->sxml)) + (config-back (sxml->configuration sxml-back))) + (unless (equal? config config-back) + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'reload) + (make-exception-with-irritants (list config xml config-back)) + (make-exception-with-message + "cannot serialize and deserialize the configuration")))) + config-back)) (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" - "private-opensmtpd-config.conf" - '(dkimA dkimB) - "letmein" - "awesome-domain.net") - (unless (and dkimA-notified dkimB-notified) - (error "no gandi request")))) - ;; Check the private opensmtpd config - (call-with-input-file "private-opensmtpd-config.conf" - (lambda (port) - (let ((cfg (get-string-all port))) - (unless (equal? cfg "# GENERATED AUTOMATICALLY, DO NOT EDIT! - -srs key \"hexdatawithseed0\" -") - (format (current-error-port) "The configuration is: ~s\n" cfg) - (error "wrong opensmtpd config"))))) - ;; 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")))) - ;; Check the private opensmtpd config - (call-with-input-file "private-opensmtpd-config.conf" - (lambda (port) - (let ((cfg (get-string-all port))) - (unless (equal? cfg "# GENERATED AUTOMATICALLY, DO NOT EDIT! - + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'run-tests) + (make-exception-with-message + "the tests failed:") + exn))) + (lambda () + ;; The process is: + ;; + ;; 1. We generate a new key pair with seed 0. + ;; 3. We rotate the key pair, it now generates a seed 1. + ;; 3. We rotate the key pair, it now generates a seed 2. + ;; + ;; First step is to generate a new key pair. + (define current-config #f) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-message + "during the initialization phase:") + exn))) + (lambda () + (set! current-config + (call-with-fake-openssl + 0 + (lambda () + (reload + (initialize '(dkimA dkimB) + "srs-secrets.conf" + "current-dkim-selector.txt" + "current-dkim-key.key" + "topsecretgandikey" + "awesome-domain.net"))))) + (let ((materialize-log-0 + (call-with-fake-openssl + 0 + (lambda () + (call-with-fake-gandi-livedns + "awesome-domain.net" + "topsecretgandikey" + (lambda (materialize) + (call-with-output-file "current-state.xml" + (lambda (port) + (materialize current-config port)))))))) + (expected-log-0 + "Change \"dkimA._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=blah blah public keyblah blah blah with seed 0\". +Change \"dkimB._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=deleted\".\n")) + (unless (equal? materialize-log-0 expected-log-0) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list materialize-log-0 expected-log-0)) + (make-exception-with-message + "incorrect gandi livedns requests.")))) + (unless (equal? + (call-with-input-file "srs-secrets.conf" get-string-all) + "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n +srs key \"hexdatawithseed0\"\n") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "srs-secrets.conf")) + (make-exception-with-message + "incorrect srs-secrets.conf content.")))) + (unless (equal? + (call-with-input-file "current-dkim-selector.txt" + read-line) + "dkimA") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-selector.txt")) + (make-exception-with-message + "incorrect current-dkim-selector.txt content.")))) + (unless (equal? + (call-with-input-file "current-dkim-key.key" + get-string-all) + "(begin-fake-private-key 0)") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-key.key")) + (make-exception-with-message + "incorrect current-dkim-key.key content."))))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-message + "during the first rotation:") + exn))) + (lambda () + (set! current-config + (call-with-fake-openssl + 1 + (lambda () + (reload + (rotate current-config))))) + (let ((materialize-log-1 + (call-with-fake-openssl + 0 + (lambda () + (call-with-fake-gandi-livedns + "awesome-domain.net" + "topsecretgandikey" + (lambda (materialize) + (call-with-output-file "current-state.xml" + (lambda (port) + (materialize current-config port)))))))) + (expected-log-1 + "Change \"dkimB._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=blah blah public keyblah blah blah with seed 1\". +Change \"dkimA._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=blah blah public keyblah blah blah with seed 0\".\n")) + (unless (equal? materialize-log-1 expected-log-1) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list materialize-log-1 expected-log-1)) + (make-exception-with-message + "incorrect gandi livedns requests.")))) + (unless (equal? + (call-with-input-file "srs-secrets.conf" get-string-all) + "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n srs key \"hexdatawithseed1\" -srs key backup \"hexdatawithseed0\" -") - (format (current-error-port) "The configuration is: ~s\n" cfg) - (error "wrong opensmtpd config"))))) - ;; 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")))) - ;; Check the private opensmtpd config - (call-with-input-file "private-opensmtpd-config.conf" - (lambda (port) - (let ((cfg (get-string-all port))) - (unless (equal? cfg "# GENERATED AUTOMATICALLY, DO NOT EDIT! - +srs key backup \"hexdatawithseed0\"\n") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "srs-secrets.conf")) + (make-exception-with-message + "incorrect srs-secrets.conf content.")))) + (unless (equal? + (call-with-input-file "current-dkim-selector.txt" + read-line) + "dkimB") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-selector.txt")) + (make-exception-with-message + "incorrect current-dkim-selector.txt content.")))) + (unless (equal? + (call-with-input-file "current-dkim-key.key" + get-string-all) + "(begin-fake-private-key 1)") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-key.key")) + (make-exception-with-message + "incorrect current-dkim-key.key content."))))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-message + "during the second rotation:") + exn))) + (lambda () + (set! current-config + (call-with-fake-openssl + 2 + (lambda () + (reload + (rotate current-config))))) + (let ((materialize-log-2 + (call-with-fake-openssl + 0 + (lambda () + (call-with-fake-gandi-livedns + "awesome-domain.net" + "topsecretgandikey" + (lambda (materialize) + (call-with-output-file "current-state.xml" + (lambda (port) + (materialize current-config port)))))))) + (expected-log-2 + "Change \"dkimA._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=blah blah public keyblah blah blah with seed 2\". +Change \"dkimB._domainkey\" TXT record to value \"v=DKIM1; k=rsa; t=s; p=blah blah public keyblah blah blah with seed 1\".\n")) + (unless (equal? materialize-log-2 expected-log-2) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list materialize-log-2 expected-log-2)) + (make-exception-with-message + "incorrect gandi livedns requests.")))) + (unless (equal? + (call-with-input-file "srs-secrets.conf" get-string-all) + "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n srs key \"hexdatawithseed2\" -srs key backup \"hexdatawithseed1\" -") - (format (current-error-port) "The configuration is: ~s\n" cfg) - (error "wrong opensmtpd config"))))) - ;; 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"))) +srs key backup \"hexdatawithseed1\"\n") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "srs-secrets.conf")) + (make-exception-with-message + "incorrect srs-secrets.conf content.")))) + (unless (equal? + (call-with-input-file "current-dkim-selector.txt" + read-line) + "dkimA") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-selector.txt")) + (make-exception-with-message + "incorrect current-dkim-selector.txt content.")))) + (unless (equal? + (call-with-input-file "current-dkim-key.key" + get-string-all) + "(begin-fake-private-key 2)") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants + (list "current-dkim-key.key")) + (make-exception-with-message + "incorrect current-dkim-key.key content.")))))))))) diff --git a/email-key-rotation/tests/fake-gandi-livedns.scm b/email-key-rotation/tests/fake-gandi-livedns.scm new file mode 100644 index 0000000..4e2df13 --- /dev/null +++ b/email-key-rotation/tests/fake-gandi-livedns.scm @@ -0,0 +1,115 @@ +(define-module (email-key-rotation tests fake-gandi-livedns) + #:use-module ((email-key-rotation) #:prefix ekr:) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 optargs) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:export (call-with-fake-gandi-livedns) + #:declarative? #t + #:duplicates (merge-generics)) + +(define (fake-http-request expected-domain expected-api-key log-port) + (lambda* (uri #:key headers body) + (unless (equal? (uri-scheme uri) 'https) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list uri)) + (make-exception-with-message + "Gandi URI is not HTTPS.")))) + (unless (equal? (uri-host uri) "api.gandi.net") + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list uri)) + (make-exception-with-message + "Wrong Gandi URI host.")))) + (when (uri-port uri) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list uri)) + (make-exception-with-message + "Custom Gandi URI port.")))) + (when (uri-userinfo uri) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list uri)) + (make-exception-with-message + "Custom Gandi URI userinfo.")))) + (unless (string-prefix? "/" (uri-path uri)) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list uri)) + (make-exception-with-message + "Gandi URI path not absolute.")))) + (let ((path-components + (split-and-decode-uri-path (uri-path uri)))) + (match path-components + (("v5" "livedns" "domains" domain + "records" name "TXT") + (begin + (unless (equal? domain expected-domain) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list domain)) + (make-exception-with-message + "wrong domain in Gandi URI path.")))) + (unless (equal? (assoc-ref headers 'content-type) + '(application/json)) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list headers)) + (make-exception-with-message + "wrong content-type header.")))) + (unless (equal? (assoc-ref headers 'Authorization) + (string-append + "ApiKey " expected-api-key)) + (raise-exception + (make-exception + (make-error) + (make-exception-with-irritants (list headers)) + (make-exception-with-message + "wrong Authorization header.")))) + (when (bytevector? body) + (set! body (utf8->string body))) + (match (json-string->scm body) + ((("rrset_values" + . (? vector? + (= vector->list + (value))))) + (begin + (format log-port "Change ~s TXT record to value ~s.\n" + name value) + (values (build-response) "")))))))))) + +(define (call-with-fake-gandi-livedns expected-domain expected-api-key f) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-origin 'call-with-fake-gandi-livedns) + (make-exception-with-message "with fake gandi livedns:") + exn))) + (lambda () + (call-with-output-string + (lambda (log-port) + (let ((http-request + (fake-http-request expected-domain + expected-api-key + log-port))) + (let ((materialize + (lambda (configuration-object output-port) + (ekr:materialize configuration-object output-port + #:http-request http-request)))) + (f materialize)))))))) diff --git a/email-key-rotation/tests/fake-openssl.scm b/email-key-rotation/tests/fake-openssl.scm new file mode 100644 index 0000000..e23e148 --- /dev/null +++ b/email-key-rotation/tests/fake-openssl.scm @@ -0,0 +1,53 @@ +(define-module (email-key-rotation tests fake-openssl) + #:use-module (email-key-rotation openssl) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 match) + #:export (call-with-fake-openssl) + #:declarative? #t + #:duplicates (merge-generics)) + +(define (call-with-fake-openssl seed thunk) + (parameterize + ((current-openssl-binary + (match-lambda + (("genrsa" "-out" output-file "2048") + (call-with-output-file output-file + (lambda (port) + (write `(begin-fake-private-key ,seed) + port)))) + (("rsa" "-in" private-key-file "-out" public-key-file "-pubout") + (let ((private-key + (call-with-input-file private-key-file + read))) + (match private-key + (('begin-fake-private-key seed) + (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)))) + (otherwise + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'call-with-fake-openssl) + (make-exception-with-irritants (list otherwise)) + (make-exception-with-message + "the private key has not been generated by the fake openssl."))))))) + (("rand" "-out" file "-hex" (= string->number n-bytes)) + (call-with-output-file file + (lambda (port) + (format port "hexdatawithseed~a" seed)))) + (otherwise + (raise-exception + (make-exception + (make-error) + (make-exception-with-origin 'call-with-fake-openssl) + (make-exception-with-irritants (list otherwise)) + (make-exception-with-message + "invalid use of openssl."))))))) + (thunk))) -- cgit v1.2.3