From 336674549dfd2102479da0d2b92aaaf583f52c92 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sat, 25 May 2019 15:54:24 +0530 Subject: services: cgit: Fix typo. * gnu/services/cgit.scm (cgit-configuration)[root-readme]: Replace "thef" with "the". --- gnu/services/cgit.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/cgit.scm b/gnu/services/cgit.scm index a84a2dadb2..94ca9e281a 100644 --- a/gnu/services/cgit.scm +++ b/gnu/services/cgit.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Christopher Baines +;;; Copyright © 2019 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -581,7 +582,7 @@ removed for the URL and name.") (root-readme (string "") "The content of the file specified with this option will be included -verbatim below thef \"about\" link on the repository index page.") +verbatim below the \"about\" link on the repository index page.") (root-title (string "") "Text printed as heading on the repository index page.") -- cgit 1.4.1 From ed90104cc82fdd6b762a159b06c0ea37b417a9a5 Mon Sep 17 00:00:00 2001 From: Reza Alizadeh Majd Date: Tue, 21 May 2019 17:51:09 +0430 Subject: services: sddm: Fix root login failure issue. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/sddm.scm (sdm-pam-service): Set uid from CONFIG. (sdm-autologin-pam-service): Set uid from CONFIG. (sdm-pam-services): Pass CONFIG to 'sddm-pam-service' and 'sddm-autologin-pam-service'. * doc/guix.texi (X Window): Adjust 'minimum-uid' documentation. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 8 ++++---- gnu/services/sddm.scm | 16 ++++++++++------ 2 files changed, 14 insertions(+), 10 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index ee10e65be0..d60f453b24 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13623,11 +13623,11 @@ Directory to look for faces. @item @code{default-path} (default "/run/current-system/profile/bin") Default PATH to use. -@item @code{minimum-uid} (default 1000) -Minimum UID to display in SDDM. +@item @code{minimum-uid} (default: 1000) +Minimum UID displayed in SDDM and allowed for log-in. -@item @code{maximum-uid} (default 2000) -Maximum UID to display in SDDM +@item @code{maximum-uid} (default: 2000) +Maximum UID to display in SDDM. @item @code{remember-last-user?} (default #t) Remember last user. diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm index b433c59e12..b0e6d40260 100644 --- a/gnu/services/sddm.scm +++ b/gnu/services/sddm.scm @@ -175,7 +175,7 @@ Relogin=" (if (sddm-configuration-relogin? config) (define (sddm-etc-service config) (list `("sddm.conf" ,(sddm-configuration-file config)))) -(define (sddm-pam-service) +(define (sddm-pam-service config) "Return a PAM service for @command{sddm}." (pam-service (name "sddm") @@ -190,7 +190,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (pam-entry (control "required") (module "pam_succeed_if.so") - (arguments (list "uid >= 1000" "quiet"))) + (arguments (list (string-append "uid >= " + (number->string (sddm-configuration-minimum-uid config))) + "quiet"))) ;; should be factored out into system-auth (pam-entry (control "required") @@ -249,7 +251,7 @@ Relogin=" (if (sddm-configuration-relogin? config) (control "required") (module "pam_unix.so")))))) -(define (sddm-autologin-pam-service) +(define (sddm-autologin-pam-service config) "Return a PAM service for @command{sddm-autologin}" (pam-service (name "sddm-autologin") @@ -261,7 +263,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (pam-entry (control "required") (module "pam_succeed_if.so") - (arguments (list "uid >= 1000" "quiet"))) + (arguments (list (string-append "uid >= " + (number->string (sddm-configuration-minimum-uid config))) + "quiet"))) (pam-entry (control "required") (module "pam_permit.so")))) @@ -282,9 +286,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (module "sddm")))))) (define (sddm-pam-services config) - (list (sddm-pam-service) + (list (sddm-pam-service config) (sddm-greeter-pam-service) - (sddm-autologin-pam-service))) + (sddm-autologin-pam-service config))) (define %sddm-accounts (list (user-group (name "sddm") (system? #t)) -- cgit 1.4.1 From f6b0e1f8ff6a6459d7d39238ced165f4caa988fe Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 4 Apr 2019 17:36:49 +0100 Subject: services: Add getmail. Getmail is a mail retriever written in Python, this commit adds a service-type to run getmail. I'm looking at this, as it's a convinient way of getting mailing list messages in to Patchwork. I initially tried putting this in the (gnu services mail) module, but due to also trying to use the define-configuration pattern, it conflicted with the dovecot service. * gnu/services/getmail.scm: New file. * gnu/local.mk: Add it. * gnu/tests/mail.scm (%getmail-os, %test-getmail): New variables. (run-getmail-test): New procedure. --- doc/guix.texi | 291 ++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/services/getmail.scm | 380 +++++++++++++++++++++++++++++++++++++++++++++++ gnu/tests/mail.scm | 178 +++++++++++++++++++++- 4 files changed, 849 insertions(+), 1 deletion(-) create mode 100644 gnu/services/getmail.scm (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index 340b806962..d94b1f2b16 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16716,6 +16716,297 @@ variables. @end table @end deftp +@subsubheading Getmail service + +@cindex IMAP +@cindex POP + +@deffn {Scheme Variable} getmail-service-type +This is the type of the @uref{http://pyropus.ca/software/getmail/, Getmail} +mail retriever, whose value should be an @code{getmail-configuration}. +@end deffn + +Available @code{getmail-configuration} fields are: + +@deftypevr {@code{getmail-configuration} parameter} symbol name +A symbol to identify the getmail service. + +Defaults to @samp{"unset"}. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} package package +The getmail package to use. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} string user +The user to run getmail as. + +Defaults to @samp{"getmail"}. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} string group +The group to run getmail as. + +Defaults to @samp{"getmail"}. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} string directory +The getmail directory to use. + +Defaults to @samp{"/var/lib/getmail/default"}. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} getmail-configuration-file rcfile +The getmail configuration file to use. + +Available @code{getmail-configuration-file} fields are: + +@deftypevr {@code{getmail-configuration-file} parameter} getmail-retriever-configuration retriever +What mail account to retrieve mail from, and how to access that account. + +Available @code{getmail-retriever-configuration} fields are: + +@deftypevr {@code{getmail-retriever-configuration} parameter} string type +The type of mail retriever to use. Valid values include @samp{passwd} +and @samp{static}. + +Defaults to @samp{"SimpleIMAPSSLRetriever"}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string server +Space separated list of arguments to the userdb driver. + +Defaults to @samp{unset}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string username +Space separated list of arguments to the userdb driver. + +Defaults to @samp{unset}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} non-negative-integer port +Space separated list of arguments to the userdb driver. + +Defaults to @samp{#f}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string password +Override fields from passwd. + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} list password-command +Override fields from passwd. + +Defaults to @samp{()}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string keyfile +PEM-formatted key file to use for the TLS negotiation + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string certfile +PEM-formatted certificate file to use for the TLS negotiation + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} string ca-certs +CA certificates to use + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-retriever-configuration} parameter} parameter-alist extra-parameters +Extra retriever parameters + +Defaults to @samp{()}. + +@end deftypevr + +@end deftypevr + +@deftypevr {@code{getmail-configuration-file} parameter} getmail-destination-configuration destination +What to do with retrieved messages. + +Available @code{getmail-destination-configuration} fields are: + +@deftypevr {@code{getmail-destination-configuration} parameter} string type +The type of mail destination. Valid values include @samp{Maildir}, +@samp{Mboxrd} and @samp{MDA_external}. + +Defaults to @samp{unset}. + +@end deftypevr + +@deftypevr {@code{getmail-destination-configuration} parameter} string-or-filelike path +The path option for the mail destination. The behaviour depends on the +chosen type. + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-destination-configuration} parameter} parameter-alist extra-parameters +Extra destination parameters + +Defaults to @samp{()}. + +@end deftypevr + +@end deftypevr + +@deftypevr {@code{getmail-configuration-file} parameter} getmail-options-configuration options +Configure getmail. + +Available @code{getmail-options-configuration} fields are: + +@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer verbose +If set to @samp{0}, getmail will only print warnings and errors. A +value of @samp{1} means that messages will be printed about retrieving +and deleting messages. If set to @samp{2}, getmail will print messages +about each of it's actions. + +Defaults to @samp{1}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean read-all +If true, getmail will retrieve all available messages. Otherwise it +will only retrieve messages it hasn't seen previously. + +Defaults to @samp{#t}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean delete +If set to true, messages will be deleted from the server after +retrieving and successfully delivering them. Otherwise, messages will +be left on the server. + +Defaults to @samp{#f}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer delete-after +Getmail will delete messages this number of days after seeing them, if +they have not been delivered. This means messages will be left on the +server this number of days after delivering them. A value of @samp{0} +disabled this feature. + +Defaults to @samp{0}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer delete-bigger-than +Delete messages larger than this of bytes after retrieving them, even if +the delete and delete-after options are disabled. A value of @samp{0} +disables this feature. + +Defaults to @samp{0}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer max-bytes-per-session +Retrieve messages totalling up to this number of bytes before closing +the session with the server. A value of @samp{0} disables this feature. + +Defaults to @samp{0}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} non-negative-integer max-message-size +Don't retrieve messages larger than this number of bytes. A value of +@samp{0} disables this feature. + +Defaults to @samp{0}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean delivered-to +If true, getmail will add a Delivered-To header to messages. + +Defaults to @samp{#t}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean received +If set, getmail adds a Received header to the messages. + +Defaults to @samp{#t}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} string message-log +Getmail will record a log of its actions to the named file. A value of +@samp{""} disables this feature. + +Defaults to @samp{""}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean message-log-syslog +If true, getmail will record a log of its actions using the system +logger. + +Defaults to @samp{#t}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} boolean message-log-verbose +If true, getmail will log information about messages not retrieved and +the reason for not retrieving them, as well as starting and ending +information lines. + +Defaults to @samp{#t}. + +@end deftypevr + +@deftypevr {@code{getmail-options-configuration} parameter} parameter-alist extra-parameters +Extra options to include. + +Defaults to @samp{()}. + +@end deftypevr + +@end deftypevr + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} list idle +A list of mailboxes that getmail should wait on the server for new mail +notifications. This depends on the server supporting the IDLE +extension. + +Defaults to @samp{()}. + +@end deftypevr + +@deftypevr {@code{getmail-configuration} parameter} list environment-variables +Environment variables to set for getmail. + +Defaults to @samp{()}. + +@end deftypevr + @subsubheading Mail Aliases Service @cindex email aliases diff --git a/gnu/local.mk b/gnu/local.mk index 55fa90f926..9b9c6e00ec 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -516,6 +516,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/docker.scm \ %D%/services/authentication.scm \ %D%/services/games.scm \ + %D%/services/getmail.scm \ %D%/services/kerberos.scm \ %D%/services/lirc.scm \ %D%/services/virtualization.scm \ 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 -- cgit 1.4.1 From 2177d9222f8c228fe5cd4e9c98d96f97e9601b86 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 3 May 2019 19:55:35 +0100 Subject: services: Add patchwork. * 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(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index d94b1f2b16..786788bad7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -19389,6 +19389,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)))) -- cgit 1.4.1 From bb64b2e7c0ab14cf899c1d81892b59fa877d4d9c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 01:30:42 +0200 Subject: herd: Use the Guile 2.2 'setvbuf' API. * gnu/services/herd.scm (open-connection): Use 'block for 'setvbuf'. --- gnu/services/herd.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 9fe757fb73..0008746fe9 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. @@ -76,7 +76,7 @@ return the socket." (catch 'system-error (lambda () (connect sock address) - (setvbuf sock _IOFBF 1024) + (setvbuf sock 'block 1024) sock) (lambda args (close-port sock) -- cgit 1.4.1 From ee2691fa33f117bcf51b148b81bb8bc4e7b13a58 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 22:27:25 +0200 Subject: services: guix-publish: Allow for multi-compression. This is a followup to b8fa86adfc01205f1d942af8cb57515eb3726c52. * guix/deprecation.scm (warn-about-deprecation): Make public. * gnu/services/base.scm ()[compression]: New field. [compression-level]: Default to #f. Add '%' to getter name. (guix-publish-configuration-compression-level): Define as deprecated. (default-compression): New procedure. (guix-publish-shepherd-service)[config->compression-options]: New procedure. Use 'match-record' instead of 'match'. * doc/guix.texi (Base Services): Remove 'compression-level' and document 'compression'. --- doc/guix.texi | 17 ++++++-- gnu/services/base.scm | 109 ++++++++++++++++++++++++++++++++------------------ guix/deprecation.scm | 1 + 3 files changed, 84 insertions(+), 43 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index c01eb3a656..a8f3a5ad27 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12232,10 +12232,19 @@ The TCP port to listen for connections. The host (and thus, network interface) to listen to. Use @code{"0.0.0.0"} to listen on all the network interfaces. -@item @code{compression-level} (default: @code{3}) -The gzip compression level at which substitutes are compressed. Use -@code{0} to disable compression altogether, and @code{9} to get the best -compression ratio at the expense of increased CPU usage. +@item @code{compression} (default: @code{'(("gzip" 3))}) +This is a list of compression method/level tuple used when compressing +substitutes. For example, to compress all substitutes with @emph{both} lzip +at level 7 and gzip at level 9, write: + +@example +'(("lzip" 7) ("gzip" 9)) +@end example + +Level 9 achieves the best compression ratio at the expense of increased CPU +usage, whereas level 1 achieves fast compression. + +An empty list disables compression altogether. @item @code{nar-path} (default: @code{"nar"}) The URL path at which ``nars'' can be fetched. @xref{Invoking guix diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f709ca5519..c88a6ddec6 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -142,7 +142,8 @@ guix-publish-configuration-guix guix-publish-configuration-port guix-publish-configuration-host - guix-publish-configuration-compression-level + guix-publish-configuration-compression + guix-publish-configuration-compression-level ;deprecated guix-publish-configuration-nar-path guix-publish-configuration-cache guix-publish-configuration-ttl @@ -1748,8 +1749,12 @@ archive' public keys, with GUIX." (default 80)) (host guix-publish-configuration-host ;string (default "localhost")) - (compression-level guix-publish-configuration-compression-level ;integer - (default 3)) + (compression guix-publish-configuration-compression + (thunked) + (default (default-compression this-record + (current-source-location)))) + (compression-level %guix-publish-configuration-compression-level ;deprecated + (default #f)) (nar-path guix-publish-configuration-nar-path ;string (default "nar")) (cache guix-publish-configuration-cache ;#f | string @@ -1759,42 +1764,68 @@ archive' public keys, with GUIX." (ttl guix-publish-configuration-ttl ;#f | integer (default #f))) -(define guix-publish-shepherd-service - (match-lambda - (($ guix port host compression - nar-path cache workers ttl) - (list (shepherd-service - (provision '(guix-publish)) - (requirement '(guix-daemon)) - (start #~(make-forkexec-constructor - (list #$(file-append guix "/bin/guix") - "publish" "-u" "guix-publish" - "-p" #$(number->string port) - "-C" #$(number->string compression) - (string-append "--nar-path=" #$nar-path) - (string-append "--listen=" #$host) - #$@(if workers - #~((string-append "--workers=" - #$(number->string - workers))) - #~()) - #$@(if ttl - #~((string-append "--ttl=" - #$(number->string ttl) - "s")) - #~()) - #$@(if cache - #~((string-append "--cache=" #$cache)) - #~())) - - ;; Make sure we run in a UTF-8 locale so we can produce - ;; nars for packages that contain UTF-8 file names such - ;; as 'nss-certs'. See . - #:environment-variables - (list (string-append "GUIX_LOCPATH=" - #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8"))) - (stop #~(make-kill-destructor))))))) +(define-deprecated (guix-publish-configuration-compression-level config) + "Return a compression level, the old way." + (match (guix-publish-configuration-compression config) + (((_ level) _ ...) level))) + +(define (default-compression config properties) + "Return the default 'guix publish' compression according to CONFIG, and +raise a deprecation warning if the 'compression-level' field was used." + (match (%guix-publish-configuration-compression-level config) + (#f + '(("gzip" 3))) + (level + (warn-about-deprecation 'compression-level properties + #:replacement 'compression) + `(("gzip" ,level))))) + +(define (guix-publish-shepherd-service config) + (define (config->compression-options config) + (match (guix-publish-configuration-compression config) + (() ;empty list means "no compression" + '("-C0")) + (lst + (append-map (match-lambda + ((type level) + `("-C" ,(string-append type ":" + (number->string level))))) + lst)))) + + (match-record config + (guix port host nar-path cache workers ttl) + (list (shepherd-service + (provision '(guix-publish)) + (requirement '(guix-daemon)) + (start #~(make-forkexec-constructor + (list #$(file-append guix "/bin/guix") + "publish" "-u" "guix-publish" + "-p" #$(number->string port) + #$@(config->compression-options config) + (string-append "--nar-path=" #$nar-path) + (string-append "--listen=" #$host) + #$@(if workers + #~((string-append "--workers=" + #$(number->string + workers))) + #~()) + #$@(if ttl + #~((string-append "--ttl=" + #$(number->string ttl) + "s")) + #~()) + #$@(if cache + #~((string-append "--cache=" #$cache)) + #~())) + + ;; Make sure we run in a UTF-8 locale so we can produce + ;; nars for packages that contain UTF-8 file names such + ;; as 'nss-certs'. See . + #:environment-variables + (list (string-append "GUIX_LOCPATH=" + #$glibc-utf8-locales "/lib/locale") + "LC_ALL=en_US.utf8"))) + (stop #~(make-kill-destructor)))))) (define %guix-publish-accounts (list (user-group (name "guix-publish") (system? #t)) diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 2f7c058940..d704e7ec61 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -21,6 +21,7 @@ #:use-module (ice-9 format) #:export (define-deprecated define-deprecated/alias + warn-about-deprecation deprecation-warning-port)) ;;; Commentary: -- cgit 1.4.1 From 36273ebde20db42d864e315c954d84d2b4957070 Mon Sep 17 00:00:00 2001 From: Alex Griffin Date: Sun, 2 Jun 2019 16:26:47 -0500 Subject: services: cups: Create /var/cache on activation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/cups.scm (%cups-activation): Create /var/cache if it doesn't exist yet. Signed-off-by: Ludovic Courtès --- gnu/services/cups.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gnu/services') diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm index 9125139ef3..9d21b6e70c 100644 --- a/gnu/services/cups.scm +++ b/gnu/services/cups.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Andy Wingo ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Alex Griffin ;;; ;;; This file is part of GNU Guix. ;;; @@ -895,6 +896,7 @@ IPP specifications.") (mkdir-p/perms "/var/spool/cups" user #o755) (mkdir-p/perms "/var/spool/cups/tmp" user #o755) (mkdir-p/perms "/var/log/cups" user #o755) + (mkdir-p/perms "/var/cache/cups" user #o770) (mkdir-p/perms "/etc/cups" user #o755) (mkdir-p/perms "/etc/cups/ssl" user #o700) ;; This certificate is used for HTTPS connections to the CUPS web -- cgit 1.4.1 From 07023ebc1892a559cad1f80235a4afb0955b29ab Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Tue, 4 Jun 2019 09:27:43 +0200 Subject: services: Add auditd. * gnu/services/auditd.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * doc/guix.texi (Miscellaneous Services): Document it. --- doc/guix.texi | 49 ++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/services/auditd.scm | 54 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 104 insertions(+) create mode 100644 gnu/services/auditd.scm (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index 996255d9dc..bdfe14c724 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24114,6 +24114,55 @@ The Containerd package to use. @end table @end deftp +@cindex Audit +@subsubheading Auditd Service + +The @code{(gnu services auditd)} module provides the following service. + +@defvr {Scheme Variable} auditd-service-type + +This is the type of the service that runs +@url{https://people.redhat.com/sgrubb/audit/,auditd}, +a daemon that tracks security-relevant information on your system. + +Examples of things that can be tracked: + +@enumerate +@item +File accesses +@item +System calls +@item +Invoked commands +@item +Failed login attempts +@item +Firewall filtering +@item +Network access +@end enumerate + +@command{auditctl} from the @code{audit} package can be used in order +to add or remove events to be tracked (until the next reboot). +In order to permanently track events, put the command line arguments +of auditctl into @file{/etc/audit/audit.rules}. +@command{aureport} from the @code{audit} package can be used in order +to view a report of all recorded events. +The audit daemon usually logs into the directory @file{/var/log/audit}. + +@end defvr + +@deftp {Data Type} auditd-configuration +This is the data type representing the configuration of auditd. + +@table @asis + +@item @code{audit} (default: @code{audit}) +The audit package to use. + +@end table +@end deftp + @node Setuid Programs @section Setuid Programs diff --git a/gnu/local.mk b/gnu/local.mk index 6878aef44a..203445ef1b 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -501,6 +501,7 @@ GNU_SYSTEM_MODULES = \ %D%/services.scm \ %D%/services/admin.scm \ %D%/services/audio.scm \ + %D%/services/auditd.scm \ %D%/services/avahi.scm \ %D%/services/base.scm \ %D%/services/certbot.scm \ diff --git a/gnu/services/auditd.scm b/gnu/services/auditd.scm new file mode 100644 index 0000000000..8a9292015f --- /dev/null +++ b/gnu/services/auditd.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic +;;; +;;; 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 auditd) + #:use-module (gnu services) + #:use-module (gnu services configuration) + #:use-module (gnu services base) + #:use-module (gnu services shepherd) + #:use-module (gnu packages admin) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (guix packages) + #:export (auditd-configuration + auditd-service-type)) + +; /etc/audit/audit.rules + +(define-configuration auditd-configuration + (audit + (package audit) + "Audit package.")) + +(define (auditd-shepherd-service config) + (let* ((audit (auditd-configuration-audit config))) + (list (shepherd-service + (documentation "Auditd allows you to audit file system accesses.") + (provision '(auditd)) + (start #~(make-forkexec-constructor + (list (string-append #$audit "/sbin/auditd")))) + (stop #~(make-kill-destructor)))))) + +(define auditd-service-type + (service-type (name 'auditd) + (description "Allows auditing file system accesses.") + (extensions + (list + (service-extension shepherd-root-service-type + auditd-shepherd-service))) + (default-value (auditd-configuration)))) -- cgit 1.4.1 From 08814aec6ae75adcd059c5235c90ad26e5d5607e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 4 Jun 2019 22:29:40 +0200 Subject: services: Add Singularity. * gnu/packages/linux.scm (singularity)[source](snippet): Change file name of setuid helpers in libexec/cli/*.exec. [arguments]: Remove "--disable-suid". * gnu/services/docker.scm (%singularity-activation): New variable. (singularity-setuid-programs): New procedure. (singularity-service-type): New variable. * gnu/tests/singularity.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * doc/guix.texi (Miscellaneous Services): Document it. --- doc/guix.texi | 13 ++++- gnu/local.mk | 1 + gnu/packages/linux.scm | 10 ++-- gnu/services/docker.scm | 61 +++++++++++++++++++++- gnu/tests/singularity.scm | 128 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 208 insertions(+), 5 deletions(-) create mode 100644 gnu/tests/singularity.scm (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index bdfe14c724..d37d63066f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24090,7 +24090,7 @@ The following is an example @code{dicod-service} configuration. @cindex Docker @subsubheading Docker Service -The @code{(gnu services docker)} module provides the following service. +The @code{(gnu services docker)} module provides the following services. @defvr {Scheme Variable} docker-service-type @@ -24163,6 +24163,17 @@ The audit package to use. @end table @end deftp +@defvr {Scheme Variable} singularity-service-type +This is the type of the service that allows you to run +@url{https://www.sylabs.io/singularity/, Singularity}, a Docker-style tool to +create and run application bundles (aka. ``containers''). The value for this +service is the Singularity package to use. + +The service does not install a daemon; instead, it installs helper programs as +setuid-root (@pxref{Setuid Programs}) such that unprivileged users can invoke +@command{singularity run} and similar commands. +@end defvr + @node Setuid Programs @section Setuid Programs diff --git a/gnu/local.mk b/gnu/local.mk index 203445ef1b..98f6ee9679 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -587,6 +587,7 @@ GNU_SYSTEM_MODULES = \ %D%/tests/networking.scm \ %D%/tests/rsync.scm \ %D%/tests/security-token.scm \ + %D%/tests/singularity.scm \ %D%/tests/ssh.scm \ %D%/tests/version-control.scm \ %D%/tests/virtualization.scm \ diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index b2f43bb1f7..cf3b838ea8 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -2899,12 +2899,16 @@ thanks to the use of namespaces.") (substitute* "bin/singularity.in" (("^PATH=.*" all) (string-append "#" all "\n"))) + + (substitute* (find-files "libexec/cli" "\\.exec$") + (("\\$SINGULARITY_libexecdir/singularity/bin/([a-z]+)-suid" + _ program) + (string-append "/run/setuid-programs/singularity-" + program "-helper"))) #t)))) (build-system gnu-build-system) (arguments - `(#:configure-flags - (list "--disable-suid" - "--localstatedir=/var") + `(#:configure-flags '("--localstatedir=/var") #:phases (modify-phases %standard-phases (add-after 'unpack 'patch-reference-to-squashfs-tools diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm index 94a04c8996..04f9127346 100644 --- a/gnu/services/docker.scm +++ b/gnu/services/docker.scm @@ -24,12 +24,14 @@ #:use-module (gnu services shepherd) #:use-module (gnu system shadow) #:use-module (gnu packages docker) + #:use-module (gnu packages linux) ;singularity #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix packages) #:export (docker-configuration - docker-service-type)) + docker-service-type + singularity-service-type)) ;;; We're not using serialize-configuration, but we must define this because ;;; the define-configuration macro validates it exists. @@ -120,3 +122,60 @@ bundles in Docker containers.") (service-extension account-service-type (const %docker-accounts)))) (default-value (docker-configuration)))) + + +;;; +;;; Singularity. +;;; + +(define %singularity-activation + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define %mount-directory + "/var/singularity/mnt/") + + ;; Create the directories that Singularity 2.6 expects to find. Make + ;; them #o755 like the 'install-data-hook' rule in 'Makefile.am' of + ;; Singularity 2.6.1. + (for-each (lambda (directory) + (let ((directory (string-append %mount-directory + directory))) + (mkdir-p directory) + (chmod directory #o755))) + '("container" "final" "overlay" "session")) + (chmod %mount-directory #o755)))) + +(define (singularity-setuid-programs singularity) + "Return the setuid-root programs that SINGULARITY needs." + (define helpers + ;; The helpers, under a meaningful name. + (computed-file "singularity-setuid-helpers" + #~(begin + (mkdir #$output) + (for-each (lambda (program) + (symlink (string-append #$singularity + "/libexec/singularity" + "/bin/" + program "-suid") + (string-append #$output + "/singularity-" + program + "-helper"))) + '("action" "mount" "start"))))) + + (list (file-append helpers "/singularity-action-helper") + (file-append helpers "/singularity-mount-helper") + (file-append helpers "/singularity-start-helper"))) + +(define singularity-service-type + (service-type (name 'singularity) + (description + "Install the Singularity application bundle tool.") + (extensions + (list (service-extension setuid-program-service-type + singularity-setuid-programs) + (service-extension activation-service-type + (const %singularity-activation)))) + (default-value singularity))) diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm new file mode 100644 index 0000000000..55324ef9ea --- /dev/null +++ b/gnu/tests/singularity.scm @@ -0,0 +1,128 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 tests singularity) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services docker) + #:use-module (gnu packages bash) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) ;singularity + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix grafts) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix scripts pack) + #:export (%test-singularity)) + +(define %singularity-os + (simple-operating-system + (service singularity-service-type) + (simple-service 'guest-account + account-service-type + (list (user-account (name "guest") (uid 1000) (group "guest")) + (user-group (name "guest") (id 1000)))))) + +(define (run-singularity-test image) + "Load IMAGE, a Squashfs image, as a Singularity image and run it inside +%SINGULARITY-OS." + (define os + (marionette-operating-system %singularity-os)) + + (define singularity-exec + #~(begin + (use-modules (ice-9 popen) (rnrs io ports)) + + (let* ((pipe (open-pipe* OPEN_READ + #$(file-append singularity + "/bin/singularity") + "exec" #$image "/bin/guile" + "-c" "(display \"hello, world\")")) + (str (get-string-all pipe)) + (status (close-pipe pipe))) + (and (zero? status) + (string=? str "hello, world"))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette)) + + (define marionette + (make-marionette (list #$(virtual-machine os)))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "singularity") + + (test-assert "singularity exec /bin/guile (as root)" + (marionette-eval '#$singularity-exec + marionette)) + + (test-equal "singularity exec /bin/guile (unprivileged)" + 0 + (marionette-eval + `(begin + (use-modules (ice-9 match)) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (setgid 1000) + (setuid 1000) + (execl #$(program-file "singularity-exec-test" + #~(exit #$singularity-exec)) + "test")) + (lambda () + (primitive-exit 127)))) + (pid + (cdr (waitpid pid))))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "singularity-test" test)) + +(define (build-tarball&run-singularity-test) + (mlet* %store-monad + ((_ (set-grafting #f)) + (guile (set-guile-for-build (default-guile))) + ;; 'singularity exec' insists on having /bin/sh in the image. + (profile (profile-derivation (packages->manifest + (list bash-minimal guile-2.2)) + #:hooks '() + #:locales? #f)) + (tarball (squashfs-image "singularity-pack" profile + #:symlinks '(("/bin" -> "bin"))))) + (run-singularity-test tarball))) + +(define %test-singularity + (system-test + (name "singularity") + (description "Test Singularity container of Guix.") + (value (build-tarball&run-singularity-test)))) -- cgit 1.4.1 From 47b9614b3110307093382363c0ba70d31f32ef59 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Thu, 9 May 2019 15:13:26 +0300 Subject: services: Add 'nix-service-type'. * gnu/services/nix.scm: New file. * gnu/local.mk: Add this. * doc/guix.texi (Miscellaneous Services): Document this. --- doc/guix.texi | 41 +++++++++++++++++++ gnu/local.mk | 3 +- gnu/services/nix.scm | 112 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 155 insertions(+), 1 deletion(-) create mode 100644 gnu/services/nix.scm (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index a9cd66ce87..83981b50d2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24197,6 +24197,47 @@ setuid-root (@pxref{Setuid Programs}) such that unprivileged users can invoke @command{singularity run} and similar commands. @end defvr +@cindex Nix +@subsubheading Nix service + +The @code{(gnu services nix)} module provides the following service. + +@defvr {Scheme Variable} nix-service-type + +This is the type of the service that runs build daemon of the +@url{https://nixos.org/nix/, Nix} package manager. Here is an example showing +how to use it: + +@example +(use-modules (gnu)) +(use-service-modules nix) +(use-package-modules package-management) + +(operating-system + ;; @dots{} + (packages (append (list nix) + %base-packages)) + + (services (append (list (service nix-service-type)) + %base-services))) +@end example + +After @command{guix system reconfigure} configure Nix for your user: + +@itemize +@item Add a Nix channel and update it. See @url{https://nixos.org/nix/manual/, +Nix Package Manager Guide}. + +@item Create a symlink to your profile and activate Nix profile: +@end itemize + +@example +$ ln -s "/nix/var/nix/profiles/per-user/$USER/profile" ~/.nix-profile +$ source /run/current-system/profile/etc/profile.d/nix.sh +@end example + +@end defvr + @node Setuid Programs @section Setuid Programs diff --git a/gnu/local.mk b/gnu/local.mk index 0522148385..34f00f9591 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -17,7 +17,7 @@ # Copyright © 2017 Mathieu Othacehe # Copyright © 2017, 2018 Gábor Boskovits # Copyright © 2018 Amirouche Boubekki -# Copyright © 2018 Oleg Pykhalov +# Copyright © 2018, 2019 Oleg Pykhalov # Copyright © 2018 Stefan Stefanović # Copyright © 2018 Maxim Cournoyer # @@ -526,6 +526,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/messaging.scm \ %D%/services/monitoring.scm \ %D%/services/networking.scm \ + %D%/services/nix.scm \ %D%/services/nfs.scm \ %D%/services/security-token.scm \ %D%/services/shepherd.scm \ diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm new file mode 100644 index 0000000000..72ecb7d089 --- /dev/null +++ b/gnu/services/nix.scm @@ -0,0 +1,112 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Oleg Pykhalov +;;; +;;; 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 nix) + #:use-module (gnu packages admin) + #:use-module (gnu packages package-management) + #:use-module (gnu services base) + #:use-module (gnu services configuration) + #:use-module (gnu services shepherd) + #:use-module (gnu services web) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (guix gexp) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (nix-service-type)) + +;;; Commentary: +;;; +;;; This module provides a service definition for the Nix daemon. +;;; +;;; Code: + + +;;; +;;; Accounts +;;; + +;; Copied from gnu/services/base.scm +(define* (nix-build-accounts count #:key + (group "nixbld") + (shadow shadow)) + "Return a list of COUNT user accounts for Nix build users with the given +GID." + (unfold (cut > <> count) + (lambda (n) + (user-account + (name (format #f "nixbld~2,'0d" n)) + (system? #t) + (group group) + (supplementary-groups (list group "kvm")) + (comment (format #f "Nix Build User ~2d" n)) + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")))) + 1+ + 1)) +(define (nix-accounts _) + "Return the user accounts and user groups." + (cons (user-group + (name "nixbld") + (system? #t) + + ;; Use a fixed GID so that we can create the store with the right + ;; owner. + (id 40000)) + (nix-build-accounts 10 #:group "nixbld"))) + +(define (nix-activation _) + "Return the activation gexp." + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (for-each (cut mkdir-p <>) '("/nix/store" "/nix/var/log" + "/nix/var/nix/gcroots/per-user" + "/nix/var/nix/profiles/per-user")) + (chown "/nix/store" + (passwd:uid (getpw "root")) (group:gid (getpw "nixbld01"))) + (chmod "/nix/store" #o775) + (for-each (cut chmod <> #o777) '("/nix/var/nix/profiles" + "/nix/var/nix/profiles/per-user"))))) + +(define (nix-shepherd-service _) + "Return a for Nix." + (list + (shepherd-service + (provision '(nix-daemon)) + (documentation "Run nix-daemon.") + (requirement '()) + (start #~(make-forkexec-constructor + (list (string-append #$nix "/bin/nix-daemon")))) + (respawn? #f) + (stop #~(make-kill-destructor))))) + +(define nix-service-type + (service-type + (name 'nix) + (extensions + (list (service-extension shepherd-root-service-type nix-shepherd-service) + (service-extension account-service-type nix-accounts) + (service-extension activation-service-type nix-activation))) + (default-value '()) + (description "Run the Nix daemon."))) + +;;; nix.scm ends here -- cgit 1.4.1 From b09793172f59403779b01796be16b385b19b3345 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 18 May 2019 21:58:40 +0100 Subject: services: guix-publish: Log to a file. This makes it easier to read the output, as it's recorded in a file. * gnu/services/base.scm (guix-publish-shepherd-service): Add #:log-file to make-forkexec-constructor. --- gnu/services/base.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index c88a6ddec6..5e46795a5a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1824,7 +1824,8 @@ raise a deprecation warning if the 'compression-level' field was used." #:environment-variables (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8"))) + "LC_ALL=en_US.utf8") + #:log-file "/var/log/guix-publish.log")) (stop #~(make-kill-destructor)))))) (define %guix-publish-accounts -- cgit 1.4.1 From 4252dace19945f56192477e8cb07973c20a526ba Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 31 May 2019 18:25:48 +0100 Subject: services: guix-publish: Configure log rotation. * gnu/services/base.scm (%guix-publish-log-rotations): New variable. (guix-publish-service-type): Extend the rottlog-service-type. --- gnu/services/base.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5e46795a5a..3c1827fb70 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -28,6 +28,7 @@ #:use-module (guix store) #:use-module (guix deprecation) #:use-module (gnu services) + #:use-module (gnu services admin) #:use-module (gnu services shepherd) #:use-module (gnu system pam) #:use-module (gnu system shadow) ; 'user-account', etc. @@ -1838,6 +1839,10 @@ raise a deprecation warning if the 'compression-level' field was used." (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) +(define %guix-publish-log-rotations + (list (log-rotation + (files (list "/var/log/guix-publish.log"))))) + (define (guix-publish-activation config) (let ((cache (guix-publish-configuration-cache config))) (if cache @@ -1859,6 +1864,8 @@ raise a deprecation warning if the 'compression-level' field was used." guix-publish-shepherd-service) (service-extension account-service-type (const %guix-publish-accounts)) + (service-extension rottlog-service-type + (const %guix-publish-log-rotations)) (service-extension activation-service-type guix-publish-activation))) (default-value (guix-publish-configuration)) -- cgit 1.4.1 From 2f9f792a1e4854bd17a26366a84911656607b4a3 Mon Sep 17 00:00:00 2001 From: Diego Nicola Barbato Date: Sat, 8 Jun 2019 09:54:20 +0200 Subject: services: slim: Update SLiM theme to 1.x. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/xorg.scm (%default-slim-theme-name): Change to "1.x". Signed-off-by: Ludovic Courtès --- gnu/services/xorg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 0a38b4013c..06d72b5f60 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -465,7 +465,7 @@ desktop session from the system or user profile will be used." (define %default-slim-theme-name ;; This must be the name of the sub-directory in %DEFAULT-SLIM-THEME that ;; contains the actual theme files. - "0.x") + "1.x") (define-record-type* slim-configuration make-slim-configuration -- cgit 1.4.1 From 2be6b5e2eea9ac084cc22281f64f7a089e46cdae Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 11 Jun 2019 20:50:37 +0200 Subject: services: Add SRFI-26 to Nix activation gexp. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fix the following fatal error on ‘guix system reconfigure’: Backtrace: 18 (primitive-load "/home/nckx/.config/guix/current/bin/guix") In guix/ui.scm: 1620:12 17 (run-guix-command _ . _) In ice-9/boot-9.scm: 829:9 16 (catch _ _ # _) 829:9 15 (catch _ _ # …) In guix/scripts/system.scm: 1325:8 14 (_) In guix/status.scm: 768:4 13 (call-with-status-report _ _) In guix/scripts/system.scm: 1181:4 12 (process-action _ _ _) In guix/store.scm: 623:10 11 (call-with-store _) 1800:24 10 (run-with-store _ _ #:guile-for-build _ #:system _ #:target _) In guix/scripts/system.scm: 920:13 9 (_ _) 409:8 8 (_ _) In unknown file: 7 (primitive-load "/gnu/store/dha7j9gcz3vgb8cy7vfvvaswwsywrrzj-activate") In ice-9/boot-9.scm: 260:13 6 (for-each # _) In unknown file: 5 (primitive-load "/gnu/store/ql1xjxrssxm51z2bn2v6l3mlrncij84h-activate-service") In ice-9/eval.scm: 619:8 4 (_ #f) 196:35 3 (_ #f) 196:27 2 (_ #f) 223:20 1 (proc #) In unknown file: 0 (%resolve-variable (7 . cut) #) ERROR: In procedure %resolve-variable: error: cut: unbound variable Reported-by: Alex McGrath on #guix. * gnu/services/nix.scm (nix-activation): Import and use (srfi srfi-26). --- gnu/services/nix.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index 72ecb7d089..b227abe32d 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -75,9 +75,11 @@ GID." (define (nix-activation _) "Return the activation gexp." - (with-imported-modules '((guix build utils)) + (with-imported-modules '((guix build utils) + (srfi srfi-26)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (srfi srfi-26)) (for-each (cut mkdir-p <>) '("/nix/store" "/nix/var/log" "/nix/var/nix/gcroots/per-user" "/nix/var/nix/profiles/per-user")) -- cgit 1.4.1 From 79d19d7d90c63eca83068cc9b1f22d8020e27563 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 12 Jun 2019 16:49:38 +0200 Subject: services: Import (srfi srfi-26) from the build side. See . * gnu/services/nix.scm (nix-activation): Remove (srfi srfi-26) from (host-) imported modules. --- gnu/services/nix.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index b227abe32d..dfe33991d0 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -75,8 +75,7 @@ GID." (define (nix-activation _) "Return the activation gexp." - (with-imported-modules '((guix build utils) - (srfi srfi-26)) + (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils) (srfi srfi-26)) -- cgit 1.4.1