blob: aadfc7d6c64faeb191adb3825ed5e4931905d7d3 (
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
(define-module (email-key-rotation srs)
#:use-module ((email-key-rotation openssl) #:prefix openssl:)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9 gnu)
#:use-module (sxml match)
#:export (<key>
key?
current-secret
expired-secret
sxml->key
key->sxml
initialize
rotate
write-private-opensmtpd-config)
#:declarative? #t)
(define-immutable-record-type <key>
(make-key current-secret expired-secret)
key?
(current-secret current-secret set-current-secret)
(expired-secret expired-secret set-expired-secret))
(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 SRS key.")
exn)))
(lambda ()
(sxml-match
sxml
((https://planete-kraus.eu/ns/email-key-rotation:srs
(@ (current-secret ,current-secret)
(expired-secret ,expired-secret)))
(make-key current-secret expired-secret))
((https://planete-kraus.eu/ns/email-key-rotation:srs
(@ (current-secret ,current-secret)))
(make-key current-secret #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 SRS key to SXML:")
exn)))
(lambda ()
(match key
(($ <key> current-secret expired-secret)
`(srs (@ (current-secret ,current-secret)
,@(if expired-secret
`((expired-secret ,expired-secret))
'()))))))))
(define (initialize)
(with-exception-handler
(lambda (exn)
(raise-exception
(make-exception
(make-exception-with-origin 'initialize)
(make-exception-with-message
"when initializing a new SRS key:")
exn)))
(lambda ()
(make-key (openssl:random-hex 32)
#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 SRS key:")
exn)))
(lambda ()
(match key
(($ <key> current-secret expired-secret)
(make-key (openssl:random-hex 32)
current-secret))))))
(define* (write-private-opensmtpd-config key #:optional (port (current-output-port)))
(with-exception-handler
(lambda (exn)
(raise-exception
(make-exception
(make-exception-with-origin 'write-private-opensmtpd-config)
(make-exception-with-irritants (list key port))
(make-exception-with-message
"when saving a private SRS 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> current expired)
(begin
(format port "# GENERATED AUTOMATICALLY, DO NOT EDIT!\n
srs key ~s\n"
current)
(when expired
(format port "srs key backup ~s\n"
expired))
(truncate-file port)))))))
|
