From patchwork Fri May 3 19:30:35 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 13887 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 5C57016F5B; Fri, 3 May 2019 20:31:14 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 73F9816F4D for ; Fri, 3 May 2019 20:31:12 +0100 (BST) Received: from localhost ([127.0.0.1]:46432 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMdtn-0007PX-TU for patchwork@mira.cbaines.net; Fri, 03 May 2019 15:31:11 -0400 Received: from eggs.gnu.org ([209.51.188.92]:60702) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMdti-0007P9-V4 for guix-patches@gnu.org; Fri, 03 May 2019 15:31:10 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hMdte-0000ld-GI for guix-patches@gnu.org; Fri, 03 May 2019 15:31:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36165) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hMdte-0000lZ-Bj for guix-patches@gnu.org; Fri, 03 May 2019 15:31:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hMdte-0002us-8p for guix-patches@gnu.org; Fri, 03 May 2019 15:31:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#33185] [PATCH 1/3] services: Add getmail. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 03 May 2019 19:31:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33185 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33185@debbugs.gnu.org Received: via spool by 33185-submit@debbugs.gnu.org id=B33185.155691185211188 (code B ref 33185); Fri, 03 May 2019 19:31:02 +0000 Received: (at 33185) by debbugs.gnu.org; 3 May 2019 19:30:52 +0000 Received: from localhost ([127.0.0.1]:49706 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtT-0002uH-JZ for submit@debbugs.gnu.org; Fri, 03 May 2019 15:30:52 -0400 Received: from mira.cbaines.net ([212.71.252.8]:58910) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtG-0002ti-Q9 for 33185@debbugs.gnu.org; Fri, 03 May 2019 15:30:40 -0400 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id 9CC4D16F4D for <33185@debbugs.gnu.org>; Fri, 3 May 2019 20:30:37 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id f336a9a0 for <33185@debbugs.gnu.org>; Fri, 3 May 2019 19:30:37 +0000 (UTC) From: Christopher Baines Date: Fri, 3 May 2019 20:30:35 +0100 Message-Id: <20190503193037.27035-1-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 In-Reply-To: <87o94jqrff.fsf@cbaines.net> References: <87o94jqrff.fsf@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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 +@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}. + +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 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 +;;; +;;; 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 . + +(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 + (($ 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 ) 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 for CONFIGS." + (map (match-lambda + (($ 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))) 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 ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2019 Christopher Baines ;;; ;;; 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 From patchwork Fri May 3 19:30:36 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 13889 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 4C9C916F58; Fri, 3 May 2019 20:32:10 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 3FBA416F4D for ; Fri, 3 May 2019 20:32:08 +0100 (BST) Received: from localhost ([127.0.0.1]:46446 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMduh-0007cD-RS for patchwork@mira.cbaines.net; Fri, 03 May 2019 15:32:07 -0400 Received: from eggs.gnu.org ([209.51.188.92]:60872) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMdue-0007ay-Fi for guix-patches@gnu.org; Fri, 03 May 2019 15:32:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hMduc-0001GR-PX for guix-patches@gnu.org; Fri, 03 May 2019 15:32:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36171) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hMduc-0001GJ-M1 for guix-patches@gnu.org; Fri, 03 May 2019 15:32:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hMduc-0002wu-HO for guix-patches@gnu.org; Fri, 03 May 2019 15:32:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#33185] [PATCH 2/3] gnu: Add patchwork. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 03 May 2019 19:32:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33185 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33185@debbugs.gnu.org Received: via spool by 33185-submit@debbugs.gnu.org id=B33185.155691186511237 (code B ref 33185); Fri, 03 May 2019 19:32:02 +0000 Received: (at 33185) by debbugs.gnu.org; 3 May 2019 19:31:05 +0000 Received: from localhost ([127.0.0.1]:49708 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtU-0002uQ-Sc for submit@debbugs.gnu.org; Fri, 03 May 2019 15:31:02 -0400 Received: from mira.cbaines.net ([212.71.252.8]:58914) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtH-0002tm-3q for 33185@debbugs.gnu.org; Fri, 03 May 2019 15:30:42 -0400 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id CCE5516F53 for <33185@debbugs.gnu.org>; Fri, 3 May 2019 20:30:37 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id c4d969d9 for <33185@debbugs.gnu.org>; Fri, 3 May 2019 19:30:37 +0000 (UTC) From: Christopher Baines Date: Fri, 3 May 2019 20:30:36 +0100 Message-Id: <20190503193037.27035-2-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190503193037.27035-1-mail@cbaines.net> References: <87o94jqrff.fsf@cbaines.net> <20190503193037.27035-1-mail@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu/packages/patchutils.scm (patchwork): New variable. --- gnu/packages/patchutils.scm | 167 ++++++++++++++++++++++++++++++++++++ 1 file changed, 167 insertions(+) diff --git a/gnu/packages/patchutils.scm b/gnu/packages/patchutils.scm index f6197b98ee..687864c008 100644 --- a/gnu/packages/patchutils.scm +++ b/gnu/packages/patchutils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014, 2018 Eric Bavier ;;; Copyright © 2015, 2018 Leo Famulari ;;; Copyright © 2018, 2019 Tobias Geerinckx-Rice +;;; Copyright © 2019 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,8 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages check) + #:use-module (gnu packages databases) + #:use-module (gnu packages django) #:use-module (gnu packages file) #:use-module (gnu packages gawk) #:use-module (gnu packages gettext) @@ -300,3 +303,167 @@ directories, and has support for many popular version control systems. Meld helps you review code changes and understand patches. It might even help you to figure out what is going on in that merge you keep avoiding.") (license gpl2))) + +(define-public patchwork + (package + (name "patchwork") + (version "2.1.2") + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/getpatchwork/patchwork.git") + (commit (string-append "v" version)))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "06ng5pv6744w98zkyfm0ldkmpdgnsql3gbbbh6awq61sr2ndr3qw")))) + (build-system python-build-system) + (arguments + `(;; TODO: Tests require a running database + #:tests? #f + #:phases + (modify-phases %standard-phases + (delete 'configure) + (delete 'build) + (add-after 'unpack 'replace-wsgi.py + (lambda* (#:key inputs outputs #:allow-other-keys) + (delete-file "patchwork/wsgi.py") + (call-with-output-file "patchwork/wsgi.py" + (lambda (port) + ;; Embed the PYTHONPATH containing the dependencies, as well + ;; as the python modules in this package in the wsgi.py file, + ;; as this will ensure they are available at runtime. + (define pythonpath + (string-append (getenv "PYTHONPATH") + ":" + (site-packages inputs outputs))) + (display + (string-append " +import os, sys + +sys.path.extend('" pythonpath "'.split(':')) + +from django.core.wsgi import get_wsgi_application + +# By default, assume that patchwork is running as a Guix service, which +# provides the settings as the 'guix.patchwork.settings' Python module. +# +# When using httpd, it's hard to set environment variables, so rely on the +# default set here. +os.environ['DJANGO_SETTINGS_MODULE'] = os.getenv( + 'DJANGO_SETTINGS_MODULE', + 'guix.patchwork.settings' # default +) + +application = get_wsgi_application()\n") port))))) + (replace 'check + (lambda* (#:key tests? #:allow-other-keys) + (when tests? + (setenv "DJANGO_SETTINGS_MODULE" "patchwork.settings.dev") + (invoke "python" "-Wonce" "./manage.py" "test" "--noinput")) + #t)) + (replace 'install + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (out-site-packages (site-packages inputs outputs))) + (for-each (lambda (directory) + (copy-recursively + directory + (string-append out-site-packages directory))) + '(;; Contains the python code + "patchwork" + ;; Contains the templates for the generated HTML + "templates")) + (delete-file-recursively + (string-append out-site-packages "patchwork/tests")) + + ;; Install patchwork related tools + (for-each (lambda (file) + (install-file file (string-append out "/bin"))) + (list + (string-append out-site-packages + "patchwork/bin/pwclient") + (string-append out-site-packages + "patchwork/bin/parsemail.sh") + (string-append out-site-packages + "patchwork/bin/parsemail-batch.sh"))) + + ;; Delete the symlink to pwclient, and replace it with the + ;; actual file, as this can cause issues when serving the file + ;; from a webserver. + (let ((template-pwclient (string-append + out-site-packages + "patchwork/templates/patchwork/pwclient"))) + (delete-file template-pwclient) + (copy-file (string-append out-site-packages + "patchwork/bin/pwclient") + template-pwclient)) + + ;; Collect the static assets, this includes JavaScript, CSS and + ;; fonts. This is a standard Django process when running a + ;; Django application for regular use, and includes assets for + ;; dependencies like the admin site from Django. + ;; + ;; The intent here is that you can serve files from this + ;; directory through a webserver, which is recommended when + ;; running Django applications. + (let ((static-root + (string-append out "/share/patchwork/htdocs"))) + (mkdir-p static-root) + (copy-file "patchwork/settings/production.example.py" + "patchwork/settings/assets.py") + (setenv "DJANGO_SECRET_KEY" "dummyvalue") + (setenv "DJANGO_SETTINGS_MODULE" "patchwork.settings.assets") + (setenv "STATIC_ROOT" static-root) + (invoke "./manage.py" "collectstatic" "--no-input")) + + ;; The lib directory includes example configuration files that + ;; may be useful when deploying patchwork. + (copy-recursively "lib" + (string-append + out "/share/doc/" ,name "-" ,version))) + #t)) + ;; The hasher script is used from the post-receive.hook + (add-after 'install 'install-hasher + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (out-site-packages (site-packages inputs outputs)) + (out-hasher.py (string-append out-site-packages + "/patchwork/hasher.py"))) + (chmod out-hasher.py #o555) + (symlink out-hasher.py (string-append out "/bin/hasher"))) + #t)) + ;; Create a patchwork specific version of Django's command line admin + ;; utility. + (add-after 'install 'install-patchwork-admin + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out"))) + (mkdir-p (string-append out "/bin")) + (call-with-output-file (string-append out "/bin/patchwork-admin") + (lambda (port) + (simple-format port "#!~A +import os, sys + +if __name__ == \"__main__\": + from django.core.management import execute_from_command_line + + execute_from_command_line(sys.argv)" (which "python")))) + (chmod (string-append out "/bin/patchwork-admin") #o555)) + #t))))) + (inputs + `(("python-wrapper" ,python-wrapper))) + (propagated-inputs + `(("python-django" ,python-django) + ;; TODO: Make this configurable + ("python-psycopg2" ,python-psycopg2) + ("python-mysqlclient" ,python-mysqlclient) + ("python-django-filter" ,python-django-filter) + ("python-djangorestframework" ,python-djangorestframework) + ("python-django-debug-toolbar" ,python-django-debug-toolbar))) + (synopsis "Web based patch tracking system") + (description + "Patchwork is a patch tracking system. It takes in emails containing +patches, and displays the patches along with comments and state information. +Users can login allowing them to change the state of patches.") + (home-page "http://jk.ozlabs.org/projects/patchwork/") + (license gpl2+))) From patchwork Fri May 3 19:30:37 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 13888 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 71FF416F58; Fri, 3 May 2019 20:31:17 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 5ECCA16F4D for ; Fri, 3 May 2019 20:31:14 +0100 (BST) Received: from localhost ([127.0.0.1]:46434 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMdtp-0007Qg-Tp for patchwork@mira.cbaines.net; Fri, 03 May 2019 15:31:13 -0400 Received: from eggs.gnu.org ([209.51.188.92]:60700) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hMdti-0007P8-UG for guix-patches@gnu.org; Fri, 03 May 2019 15:31:11 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hMdte-0000lR-5w for guix-patches@gnu.org; Fri, 03 May 2019 15:31:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36164) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hMdte-0000lK-1H for guix-patches@gnu.org; Fri, 03 May 2019 15:31:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hMdtd-0002uk-QR for guix-patches@gnu.org; Fri, 03 May 2019 15:31:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#33185] [PATCH 3/3] services: Add patchwork. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 03 May 2019 19:31:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33185 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33185@debbugs.gnu.org Received: via spool by 33185-submit@debbugs.gnu.org id=B33185.155691185111180 (code B ref 33185); Fri, 03 May 2019 19:31:01 +0000 Received: (at 33185) by debbugs.gnu.org; 3 May 2019 19:30:51 +0000 Received: from localhost ([127.0.0.1]:49704 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtK-0002u6-Dv for submit@debbugs.gnu.org; Fri, 03 May 2019 15:30:51 -0400 Received: from mira.cbaines.net ([212.71.252.8]:58912) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hMdtG-0002tj-Q9 for 33185@debbugs.gnu.org; Fri, 03 May 2019 15:30:40 -0400 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id 01A9E16F58 for <33185@debbugs.gnu.org>; Fri, 3 May 2019 20:30:37 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 0fac7396 for <33185@debbugs.gnu.org>; Fri, 3 May 2019 19:30:37 +0000 (UTC) From: Christopher Baines Date: Fri, 3 May 2019 20:30:37 +0100 Message-Id: <20190503193037.27035-3-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190503193037.27035-1-mail@cbaines.net> References: <87o94jqrff.fsf@cbaines.net> <20190503193037.27035-1-mail@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu/service/web.scm ( , ): New record types. (patchwork-virtualhost): New procedure. (patchwork-service-type): New variable. * gnu/tests/web.scm (%test-patchwork): New variable. * doc/guix.text (Web Services): Document it. --- doc/guix.texi | 174 ++++++++++++++++++++ gnu/services/web.scm | 368 ++++++++++++++++++++++++++++++++++++++++++- gnu/tests/web.scm | 164 ++++++++++++++++++- 3 files changed, 702 insertions(+), 4 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index e23d178697..cd70de5cb5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -19323,6 +19323,180 @@ Additional arguments to pass to the @command{varnishd} process. @end table @end deftp +@subsubheading Patchwork +@cindex Patchwork +Patchwork is a patch tracking system. It can collect patches sent to a +mailing list, and display them in a web interface. + +@defvr {Scheme Variable} patchwork-service-type +Service type for Patchwork. +@end defvr + +The following example is an example of a minimal service for Patchwork, for +the @code{patchwork.example.com} domain. + +@example +(service patchwork-service-type + (patchwork-configuration + (domain "patchwork.example.com") + (settings-module + (patchwork-settings-module + (allowed-hosts (list domain)) + (default-from-email "patchwork@@patchwork.example.com"))) + (getmail-retriever-config + (getmail-retriever-configuration + (type "SimpleIMAPSSLRetriever") + (server "imap.example.com") + (port 993) + (username "patchwork") + (password-command + (list (file-append coreutils "/bin/cat") + "/etc/getmail-patchwork-imap-password")) + (extra-parameters + '((mailboxes . ("Patches")))))))) + +@end example + +There are three records for configuring the Patchwork service. The +@code{} relates to the configuration for Patchwork +within the HTTPD service. + +The @code{settings-module} field within the @code{} +record can be populated with the @code{} record, +which describes a settings module that is generated within the Guix store. + +For the @code{database-configuration} field within the +@code{}, the +@code{} must be used. + +@deftp {Data Type} patchwork-configuration +Data type representing the Patchwork service configuration. This type has the +following parameters: + +@table @asis +@item @code{patchwork} (default: @code{patchwork}) +The Patchwork package to use. + +@item @code{domain} +The domain to use for Patchwork, this is used in the HTTPD service virtual +host. + +@item @code{settings-module} +The settings module to use for Patchwork. As a Django application, Patchwork +is configured with a Python module containing the settings. This can either be +an instance of the @code{} record, any other record +that represents the settings in the store, or a directory outside of the +store. + +@item @code{static-path} (default: @code{"/static/"}) +The path under which the HTTPD service should serve the static files. + +@item @code{getmail-retriever-config} +The getmail-retriever-configuration record value to use with +Patchwork. Getmail will be configured with this value, the messages will be +delivered to Patchwork. + +@end table +@end deftp + +@deftp {Data Type} patchwork-settings-module +Data type representing a settings module for Patchwork. Some of these +settings relate directly to Patchwork, but others relate to Django, the web +framework used by Patchwork, or the Django Rest Framework library. This type +has the following parameters: + +@table @asis +@item @code{database-configuration} (default: @code{(patchwork-database-configuration)}) +The database connection settings used for Patchwork. See the +@code{} record type for more information. + +@item @code{secret-key-file} (default: @code{"/etc/patchwork/django-secret-key"}) +Patchwork, as a Django web application uses a secret key for cryptographically +signing values. This file should contain a unique unpredictable value. + +If this file does not exist, it will be created and populated with a random +value by the patchwork-setup shepherd service. + +This setting relates to Django. + +@item @code{allowed-hosts} +A list of valid hosts for this Patchwork service. This should at least include +the domain specified in the @code{} record. + +This is a Django setting. + +@item @code{default-from-email} +The email address from which Patchwork should send email by default. + +This is a Patchwork setting. + +@item @code{static-url} (default: @code{#f}) +The URL to use when serving static assets. It can be part of a URL, or a full +URL, but must end in a @code{/}. + +If the default value is used, the @code{static-path} value from the +@code{} record will be used. + +This is a Django setting. + +@item @code{admins} (default: @code{'()}) +Email addresses to send the details of errors that occur. Each value should +be a list containing two elements, the name and then the email address. + +This is a Django setting. + +@item @code{debug?} (default: @code{#f}) +Whether to run Patchwork in debug mode. If set to @code{#t}, detailed error +messages will be shown. + +This is a Django setting. + +@item @code{enable-rest-api?} (default: @code{#t}) +Whether to enable the Patchwork REST API. + +This is a Patchwork setting. + +@item @code{enable-xmlrpc?} (default: @code{#t}) +Whether to enable the XML RPC API. + +This is a Patchwork setting. + +@item @code{force-https-links?} (default: @code{#t}) +Whether to use HTTPS links on Patchwork pages. + +This is a Patchwork setting. + +@item @code{extra-settings} (default: @code{""}) +Extra code to place at the end of the Patchwork settings module. + +@end table +@end deftp + +@deftp {Data Type} patchwork-database-configuration +Data type representing the database configuration for Patchwork. + +@table @asis +@item @code{engine} (default: @code{"django.db.backends.postgresql_psycopg2"}) +The database engine to use. + +@item @code{name} (default: @code{"patchwork"}) +The name of the database to use. + +@item @code{user} (default: @code{"httpd"}) +The user to connect to the database as. + +@item @code{password} (default: @code{""}) +The password to use when connecting to the database. + +@item @code{host} (default: @code{""}) +The host to make the database connection to. + +@item @code{port} (default: @code{""}) +The port on which to connect to the database. + +@end table +@end deftp + @subsubheading FastCGI @cindex fastcgi @cindex fcgiwrap diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 84294db53b..35efddb0ae 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2017 nee ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2018 Pierre-Antoine Rouby -;;; Copyright © 2017 Christopher Baines +;;; Copyright © 2017, 2018, 2019 Christopher Baines ;;; Copyright © 2018 Marius Bakke ;;; ;;; This file is part of GNU Guix. @@ -29,14 +29,23 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services admin) + #:use-module (gnu services getmail) + #:use-module (gnu services mail) #:use-module (gnu system pam) #:use-module (gnu system shadow) #:use-module (gnu packages admin) + #:use-module (gnu packages databases) #:use-module (gnu packages web) + #:use-module (gnu packages patchutils) #:use-module (gnu packages php) + #:use-module (gnu packages python) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages guile) #:use-module (gnu packages logging) + #:use-module (guix packages) #:use-module (guix records) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (guix gexp) #:use-module ((guix store) #:select (text-file)) #:use-module ((guix utils) #:select (version-major)) @@ -210,7 +219,42 @@ varnish-configuration-parameters varnish-configuration-extra-options - varnish-service-type)) + varnish-service-type + + + patchwork-database-configuration + patchwork-database-configuration? + patchwork-database-configuration-engine + patchwork-database-configuration-name + patchwork-database-configuration-user + patchwork-database-configuration-password + patchwork-database-configuration-host + patchwork-database-configuration-port + + + patchwork-settings-module + patchwork-settings-module? + patchwork-settings-module-database-configuration + patchwork-settings-module-secret-key + patchwork-settings-module-allowed-hosts + patchwork-settings-module-default-from-email + patchwork-settings-module-static-url + patchwork-settings-module-admins + patchwork-settings-module-debug? + patchwork-settings-module-enable-rest-api? + patchwork-settings-module-enable-xmlrpc? + patchwork-settings-module-force-https-links? + patchwork-settings-module-extra-settings + + + patchwork-configuration + patchwork-configuration? + patchwork-configuration-patchwork + patchwork-configuration-settings-module + patchwork-configuration-domain + + patchwork-virtualhost + patchwork-service-type)) ;;; Commentary: ;;; @@ -1268,3 +1312,323 @@ files.") varnish-shepherd-service))) (default-value (varnish-configuration)))) + + +;;; +;;; Patchwork +;;; + +(define-record-type* + patchwork-database-configuration make-patchwork-database-configuration + patchwork-database-configuration? + (engine patchwork-database-configuration-engine + (default "django.db.backends.postgresql_psycopg2")) + (name patchwork-database-configuration-name + (default "patchwork")) + (user patchwork-database-configuration-user + (default "httpd")) + (password patchwork-database-configuration-password + (default "")) + (host patchwork-database-configuration-host + (default "")) + (port patchwork-database-configuration-port + (default ""))) + +(define-record-type* + patchwork-settings-module make-patchwork-settings-module + patchwork-settings-module? + (database-configuration patchwork-settings-module-database-configuration + (default (patchwork-database-configuration))) + (secret-key-file patchwork-settings-module-secret-key-file + (default "/etc/patchwork/django-secret-key")) + (allowed-hosts patchwork-settings-module-allowed-hosts) + (default-from-email patchwork-settings-module-default-from-email) + (static-url patchwork-settings-module-static-url + (default "/static/")) + (admins patchwork-settings-module-admins + (default '())) + (debug? patchwork-settings-module-debug? + (default #f)) + (enable-rest-api? patchwork-settings-module-enable-rest-api? + (default #t)) + (enable-xmlrpc? patchwork-settings-module-enable-xmlrpc? + (default #t)) + (force-https-links? patchwork-settings-module-force-https-links? + (default #t)) + (extra-settings patchwork-settings-module-extra-settings + (default ""))) + +(define-record-type* + patchwork-configuration make-patchwork-configuration + patchwork-configuration? + (patchwork patchwork-configuration-patchwork + (default patchwork)) + (domain patchwork-configuration-domain) + (settings-module patchwork-configuration-settings-module) + (static-path patchwork-configuration-static-url + (default "/static/")) + (getmail-retriever-config getmail-retriever-config)) + +;; Django uses a Python module for configuration, so this compiler generates a +;; Python module from the configuration record. +(define-gexp-compiler (patchwork-settings-module-compiler + (file ) system target) + (match file + (($ database-configuration secret-key-file + allowed-hosts default-from-email + static-url admins debug? enable-rest-api? + enable-xmlrpc? force-https-links? + extra-configuration) + (gexp->derivation + "patchwork-settings" + (with-imported-modules '((guix build utils)) + #~(let ((output #$output)) + (define (create-__init__.py filename) + (call-with-output-file filename + (lambda (port) (display "" port)))) + + (use-modules (guix build utils) + (srfi srfi-1)) + + (mkdir-p (string-append output "/guix/patchwork")) + (create-__init__.py + (string-append output "/guix/__init__.py")) + (create-__init__.py + (string-append output "/guix/patchwork/__init__.py")) + + (call-with-output-file + (string-append output "/guix/patchwork/settings.py") + (lambda (port) + (display + (string-append "from patchwork.settings.base import * + +# Configuration from Guix +with open('" #$secret-key-file "') as f: + SECRET_KEY = f.read().strip() + +ALLOWED_HOSTS = [ +" #$(string-concatenate + (map (lambda (allowed-host) + (string-append " '" allowed-host "'\n")) + allowed-hosts)) +"] + +ADMINS = [ +" #$(string-concatenate + (map (match-lambda + ((name email-address) + (string-append + "('" name "','" email-address "'),"))) + admins)) +"] + +DEBUG = " #$(if debug? "True" "False") " + +ENABLE_REST_API = " #$(if enable-xmlrpc? "True" "False") " +ENABLE_XMLRPC = " #$(if enable-xmlrpc? "True" "False") " + +FORCE_HTTPS_LINKS = " #$(if force-https-links? "True" "False") " + +DATABASES = { + 'default': { +" #$(match database-configuration + (($ + engine name user password host port) + (string-append + " 'ENGINE': '" engine "',\n" + " 'NAME': '" name "',\n" + " 'USER': '" user "',\n" + " 'PASSWORD': '" password "',\n" + " 'HOST': '" host "',\n" + " 'PORT': '" port "',\n"))) " + }, +} + +" #$(if debug? + #~(string-append "STATIC_ROOT = '" + #$(file-append patchwork "/share/patchwork/htdocs") + "'") + #~(string-append "STATIC_URL = '" #$static-url "'")) " + +STATICFILES_STORAGE = ( + 'django.contrib.staticfiles.storage.StaticFilesStorage' +) + +# Guix Extra Configuration +" #$extra-configuration " +") port))) + #t)) + #:local-build? #t)))) + +(define patchwork-virtualhost + (match-lambda + (($ patchwork domain + settings-module static-path + getmail-retriever-config) + (define wsgi.py + (file-append patchwork + (string-append + "/lib/python" + (version-major+minor + (package-version python)) + "/site-packages/patchwork/wsgi.py"))) + + (httpd-virtualhost + "*:8080" + `("ServerAdmin admin@example.com` +ServerName " ,domain " + +LogFormat \"%v %h %l %u %t \\\"%r\\\" %>s %b \\\"%{Referer}i\\\" \\\"%{User-Agent}i\\\"\" customformat +LogLevel info +CustomLog \"/var/log/httpd/" ,domain "-access_log\" customformat + +ErrorLog /var/log/httpd/error.log + +WSGIScriptAlias / " ,wsgi.py " +WSGIDaemonProcess " ,(package-name patchwork) " user=httpd group=httpd processes=1 threads=2 display-name=%{GROUP} lang='en_US.UTF-8' locale='en_US.UTF-8' python-path=" ,settings-module " +WSGIProcessGroup " ,(package-name patchwork) " +WSGIPassAuthorization On + + + Require all granted + + +" ,@(if static-path + `("Alias " ,static-path " " ,patchwork "/share/patchwork/htdocs/") + '()) +" + + AllowOverride None + Options MultiViews Indexes SymlinksIfOwnerMatch IncludesNoExec + Require method GET POST OPTIONS +"))))) + +(define (patchwork-httpd-configuration patchwork-configuration) + (list "WSGISocketPrefix /var/run/mod_wsgi" + (list "LoadModule wsgi_module " + (file-append mod-wsgi "/modules/mod_wsgi.so")) + (patchwork-virtualhost patchwork-configuration))) + +(define (patchwork-django-admin-gexp patchwork settings-module) + #~(lambda command + (let ((pid (primitive-fork)) + (user (getpwnam "httpd"))) + (if (eq? pid 0) + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + + (setenv "DJANGO_SETTINGS_MODULE" "guix.patchwork.settings") + (setenv "PYTHONPATH" #$settings-module) + (primitive-exit + (if (zero? + (apply system* + #$(file-append patchwork "/bin/patchwork-admin") + command)) + 0 + 1))) + (lambda () + (primitive-exit 1))) + (zero? (cdr (waitpid pid))))))) + +(define (patchwork-django-admin-action patchwork settings-module) + (shepherd-action + (name 'django-admin) + (documentation + "Run a django admin command for patchwork") + (procedure (patchwork-django-admin-gexp patchwork settings-module)))) + +(define patchwork-shepherd-services + (match-lambda + (($ patchwork domain + settings-module static-path + getmail-retriever-config) + (define secret-key-file-creation-gexp + (if (patchwork-settings-module? settings-module) + (with-extensions (list guile-gcrypt) + #~(let ((secret-key-file + #$(patchwork-settings-module-secret-key-file + settings-module))) + (use-modules (guix build utils) + (gcrypt random)) + + (unless (file-exists? secret-key-file) + (mkdir-p (dirname secret-key-file)) + (call-with-output-file secret-key-file + (lambda (port) + (display (random-token 30 'very-strong) port))) + (let* ((pw (getpwnam "httpd")) + (uid (passwd:uid pw)) + (gid (passwd:gid pw))) + (chown secret-key-file uid gid) + (chmod secret-key-file #o400))))) + #~())) + + (list (shepherd-service + (requirement '(postgres)) + (provision (list (string->symbol + (string-append (package-name patchwork) + "-setup")))) + (start + #~(lambda () + (define run-django-admin-command + #$(patchwork-django-admin-gexp patchwork + settings-module)) + + #$secret-key-file-creation-gexp + + (run-django-admin-command "migrate"))) + (stop #~(const #f)) + (actions + (list (patchwork-django-admin-action patchwork + settings-module))) + (respawn? #f) + (documentation "Setup Patchwork.")))))) + +(define patchwork-getmail-configs + (match-lambda + (($ patchwork domain + settings-module static-path + getmail-retriever-config) + (list + (getmail-configuration + (name (string->symbol (package-name patchwork))) + (user "httpd") + (directory (string-append + "/var/lib/getmail/" (package-name patchwork))) + (rcfile + (getmail-configuration-file + (retriever getmail-retriever-config) + (destination + (getmail-destination-configuration + (type "MDA_external") + (path (file-append patchwork "/bin/patchwork-admin")) + (extra-parameters + '((arguments . ("parsemail")))))) + (options + (getmail-options-configuration + (read-all #f) + (delivered-to #f) + (received #f))))) + (idle (assq-ref + (getmail-retriever-configuration-extra-parameters + getmail-retriever-config) + 'mailboxes)) + (environment-variables + (list "DJANGO_SETTINGS_MODULE=guix.patchwork.settings" + #~(string-append "PYTHONPATH=" #$settings-module)))))))) + +(define patchwork-service-type + (service-type + (name 'patchwork-setup) + (extensions + (list (service-extension httpd-service-type + patchwork-httpd-configuration) + (service-extension shepherd-root-service-type + patchwork-shepherd-services) + (service-extension getmail-service-type + patchwork-getmail-configs))) + (description + "Patchwork patch tracking system."))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 319655396a..7c1c0aa511 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ludovic Courtès -;;; Copyright © 2017 Christopher Baines +;;; Copyright © 2017, 2019 Christopher Baines ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2018 Pierre-Antoine Rouby ;;; Copyright © 2018 Marius Bakke @@ -28,15 +28,29 @@ #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services web) + #:use-module (gnu services databases) + #:use-module (gnu services getmail) #:use-module (gnu services networking) + #:use-module (gnu services shepherd) + #:use-module (gnu services mail) + #:use-module (gnu packages databases) + #:use-module (gnu packages patchutils) + #:use-module (gnu packages python) + #:use-module (gnu packages web) + #:use-module (guix packages) + #:use-module (guix modules) + #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 match) #:export (%test-httpd %test-nginx %test-varnish %test-php-fpm %test-hpcguix-web - %test-tailon)) + %test-tailon + %test-patchwork)) (define %index.html-contents ;; Contents of the /index.html file. @@ -498,3 +512,149 @@ HTTP-PORT." (name "tailon") (description "Connect to a running Tailon server.") (value (run-tailon-test)))) + + +;;; +;;; Patchwork +;;; + +(define patchwork-initial-database-setup-service + (match-lambda + (($ + engine name user password host port) + + (define start-gexp + #~(lambda () + (let ((pid (primitive-fork)) + (postgres (getpwnam "postgres"))) + (if (eq? pid 0) + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid postgres)) + (setuid (passwd:uid postgres)) + (primitive-exit + (if (and + (zero? + (system* #$(file-append postgresql "/bin/createuser") + #$user)) + (zero? + (system* #$(file-append postgresql "/bin/createdb") + "-O" #$user #$name))) + 0 + 1))) + (lambda () + (primitive-exit 1))) + (zero? (cdr (waitpid pid))))))) + + (shepherd-service + (requirement '(postgres)) + (provision '(patchwork-postgresql-user-and-database)) + (start start-gexp) + (stop #~(const #f)) + (respawn? #f) + (documentation "Setup patchwork database."))))) + +(define (patchwork-os patchwork) + (simple-operating-system + (service dhcp-client-service-type) + (service httpd-service-type + (httpd-configuration + (config + (httpd-config-file + (listen '("8080")))))) + (service postgresql-service-type) + (service patchwork-service-type + (patchwork-configuration + (patchwork patchwork) + (domain "localhost") + (settings-module + (patchwork-settings-module + (allowed-hosts (list domain)) + (default-from-email ""))) + (getmail-retriever-config + (getmail-retriever-configuration + (type "SimpleIMAPSSLRetriever") + (server "imap.example.com") + (port 993) + (username "username") + (password "password") + (extra-parameters + '((mailboxes . ("INBOX")))))))) + (simple-service 'patchwork-database-setup + shepherd-root-service-type + (list + (patchwork-initial-database-setup-service + (patchwork-database-configuration)))))) + +(define (run-patchwork-test patchwork) + "Run tests in %NGINX-OS, which has nginx running and listening on +HTTP-PORT." + (define os + (marionette-operating-system + (patchwork-os patchwork) + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define forwarded-port 8080) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((8080 . ,forwarded-port))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "patchwork") + + (test-assert "patchwork-postgresql-user-and-service started" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'patchwork-postgresql-user-and-database) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((#t) #t) + ((pid) (number? pid)))))) + marionette)) + + (test-assert "httpd running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'httpd)) + marionette)) + + (test-equal "http-get" + 200 + (let-values + (((response text) + (http-get #$(simple-format + #f "http://localhost:~A/" forwarded-port) + #:decode-body? #t))) + (response-code response))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "patchwork-test" test)) + +(define %test-patchwork + (system-test + (name "patchwork") + (description "Connect to a running Patchwork service.") + (value (run-patchwork-test patchwork))))