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 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'doc') 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. -- cgit v1.2.3 From f644f6365505eaad79ffca7046e18907b5d7a5b6 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 23 May 2019 10:39:52 -0400 Subject: doc: Update default value of terminal-outputs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi: (terminal-outputs) Update default value. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index d60f453b24..98c5d1e91d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24132,7 +24132,7 @@ The bootloader theme object describing the theme to use. If no theme is provided, some bootloaders might use a default theme, that's true for GRUB. -@item @code{terminal-outputs} (default: @code{'gfxterm}) +@item @code{terminal-outputs} (default: @code{'(gfxterm)}) The output terminals used for the bootloader boot menu, as a list of symbols. GRUB accepts the values: @code{console}, @code{serial}, @code{serial_@{0-3@}}, @code{gfxterm}, @code{vga_text}, -- cgit v1.2.3 From 66229b04ae0ee05779b93d77900a062b8e0e8770 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 May 2019 08:26:38 +0200 Subject: publish: Add support for lzip. * guix/scripts/publish.scm (show-help, %options): Support '-C METHOD' and '-C METHOD:LEVEL'. (default-compression): New procedure. (bake-narinfo+nar): Add lzip. (nar-response-port): Likewise. (string->compression-type): New procedure. (make-request-handler): Generalize /nar/gzip handler to handle /nar/lzip as well. * tests/publish.scm ("/nar/lzip/*"): New test. ("/*.narinfo with lzip compression"): New test. * doc/guix.texi (Invoking guix publish): Document it. (Requirements): Mention lzlib. --- .dir-locals.el | 2 ++ doc/guix.texi | 25 ++++++++++---- guix/scripts/publish.scm | 84 +++++++++++++++++++++++++++++++++++------------- tests/publish.scm | 36 +++++++++++++++++++++ 4 files changed, 119 insertions(+), 28 deletions(-) (limited to 'doc') diff --git a/.dir-locals.el b/.dir-locals.el index 550e06ef09..f1196fd781 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -53,6 +53,8 @@ (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-output-port 'scheme-indent-function 1)) (eval . (put 'signature-case 'scheme-indent-function 1)) (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 98c5d1e91d..340b806962 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -757,6 +757,11 @@ Support for build offloading (@pxref{Daemon Offload Setup}) and @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH}, version 0.10.2 or later. +@item +When @url{https://www.nongnu.org/lzip/lzlib.html, lzlib} is available, lzlib +substitutes can be used and @command{guix publish} can compress substitutes +with lzlib. + @item When @url{http://www.bzip.org, libbz2} is available, @command{guix-daemon} can use it to compress build logs. @@ -9656,12 +9661,20 @@ accept connections from any interface. Change privileges to @var{user} as soon as possible---i.e., once the server socket is open and the signing key has been read. -@item --compression[=@var{level}] -@itemx -C [@var{level}] -Compress data using the given @var{level}. When @var{level} is zero, -disable compression. The range 1 to 9 corresponds to different gzip -compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). -The default is 3. +@item --compression[=@var{method}[:@var{level}]] +@itemx -C [@var{method}[:@var{level}]] +Compress data using the given @var{method} and @var{level}. @var{method} is +one of @code{lzip} and @code{gzip}; when @var{method} is omitted, @code{gzip} +is used. + +When @var{level} is zero, disable compression. The range 1 to 9 corresponds +to different compression levels: 1 is the fastest, and 9 is the best +(CPU-intensive). The default is 3. + +Usually, @code{lzip} compresses noticeably better than @code{gzip} for a small +increase in CPU usage; see +@uref{https://nongnu.org/lzip/lzip_benchmark.html,benchmarks on the lzip Web +page}. Unless @option{--cache} is used, compression occurs on the fly and the compressed streams are not diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index db64d6483e..11e7e985d1 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,6 +51,7 @@ (define-module (guix scripts publish) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix zlib) + #:autoload (guix lzlib) (lzlib-available?) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -74,8 +75,8 @@ (define (show-help) (display (G_ " -u, --user=USER change privileges to USER as soon as possible")) (display (G_ " - -C, --compression[=LEVEL] - compress archives at LEVEL")) + -C, --compression[=METHOD:LEVEL] + compress archives with METHOD at LEVEL")) (display (G_ " -c, --cache=DIRECTORY cache published items to DIRECTORY")) (display (G_ " @@ -121,6 +122,9 @@ (define %default-gzip-compression ;; Since we compress on the fly, default to fast compression. (compression 'gzip 3)) +(define (default-compression type) + (compression type 3)) + (define (actual-compression item requested) "Return the actual compression used for ITEM, which may be %NO-COMPRESSION if ITEM is already compressed." @@ -153,18 +157,28 @@ (define %options name))))) (option '(#\C "compression") #f #t (lambda (opt name arg result) - (match (if arg (string->number* arg) 3) - (0 - (alist-cons 'compression %no-compression result)) - (level - (if (zlib-available?) - (alist-cons 'compression - (compression 'gzip level) - result) - (begin - (warning (G_ "zlib support is missing; \ -compression disabled~%")) - result)))))) + (let* ((colon (string-index arg #\:)) + (type (cond + (colon (string-take arg colon)) + ((string->number arg) "gzip") + (else arg))) + (level (if colon + (string->number* + (string-drop arg (+ 1 colon))) + (or (string->number arg) 3)))) + (match level + (0 + (alist-cons 'compression %no-compression result)) + (level + (match (string->compression-type type) + ((? symbol? type) + (alist-cons 'compression + (compression type level) + result)) + (_ + (warning (G_ "~a: unsupported compression type~%") + type) + result))))))) (option '(#\c "cache") #t #f (lambda (opt name arg result) (alist-cons 'cache arg result))) @@ -511,6 +525,13 @@ (define* (bake-narinfo+nar cache item #:level (compression-level compression) #:buffer-size (* 128 1024)) (rename-file (string-append nar ".tmp") nar)) + ('lzip + ;; Note: the file port gets closed along with the lzip port. + (call-with-lzip-output-port (open-output-file (string-append nar ".tmp")) + (lambda (port) + (write-file item port)) + #:level (compression-level compression)) + (rename-file (string-append nar ".tmp") nar)) ('none ;; Cache nars even when compression is disabled so that we can ;; guarantee the TTL (see .) @@ -715,6 +736,9 @@ (define (nar-response-port response compression) (make-gzip-output-port (response-port response) #:level level #:buffer-size (* 64 1024))) + (($ 'lzip level) + (make-lzip-output-port (response-port response) + #:level level)) (($ 'none) (response-port response)) (#f @@ -789,12 +813,23 @@ (define-server-impl concurrent-http-server http-write (@@ (web server http) http-close)) +(define (string->compression-type string) + "Return a symbol denoting the compression method expressed by STRING; return +#f if STRING doesn't match any supported method." + (match string + ("gzip" (and (zlib-available?) 'gzip)) + ("lzip" (and (lzlib-available?) 'lzip)) + (_ #f))) + (define* (make-request-handler store #:key cache pool narinfo-ttl (nar-path "nar") (compression %no-compression)) + (define compression-type? + string->compression-type) + (define nar-path? (let ((expected (split-and-decode-uri-path nar-path))) (cut equal? expected <>))) @@ -843,13 +878,18 @@ (define nar-path? ;; is restarted with different compression parameters. ;; /nar/gzip/ - ((components ... "gzip" store-item) - (if (and (nar-path? components) (zlib-available?)) - (let ((compression (match compression - (($ 'gzip) - compression) - (_ - %default-gzip-compression)))) + ((components ... (? compression-type? type) store-item) + (if (nar-path? components) + (let* ((compression-type (string->compression-type type)) + (compression (match compression + (($ type) + (if (eq? type compression-type) + compression + (default-compression + compression-type))) + (_ + (default-compression + compression-type))))) (if cache (render-nar/cached store cache request store-item #:ttl narinfo-ttl diff --git a/tests/publish.scm b/tests/publish.scm index 7f44bc700f..80e0977cd5 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -36,6 +36,7 @@ (define-module (test-publish) #:use-module (gcrypt pk-crypto) #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module (guix zlib) + #:use-module (guix lzlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -229,6 +230,19 @@ (define %gzip-magic-bytes (string-append "/nar/gzip/" (basename %item)))))) (get-bytevector-n nar (bytevector-length %gzip-magic-bytes)))) +(unless (lzlib-available?) + (test-skip 1)) +(test-equal "/nar/lzip/*" + "bar" + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/lzip/" (basename %item)))))) + (call-with-lzip-input-port nar + (cut restore-file <> temp))) + (call-with-input-file temp read-string)))) + (unless (zlib-available?) (test-skip 1)) (test-equal "/*.narinfo with compression" @@ -251,6 +265,28 @@ (define %gzip-magic-bytes (_ #f))) (recutils->alist body))))) +(unless (lzlib-available?) + (test-skip 1)) +(test-equal "/*.narinfo with lzip compression" + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/lzip/" (basename %item))) + ("Compression" . "lzip")) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6790" "-Clzip")))))) + (wait-until-ready 6790) + (let* ((url (string-append "http://localhost:6790/" + (store-path-hash-part %item) ".narinfo")) + (body (http-get-port url))) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body))))) + (unless (zlib-available?) (test-skip 1)) (test-equal "/*.narinfo for a compressed file" -- cgit v1.2.3 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 'doc') 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 @@ (define-module (gnu tests mail) #: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 @@ (define-module (gnu tests mail) #: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 @@ (define %test-dovecot (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 v1.2.3 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 'doc') 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 @@ (define-module (gnu services web) #: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 @@ (define-module (gnu services web) 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 @@ (define varnish-service-type 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 @@ (define-module (gnu tests web) #: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 @@ (define %test-tailon (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 v1.2.3 From b8fa86adfc01205f1d942af8cb57515eb3726c52 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 May 2019 18:36:37 +0200 Subject: publish: '--compression' can be repeated. This allows 'guix publish' to compress and advertise multiple compression methods from which users can choose. * guix/scripts/publish.scm (actual-compression): Rename to... (actual-compressions): ... this. Expect REQUESTED to be a list, and always return a list. (%default-options): Remove 'compression. (store-item->recutils): New procedure. (narinfo-string): Change #:compression to #:compressions (plural). Adjust accordingly. (render-narinfo, render-narinfo/cached): Likewise. (bake-narinfo+nar): Change #:compression to #:compressions. [compressed-nar-size]: New procedure. Call 'compress-nar' for each item returned by 'actual-compressions'. Create a narinfo for each compression. (effective-compression): New procedure. (make-request-handler): Change #:compression to #:compressions. Use 'effective-compression' to determine the applicable compression. (guix-publish): Adjust handling of '--compression'. Print a message for each compression that is enabled. * tests/publish.scm ("/*.narinfo"): Adjust to new narinfo field ordering. ("/*.narinfo with properly encoded '+' sign"): Likewise. ("/*.narinfo with lzip + gzip"): New test. ("with cache, lzip + gzip"): New test. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 5 ++ guix/scripts/publish.scm | 206 ++++++++++++++++++++++++++++------------------- tests/publish.scm | 89 ++++++++++++++++++-- 3 files changed, 211 insertions(+), 89 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 786788bad7..c01eb3a656 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9685,6 +9685,11 @@ run @command{guix publish} behind a caching proxy, or to use allows @command{guix publish} to add @code{Content-Length} HTTP header to its responses. +This option can be repeated, in which case every substitute gets compressed +using all the selected methods, and all of them are advertised. This is +useful when users may not support all the compression methods: they can select +the one they support. + @item --cache=@var{directory} @itemx -c @var{directory} Cache archives and meta-data (@code{.narinfo} URLs) to @var{directory} diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c55873db78..b4334b3f16 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -125,11 +125,11 @@ (define %default-gzip-compression (define (default-compression type) (compression type 3)) -(define (actual-compression item requested) - "Return the actual compression used for ITEM, which may be %NO-COMPRESSION +(define (actual-compressions item requested) + "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION if ITEM is already compressed." (if (compressed-file? item) - %no-compression + (list %no-compression) requested)) (define %options @@ -217,11 +217,6 @@ (define %default-options (public-key-file . ,%public-key-file) (private-key-file . ,%private-key-file) - ;; Default to fast & low compression. - (compression . ,(if (zlib-available?) - %default-gzip-compression - %no-compression)) - ;; Default number of workers when caching is enabled. (workers . ,(current-processor-count)) @@ -249,29 +244,40 @@ (define (signed-string s) (define base64-encode-string (compose base64-encode string->utf8)) +(define* (store-item->recutils store-item + #:key + (nar-path "nar") + (compression %no-compression) + file-size) + "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM, +with COMPRESSION, starting at NAR-PATH." + (let ((url (encode-and-join-uri-path + `(,@(split-and-decode-uri-path nar-path) + ,@(match compression + (($ 'none) + '()) + (($ type) + (list (symbol->string type)))) + ,(basename store-item))))) + (format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]" + url (compression-type compression) file-size))) + (define* (narinfo-string store store-path key - #:key (compression %no-compression) - (nar-path "nar") file-size) + #:key (compressions (list %no-compression)) + (nar-path "nar") (file-sizes '())) "Generate a narinfo key/value string for STORE-PATH; an exception is raised if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs. -Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it -informs the client of how much needs to be downloaded." + +Optionally, FILE-SIZES is a list of compression/integer pairs, where the +integer is size in bytes of the compressed NAR; it informs the client of how +much needs to be downloaded." (let* ((path-info (query-path-info store store-path)) - (compression (actual-compression store-path compression)) - (url (encode-and-join-uri-path - `(,@(split-and-decode-uri-path nar-path) - ,@(match compression - (($ 'none) - '()) - (($ type) - (list (symbol->string type)))) - ,(basename store-path)))) + (compressions (actual-compressions store-path compressions)) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) - (file-size (or file-size - (and (eq? compression %no-compression) size))) + (file-sizes `((,%no-compression . ,size) ,@file-sizes)) (references (string-join (map basename (path-info-references path-info)) " ")) @@ -279,17 +285,21 @@ (define* (narinfo-string store store-path key (base-info (format #f "\ StorePath: ~a -URL: ~a -Compression: ~a +~{~a~}\ NarHash: sha256:~a NarSize: ~d -References: ~a~%~a" - store-path url - (compression-type compression) - hash size references - (if file-size - (format #f "FileSize: ~a~%" file-size) - ""))) +References: ~a~%" + store-path + (map (lambda (compression) + (let ((size (assoc-ref file-sizes + compression))) + (store-item->recutils store-path + #:file-size size + #:nar-path nar-path + #:compression + compression))) + compressions) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -332,7 +342,7 @@ (define (render-nix-cache-info) %nix-cache-info)))) (define* (render-narinfo store request hash - #:key ttl (compression %no-compression) + #:key ttl (compressions (list %no-compression)) (nar-path "nar")) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the @@ -348,7 +358,7 @@ (define* (render-narinfo store request hash (cut display (narinfo-string store store-path (%private-key) #:nar-path nar-path - #:compression compression) + #:compressions compressions) <>))))) (define* (nar-cache-file directory item @@ -442,7 +452,7 @@ (define (hash-part->path* store hash cache) (apply throw args)))))) (define* (render-narinfo/cached store request hash - #:key ttl (compression %no-compression) + #:key ttl (compressions (list %no-compression)) (nar-path "nar") cache pool) "Respond to the narinfo request for REQUEST. If the narinfo is available in @@ -460,11 +470,12 @@ (define (delete-entry narinfo) (delete-file* nar) (delete-file* mapping))) - (let* ((item (hash-part->path* store hash cache)) - (compression (actual-compression item compression)) - (cached (and (not (string-null? item)) - (narinfo-cache-file cache item - #:compression compression)))) + (let* ((item (hash-part->path* store hash cache)) + (compressions (actual-compressions item compressions)) + (cached (and (not (string-null? item)) + (narinfo-cache-file cache item + #:compression + (first compressions))))) (cond ((string-null? item) (not-found request)) ((file-exists? cached) @@ -488,7 +499,7 @@ (define (delete-entry narinfo) ;; (format #t "baking ~s~%" item) (bake-narinfo+nar cache item #:ttl ttl - #:compression compression + #:compressions compressions #:nar-path nar-path))) (when ttl @@ -535,30 +546,45 @@ (define nar (write-file item port)))))) (define* (bake-narinfo+nar cache item - #:key ttl (compression %no-compression) + #:key ttl (compressions (list %no-compression)) (nar-path "/nar")) "Write the narinfo and nar for ITEM to CACHE." - (let* ((compression (actual-compression item compression)) - (nar (nar-cache-file cache item - #:compression compression)) - (narinfo (narinfo-cache-file cache item - #:compression compression))) - (compress-nar cache item compression) - - (mkdir-p (dirname narinfo)) - (with-atomic-file-output narinfo - (lambda (port) - ;; Open a new connection to the store. We cannot reuse the main - ;; thread's connection to the store since we would end up sending - ;; stuff concurrently on the same channel. - (with-store store - (display (narinfo-string store item - (%private-key) - #:nar-path nar-path - #:compression compression - #:file-size (and=> (stat nar #f) - stat:size)) - port)))))) + (define (compressed-nar-size compression) + (let* ((nar (nar-cache-file cache item #:compression compression)) + (stat (stat nar #f))) + (and stat + (cons compression (stat:size stat))))) + + (let ((compression (actual-compressions item compressions))) + + (for-each (cut compress-nar cache item <>) compressions) + + (match compressions + ((main others ...) + (let ((narinfo (narinfo-cache-file cache item + #:compression main))) + (with-atomic-file-output narinfo + (lambda (port) + ;; Open a new connection to the store. We cannot reuse the main + ;; thread's connection to the store since we would end up sending + ;; stuff concurrently on the same channel. + (with-store store + (let ((sizes (filter-map compressed-nar-size compression))) + (display (narinfo-string store item + (%private-key) + #:nar-path nar-path + #:compressions compressions + #:file-sizes sizes) + port))))) + + ;; Make narinfo files for OTHERS hard links to NARINFO such that the + ;; atime-based cache eviction considers either all the nars or none + ;; of them as candidates. + (for-each (lambda (other) + (let ((other (narinfo-cache-file cache item + #:compression other))) + (link narinfo other))) + others)))))) ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to @@ -827,12 +853,22 @@ (define (string->compression-type string) ("lzip" (and (lzlib-available?) 'lzip)) (_ #f))) +(define (effective-compression requested-type compressions) + "Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION +methods, return the applicable compression." + (or (find (match-lambda + (($ type) + (and (eq? type requested-type) + compression))) + compressions) + (default-compression requested-type))) + (define* (make-request-handler store #:key cache pool narinfo-ttl (nar-path "nar") - (compression %no-compression)) + (compressions (list %no-compression))) (define compression-type? string->compression-type) @@ -860,11 +896,11 @@ (define nar-path? #:pool pool #:ttl narinfo-ttl #:nar-path nar-path - #:compression compression) + #:compressions compressions) (render-narinfo store request hash #:ttl narinfo-ttl #:nar-path nar-path - #:compression compression))) + #:compressions compressions))) ;; /nar/file/NAME/sha256/HASH (("file" name "sha256" hash) (guard (c ((invalid-base32-character? c) @@ -885,15 +921,8 @@ (define nar-path? ((components ... (? compression-type? type) store-item) (if (nar-path? components) (let* ((compression-type (string->compression-type type)) - (compression (match compression - (($ type) - (if (eq? type compression-type) - compression - (default-compression - compression-type))) - (_ - (default-compression - compression-type))))) + (compression (effective-compression compression-type + compressions))) (if cache (render-nar/cached store cache request store-item #:ttl narinfo-ttl @@ -917,7 +946,8 @@ (define nar-path? (not-found request)))) (define* (run-publish-server socket store - #:key (compression %no-compression) + #:key + (compressions (list %no-compression)) (nar-path "nar") narinfo-ttl cache pool) (run-server (make-request-handler store @@ -925,7 +955,7 @@ (define* (run-publish-server socket store #:pool pool #:nar-path nar-path #:narinfo-ttl narinfo-ttl - #:compression compression) + #:compressions compressions) concurrent-http-server `(#:socket ,socket))) @@ -964,7 +994,17 @@ (define (guix-publish . args) (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) - (compression (assoc-ref opts 'compression)) + (compressions (match (filter-map (match-lambda + (('compression . compression) + compression) + (_ #f)) + opts) + (() + ;; Default to fast & low compression. + (list (if (zlib-available?) + %default-gzip-compression + %no-compression))) + (lst (reverse lst)))) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -996,9 +1036,11 @@ (define (guix-publish . args) (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) (sockaddr:port address)) - (when compression - (info (G_ "using '~a' compression method, level ~a~%") - (compression-type compression) (compression-level compression))) + (for-each (lambda (compression) + (info (G_ "using '~a' compression method, level ~a~%") + (compression-type compression) + (compression-level compression))) + compressions) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) @@ -1013,7 +1055,7 @@ (define (guix-publish . args) #:thread-name "publish worker")) #:nar-path nar-path - #:compression compression + #:compressions compressions #:narinfo-ttl ttl)))))) ;;; Local Variables: diff --git a/tests/publish.scm b/tests/publish.scm index 80e0977cd5..64a8ff3cae 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -138,17 +138,17 @@ (define %gzip-magic-bytes "StorePath: ~a URL: nar/~a Compression: none +FileSize: ~a NarHash: sha256:~a NarSize: ~d -References: ~a -FileSize: ~a~%" +References: ~a~%" %item (basename %item) + (path-info-nar-size info) (bytevector->nix-base32-string (path-info-hash info)) (path-info-nar-size info) - (basename (first (path-info-references info))) - (path-info-nar-size info))) + (basename (first (path-info-references info))))) (signature (base64-encode (string->utf8 (canonical-sexp->string @@ -170,15 +170,15 @@ (define %gzip-magic-bytes "StorePath: ~a URL: nar/~a Compression: none +FileSize: ~a NarHash: sha256:~a NarSize: ~d -References: ~%\ -FileSize: ~a~%" +References: ~%" item (uri-encode (basename item)) + (path-info-nar-size info) (bytevector->nix-base32-string (path-info-hash info)) - (path-info-nar-size info) (path-info-nar-size info))) (signature (base64-encode (string->utf8 @@ -301,6 +301,35 @@ (define %gzip-magic-bytes (list (assoc-ref info "Compression") (dirname (assoc-ref info "URL"))))) +(unless (and (zlib-available?) (lzlib-available?)) + (test-skip 1)) +(test-equal "/*.narinfo with lzip + gzip" + `((("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip") + ("URL" . ,(string-append "nar/lzip/" (basename %item))) + ("Compression" . "lzip")) + 200 + 200) + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2")))))) + (wait-until-ready 6793) + (let* ((base "http://localhost:6793/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (body (http-get-port url))) + (list (take (recutils->alist body) 5) + (response-code + (http-get (string-append base "nar/gzip/" + (basename %item)))) + (response-code + (http-get (string-append base "nar/lzip/" + (basename %item)))))))))) + (test-equal "custom nar path" ;; Serve nars at /foo/bar/chbouib instead of /nar. (list `(("StorePath" . ,%item) @@ -441,6 +470,52 @@ (define %gzip-magic-bytes (stat:size (stat nar))) (response-code uncompressed))))))))) +(unless (and (zlib-available?) (lzlib-available?)) + (test-skip 1)) +(test-equal "with cache, lzip + gzip" + '(200 200 404) + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2" + (string-append "--cache=" cache))))))) + (wait-until-ready 6794) + (let* ((base "http://localhost:6794/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (nar-url (cute string-append "nar/" <> "/" + (basename %item))) + (cached (cute string-append cache "/" <> "/" + (basename %item) ".narinfo")) + (nar (cute string-append cache "/" <> "/" + (basename %item) ".nar")) + (response (http-get url))) + (wait-for-file (cached "gzip")) + (let* ((body (http-get-port url)) + (narinfo (recutils->alist body)) + (uncompressed (string-append base "nar/" + (basename %item)))) + (and (file-exists? (nar "gzip")) + (file-exists? (nar "lzip")) + (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7) + `(("StorePath" . ,%item) + ("URL" . ,(nar-url "gzip")) + ("Compression" . "gzip") + ("FileSize" . ,(number->string + (stat:size (stat (nar "gzip"))))) + ("URL" . ,(nar-url "lzip")) + ("Compression" . "lzip") + ("FileSize" . ,(number->string + (stat:size (stat (nar "lzip"))))))) + (list (response-code + (http-get (string-append base (nar-url "gzip")))) + (response-code + (http-get (string-append base (nar-url "lzip")))) + (response-code + (http-get uncompressed)))))))))) + (unless (zlib-available?) (test-skip 1)) (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" -- cgit v1.2.3 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 'doc') 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 @@ (define-module (gnu services base) 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 @@ (define-record-type* (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 @@ (define-record-type* (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 @@ (define-module (guix deprecation) #:use-module (ice-9 format) #:export (define-deprecated define-deprecated/alias + warn-about-deprecation deprecation-warning-port)) ;;; Commentary: -- cgit v1.2.3 From 7f6a717b723bbc22bab7b1aa960b22fbfb5b93cb Mon Sep 17 00:00:00 2001 From: Diego Nicola Barbato Date: Thu, 16 May 2019 13:39:18 +0200 Subject: doc: Fix typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi (Invoking guix archive): Remove spurious hyphen in example. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a8f3a5ad27..996255d9dc 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4219,7 +4219,7 @@ to another like this: @example guix archive --export -r $(readlink -f ~/.guix-profile) | \ - ssh the-machine guix-archive --import + ssh the-machine guix archive --import @end example @noindent -- cgit v1.2.3 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 'doc') 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 v1.2.3 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 'doc') 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 @@ (define-public singularity (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 @@ (define-module (gnu services docker) #: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 @@ (define docker-service-type (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 v1.2.3 From a0f352b30f4869a7af7017b8a5011ac7602dd115 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 4 Jun 2019 18:43:23 +0200 Subject: pack: Add '--entry-point'. * guix/scripts/pack.scm (self-contained-tarball): Add #:entry-point and warn when it's true. (squashfs-image): Add #:entry-point and honor it. (docker-image): Add #:entry-point and honor it. (%options, show-help): Add '--entry-point'. (guix-pack): Honor '--entry-point' and pass #:entry-point to BUILD-IMAGE. * gnu/tests/docker.scm (run-docker-test): Test 'docker run' with the default entry point. (build-tarball&run-docker-test): Pass #:entry-point to 'docker-image'. * doc/guix.texi (Invoking guix pack): Document it. * gnu/tests/singularity.scm (run-singularity-test)["singularity run"]: New test. (build-tarball&run-singularity-test): Pass #:entry-point to 'squashfs-image'. --- doc/guix.texi | 23 +++++++++++++++++++++++ gnu/tests/docker.scm | 19 ++++++++++++------- gnu/tests/singularity.scm | 9 +++++++++ guix/scripts/pack.scm | 41 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 85 insertions(+), 7 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index d37d63066f..bd0f3e8fd5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4866,6 +4866,29 @@ advantage to work without requiring special kernel support, but it incurs run-time overhead every time a system call is made. @end quotation +@cindex entry point, for Docker images +@item --entry-point=@var{command} +Use @var{command} as the @dfn{entry point} of the resulting pack, if the pack +format supports it---currently @code{docker} and @code{squashfs} (Singularity) +support it. @var{command} must be relative to the profile contained in the +pack. + +The entry point specifies the command that tools like @code{docker run} or +@code{singularity run} automatically start by default. For example, you can +do: + +@example +guix pack -f docker --entry-point=bin/guile guile +@end example + +The resulting pack can easily be loaded and @code{docker run} with no extra +arguments will spawn @code{bin/guile}: + +@example +docker load -i pack.tar.gz +docker run @var{image-id} +@end example + @item --expression=@var{expr} @itemx -e @var{expr} Consider the package @var{expr} evaluates to. diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3cd3a27884..f2674cdbe8 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -101,7 +101,7 @@ (define marionette marionette)) (test-equal "Load docker image and run it" - "hello world" + '("hello world" "hi!") (marionette-eval `(begin (define slurp @@ -117,12 +117,16 @@ (define slurp (repository&tag (string-drop raw-line (string-length "Loaded image: "))) - (response (slurp - ,(string-append #$docker-cli "/bin/docker") - "run" "--entrypoint" "bin/Guile" - repository&tag - "/aa.scm"))) - response)) + (response1 (slurp + ,(string-append #$docker-cli "/bin/docker") + "run" "--entrypoint" "bin/Guile" + repository&tag + "/aa.scm")) + (response2 (slurp ;default entry point + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag + "-c" "(display \"hi!\")"))) + (list response1 response2))) marionette)) (test-end) @@ -161,6 +165,7 @@ (define (build-tarball&run-docker-test) (tarball (docker-image "docker-pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile") ("aa.scm" -> "a.scm")) + #:entry-point "bin/guile" #:localstatedir? #t))) (run-docker-test tarball))) diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm index 55324ef9ea..668043a0bc 100644 --- a/gnu/tests/singularity.scm +++ b/gnu/tests/singularity.scm @@ -103,6 +103,14 @@ (define marionette (cdr (waitpid pid))))) marionette)) + (test-equal "singularity run" ;test the entry point + 42 + (marionette-eval + `(status:exit-val + (system* #$(file-append singularity "/bin/singularity") + "run" #$image "-c" "(exit 42)")) + marionette)) + (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) @@ -118,6 +126,7 @@ (define (build-tarball&run-singularity-test) #:hooks '() #:locales? #f)) (tarball (squashfs-image "singularity-pack" profile + #:entry-point "bin/guile" #:symlinks '(("/bin" -> "bin"))))) (run-singularity-test tarball))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c17b374330..5da23e038b 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -152,6 +152,7 @@ (define* (self-contained-tarball name profile #:key target (profile-name "guix-profile") deduplicate? + entry-point (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -275,6 +276,10 @@ (define tar-supports-sort? (_ #f)) directives))))))))) + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") + 'tarball)) + (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) build @@ -284,6 +289,7 @@ (define* (squashfs-image name profile #:key target (profile-name "guix-profile") (compressor (first %compressors)) + entry-point localstatedir? (symlinks '()) (archiver squashfs-tools-next)) @@ -315,6 +321,7 @@ (define build (ice-9 match)) (define database #+database) + (define entry-point #$entry-point) (setenv "PATH" (string-append #$archiver "/bin")) @@ -371,6 +378,28 @@ (define database #+database) target))))))) '#$symlinks) + ;; Create /.singularity.d/actions, and optionally the 'run' + ;; script, used by 'singularity run'. + "-p" "/.singularity.d d 555 0 0" + "-p" "/.singularity.d/actions d 555 0 0" + ,@(if entry-point + `(;; This one if for Singularity 2.x. + "-p" + ,(string-append + "/.singularity.d/actions/run s 777 0 0 " + (relative-file-name "/.singularity.d/actions" + (string-append #$profile "/" + entry-point))) + + ;; This one is for Singularity 3.x. + "-p" + ,(string-append + "/.singularity.d/runscript s 777 0 0 " + (relative-file-name "/.singularity.d" + (string-append #$profile "/" + entry-point)))) + '()) + ;; Create empty mount points. "-p" "/proc d 555 0 0" "-p" "/sys d 555 0 0" @@ -392,6 +421,7 @@ (define* (docker-image name profile #:key target (profile-name "guix-profile") (compressor (first %compressors)) + entry-point localstatedir? (symlinks '()) (archiver tar)) @@ -425,6 +455,8 @@ (define build #$profile #:database #+database #:system (or #$target (utsname:machine (uname))) + #:entry-point (string-append #$profile "/" + #$entry-point) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) @@ -689,6 +721,9 @@ (define %options (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '("entry-point") #t #f + (lambda (opt name arg result) + (alist-cons 'entry-point arg result))) (option '("target") #t #f (lambda (opt name arg result) (alist-cons 'target arg @@ -765,6 +800,9 @@ (define (show-help) -S, --symlink=SPEC create symlinks to the profile according to SPEC")) (display (G_ " -m, --manifest=FILE create a pack with the manifest from FILE")) + (display (G_ " + --entry-point=PROGRAM + use PROGRAM as the entry point of the pack")) (display (G_ " --save-provenance save provenance information")) (display (G_ " @@ -889,6 +927,7 @@ (define properties (leave (G_ "~a: unknown pack format~%") pack-format)))) (localstatedir? (assoc-ref opts 'localstatedir?)) + (entry-point (assoc-ref opts 'entry-point)) (profile-name (assoc-ref opts 'profile-name)) (gc-root (assoc-ref opts 'gc-root))) (when (null? (manifest-entries manifest)) @@ -919,6 +958,8 @@ (define properties symlinks #:localstatedir? localstatedir? + #:entry-point + entry-point #:profile-name profile-name #:archiver -- cgit v1.2.3 From 940511257c83538f8cd7631292d173c8ce927152 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 9 Jun 2019 03:29:59 +0200 Subject: doc: Fix typos. * doc/guix.texi (Version Control Services): Fix typos & edit surrounding text. --- doc/guix.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index bd0f3e8fd5..a9cd66ce87 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -22723,10 +22723,10 @@ Extra options will be passed to @code{git daemon}, please run @end deftp The @code{git://} protocol lacks authentication. When you pull from a -repository fetched via @code{git://}, you don't know that the data you -receive was modified is really coming from the specified host, and you -have your connection is subject to eavesdropping. It's better to use an -authenticated and encrypted transport, such as @code{https}. Although Git allows you +repository fetched via @code{git://}, you don't know whether the data you +receive was modified or is even coming from the specified host, and your +connection is subject to eavesdropping. It's better to use an authenticated +and encrypted transport, such as @code{https}. Although Git allows you to serve repositories using unsophisticated file-based web servers, there is a faster protocol implemented by the @code{git-http-backend} program. This program is the back-end of a proper Git web service. It -- cgit v1.2.3 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 'doc') 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 v1.2.3 From aec9bb8793ca75a5bbc1731460ed4eb388764202 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Mon, 10 Jun 2019 18:26:49 +0200 Subject: doc: Work around a po4a bug. * doc/guix.texi: Work around a po4a bug that prevents `guix pull` from completing. --- doc/guix.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 83981b50d2..93bec28fc9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24225,8 +24225,8 @@ how to use it: 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 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 -- cgit v1.2.3 From f8a9f99cd602ce1dc5307cb0c21ae718ad8796bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 22:10:21 +0200 Subject: store: 'build-things' accepts derivation/output pairs. This allows callers to request the substitution of a single derivation output. * guix/store.scm (build-things): Accept derivation/output pairs among THINGS. * guix/derivations.scm (build-derivations): Likewise. * tests/store.scm ("substitute + build-things with specific output"): New test. * tests/derivations.scm ("build-derivations with specific output"): New test. * doc/guix.texi (The Store): Adjust accordingly. --- doc/guix.texi | 9 +++++---- guix/derivations.scm | 13 +++++++++---- guix/store.scm | 26 ++++++++++++++++---------- tests/derivations.scm | 22 ++++++++++++++++++++++ tests/store.scm | 20 ++++++++++++++++++++ 5 files changed, 72 insertions(+), 18 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 93bec28fc9..87dc6ea5c5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6466,10 +6466,11 @@ path. @var{references} is the list of store paths referred to by the resulting store path. @end deffn -@deffn {Scheme Procedure} build-derivations @var{server} @var{derivations} -Build @var{derivations} (a list of @code{} objects or -derivation paths), and return when the worker is done building them. -Return @code{#t} on success. +@deffn {Scheme Procedure} build-derivations @var{store} @var{derivations} @ + [@var{mode}] +Build @var{derivations}, a list of @code{} objects, @file{.drv} +file names, or derivation/output pairs, using the specified +@var{mode}---@code{(build-mode normal)} by default. @end deffn Note that the @code{(guix monads)} module provides a monad as well as diff --git a/guix/derivations.scm b/guix/derivations.scm index 7a5c3bca94..cad77bdb06 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -982,12 +982,17 @@ (define rewritten-input (define* (build-derivations store derivations #:optional (mode (build-mode normal))) - "Build DERIVATIONS, a list of objects or .drv file names, using -the specified MODE." + "Build DERIVATIONS, a list of objects, .drv file names, or +derivation/output pairs, using the specified MODE." (build-things store (map (match-lambda + ((? derivation? drv) + (derivation-file-name drv)) ((? string? file) file) - ((and drv ($ )) - (derivation-file-name drv))) + (((? derivation? drv) . output) + (cons (derivation-file-name drv) + output)) + (((? string? file) . output) + (cons file output))) derivations) mode)) diff --git a/guix/store.scm b/guix/store.scm index 738c0fb5f3..8fa16499f8 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1211,16 +1211,22 @@ (define build-things "Build THINGS, a list of store items which may be either '.drv' files or outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. -Return #t on success." - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (if (>= (store-connection-minor-version store) 15) - (build store things mode) - (if (= mode (build-mode normal)) - (build/old store things) - (raise (condition (&store-protocol-error - (message "unsupported build mode") - (status 1)))))))))) +Alternately, an element of THING can be a derivation/output name pair, in +which case the daemon will attempt to substitute just the requested output of +the derivation. Return #t on success." + (let ((things (map (match-lambda + ((drv . output) (string-append drv "!" output)) + (thing thing)) + things))) + (parameterize ((current-store-protocol-version + (store-connection-version store))) + (if (>= (store-connection-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&store-protocol-error + (message "unsupported build mode") + (status 1))))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. diff --git a/tests/derivations.scm b/tests/derivations.scm index dbb5b584eb..c421d094a4 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -787,6 +787,28 @@ (define %coreutils (build-derivations store (list drv)) #f))) +(test-assert "build-derivations with specific output" + (with-store store + (let* ((content (random-text)) ;contents of the output + (drv (build-expression->derivation + store "substitute-me" + `(begin ,content (exit 1)) ;would fail + #:outputs '("out" "one" "two") + #:guile-for-build + (package-derivation store %bootstrap-guile))) + (out (derivation->output-path drv))) + (with-derivation-substitute drv content + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? store out) + + ;; Ask for nothing but the "out" output of DRV. + (build-derivations store `((,drv . "out"))) + + (valid-path? store out) + (equal? (pk 'x content) (pk 'y (call-with-input-file out get-string-all))) + ))))) + (test-assert "build-expression->derivation and derivation-prerequisites-to-build" (let ((drv (build-expression->derivation %store "fail" #f))) ;; The only direct dependency is (%guile-for-build) and it's already diff --git a/tests/store.scm b/tests/store.scm index df66feaebb..518750d26a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -599,6 +599,26 @@ (define (same? x y) (valid-path? s o) (equal? c (call-with-input-file o get-string-all))))))) +(test-assert "substitute + build-things with specific output" + (with-store s + (let* ((c (random-text)) ;contents of the output + (d (build-expression->derivation + s "substitute-me" `(begin ,c (exit 1)) ;would fail + #:outputs '("out" "one" "two") + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation->output-path d))) + (with-derivation-substitute d c + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? s o) + + ;; Ask for nothing but the "out" output of D. + (build-things s `((,(derivation-file-name d) . "out"))) + + (valid-path? s o) + (equal? c (call-with-input-file o get-string-all))))))) + (test-assert "substitute, corrupt output hash" ;; Tweak the substituter into installing a substitute whose hash doesn't ;; match the one announced in the narinfo. The daemon must notice this and -- cgit v1.2.3 From 8a290772a45fd56cb5e85cb718ce654dddb54ea6 Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Fri, 17 May 2019 09:07:54 -0700 Subject: doc: Update cargo-build-system parameter docs. * doc/guix.texi: (Build Systems)[cargo-build-system]: Add references to the #:rust, #:cargo-inputs, and #:cargo-development-inputs parameters. Remove reference to installing crate sources. Signed-off-by: Chris Marusich --- doc/guix.texi | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 87dc6ea5c5..1b07327278 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -64,6 +64,7 @@ Copyright @copyright{} 2018 Laura Lazzati@* Copyright @copyright{} 2018 Alex Vong@* Copyright @copyright{} 2019 Josh Holland@* Copyright @copyright{} 2019 Diego Nicola Barbato@* +Copyright @copyright{} 2019 Ivan Petkov@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -5814,10 +5815,21 @@ This variable is exported by @code{(guix build-system cargo)}. It supports builds of packages using Cargo, the build tool of the @uref{https://www.rust-lang.org, Rust programming language}. -In its @code{configure} phase, this build system replaces dependencies -specified in the @file{Cargo.toml} file with inputs to the Guix package. -The @code{install} phase installs the binaries, and it also installs the -source code and @file{Cargo.toml} file. +It adds @code{rustc} and @code{cargo} to the set of inputs. +A different Rust package can be specified with the @code{#:rust} parameter. + +Regular cargo dependencies should be added to the package definition via the +@code{#:cargo-inputs} parameter as a list of name and spec pairs, where the +spec can be a package or a source definition. Note that the spec must +evaluate to a path to a gzipped tarball which includes a @code{Cargo.toml} +file at its root, or it will be ignored. Similarly, cargo dev-dependencies +should be added to the package definition via the +@code{#:cargo-development-inputs} parameter. + +In its @code{configure} phase, this build system will make any source inputs +specified in the @code{#:cargo-inputs} and @code{#:cargo-development-inputs} +parameters available to cargo. The @code{install} phase installs any crate +the binaries if they are defined by the crate. @end defvr @cindex Clojure (programming language) -- cgit v1.2.3 From 88b696ef27134c3e55355706d5917f0aa975a6be Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 12 Jun 2019 18:51:55 +0200 Subject: doc: Improve tarball extraction example. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 1b07327278..9dc1d2a9ca 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -570,7 +570,7 @@ you may have to run @code{su -} or @code{sudo -i}. As @code{root}, run: @example # cd /tmp # tar --warning=no-timestamp -xf \ - guix-binary-@value{VERSION}.@var{system}.tar.xz + /path/to/guix-binary-@value{VERSION}.@var{system}.tar.xz # mv var/guix /var/ && mv gnu / @end example -- cgit v1.2.3