services: Add getmail.
Getmail is a mail retriever written in Python, this commit adds a service-type to run getmail. I'm looking at this, as it's a convinient way of getting mailing list messages in to Patchwork. I initially tried putting this in the (gnu services mail) module, but due to also trying to use the define-configuration pattern, it conflicted with the dovecot service. * gnu/services/getmail.scm: New file. * gnu/local.mk: Add it. * gnu/tests/mail.scm (%getmail-os, %test-getmail): New variables. (run-getmail-test): New procedure.master
Christopher Baines
parent
9bc1de3134
commit
f6b0e1f8ff
291
doc/guix.texi
291
doc/guix.texi
|
|
@ -16716,6 +16716,297 @@ variables.
|
|||
@end table
|
||||
@end deftp
|
||||
|
||||
@subsubheading Getmail service
|
||||
|
||||
@cindex IMAP
|
||||
@cindex POP
|
||||
|
||||
@deffn {Scheme Variable} getmail-service-type
|
||||
This is the type of the @uref{http://pyropus.ca/software/getmail/, Getmail}
|
||||
mail retriever, whose value should be an @code{getmail-configuration}.
|
||||
@end deffn
|
||||
|
||||
Available @code{getmail-configuration} fields are:
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} symbol name
|
||||
A symbol to identify the getmail service.
|
||||
|
||||
Defaults to @samp{"unset"}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} package package
|
||||
The getmail package to use.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} string user
|
||||
The user to run getmail as.
|
||||
|
||||
Defaults to @samp{"getmail"}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} string group
|
||||
The group to run getmail as.
|
||||
|
||||
Defaults to @samp{"getmail"}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} string directory
|
||||
The getmail directory to use.
|
||||
|
||||
Defaults to @samp{"/var/lib/getmail/default"}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} getmail-configuration-file rcfile
|
||||
The getmail configuration file to use.
|
||||
|
||||
Available @code{getmail-configuration-file} fields are:
|
||||
|
||||
@deftypevr {@code{getmail-configuration-file} parameter} getmail-retriever-configuration retriever
|
||||
What mail account to retrieve mail from, and how to access that account.
|
||||
|
||||
Available @code{getmail-retriever-configuration} fields are:
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string type
|
||||
The type of mail retriever to use. Valid values include @samp{passwd}
|
||||
and @samp{static}.
|
||||
|
||||
Defaults to @samp{"SimpleIMAPSSLRetriever"}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string server
|
||||
Space separated list of arguments to the userdb driver.
|
||||
|
||||
Defaults to @samp{unset}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string username
|
||||
Space separated list of arguments to the userdb driver.
|
||||
|
||||
Defaults to @samp{unset}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} non-negative-integer port
|
||||
Space separated list of arguments to the userdb driver.
|
||||
|
||||
Defaults to @samp{#f}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string password
|
||||
Override fields from passwd.
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} list password-command
|
||||
Override fields from passwd.
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string keyfile
|
||||
PEM-formatted key file to use for the TLS negotiation
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string certfile
|
||||
PEM-formatted certificate file to use for the TLS negotiation
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} string ca-certs
|
||||
CA certificates to use
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-retriever-configuration} parameter} parameter-alist extra-parameters
|
||||
Extra retriever parameters
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration-file} parameter} getmail-destination-configuration destination
|
||||
What to do with retrieved messages.
|
||||
|
||||
Available @code{getmail-destination-configuration} fields are:
|
||||
|
||||
@deftypevr {@code{getmail-destination-configuration} parameter} string type
|
||||
The type of mail destination. Valid values include @samp{Maildir},
|
||||
@samp{Mboxrd} and @samp{MDA_external}.
|
||||
|
||||
Defaults to @samp{unset}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-destination-configuration} parameter} string-or-filelike path
|
||||
The path option for the mail destination. The behaviour depends on the
|
||||
chosen type.
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-destination-configuration} parameter} parameter-alist extra-parameters
|
||||
Extra destination parameters
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration-file} parameter} getmail-options-configuration options
|
||||
Configure getmail.
|
||||
|
||||
Available @code{getmail-options-configuration} fields are:
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer verbose
|
||||
If set to @samp{0}, getmail will only print warnings and errors. A
|
||||
value of @samp{1} means that messages will be printed about retrieving
|
||||
and deleting messages. If set to @samp{2}, getmail will print messages
|
||||
about each of it's actions.
|
||||
|
||||
Defaults to @samp{1}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean read-all
|
||||
If true, getmail will retrieve all available messages. Otherwise it
|
||||
will only retrieve messages it hasn't seen previously.
|
||||
|
||||
Defaults to @samp{#t}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean delete
|
||||
If set to true, messages will be deleted from the server after
|
||||
retrieving and successfully delivering them. Otherwise, messages will
|
||||
be left on the server.
|
||||
|
||||
Defaults to @samp{#f}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer delete-after
|
||||
Getmail will delete messages this number of days after seeing them, if
|
||||
they have not been delivered. This means messages will be left on the
|
||||
server this number of days after delivering them. A value of @samp{0}
|
||||
disabled this feature.
|
||||
|
||||
Defaults to @samp{0}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer delete-bigger-than
|
||||
Delete messages larger than this of bytes after retrieving them, even if
|
||||
the delete and delete-after options are disabled. A value of @samp{0}
|
||||
disables this feature.
|
||||
|
||||
Defaults to @samp{0}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer max-bytes-per-session
|
||||
Retrieve messages totalling up to this number of bytes before closing
|
||||
the session with the server. A value of @samp{0} disables this feature.
|
||||
|
||||
Defaults to @samp{0}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer max-message-size
|
||||
Don't retrieve messages larger than this number of bytes. A value of
|
||||
@samp{0} disables this feature.
|
||||
|
||||
Defaults to @samp{0}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean delivered-to
|
||||
If true, getmail will add a Delivered-To header to messages.
|
||||
|
||||
Defaults to @samp{#t}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean received
|
||||
If set, getmail adds a Received header to the messages.
|
||||
|
||||
Defaults to @samp{#t}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} string message-log
|
||||
Getmail will record a log of its actions to the named file. A value of
|
||||
@samp{""} disables this feature.
|
||||
|
||||
Defaults to @samp{""}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean message-log-syslog
|
||||
If true, getmail will record a log of its actions using the system
|
||||
logger.
|
||||
|
||||
Defaults to @samp{#t}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} boolean message-log-verbose
|
||||
If true, getmail will log information about messages not retrieved and
|
||||
the reason for not retrieving them, as well as starting and ending
|
||||
information lines.
|
||||
|
||||
Defaults to @samp{#t}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-options-configuration} parameter} parameter-alist extra-parameters
|
||||
Extra options to include.
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} list idle
|
||||
A list of mailboxes that getmail should wait on the server for new mail
|
||||
notifications. This depends on the server supporting the IDLE
|
||||
extension.
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@deftypevr {@code{getmail-configuration} parameter} list environment-variables
|
||||
Environment variables to set for getmail.
|
||||
|
||||
Defaults to @samp{()}.
|
||||
|
||||
@end deftypevr
|
||||
|
||||
@subsubheading Mail Aliases Service
|
||||
|
||||
@cindex email aliases
|
||||
|
|
|
|||
|
|
@ -516,6 +516,7 @@ GNU_SYSTEM_MODULES = \
|
|||
%D%/services/docker.scm \
|
||||
%D%/services/authentication.scm \
|
||||
%D%/services/games.scm \
|
||||
%D%/services/getmail.scm \
|
||||
%D%/services/kerberos.scm \
|
||||
%D%/services/lirc.scm \
|
||||
%D%/services/virtualization.scm \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,380 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu services getmail)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services configuration)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (gnu system pam)
|
||||
#:use-module (gnu system shadow)
|
||||
#:use-module (gnu packages mail)
|
||||
#:use-module (gnu packages admin)
|
||||
#:use-module (gnu packages tls)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (getmail-retriever-configuration
|
||||
getmail-retriever-configuration-extra-parameters
|
||||
getmail-destination-configuration
|
||||
getmail-options-configuration
|
||||
getmail-configuration-file
|
||||
getmail-configuration
|
||||
getmail-service-type))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Service for the getmail mail retriever.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (uglify-field-name field-name)
|
||||
(let ((str (symbol->string field-name)))
|
||||
(string-join (string-split (if (string-suffix? "?" str)
|
||||
(substring str 0 (1- (string-length str)))
|
||||
str)
|
||||
#\-)
|
||||
"_")))
|
||||
|
||||
(define (serialize-field field-name val)
|
||||
#~(let ((val '#$val))
|
||||
(format #f "~a = ~a\n"
|
||||
#$(uglify-field-name field-name)
|
||||
(cond
|
||||
((list? val)
|
||||
(string-append
|
||||
"("
|
||||
(string-concatenate
|
||||
(map (lambda (list-val)
|
||||
(format #f "\"~a\", " list-val))
|
||||
val))
|
||||
")"))
|
||||
(else
|
||||
val)))))
|
||||
|
||||
(define (serialize-string field-name val)
|
||||
(if (string=? val "")
|
||||
""
|
||||
(serialize-field field-name val)))
|
||||
|
||||
(define (string-or-filelike? val)
|
||||
(or (string? val)
|
||||
(file-like? val)))
|
||||
(define (serialize-string-or-filelike field-name val)
|
||||
(if (equal? val "")
|
||||
""
|
||||
(serialize-field field-name val)))
|
||||
|
||||
(define (serialize-boolean field-name val)
|
||||
(serialize-field field-name (if val "true" "false")))
|
||||
|
||||
(define (non-negative-integer? val)
|
||||
(and (exact-integer? val) (not (negative? val))))
|
||||
(define (serialize-non-negative-integer field-name val)
|
||||
(serialize-field field-name val))
|
||||
|
||||
(define serialize-list serialize-field)
|
||||
|
||||
(define parameter-alist? list?)
|
||||
(define (serialize-parameter-alist field-name val)
|
||||
#~(string-append
|
||||
#$@(map (match-lambda
|
||||
((key . value)
|
||||
(serialize-field key value)))
|
||||
val)))
|
||||
|
||||
(define (serialize-getmail-retriever-configuration field-name val)
|
||||
(serialize-configuration val getmail-retriever-configuration-fields))
|
||||
|
||||
(define-configuration getmail-retriever-configuration
|
||||
(type
|
||||
(string "SimpleIMAPSSLRetriever")
|
||||
"The type of mail retriever to use. Valid values include
|
||||
@samp{passwd} and @samp{static}.")
|
||||
(server
|
||||
(string 'unset)
|
||||
"Space separated list of arguments to the userdb driver.")
|
||||
(username
|
||||
(string 'unset)
|
||||
"Space separated list of arguments to the userdb driver.")
|
||||
(port
|
||||
(non-negative-integer #f)
|
||||
"Space separated list of arguments to the userdb driver.")
|
||||
(password
|
||||
(string "")
|
||||
"Override fields from passwd.")
|
||||
(password-command
|
||||
(list '())
|
||||
"Override fields from passwd.")
|
||||
(keyfile
|
||||
(string "")
|
||||
"PEM-formatted key file to use for the TLS negotiation")
|
||||
(certfile
|
||||
(string "")
|
||||
"PEM-formatted certificate file to use for the TLS negotiation")
|
||||
(ca-certs
|
||||
(string "")
|
||||
"CA certificates to use")
|
||||
(extra-parameters
|
||||
(parameter-alist '())
|
||||
"Extra retriever parameters"))
|
||||
|
||||
(define (serialize-getmail-destination-configuration field-name val)
|
||||
(serialize-configuration val getmail-destination-configuration-fields))
|
||||
|
||||
(define-configuration getmail-destination-configuration
|
||||
(type
|
||||
(string 'unset)
|
||||
"The type of mail destination. Valid values include @samp{Maildir},
|
||||
@samp{Mboxrd} and @samp{MDA_external}.")
|
||||
(path
|
||||
(string-or-filelike "")
|
||||
"The path option for the mail destination. The behaviour depends on the
|
||||
chosen type.")
|
||||
(extra-parameters
|
||||
(parameter-alist '())
|
||||
"Extra destination parameters"))
|
||||
|
||||
(define (serialize-getmail-options-configuration field-name val)
|
||||
(serialize-configuration val getmail-options-configuration-fields))
|
||||
|
||||
(define-configuration getmail-options-configuration
|
||||
(verbose
|
||||
(non-negative-integer 1)
|
||||
"If set to @samp{0}, getmail will only print warnings and errors. A value
|
||||
of @samp{1} means that messages will be printed about retrieving and deleting
|
||||
messages. If set to @samp{2}, getmail will print messages about each of it's
|
||||
actions.")
|
||||
(read-all
|
||||
(boolean #t)
|
||||
"If true, getmail will retrieve all available messages. Otherwise it will
|
||||
only retrieve messages it hasn't seen previously.")
|
||||
(delete
|
||||
(boolean #f)
|
||||
"If set to true, messages will be deleted from the server after retrieving
|
||||
and successfully delivering them. Otherwise, messages will be left on the
|
||||
server.")
|
||||
(delete-after
|
||||
(non-negative-integer 0)
|
||||
"Getmail will delete messages this number of days after seeing them, if
|
||||
they have not been delivered. This means messages will be left on the server
|
||||
this number of days after delivering them. A value of @samp{0} disabled this
|
||||
feature.")
|
||||
(delete-bigger-than
|
||||
(non-negative-integer 0)
|
||||
"Delete messages larger than this of bytes after retrieving them, even if
|
||||
the delete and delete-after options are disabled. A value of @samp{0}
|
||||
disables this feature.")
|
||||
(max-bytes-per-session
|
||||
(non-negative-integer 0)
|
||||
"Retrieve messages totalling up to this number of bytes before closing the
|
||||
session with the server. A value of @samp{0} disables this feature.")
|
||||
(max-message-size
|
||||
(non-negative-integer 0)
|
||||
"Don't retrieve messages larger than this number of bytes. A value of
|
||||
@samp{0} disables this feature.")
|
||||
(delivered-to
|
||||
(boolean #t)
|
||||
"If true, getmail will add a Delivered-To header to messages.")
|
||||
(received
|
||||
(boolean #t)
|
||||
"If set, getmail adds a Received header to the messages.")
|
||||
(message-log
|
||||
(string "")
|
||||
"Getmail will record a log of its actions to the named file. A value of
|
||||
@samp{\"\"} disables this feature.")
|
||||
(message-log-syslog
|
||||
(boolean #t)
|
||||
"If true, getmail will record a log of its actions using the system
|
||||
logger.")
|
||||
(message-log-verbose
|
||||
(boolean #t)
|
||||
"If true, getmail will log information about messages not retrieved and the
|
||||
reason for not retrieving them, as well as starting and ending information
|
||||
lines.")
|
||||
(extra-parameters
|
||||
(parameter-alist '())
|
||||
"Extra options to include."))
|
||||
|
||||
(define (serialize-getmail-configuration-file field-name val)
|
||||
(match val
|
||||
(($ <getmail-configuration-file> location
|
||||
retriever destination options)
|
||||
#~(string-append
|
||||
"[retriever]\n"
|
||||
#$(serialize-getmail-retriever-configuration #f retriever)
|
||||
"\n[destination]\n"
|
||||
#$(serialize-getmail-destination-configuration #f destination)
|
||||
"\n[options]\n"
|
||||
#$(serialize-getmail-options-configuration #f options)))))
|
||||
|
||||
(define-configuration getmail-configuration-file
|
||||
(retriever
|
||||
(getmail-retriever-configuration (getmail-retriever-configuration))
|
||||
"What mail account to retrieve mail from, and how to access that account.")
|
||||
(destination
|
||||
(getmail-destination-configuration (getmail-destination-configuration))
|
||||
"What to do with retrieved messages.")
|
||||
(options
|
||||
(getmail-options-configuration (getmail-options-configuration))
|
||||
"Configure getmail."))
|
||||
|
||||
(define (serialize-symbol field-name val) "")
|
||||
(define (serialize-getmail-configuration field-name val) "")
|
||||
|
||||
(define-configuration getmail-configuration
|
||||
(name
|
||||
(symbol "unset")
|
||||
"A symbol to identify the getmail service.")
|
||||
(package
|
||||
(package getmail)
|
||||
"The getmail package to use.")
|
||||
(user
|
||||
(string "getmail")
|
||||
"The user to run getmail as.")
|
||||
(group
|
||||
(string "getmail")
|
||||
"The group to run getmail as.")
|
||||
(directory
|
||||
(string "/var/lib/getmail/default")
|
||||
"The getmail directory to use.")
|
||||
(rcfile
|
||||
(getmail-configuration-file (getmail-configuration-file))
|
||||
"The getmail configuration file to use.")
|
||||
(idle
|
||||
(list '())
|
||||
"A list of mailboxes that getmail should wait on the server for new mail
|
||||
notifications. This depends on the server supporting the IDLE extension.")
|
||||
(environment-variables
|
||||
(list '())
|
||||
"Environment variables to set for getmail."))
|
||||
|
||||
(define (generate-getmail-documentation)
|
||||
(generate-documentation
|
||||
`((getmail-configuration
|
||||
,getmail-configuration-fields
|
||||
(rcfile getmail-configuration-file))
|
||||
(getmail-configuration-file
|
||||
,getmail-configuration-file-fields
|
||||
(retriever getmail-retriever-configuration)
|
||||
(destination getmail-destination-configuration)
|
||||
(options getmail-options-configuration))
|
||||
(getmail-retriever-configuration ,getmail-retriever-configuration-fields)
|
||||
(getmail-destination-configuration ,getmail-destination-configuration-fields)
|
||||
(getmail-options-configuration ,getmail-options-configuration-fields))
|
||||
'getmail-configuration))
|
||||
|
||||
(define-gexp-compiler (getmail-configuration-file-compiler
|
||||
(rcfile <getmail-configuration-file>) system target)
|
||||
(gexp->derivation
|
||||
"getmailrc"
|
||||
#~(call-with-output-file #$output
|
||||
(lambda (port)
|
||||
(display #$(serialize-getmail-configuration-file #f rcfile)
|
||||
port)))
|
||||
#:system system
|
||||
#:target target))
|
||||
|
||||
(define (getmail-accounts configs)
|
||||
(let ((users (delete-duplicates
|
||||
(map getmail-configuration-user
|
||||
configs)))
|
||||
(groups (delete-duplicates
|
||||
(map getmail-configuration-group
|
||||
configs))))
|
||||
(append
|
||||
(map (lambda (group)
|
||||
(user-group
|
||||
(name group)
|
||||
(system? #t)))
|
||||
groups)
|
||||
(map (lambda (user)
|
||||
(user-account
|
||||
(name user)
|
||||
(group (getmail-configuration-group
|
||||
(find (lambda (config)
|
||||
(and
|
||||
(string=? user (getmail-configuration-user config))
|
||||
(getmail-configuration-group config)))
|
||||
configs)))
|
||||
(system? #t)
|
||||
(comment "Getmail user")
|
||||
(home-directory "/var/empty")
|
||||
(shell (file-append shadow "/sbin/nologin"))))
|
||||
users))))
|
||||
|
||||
(define (getmail-activation configs)
|
||||
"Return the activation GEXP for CONFIGS."
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
#$@(map
|
||||
(lambda (config)
|
||||
#~(let* ((pw (getpw #$(getmail-configuration-user config)))
|
||||
(uid (passwd:uid pw))
|
||||
(gid (passwd:gid pw))
|
||||
(getmaildir #$(getmail-configuration-directory config)))
|
||||
(mkdir-p getmaildir)
|
||||
(chown getmaildir uid gid)))
|
||||
configs))))
|
||||
|
||||
(define (getmail-shepherd-services configs)
|
||||
"Return a list of <shepherd-service> for CONFIGS."
|
||||
(map (match-lambda
|
||||
(($ <getmail-configuration> location name package
|
||||
user group directory rcfile idle
|
||||
environment-variables)
|
||||
(shepherd-service
|
||||
(documentation "Run getmail.")
|
||||
(provision (list (symbol-append 'getmail- name)))
|
||||
(requirement '(networking))
|
||||
(start #~(make-forkexec-constructor
|
||||
`(#$(file-append package "/bin/getmail")
|
||||
,(string-append "--getmaildir=" #$directory)
|
||||
#$@(map (lambda (idle)
|
||||
(string-append "--idle=" idle))
|
||||
idle)
|
||||
,(string-append "--rcfile=" #$rcfile))
|
||||
#:user #$user
|
||||
#:group #$group
|
||||
#:environment-variables
|
||||
(list #$@environment-variables)
|
||||
#:log-file
|
||||
#$(string-append "/var/log/getmail-"
|
||||
(symbol->string name)))))))
|
||||
configs))
|
||||
|
||||
(define getmail-service-type
|
||||
(service-type
|
||||
(name 'getmail)
|
||||
(extensions
|
||||
(list (service-extension shepherd-root-service-type
|
||||
getmail-shepherd-services)
|
||||
(service-extension activation-service-type
|
||||
getmail-activation)
|
||||
(service-extension account-service-type
|
||||
getmail-accounts)))
|
||||
(description
|
||||
"Run @command{getmail}, a mail retriever program.")
|
||||
(default-value '())
|
||||
(compose concatenate)
|
||||
(extend append)))
|
||||
|
|
@ -4,6 +4,7 @@
|
|||
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
|
||||
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
|
||||
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -25,6 +26,7 @@
|
|||
#:use-module (gnu system)
|
||||
#:use-module (gnu system vm)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services getmail)
|
||||
#:use-module (gnu services mail)
|
||||
#:use-module (gnu services networking)
|
||||
#:use-module (guix gexp)
|
||||
|
|
@ -32,7 +34,8 @@
|
|||
#:use-module (ice-9 ftw)
|
||||
#:export (%test-opensmtpd
|
||||
%test-exim
|
||||
%test-dovecot))
|
||||
%test-dovecot
|
||||
%test-getmail))
|
||||
|
||||
(define %opensmtpd-os
|
||||
(simple-operating-system
|
||||
|
|
@ -394,3 +397,176 @@ Subject: Hello Nice to meet you!")
|
|||
(name "dovecot")
|
||||
(description "Connect to a running Dovecot server.")
|
||||
(value (run-dovecot-test))))
|
||||
|
||||
(define %getmail-os
|
||||
(simple-operating-system
|
||||
(service dhcp-client-service-type)
|
||||
(service dovecot-service-type
|
||||
(dovecot-configuration
|
||||
(disable-plaintext-auth? #f)
|
||||
(ssl? "no")
|
||||
(auth-mechanisms '("anonymous" "plain"))
|
||||
(auth-anonymous-username "alice")
|
||||
(mail-location
|
||||
(string-append "maildir:~/Maildir"
|
||||
":INBOX=~/Maildir/INBOX"
|
||||
":LAYOUT=fs"))))
|
||||
(service getmail-service-type
|
||||
(list
|
||||
(getmail-configuration
|
||||
(name 'test)
|
||||
(user "alice")
|
||||
(directory "/var/lib/getmail/alice")
|
||||
(idle '("TESTBOX"))
|
||||
(rcfile
|
||||
(getmail-configuration-file
|
||||
(retriever
|
||||
(getmail-retriever-configuration
|
||||
(type "SimpleIMAPRetriever")
|
||||
(server "localhost")
|
||||
(username "alice")
|
||||
(port 143)
|
||||
(extra-parameters
|
||||
'((password . "testpass")
|
||||
(mailboxes . ("TESTBOX"))))))
|
||||
(destination
|
||||
(getmail-destination-configuration
|
||||
(type "Maildir")
|
||||
(path "/home/alice/TestMaildir/")))
|
||||
(options
|
||||
(getmail-options-configuration
|
||||
(read-all #f))))))))))
|
||||
|
||||
(define (run-getmail-test)
|
||||
"Return a test of an OS running Getmail service."
|
||||
(define vm
|
||||
(virtual-machine
|
||||
(operating-system (marionette-operating-system
|
||||
%getmail-os
|
||||
#:imported-modules '((gnu services herd))))
|
||||
(port-forwardings '((8143 . 143)))))
|
||||
|
||||
(define test
|
||||
(with-imported-modules '((gnu build marionette))
|
||||
#~(begin
|
||||
(use-modules (gnu build marionette)
|
||||
(ice-9 iconv)
|
||||
(ice-9 rdelim)
|
||||
(rnrs base)
|
||||
(rnrs bytevectors)
|
||||
(srfi srfi-64))
|
||||
|
||||
(define marionette
|
||||
(make-marionette '(#$vm)))
|
||||
|
||||
(define* (message-length message #:key (encoding "iso-8859-1"))
|
||||
(bytevector-length (string->bytevector message encoding)))
|
||||
|
||||
(define message "From: test@example.com\n\
|
||||
Subject: Hello Nice to meet you!")
|
||||
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
|
||||
(test-begin "getmail")
|
||||
|
||||
;; Wait for dovecot to be up and running.
|
||||
(test-assert "dovecot running"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
(start-service 'dovecot))
|
||||
marionette))
|
||||
|
||||
(test-assert "set password for alice"
|
||||
(marionette-eval
|
||||
'(system "echo -e \"testpass\ntestpass\" | passwd alice")
|
||||
marionette))
|
||||
|
||||
;; Wait for getmail to be up and running.
|
||||
(test-assert "getmail-test running"
|
||||
(marionette-eval
|
||||
'(let* ((pw (getpw "alice"))
|
||||
(uid (passwd:uid pw))
|
||||
(gid (passwd:gid pw)))
|
||||
(use-modules (gnu services herd))
|
||||
|
||||
(for-each
|
||||
(lambda (dir)
|
||||
(mkdir dir)
|
||||
(chown dir uid gid))
|
||||
'("/home/alice/TestMaildir"
|
||||
"/home/alice/TestMaildir/cur"
|
||||
"/home/alice/TestMaildir/new"
|
||||
"/home/alice/TestMaildir/tmp"
|
||||
"/home/alice/TestMaildir/TESTBOX"
|
||||
"/home/alice/TestMaildir/TESTBOX/cur"
|
||||
"/home/alice/TestMaildir/TESTBOX/new"
|
||||
"/home/alice/TestMaildir/TESTBOX/tmp"))
|
||||
|
||||
(start-service 'getmail-test))
|
||||
marionette))
|
||||
|
||||
;; Check Dovecot service's PID.
|
||||
(test-assert "service process id"
|
||||
(let ((pid
|
||||
(number->string (wait-for-file "/var/run/dovecot/master.pid"
|
||||
marionette))))
|
||||
(marionette-eval `(file-exists? (string-append "/proc/" ,pid))
|
||||
marionette)))
|
||||
|
||||
(test-assert "accept an email"
|
||||
(let ((imap (socket AF_INET SOCK_STREAM 0))
|
||||
(addr (make-socket-address AF_INET INADDR_LOOPBACK 8143)))
|
||||
(connect imap addr)
|
||||
;; Be greeted.
|
||||
(read-line imap) ;OK
|
||||
;; Authenticate
|
||||
(write-line "a AUTHENTICATE ANONYMOUS" imap)
|
||||
(read-line imap) ;+
|
||||
(write-line "c2lyaGM=" imap)
|
||||
(read-line imap) ;OK
|
||||
;; Create a TESTBOX mailbox
|
||||
(write-line "a CREATE TESTBOX" imap)
|
||||
(read-line imap) ;OK
|
||||
;; Append a message to a TESTBOX mailbox
|
||||
(write-line (format #f "a APPEND TESTBOX {~a}"
|
||||
(number->string (message-length message)))
|
||||
imap)
|
||||
(read-line imap) ;+
|
||||
(write-line message imap)
|
||||
(read-line imap) ;OK
|
||||
;; Logout
|
||||
(write-line "a LOGOUT" imap)
|
||||
(close imap)
|
||||
#t))
|
||||
|
||||
(sleep 1)
|
||||
|
||||
(test-assert "mail arrived"
|
||||
(string-contains
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (ice-9 ftw)
|
||||
(ice-9 match))
|
||||
(let ((TESTBOX/new "/home/alice/TestMaildir/new/"))
|
||||
(match (scandir TESTBOX/new)
|
||||
(("." ".." message-file)
|
||||
(call-with-input-file
|
||||
(string-append TESTBOX/new message-file)
|
||||
get-string-all)))))
|
||||
marionette)
|
||||
message))
|
||||
|
||||
(test-end)
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||
|
||||
(gexp->derivation "getmail-test" test))
|
||||
|
||||
(define %test-getmail
|
||||
(system-test
|
||||
(name "getmail")
|
||||
(description "Connect to a running Getmail server.")
|
||||
(value (run-getmail-test))))
|
||||
|
||||
%getmail-os
|
||||
|
|
|
|||
Reference in New Issue