Commit | Line | Data |
---|---|---|
f6b0e1f8 CB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu services getmail) | |
20 | #:use-module (gnu services) | |
21 | #:use-module (gnu services base) | |
22 | #:use-module (gnu services configuration) | |
23 | #:use-module (gnu services shepherd) | |
24 | #:use-module (gnu system pam) | |
25 | #:use-module (gnu system shadow) | |
26 | #:use-module (gnu packages mail) | |
27 | #:use-module (gnu packages admin) | |
28 | #:use-module (gnu packages tls) | |
29 | #:use-module (guix records) | |
30 | #:use-module (guix store) | |
31 | #:use-module (guix packages) | |
32 | #:use-module (guix gexp) | |
33 | #:use-module (ice-9 match) | |
34 | #:use-module (ice-9 format) | |
35 | #:use-module (srfi srfi-1) | |
36 | #:export (getmail-retriever-configuration | |
37 | getmail-retriever-configuration-extra-parameters | |
38 | getmail-destination-configuration | |
39 | getmail-options-configuration | |
40 | getmail-configuration-file | |
41 | getmail-configuration | |
42 | getmail-service-type)) | |
43 | ||
44 | ;;; Commentary: | |
45 | ;;; | |
46 | ;;; Service for the getmail mail retriever. | |
47 | ;;; | |
48 | ;;; Code: | |
49 | ||
50 | (define (uglify-field-name field-name) | |
51 | (let ((str (symbol->string field-name))) | |
52 | (string-join (string-split (if (string-suffix? "?" str) | |
53 | (substring str 0 (1- (string-length str))) | |
54 | str) | |
55 | #\-) | |
56 | "_"))) | |
57 | ||
58 | (define (serialize-field field-name val) | |
59 | #~(let ((val '#$val)) | |
60 | (format #f "~a = ~a\n" | |
61 | #$(uglify-field-name field-name) | |
62 | (cond | |
63 | ((list? val) | |
64 | (string-append | |
65 | "(" | |
66 | (string-concatenate | |
67 | (map (lambda (list-val) | |
68 | (format #f "\"~a\", " list-val)) | |
69 | val)) | |
70 | ")")) | |
71 | (else | |
72 | val))))) | |
73 | ||
74 | (define (serialize-string field-name val) | |
75 | (if (string=? val "") | |
76 | "" | |
77 | (serialize-field field-name val))) | |
78 | ||
79 | (define (string-or-filelike? val) | |
80 | (or (string? val) | |
81 | (file-like? val))) | |
82 | (define (serialize-string-or-filelike field-name val) | |
83 | (if (equal? val "") | |
84 | "" | |
85 | (serialize-field field-name val))) | |
86 | ||
87 | (define (serialize-boolean field-name val) | |
88 | (serialize-field field-name (if val "true" "false"))) | |
89 | ||
90 | (define (non-negative-integer? val) | |
91 | (and (exact-integer? val) (not (negative? val)))) | |
92 | (define (serialize-non-negative-integer field-name val) | |
93 | (serialize-field field-name val)) | |
94 | ||
95 | (define serialize-list serialize-field) | |
96 | ||
97 | (define parameter-alist? list?) | |
98 | (define (serialize-parameter-alist field-name val) | |
99 | #~(string-append | |
100 | #$@(map (match-lambda | |
101 | ((key . value) | |
102 | (serialize-field key value))) | |
103 | val))) | |
104 | ||
105 | (define (serialize-getmail-retriever-configuration field-name val) | |
106 | (serialize-configuration val getmail-retriever-configuration-fields)) | |
107 | ||
108 | (define-configuration getmail-retriever-configuration | |
109 | (type | |
110 | (string "SimpleIMAPSSLRetriever") | |
111 | "The type of mail retriever to use. Valid values include | |
112 | @samp{passwd} and @samp{static}.") | |
113 | (server | |
114 | (string 'unset) | |
9ea68dd7 | 115 | "Name or IP address of the server to retrieve mail from.") |
f6b0e1f8 CB |
116 | (username |
117 | (string 'unset) | |
2e1a3148 | 118 | "Username to login to the mail server with.") |
f6b0e1f8 CB |
119 | (port |
120 | (non-negative-integer #f) | |
2e1a3148 | 121 | "Port number to connect to.") |
f6b0e1f8 CB |
122 | (password |
123 | (string "") | |
124 | "Override fields from passwd.") | |
125 | (password-command | |
126 | (list '()) | |
127 | "Override fields from passwd.") | |
128 | (keyfile | |
129 | (string "") | |
2e1a3148 | 130 | "PEM-formatted key file to use for the TLS negotiation.") |
f6b0e1f8 CB |
131 | (certfile |
132 | (string "") | |
2e1a3148 | 133 | "PEM-formatted certificate file to use for the TLS negotiation.") |
f6b0e1f8 CB |
134 | (ca-certs |
135 | (string "") | |
2e1a3148 | 136 | "CA certificates to use.") |
f6b0e1f8 CB |
137 | (extra-parameters |
138 | (parameter-alist '()) | |
2e1a3148 | 139 | "Extra retriever parameters.")) |
f6b0e1f8 CB |
140 | |
141 | (define (serialize-getmail-destination-configuration field-name val) | |
142 | (serialize-configuration val getmail-destination-configuration-fields)) | |
143 | ||
144 | (define-configuration getmail-destination-configuration | |
145 | (type | |
146 | (string 'unset) | |
147 | "The type of mail destination. Valid values include @samp{Maildir}, | |
148 | @samp{Mboxrd} and @samp{MDA_external}.") | |
149 | (path | |
150 | (string-or-filelike "") | |
151 | "The path option for the mail destination. The behaviour depends on the | |
152 | chosen type.") | |
153 | (extra-parameters | |
154 | (parameter-alist '()) | |
155 | "Extra destination parameters")) | |
156 | ||
157 | (define (serialize-getmail-options-configuration field-name val) | |
158 | (serialize-configuration val getmail-options-configuration-fields)) | |
159 | ||
160 | (define-configuration getmail-options-configuration | |
161 | (verbose | |
162 | (non-negative-integer 1) | |
163 | "If set to @samp{0}, getmail will only print warnings and errors. A value | |
164 | of @samp{1} means that messages will be printed about retrieving and deleting | |
165 | messages. If set to @samp{2}, getmail will print messages about each of it's | |
166 | actions.") | |
167 | (read-all | |
168 | (boolean #t) | |
169 | "If true, getmail will retrieve all available messages. Otherwise it will | |
170 | only retrieve messages it hasn't seen previously.") | |
171 | (delete | |
172 | (boolean #f) | |
173 | "If set to true, messages will be deleted from the server after retrieving | |
174 | and successfully delivering them. Otherwise, messages will be left on the | |
175 | server.") | |
176 | (delete-after | |
177 | (non-negative-integer 0) | |
178 | "Getmail will delete messages this number of days after seeing them, if | |
99190575 FP |
179 | they have been delivered. This means messages will be left on the server this |
180 | number of days after delivering them. A value of @samp{0} disabled this | |
f6b0e1f8 CB |
181 | feature.") |
182 | (delete-bigger-than | |
183 | (non-negative-integer 0) | |
184 | "Delete messages larger than this of bytes after retrieving them, even if | |
185 | the delete and delete-after options are disabled. A value of @samp{0} | |
186 | disables this feature.") | |
187 | (max-bytes-per-session | |
188 | (non-negative-integer 0) | |
189 | "Retrieve messages totalling up to this number of bytes before closing the | |
190 | session with the server. A value of @samp{0} disables this feature.") | |
191 | (max-message-size | |
192 | (non-negative-integer 0) | |
193 | "Don't retrieve messages larger than this number of bytes. A value of | |
194 | @samp{0} disables this feature.") | |
195 | (delivered-to | |
196 | (boolean #t) | |
197 | "If true, getmail will add a Delivered-To header to messages.") | |
198 | (received | |
199 | (boolean #t) | |
200 | "If set, getmail adds a Received header to the messages.") | |
201 | (message-log | |
202 | (string "") | |
203 | "Getmail will record a log of its actions to the named file. A value of | |
204 | @samp{\"\"} disables this feature.") | |
205 | (message-log-syslog | |
c8defb2b | 206 | (boolean #f) |
f6b0e1f8 CB |
207 | "If true, getmail will record a log of its actions using the system |
208 | logger.") | |
209 | (message-log-verbose | |
c8defb2b | 210 | (boolean #f) |
f6b0e1f8 CB |
211 | "If true, getmail will log information about messages not retrieved and the |
212 | reason for not retrieving them, as well as starting and ending information | |
213 | lines.") | |
214 | (extra-parameters | |
215 | (parameter-alist '()) | |
216 | "Extra options to include.")) | |
217 | ||
218 | (define (serialize-getmail-configuration-file field-name val) | |
219 | (match val | |
220 | (($ <getmail-configuration-file> location | |
221 | retriever destination options) | |
222 | #~(string-append | |
223 | "[retriever]\n" | |
224 | #$(serialize-getmail-retriever-configuration #f retriever) | |
225 | "\n[destination]\n" | |
226 | #$(serialize-getmail-destination-configuration #f destination) | |
227 | "\n[options]\n" | |
228 | #$(serialize-getmail-options-configuration #f options))))) | |
229 | ||
230 | (define-configuration getmail-configuration-file | |
231 | (retriever | |
232 | (getmail-retriever-configuration (getmail-retriever-configuration)) | |
233 | "What mail account to retrieve mail from, and how to access that account.") | |
234 | (destination | |
235 | (getmail-destination-configuration (getmail-destination-configuration)) | |
236 | "What to do with retrieved messages.") | |
237 | (options | |
238 | (getmail-options-configuration (getmail-options-configuration)) | |
239 | "Configure getmail.")) | |
240 | ||
241 | (define (serialize-symbol field-name val) "") | |
242 | (define (serialize-getmail-configuration field-name val) "") | |
243 | ||
244 | (define-configuration getmail-configuration | |
245 | (name | |
246 | (symbol "unset") | |
247 | "A symbol to identify the getmail service.") | |
248 | (package | |
249 | (package getmail) | |
250 | "The getmail package to use.") | |
251 | (user | |
252 | (string "getmail") | |
253 | "The user to run getmail as.") | |
254 | (group | |
255 | (string "getmail") | |
256 | "The group to run getmail as.") | |
257 | (directory | |
258 | (string "/var/lib/getmail/default") | |
259 | "The getmail directory to use.") | |
260 | (rcfile | |
261 | (getmail-configuration-file (getmail-configuration-file)) | |
262 | "The getmail configuration file to use.") | |
263 | (idle | |
264 | (list '()) | |
265 | "A list of mailboxes that getmail should wait on the server for new mail | |
266 | notifications. This depends on the server supporting the IDLE extension.") | |
267 | (environment-variables | |
268 | (list '()) | |
269 | "Environment variables to set for getmail.")) | |
270 | ||
271 | (define (generate-getmail-documentation) | |
272 | (generate-documentation | |
273 | `((getmail-configuration | |
274 | ,getmail-configuration-fields | |
275 | (rcfile getmail-configuration-file)) | |
276 | (getmail-configuration-file | |
277 | ,getmail-configuration-file-fields | |
278 | (retriever getmail-retriever-configuration) | |
279 | (destination getmail-destination-configuration) | |
280 | (options getmail-options-configuration)) | |
281 | (getmail-retriever-configuration ,getmail-retriever-configuration-fields) | |
282 | (getmail-destination-configuration ,getmail-destination-configuration-fields) | |
283 | (getmail-options-configuration ,getmail-options-configuration-fields)) | |
284 | 'getmail-configuration)) | |
285 | ||
286 | (define-gexp-compiler (getmail-configuration-file-compiler | |
287 | (rcfile <getmail-configuration-file>) system target) | |
288 | (gexp->derivation | |
289 | "getmailrc" | |
290 | #~(call-with-output-file #$output | |
291 | (lambda (port) | |
292 | (display #$(serialize-getmail-configuration-file #f rcfile) | |
293 | port))) | |
294 | #:system system | |
295 | #:target target)) | |
296 | ||
297 | (define (getmail-accounts configs) | |
298 | (let ((users (delete-duplicates | |
299 | (map getmail-configuration-user | |
300 | configs))) | |
301 | (groups (delete-duplicates | |
302 | (map getmail-configuration-group | |
303 | configs)))) | |
304 | (append | |
305 | (map (lambda (group) | |
306 | (user-group | |
307 | (name group) | |
308 | (system? #t))) | |
309 | groups) | |
310 | (map (lambda (user) | |
311 | (user-account | |
312 | (name user) | |
313 | (group (getmail-configuration-group | |
314 | (find (lambda (config) | |
315 | (and | |
316 | (string=? user (getmail-configuration-user config)) | |
317 | (getmail-configuration-group config))) | |
318 | configs))) | |
319 | (system? #t) | |
320 | (comment "Getmail user") | |
321 | (home-directory "/var/empty") | |
322 | (shell (file-append shadow "/sbin/nologin")))) | |
323 | users)))) | |
324 | ||
325 | (define (getmail-activation configs) | |
326 | "Return the activation GEXP for CONFIGS." | |
327 | (with-imported-modules '((guix build utils)) | |
328 | #~(begin | |
329 | (use-modules (guix build utils)) | |
330 | #$@(map | |
331 | (lambda (config) | |
332 | #~(let* ((pw (getpw #$(getmail-configuration-user config))) | |
333 | (uid (passwd:uid pw)) | |
334 | (gid (passwd:gid pw)) | |
335 | (getmaildir #$(getmail-configuration-directory config))) | |
336 | (mkdir-p getmaildir) | |
337 | (chown getmaildir uid gid))) | |
338 | configs)))) | |
339 | ||
340 | (define (getmail-shepherd-services configs) | |
341 | "Return a list of <shepherd-service> for CONFIGS." | |
342 | (map (match-lambda | |
343 | (($ <getmail-configuration> location name package | |
344 | user group directory rcfile idle | |
345 | environment-variables) | |
346 | (shepherd-service | |
347 | (documentation "Run getmail.") | |
348 | (provision (list (symbol-append 'getmail- name))) | |
349 | (requirement '(networking)) | |
350 | (start #~(make-forkexec-constructor | |
351 | `(#$(file-append package "/bin/getmail") | |
352 | ,(string-append "--getmaildir=" #$directory) | |
353 | #$@(map (lambda (idle) | |
354 | (string-append "--idle=" idle)) | |
355 | idle) | |
356 | ,(string-append "--rcfile=" #$rcfile)) | |
357 | #:user #$user | |
358 | #:group #$group | |
359 | #:environment-variables | |
360 | (list #$@environment-variables) | |
361 | #:log-file | |
362 | #$(string-append "/var/log/getmail-" | |
147a7f1f CB |
363 | (symbol->string name)))) |
364 | (stop #~(make-kill-destructor))))) | |
f6b0e1f8 CB |
365 | configs)) |
366 | ||
367 | (define getmail-service-type | |
368 | (service-type | |
369 | (name 'getmail) | |
370 | (extensions | |
371 | (list (service-extension shepherd-root-service-type | |
372 | getmail-shepherd-services) | |
373 | (service-extension activation-service-type | |
374 | getmail-activation) | |
375 | (service-extension account-service-type | |
376 | getmail-accounts))) | |
377 | (description | |
378 | "Run @command{getmail}, a mail retriever program.") | |
379 | (default-value '()) | |
380 | (compose concatenate) | |
381 | (extend append))) |