| 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 | (define-module (gnu services getmail)
|
| 26 | #:use-module (gnu services)
|
| 27 | #:use-module (gnu services base)
|
| 28 | #:use-module (gnu services configuration)
|
| 29 | #:use-module (gnu services shepherd)
|
| 30 | #:use-module (gnu system pam)
|
| 31 | #:use-module (gnu system shadow)
|
| 32 | #:use-module (gnu packages mail)
|
| 33 | #:use-module (gnu packages admin)
|
| 34 | #:use-module (gnu packages tls)
|
| 35 | #:use-module (guix records)
|
| 36 | #:use-module (guix store)
|
| 37 | #:use-module (guix packages)
|
| 38 | #:use-module (guix gexp)
|
| 39 | #:use-module (ice-9 match)
|
| 40 | #:use-module (ice-9 format)
|
| 41 | #:use-module (srfi srfi-1)
|
| 42 | #:export (getmail-retriever-configuration
|
| 43 | getmail-retriever-configuration-extra-parameters
|
| 44 | getmail-destination-configuration
|
| 45 | getmail-options-configuration
|
| 46 | getmail-configuration-file
|
| 47 | getmail-configuration
|
| 48 | getmail-service-type))
|
| 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
|
| 115 | "Name or IP address of the server to retrieve mail from.")
|
| 116 | (username
|
| 117 | string
|
| 118 | "Username to login to the mail server with.")
|
| 119 | (port
|
| 120 | (non-negative-integer #f)
|
| 121 | "Port number to connect to.")
|
| 122 | (password
|
| 123 | (string "")
|
| 124 | "Override fields from passwd.")
|
| 125 | (password-command
|
| 126 | (list '())
|
| 127 | "Override fields from passwd.")
|
| 128 | (keyfile
|
| 129 | (string "")
|
| 130 | "PEM-formatted key file to use for the TLS negotiation.")
|
| 131 | (certfile
|
| 132 | (string "")
|
| 133 | "PEM-formatted certificate file to use for the TLS negotiation.")
|
| 134 | (ca-certs
|
| 135 | (string "")
|
| 136 | "CA certificates to use.")
|
| 137 | (extra-parameters
|
| 138 | (parameter-alist '())
|
| 139 | "Extra retriever parameters."))
|
| 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
|
| 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
|
| 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
|
| 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
|
| 206 | (boolean #f)
|
| 207 | "If true, getmail will record a log of its actions using the system
|
| 208 | logger.")
|
| 209 | (message-log-verbose
|
| 210 | (boolean #f)
|
| 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-configuration getmail-configuration-file
|
| 219 | (retriever
|
| 220 | (getmail-retriever-configuration (getmail-retriever-configuration))
|
| 221 | "What mail account to retrieve mail from, and how to access that account.")
|
| 222 | (destination
|
| 223 | (getmail-destination-configuration (getmail-destination-configuration))
|
| 224 | "What to do with retrieved messages.")
|
| 225 | (options
|
| 226 | (getmail-options-configuration (getmail-options-configuration))
|
| 227 | "Configure getmail."))
|
| 228 |
|
| 229 | (define (serialize-getmail-configuration-file field-name val)
|
| 230 | (match-record val <getmail-configuration-file>
|
| 231 | (retriever destination options)
|
| 232 | #~(string-append
|
| 233 | "[retriever]\n"
|
| 234 | #$(serialize-getmail-retriever-configuration #f retriever)
|
| 235 | "\n[destination]\n"
|
| 236 | #$(serialize-getmail-destination-configuration #f destination)
|
| 237 | "\n[options]\n"
|
| 238 | #$(serialize-getmail-options-configuration #f options))))
|
| 239 |
|
| 240 | (define (serialize-symbol field-name val) "")
|
| 241 | (define (serialize-getmail-configuration field-name val) "")
|
| 242 |
|
| 243 | (define-configuration getmail-configuration
|
| 244 | (name
|
| 245 | (symbol "unset")
|
| 246 | "A symbol to identify the getmail service.")
|
| 247 | (package
|
| 248 | (file-like getmail6)
|
| 249 | "The getmail package to use.")
|
| 250 | (user
|
| 251 | (string "getmail")
|
| 252 | "The user to run getmail as.")
|
| 253 | (group
|
| 254 | (string "getmail")
|
| 255 | "The group to run getmail as.")
|
| 256 | (directory
|
| 257 | (string "/var/lib/getmail/default")
|
| 258 | "The getmail directory to use.")
|
| 259 | (rcfile
|
| 260 | (getmail-configuration-file (getmail-configuration-file))
|
| 261 | "The getmail configuration file to use.")
|
| 262 | (idle
|
| 263 | (list '())
|
| 264 | "A list of mailboxes that getmail should wait on the server for new mail
|
| 265 | notifications. This depends on the server supporting the IDLE extension.")
|
| 266 | (environment-variables
|
| 267 | (list '())
|
| 268 | "Environment variables to set for getmail."))
|
| 269 |
|
| 270 | (define (generate-getmail-documentation)
|
| 271 | (generate-documentation
|
| 272 | `((getmail-configuration
|
| 273 | ,getmail-configuration-fields
|
| 274 | (rcfile getmail-configuration-file))
|
| 275 | (getmail-configuration-file
|
| 276 | ,getmail-configuration-file-fields
|
| 277 | (retriever getmail-retriever-configuration)
|
| 278 | (destination getmail-destination-configuration)
|
| 279 | (options getmail-options-configuration))
|
| 280 | (getmail-retriever-configuration ,getmail-retriever-configuration-fields)
|
| 281 | (getmail-destination-configuration ,getmail-destination-configuration-fields)
|
| 282 | (getmail-options-configuration ,getmail-options-configuration-fields))
|
| 283 | 'getmail-configuration))
|
| 284 |
|
| 285 | (define-gexp-compiler (getmail-configuration-file-compiler
|
| 286 | (rcfile <getmail-configuration-file>) system target)
|
| 287 | (gexp->derivation
|
| 288 | "getmailrc"
|
| 289 | #~(call-with-output-file #$output
|
| 290 | (lambda (port)
|
| 291 | (display #$(serialize-getmail-configuration-file #f rcfile)
|
| 292 | port)))
|
| 293 | #:system system
|
| 294 | #:target target))
|
| 295 |
|
| 296 | (define (getmail-accounts configs)
|
| 297 | (let ((users (delete-duplicates
|
| 298 | (map getmail-configuration-user
|
| 299 | configs)))
|
| 300 | (groups (delete-duplicates
|
| 301 | (map getmail-configuration-group
|
| 302 | configs))))
|
| 303 | (append
|
| 304 | (map (lambda (group)
|
| 305 | (user-group
|
| 306 | (name group)
|
| 307 | (system? #t)))
|
| 308 | groups)
|
| 309 | (map (lambda (user)
|
| 310 | (user-account
|
| 311 | (name user)
|
| 312 | (group (getmail-configuration-group
|
| 313 | (find (lambda (config)
|
| 314 | (and
|
| 315 | (string=? user (getmail-configuration-user config))
|
| 316 | (getmail-configuration-group config)))
|
| 317 | configs)))
|
| 318 | (system? #t)
|
| 319 | (comment "Getmail user")
|
| 320 | (home-directory "/var/empty")
|
| 321 | (shell (file-append shadow "/sbin/nologin"))))
|
| 322 | users))))
|
| 323 |
|
| 324 | (define (getmail-activation configs)
|
| 325 | "Return the activation GEXP for CONFIGS."
|
| 326 | (with-imported-modules '((guix build utils))
|
| 327 | #~(begin
|
| 328 | (use-modules (guix build utils))
|
| 329 | #$@(map
|
| 330 | (lambda (config)
|
| 331 | #~(let* ((pw (getpw #$(getmail-configuration-user config)))
|
| 332 | (uid (passwd:uid pw))
|
| 333 | (gid (passwd:gid pw))
|
| 334 | (getmaildir #$(getmail-configuration-directory config)))
|
| 335 | (mkdir-p getmaildir)
|
| 336 | (chown getmaildir uid gid)))
|
| 337 | configs))))
|
| 338 |
|
| 339 | (define (getmail-shepherd-services configs)
|
| 340 | "Return a list of <shepherd-service> for CONFIGS."
|
| 341 | (map (lambda (config)
|
| 342 | (match-record config <getmail-configuration>
|
| 343 | (name package user group directory rcfile idle environment-variables)
|
| 344 | (shepherd-service
|
| 345 | (documentation "Run getmail.")
|
| 346 | (provision (list (symbol-append 'getmail- name)))
|
| 347 | (requirement '(networking))
|
| 348 | (start #~(make-forkexec-constructor
|
| 349 | `(#$(file-append package "/bin/getmail")
|
| 350 | ,(string-append "--getmaildir=" #$directory)
|
| 351 | #$@(map (lambda (idle)
|
| 352 | (string-append "--idle=" idle))
|
| 353 | idle)
|
| 354 | ,(string-append "--rcfile=" #$rcfile))
|
| 355 | #:user #$user
|
| 356 | #:group #$group
|
| 357 | #:environment-variables
|
| 358 | (list #$@environment-variables)
|
| 359 | #:log-file
|
| 360 | #$(string-append "/var/log/getmail-"
|
| 361 | (symbol->string name))))
|
| 362 | (stop #~(make-kill-destructor)))))
|
| 363 | configs))
|
| 364 |
|
| 365 | (define getmail-service-type
|
| 366 | (service-type
|
| 367 | (name 'getmail)
|
| 368 | (extensions
|
| 369 | (list (service-extension shepherd-root-service-type
|
| 370 | getmail-shepherd-services)
|
| 371 | (service-extension activation-service-type
|
| 372 | getmail-activation)
|
| 373 | (service-extension account-service-type
|
| 374 | getmail-accounts)))
|
| 375 | (description
|
| 376 | "Run @command{getmail}, a mail retriever program.")
|
| 377 | (default-value '())
|
| 378 | (compose concatenate)
|
| 379 | (extend append)))
|