(define-module (email-key-rotation rotation)
  #:use-module (email-key-rotation state)
  #:use-module (email-key-rotation openssl)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:export (initialize-rotation rotate-key)
  #:declarative? #t
  #:duplicates (merge-generics))

(define (initialize-rotation private-key-file private-opensmtpd-config selectors)
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-exception-with-origin 'initialize-key-rotation)
	  (make-exception-with-irritants (list private-key-file private-opensmtpd-config selectors))
	  (make-exception-with-message
	   "cannot initialize the key rotation.")
	  exn)))
    (lambda ()
      (the-email-key-rotation-state
       (make <email-key-rotation-state>
	 #:private-key-file private-key-file
	 #:private-opensmtpd-config private-opensmtpd-config
	 #:selectors selectors
	 #:current-dkim-selector (car selectors)
	 #:current-dkim-private-key
	 (generate-key 2048)
	 #:current-srs-secret (random-hex 32))))))

(define-method (rotate-key (s <email-key-rotation-state>))
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-exception-with-origin 'rotate-dkim-key)
	  (make-exception-with-irritants (list s))
	  (make-exception-with-message
	   "cannot rotate the email keys.")
	  exn)))
    (lambda ()
      (let ((ret (shallow-clone (the-email-key-rotation-state s))))
	(slot-set! ret 'expired-dkim-private-key
		   (slot-ref s 'current-dkim-private-key))
	(slot-set! ret 'current-dkim-private-key
		   (generate-key 2048))
	(slot-set!
	 ret 'current-dkim-selector
	 (match (memq (current-dkim-selector s)
		      (selectors s))
	   (#f
	    (error "cannot happen, the state has been validated"))
	   ((_)
	    ;; The current selector is the last, start from the head
	    ;; again.
	    (car (selectors s)))
	   ((_ next _ ...)
	    next)))
	(slot-set! ret 'expired-srs-secret
		   (slot-ref s 'current-srs-secret))
	(slot-set! ret 'current-srs-secret
		   (random-hex 32))
	ret))))