gnu/services/getmail.scm

   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)
 115    "Name or IP address of the server to retrieve mail from.")
 116   (username
 117    (string 'unset)
 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 '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
 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 (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-"
 363                                       (symbol->string name))))
 364            (stop #~(make-kill-destructor)))))
 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)))