[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#33185] [PATCH 1/3] services: Add getmail.
|
From: |
Christopher Baines |
|
Subject: |
[bug#33185] [PATCH 1/3] services: Add getmail. |
|
Date: |
Fri, 3 May 2019 20:30:35 +0100 |
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.
---
doc/guix.texi | 290 ++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
gnu/services/getmail.scm | 380 +++++++++++++++++++++++++++++++++++++++
gnu/tests/mail.scm | 178 +++++++++++++++++-
4 files changed, 848 insertions(+), 1 deletion(-)
create mode 100644 gnu/services/getmail.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index 7cda06de5c..e23d178697 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -16651,6 +16651,296 @@ variables.
@end table
@end deftp
address@hidden Getmail service
+
address@hidden IMAP
address@hidden POP
+
address@hidden {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}.
+
+Available @code{getmail-configuration} fields are:
+
address@hidden address@hidden parameter} symbol name
+A symbol to identify the getmail service.
+
+Defaults to @samp{"unset"}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} package package
+The getmail package to use.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string user
+The user to run getmail as.
+
+Defaults to @samp{"getmail"}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string group
+The group to run getmail as.
+
+Defaults to @samp{"getmail"}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string directory
+The getmail directory to use.
+
+Defaults to @samp{"/var/lib/getmail/default"}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} getmail-configuration-file rcfile
+The getmail configuration file to use.
+
+Available @code{getmail-configuration-file} fields are:
+
address@hidden address@hidden 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:
+
address@hidden address@hidden parameter} string type
+The type of mail retriever to use. Valid values include @samp{passwd}
+and @samp{static}.
+
+Defaults to @samp{"SimpleIMAPSSLRetriever"}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string server
+Space separated list of arguments to the userdb driver.
+
+Defaults to @samp{unset}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string username
+Space separated list of arguments to the userdb driver.
+
+Defaults to @samp{unset}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer port
+Space separated list of arguments to the userdb driver.
+
+Defaults to @samp{#f}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string password
+Override fields from passwd.
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} list password-command
+Override fields from passwd.
+
+Defaults to @samp{()}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string keyfile
+PEM-formatted key file to use for the TLS negotiation
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string certfile
+PEM-formatted certificate file to use for the TLS negotiation
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string ca-certs
+CA certificates to use
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} parameter-alist extra-parameters
+Extra retriever parameters
+
+Defaults to @samp{()}.
+
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} getmail-destination-configuration
destination
+What to do with retrieved messages.
+
+Available @code{getmail-destination-configuration} fields are:
+
address@hidden address@hidden parameter} string type
+The type of mail destination. Valid values include @samp{Maildir},
address@hidden and @samp{MDA_external}.
+
+Defaults to @samp{unset}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string-or-filelike path
+The path option for the mail destination. The behaviour depends on the
+chosen type.
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} parameter-alist extra-parameters
+Extra destination parameters
+
+Defaults to @samp{()}.
+
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} getmail-options-configuration options
+Configure getmail.
+
+Available @code{getmail-options-configuration} fields are:
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-message-size
+Don't retrieve messages larger than this number of bytes. A value of
address@hidden disables this feature.
+
+Defaults to @samp{0}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean delivered-to
+If true, getmail will add a Delivered-To header to messages.
+
+Defaults to @samp{#t}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean received
+If set, getmail adds a Received header to the messages.
+
+Defaults to @samp{#t}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} string message-log
+Getmail will record a log of its actions to the named file. A value of
address@hidden""} disables this feature.
+
+Defaults to @samp{""}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean message-log-syslog
+If true, getmail will record a log of its actions using the system
+logger.
+
+Defaults to @samp{#t}.
+
address@hidden deftypevr
+
address@hidden address@hidden 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}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} parameter-alist extra-parameters
+Extra options to include.
+
+Defaults to @samp{()}.
+
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden address@hidden 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{()}.
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} list environment-variables
+Environment variables to set for getmail.
+
+Defaults to @samp{()}.
+
address@hidden deftypevr
+
@subsubheading Mail Aliases Service
@cindex email aliases
diff --git a/gnu/local.mk b/gnu/local.mk
index a0f40d13ae..f7dbf5d919 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -513,6 +513,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 \
diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm
new file mode 100644
index 0000000000..b807bb3a5d
--- /dev/null
+++ b/gnu/services/getmail.scm
@@ -0,0 +1,380 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Christopher Baines <address@hidden>
+;;;
+;;; 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
address@hidden 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},
address@hidden 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
address@hidden 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
address@hidden"\"} 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 address@hidden)
+ #: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)))
diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm
index 33aa4d3437..10e5be71d8 100644
--- a/gnu/tests/mail.scm
+++ b/gnu/tests/mail.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2017 Ludovic Courtès <address@hidden>
;;; Copyright © 2018 Oleg Pykhalov <address@hidden>
;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2019 Christopher Baines <address@hidden>
;;;
;;; 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: address@hidden
+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
--
2.21.0