path: root/email-key-rotation/tests.scm

(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))))))
    ((_ "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 (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!

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 \"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")))