blob: a6e9593ef86a943a146c8f0fa74bc4b67701bbf0 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
(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))))
|
