blob: 45c408f01997c83eebacdb2513a1996805c98bee (
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
(define-module (vkraus services guix-wot-system)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services ssh)
#:use-module (gnu services mcron)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix build utils)
#:use-module (gnu packages gnupg)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 optargs)
#:use-module (ice-9 threads)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 receive)
#:use-module (oop goops)
#:declarative? #t
#:export
(
<guix-system-wot-configuration>
users key-servers
guix-system-wot-service-type
))
;; This module defines a guix system service that converts GPG key
;; fingerprints to authorized SSH keys. The public keys are pulled
;; from key servers at reconfiguration time.
(define gpg-program
(file-append gnupg "/bin/gpg"))
(define-class <guix-system-wot-configuration> ()
(users
#:init-keyword #:users
#:accessor users
#:init-value '())
(public-keys-file
#:init-keyword #:public-keys-file
#:accessor public-keys-file
#:init-value "/var/lib/user-keys.gpg")
(key-servers
#:init-keyword #:key-servers
#:accessor key-servers
#:init-value '()))
(define-method (+ (main <guix-system-wot-configuration>)
(other <guix-system-wot-configuration>))
(let ((ret (shallow-clone main)))
(set! (users ret)
(append (users main) (users other)))
(unless (public-keys-file ret)
(set! (public-keys-file ret)
(public-keys-file other)))
(set! (key-servers ret)
(append (key-servers main) (key-servers other)))
ret))
(define (sync-script configuration)
(program-file
"update-keys"
(with-imported-modules
(source-module-closure
'((guix build utils)))
#~(begin
(use-modules (guix build utils))
(let ((gpg #$gpg-program)
(all-public-keys
(list
#$@(apply append
(map (match-lambda
(((? string?) . (? string? fingerprint))
(list fingerprint))
(((? string?) (? string? fingerprint) ...)
fingerprint))
(users configuration)))))
(file #$(public-keys-file configuration)))
(mkdir-p ".tmp-gnupg-home")
(setenv "GNUPGHOME" (string-append (getcwd) "/.tmp-gnupg-home"))
(catch #t
(lambda ()
(invoke gpg "--import" file))
(lambda _ #t))
(apply invoke gpg
#$@(apply append
(map (cute list "--keyserver" <>)
(key-servers configuration)))
"--recv-key"
all-public-keys)
(catch #t
(lambda ()
(delete-file (string-append file "~")))
(lambda _ #t))
(apply invoke gpg "--export" "-o" (string-append file "~") all-public-keys)
(catch #t
(lambda ()
(delete-file (string-append (getcwd) "/.tmp-gnupg-home")))
(lambda _ #t))
(rename-file (string-append file "~") file))))))
(define (guix-system-wot-mcron-service configuration)
(let ((script (sync-script configuration)))
(list
(with-imported-modules
(source-module-closure
'((guix build utils)))
#~(job '(next-hour)
(lambda ()
#$script))))))
(define (guix-system-wot-openssh-service configuration)
(let ((script (sync-script configuration)))
(map
(lambda (record)
(receive (user fingerprints)
(match record
((user . fingerprint)
(values user (list fingerprint)))
((user fingerprint ...)
(values user fingerprint)))
(let ((fingerprint-files
(map
(lambda (fingerprint)
(computed-file
(format #f "ssh-key-for-~a" user)
(with-imported-modules
(source-module-closure
'((guix build utils)))
#~(begin
(use-modules (guix build utils))
(format (current-error-port) "To synchronize the keys, please run ~a.\n"
#$script)
(let ((gpg #$gpg-program)
(repository
#$(catch #t
(lambda ()
(local-file (public-keys-file configuration)))
(lambda exn
(let ((message
(format #f "Error: no keys have been downloaded yet. Please run ~a and reconfigure.\n"
script)))
(display message)
(apply throw exn))))))
(setenv "GNUPGHOME" (getcwd))
(invoke gpg "--import" repository)
(mkdir-p (dirname #$output))
(invoke gpg "-o" #$output "--export-ssh-key" #$fingerprint))))))
fingerprints)))
`(,user
,@fingerprint-files))))
(users configuration))))
(define guix-system-wot-service-type
(service-type
(name 'guix-system-wot)
(extensions
(list
(service-extension mcron-service-type guix-system-wot-mcron-service)
(service-extension openssh-service-type guix-system-wot-openssh-service)))
(compose
(lambda (extensions)
(apply append extensions)))
(extend
(lambda (base-configuration other-configurations)
(let fold-configurations ((cfgs other-configurations)
(total base-configuration))
(match cfgs
(() total)
((next cfgs ...)
(fold-configurations cfgs (+ total next)))))))
(description
(format #f "Add every available authentication keys for each user
as an auhorized SSH key."))))
|
