(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 (<key>
	    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 <key>
  (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
       ;; Guile removes newlines in attributes, so we preserve them by
       ;; saving the keys as uri-encoded strings.
       ((https://planete-kraus.eu/ns/email-key-rotation:key
	 (@ (current-selector ,current-selector)
	    (current-private-key ,current-private-key-encoded)
	    (expired-private-key ,expired-private-key-encoded))
	 (https://planete-kraus.eu/ns/email-key-rotation:next-selector
	  (@ (name ,next-selectors))) ...)
	(make-key (string->symbol current-selector)
		  (map string->symbol next-selectors)
		  (uri-decode current-private-key-encoded)
		  (uri-decode expired-private-key-encoded)))
       ((https://planete-kraus.eu/ns/email-key-rotation:key
	 (@ (current-selector ,current-selector)
	    (current-private-key ,current-private-key-encoded))
	 (https://planete-kraus.eu/ns/email-key-rotation:next-selector
	  (@ (name ,next-selectors))) ...)
	(make-key (string->symbol current-selector)
		  (map string->symbol next-selectors)
		  (uri-decode current-private-key-encoded)
		  #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
	(($ <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
		     ,(uri-encode current-private-key))
		    ,@(if expired-private-key
			  `((expired-private-key
			     ,(uri-encode 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
	(($ <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> _ _ 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
	(($ <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)))))))