(define-module (email-key-rotation)
  #: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 (ice-9 receive)
  #:use-module (ice-9 i18n)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (sxml match)
  #:use-module (sxml simple)
  #:use-module (web client)
  #:export (<configuration>
	    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
	    xml->configuration
	    configuration->sxml
	    initialize
	    rotate
	    materialize)
  #:declarative? #t)

(define (G_ msg) (gettext msg "email-key-rotation"))

(define-immutable-record-type <configuration>
  (make-configuration/uninitialized 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 (make-configuration . args)
  (bindtextdomain "email-key-rotation" "/usr/local/share/locale")
  (apply make-configuration/uninitialized args))

(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 (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
	   (G_ "cannot read the XML fragment as a configuration."))
	  exn)))
    (lambda ()
      (receive (essential extra-state)
	  (essential-configuration sxml)
	(refine-configuration extra-state essential)))))

(define* (xml->configuration #:optional (port (current-input-port)))
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-error)
	  (make-exception-with-origin 'xml->configuration)
	  (make-exception-with-irritants (list port))
	  (make-exception-with-message
	   (G_ "cannot read a configuration from file."))
	  exn)))
    (lambda ()
      (sxml->configuration
       (xml->sxml port)))))

(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
	   (G_ "when converting a configuration to SXML:"))
	  exn)))
    (lambda ()
      (match config
	(($ <configuration> 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 (G_ "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 (G_ "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 (G_ "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
	   (G_ "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 'rotate)
	  (make-exception-with-irritants (list configuration))
	  (make-exception-with-message
	   (G_ "when rotating a config file"))
	  exn)))
    (lambda ()
      (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))))))))