From 493375cdb23fc1416348da584f17bec7171faadd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 May 2019 01:18:53 +0200 Subject: publish: Maintain a hash-part-to-store-item mapping in cache. Fixes . * guix/scripts/publish.scm (hash-part-mapping-cache-file) (hash-part->path*): New procedures. * guix/scripts/publish.scm (render-narinfo/cached)[delete-entry]: Delete the 'hash-part-mapping-cache-file'. Use 'hash-part->path*' instead of 'hash-part->path'. * tests/publish.scm ("with cache, vanishing item"): New test. --- guix/scripts/publish.scm | 38 +++++++++++++++++++++++++++++++++----- 1 file changed, 33 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a236f3e45c..db64d6483e 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -350,6 +350,9 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." "/" (basename item) ".narinfo")) +(define (hash-part-mapping-cache-file directory hash) + (string-append directory "/hashes/" hash)) + (define run-single-baker (let ((baking (make-weak-value-hash-table)) (mutex (make-mutex))) @@ -403,6 +406,27 @@ items. Failing that, we could eventually have to recompute them and return +inf.0 (expiration-time file)))))) +(define (hash-part->path* store hash cache) + "Like 'hash-part->path' but cached results under CACHE. This ensures we can +still map HASH to the corresponding store file name, even if said store item +vanished from the store in the meantime." + (let ((cached (hash-part-mapping-cache-file cache hash))) + (catch 'system-error + (lambda () + (call-with-input-file cached read-string)) + (lambda args + (if (= ENOENT (system-error-errno args)) + (match (hash-part->path store hash) + ("" "") + (result + (mkdir-p (dirname cached)) + (call-with-output-file (string-append cached ".tmp") + (lambda (port) + (display result port))) + (rename-file (string-append cached ".tmp") cached) + result)) + (apply throw args)))))) + (define* (render-narinfo/cached store request hash #:key ttl (compression %no-compression) (nar-path "nar") @@ -412,13 +436,17 @@ CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo requested using POOL." (define (delete-entry narinfo) ;; Delete NARINFO and the corresponding nar from CACHE. - (let ((nar (string-append (string-drop-right narinfo - (string-length ".narinfo")) - ".nar"))) + (let* ((nar (string-append (string-drop-right narinfo + (string-length ".narinfo")) + ".nar")) + (base (basename narinfo ".narinfo")) + (hash (string-take base (string-index base #\-))) + (mapping (hash-part-mapping-cache-file cache hash))) (delete-file* narinfo) - (delete-file* nar))) + (delete-file* nar) + (delete-file* mapping))) - (let* ((item (hash-part->path store hash)) + (let* ((item (hash-part->path* store hash cache)) (compression (actual-compression item compression)) (cached (and (not (string-null? item)) (narinfo-cache-file cache item -- 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 'guix/scripts') 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 @@ #: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 @@ Publish ~a over HTTP.\n") %store-directory) (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 @@ Publish ~a over HTTP.\n") %store-directory) ;; 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 @@ if ITEM is already compressed." 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 @@ requested using POOL." #: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 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (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 @@ blocking." 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 @@ blocking." ;; 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 @@ #: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 @@ FileSize: ~a~%" (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 @@ FileSize: ~a~%" (_ #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 35d1354fe87003dbe19b1b97aa64db1f7d989701 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 May 2019 22:38:15 +0200 Subject: publish: Display the compression method and level in use. * guix/scripts/publish.scm (guix-publish): Use 'info' instead of 'format' for the initial message. When COMPRESSION is true, display the method and level in use. --- guix/scripts/publish.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 11e7e985d1..889dbef860 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -987,10 +987,15 @@ consider using the '--user' option!~%"))) (parameterize ((%public-key public-key) (%private-key private-key)) - (format #t (G_ "publishing ~a on ~a, port ~d~%") - %store-directory - (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) - (sockaddr:port address)) + (info (G_ "publishing ~a on ~a, port ~d~%") + %store-directory + (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))) + (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) -- cgit v1.2.3 From e84e0369435add8e839fec78d4be7b2e71f6d4a8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 May 2019 11:35:15 +0200 Subject: publish: Remove outdated comment. * guix/scripts/publish.scm (make-request-handler): Remove outdated TODO. --- guix/scripts/publish.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 889dbef860..2875904758 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -848,8 +848,6 @@ blocking." (render-home-page request)) ;; /.narinfo (((= extract-narinfo-hash (? string? hash))) - ;; TODO: Register roots for HASH that will somehow remain for - ;; NARINFO-TTL. (if cache (render-narinfo/cached store request hash #:cache cache -- cgit v1.2.3 From 73bddab54504c6380a896b7263ab6c3dd8558ef7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 May 2019 11:38:17 +0200 Subject: publish: Factorize 'compress-nar'. * guix/scripts/publish.scm (compress-nar): New procedure. (bake-narinfo+nar): Use it. --- guix/scripts/publish.scm | 54 +++++++++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 24 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 2875904758..c55873db78 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -505,6 +505,35 @@ requested using POOL." (else (not-found request #:phrase ""))))) +(define (compress-nar cache item compression) + "Save in directory CACHE the nar for ITEM compressed with COMPRESSION." + (define nar + (nar-cache-file cache item #:compression compression)) + + (mkdir-p (dirname nar)) + (match (compression-type compression) + ('gzip + ;; Note: the file port gets closed along with the gzip port. + (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) + (lambda (port) + (write-file item port)) + #: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 .) + (with-atomic-file-output nar + (lambda (port) + (write-file item port)))))) + (define* (bake-narinfo+nar cache item #:key ttl (compression %no-compression) (nar-path "/nar")) @@ -514,30 +543,7 @@ requested using POOL." #:compression compression)) (narinfo (narinfo-cache-file cache item #:compression compression))) - - (mkdir-p (dirname nar)) - (match (compression-type compression) - ('gzip - ;; Note: the file port gets closed along with the gzip port. - (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) - (lambda (port) - (write-file item port)) - #: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 .) - (with-atomic-file-output nar - (lambda (port) - (write-file item port))))) + (compress-nar cache item compression) (mkdir-p (dirname narinfo)) (with-atomic-file-output narinfo -- 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 'guix/scripts') 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 @@ Publish ~a over HTTP.\n") %store-directory) (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 @@ if ITEM is already compressed." (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 @@ if ITEM is already compressed." (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 @@ informs the client of how much needs to be downloaded." (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 @@ References: ~a~%~a" %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 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (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 @@ vanished from the store in the meantime." (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 @@ requested using POOL." (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 @@ requested using POOL." ;; (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 @@ requested using POOL." (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 @@ blocking." ("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 @@ blocking." #: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 @@ blocking." ((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 @@ blocking." (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 @@ blocking." #:pool pool #:nar-path nar-path #:narinfo-ttl narinfo-ttl - #:compression compression) + #:compressions compressions) concurrent-http-server `(#:socket ,socket))) @@ -964,7 +994,17 @@ blocking." (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 @@ consider using the '--user' option!~%"))) (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 @@ consider using the '--user' option!~%"))) #: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 @@ "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 @@ FileSize: ~a~%" "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 @@ FileSize: ~a~%" (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 @@ FileSize: ~a~%" (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 b90ae065b5a5fab4ed475bf2faa3a84476389a02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 May 2019 16:26:08 +0200 Subject: substitute: Select the best compression methods. When a server publishes several URLs with different compression methods, 'guix substitute' can now choose the best one among the compression methods that it supports. * guix/scripts/substitute.scm ()[uri]: Replace with... [uris]: ... this. [compression]: Replace with... [compressions]: ... this. [file-size]: Replace with... [file-sizes]: ... this. [file-hash]: Replace with... [file-hashes]: ... this. (narinfo-maker): Adjust accordingly. Ensure 'file-sizes' and 'file-hashes' have the right length. (assert-valid-signature, valid-narinfo?): Use the first element of 'narinfo-uris' in error messages. (read-narinfo): Expect "URL", "Compression", "FileSize", and "FileHash" to occur multiple times. (display-narinfo-data): Call 'select-uri' to determine the file size. (%compression-methods): New variable. (supported-compression?, compresses-better?, select-uri): New procedures. (process-substitution): Call 'select-uri' to select the URI and compression. * guix/scripts/weather.scm (report-server-coverage): Account for all the values returned by 'narinfo-file-sizes'. * tests/substitute.scm ("substitute, narinfo with several URLs"): New test. --- guix/scripts/challenge.scm | 4 +- guix/scripts/substitute.scm | 141 ++++++++++++++++++++++++++++++++------------ guix/scripts/weather.scm | 5 +- tests/substitute.scm | 51 +++++++++++++++- 4 files changed, 160 insertions(+), 41 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 65de42053d..17e87f0291 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -192,7 +192,7 @@ inconclusive reports." (report (G_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) (report (G_ " ~50a: ~a~%") - (uri->string (narinfo-uri narinfo)) + (uri->string (first (narinfo-uris narinfo))) (hash->string (narinfo-hash->sha256 (narinfo-hash narinfo))))) narinfos)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 135398ba48..dba08edf50 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -42,6 +42,7 @@ #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:autoload (guix lzlib) (lzlib-available?) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -66,11 +67,11 @@ narinfo? narinfo-path - narinfo-uri + narinfo-uris narinfo-uri-base - narinfo-compression - narinfo-file-hash - narinfo-file-size + narinfo-compressions + narinfo-file-hashes + narinfo-file-sizes narinfo-hash narinfo-size narinfo-references @@ -280,15 +281,16 @@ failure, return #f and #f." (define-record-type - (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size - references deriver system signature contents) + (%make-narinfo path uri-base uris compressions file-sizes file-hashes + nar-hash nar-size references deriver system + signature contents) narinfo? (path narinfo-path) - (uri narinfo-uri) - (uri-base narinfo-uri-base) ; URI of the cache it originates from - (compression narinfo-compression) - (file-hash narinfo-file-hash) - (file-size narinfo-file-size) + (uri-base narinfo-uri-base) ;URI of the cache it originates from + (uris narinfo-uris) ;list of strings + (compressions narinfo-compressions) ;list of strings + (file-sizes narinfo-file-sizes) ;list of (integers | #f) + (file-hashes narinfo-file-hashes) (nar-hash narinfo-hash) (nar-size narinfo-size) (references narinfo-references) @@ -334,17 +336,25 @@ s-expression: ~s~%") (define (narinfo-maker str cache-url) "Return a narinfo constructor for narinfos originating from CACHE-URL. STR must contain the original contents of a narinfo file." - (lambda (path url compression file-hash file-size nar-hash nar-size - references deriver system signature) + (lambda (path urls compressions file-hashes file-sizes + nar-hash nar-size references deriver system + signature) "Return a new object." - (%make-narinfo path + (define len (length urls)) + (%make-narinfo path cache-url ;; Handle the case where URL is a relative URL. - (or (string->uri url) - (string->uri (string-append cache-url "/" url))) - cache-url - - compression file-hash - (and=> file-size string->number) + (map (lambda (url) + (or (string->uri url) + (string->uri + (string-append cache-url "/" url)))) + urls) + compressions + (match file-sizes + (() (make-list len #f)) + ((lst ...) (map string->number lst))) + (match file-hashes + (() (make-list len #f)) + ((lst ...) (map string->number lst))) nar-hash (and=> nar-size string->number) (string-tokenize references) @@ -360,7 +370,7 @@ must contain the original contents of a narinfo file." #:optional (acl (current-acl))) "Bail out if SIGNATURE, a canonical sexp representing the signature of NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." - (let ((uri (uri->string (narinfo-uri narinfo)))) + (let ((uri (uri->string (first (narinfo-uris narinfo))))) (signature-case (signature hash acl) (valid-signature #t) (invalid-signature @@ -387,7 +397,8 @@ No authentication and authorization checks are performed here!" '("StorePath" "URL" "Compression" "FileHash" "FileSize" "NarHash" "NarSize" "References" "Deriver" "System" - "Signature")))) + "Signature") + '("URL" "Compression" "FileSize" "FileHash")))) (define (narinfo-sha256 narinfo) "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a @@ -414,7 +425,7 @@ No authentication and authorization checks are performed here!" (or %allow-unauthenticated-substitutes? (let ((hash (narinfo-sha256 narinfo)) (signature (narinfo-signature narinfo)) - (uri (uri->string (narinfo-uri narinfo)))) + (uri (uri->string (first (narinfo-uris narinfo))))) (and hash signature (signature-case (signature hash acl) (valid-signature #t) @@ -919,9 +930,11 @@ expected by the daemon." (length (narinfo-references narinfo))) (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) (narinfo-references narinfo)) - (format #t "~a\n~a\n" - (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0))) + + (let-values (((uri compression file-size) (select-uri narinfo))) + (format #t "~a\n~a\n" + (or file-size 0) + (or (narinfo-size narinfo) 0)))) (define* (process-query command #:key cache-urls acl) @@ -947,17 +960,73 @@ authorized substitutes." (wtf (error "unknown `--query' command" wtf)))) +(define %compression-methods + ;; Known compression methods and a thunk to determine whether they're + ;; supported. See 'decompressed-port' in (guix utils). + `(("gzip" . ,(const #t)) + ("lzip" . ,lzlib-available?) + ("xz" . ,(const #t)) + ("bzip2" . ,(const #t)) + ("none" . ,(const #t)))) + +(define (supported-compression? compression) + "Return true if COMPRESSION, a string, denotes a supported compression +method." + (match (assoc-ref %compression-methods compression) + (#f #f) + (supported? (supported?)))) + +(define (compresses-better? compression1 compression2) + "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; +this is a rough approximation." + (match compression1 + ("none" #f) + ("gzip" (string=? compression2 "none")) + (_ (or (string=? compression2 "none") + (string=? compression2 "gzip"))))) + +(define (select-uri narinfo) + "Select the \"best\" URI to download NARINFO's nar, and return three values: +the URI, its compression method (a string), and the compressed file size." + (define choices + (filter (match-lambda + ((uri compression file-size) + (supported-compression? compression))) + (zip (narinfo-uris narinfo) + (narinfo-compressions narinfo) + (narinfo-file-sizes narinfo)))) + + (define (file-size acl))) - (uri (and=> narinfo narinfo-uri))) - (unless uri - (leave (G_ "no valid substitute for '~a'~%") - store-item)) + (define narinfo + (lookup-narinfo cache-urls store-item + (cut valid-narinfo? <> acl))) + + (unless narinfo + (leave (G_ "no valid substitute for '~a'~%") + store-item)) + (let-values (((uri compression file-size) + (select-uri narinfo))) ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) @@ -971,9 +1040,8 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; DOWNLOAD-SIZE is #f in practice. (fetch uri #:buffered? #f #:timeout? #f)) ((progress) - (let* ((comp (narinfo-compression narinfo)) - (dl-size (or download-size - (and (equal? comp "none") + (let* ((dl-size (or download-size + (and (equal? compression "none") (narinfo-size narinfo)))) (reporter (if print-build-trace? (progress-reporter/trace @@ -989,8 +1057,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; NOTE: This 'progress' port of current process will be ;; closed here, while the child process doing the ;; reporting will close it upon exit. - (decompressed-port (and=> (narinfo-compression narinfo) - string->symbol) + (decompressed-port (string->symbol compression) progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 78b8674e0c..1701772bc1 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -175,7 +175,10 @@ about the derivations queued, as is the case with Hydra." (requested (length items)) (missing (lset-difference string=? items (map narinfo-path narinfos))) - (sizes (filter-map narinfo-file-size narinfos)) + (sizes (append-map (lambda (narinfo) + (filter integer? + (narinfo-file-sizes narinfo))) + narinfos)) (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) (format #t (G_ " ~2,1f% substitutes available (~h out of ~h)~%") diff --git a/tests/substitute.scm b/tests/substitute.scm index f4f2e9512d..ff2be662be 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -28,8 +28,10 @@ #:use-module (guix base32) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) + #:use-module ((guix utils) #:select (call-with-compressed-output-port)) + #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module ((guix build utils) - #:select (mkdir-p delete-file-recursively)) + #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) @@ -475,6 +477,53 @@ System: mips64el-linux\n") "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") "substitute-retrieved")))) +(test-equal "substitute, narinfo with several URLs" + "Substitutable data." + (let ((narinfo (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +URL: example.nar.gz +Compression: gzip +URL: example.nar.lz +Compression: lzip +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string + (sha256 (string->utf8 "Substitutable data."))) " +NarSize: 42 +References: bar baz +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n"))) + (with-narinfo (string-append narinfo "Signature: " + (signature-field narinfo)) + (dynamic-wind + (const #t) + (lambda () + (define (compress input output compression) + (call-with-output-file output + (lambda (port) + (call-with-compressed-output-port compression port + (lambda (port) + (call-with-input-file input + (lambda (input) + (dump-port input port)))))))) + + (let ((nar (string-append %main-substitute-directory + "/example.nar"))) + (compress nar (string-append nar ".gz") 'gzip) + (when (lzlib-available?) + (compress nar (string-append nar ".lz") 'lzip))) + + (parameterize ((substitute-urls + (list (string-append "file://" + %main-substitute-directory)))) + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "substitute-retrieved")) + (call-with-input-file "substitute-retrieved" get-string-all)) + (lambda () + (false-if-exception (delete-file "substitute-retrieved"))))))) + (test-end "substitute") ;;; Local Variables: -- cgit v1.2.3 From bcb7c900cc9d01603fb8fa47bc52caa8e7ebd480 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 5 Jun 2019 17:33:37 +0200 Subject: guix package: Do not list environment variables that need to be set. Fixes . * guix/scripts/package.scm (display-search-paths): Rename to... (display-search-path-hint): ... this. Adjust callers. Remove #:kind parameter. Replace the list of environment variables with an invitation to source $GUIX_PROFILE/etc/profile or run 'guix package --search-paths'. --- guix/scripts/package.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 06e4cf5b9c..5751123525 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -57,7 +57,6 @@ #:export (build-and-use-profile delete-generations delete-matching-generations - display-search-paths guix-package (%options . %package-options) @@ -169,8 +168,7 @@ hooks\" run when building the profile." "~a packages in profile~%" count) count) - (display-search-paths entries (list profile) - #:kind 'prefix))) + (display-search-path-hint entries profile))) (warn-about-disk-space profile)))))) @@ -289,17 +287,23 @@ symlinks like 'canonicalize-path' would do." file (string-append (getcwd) "/" file))) -(define* (display-search-paths entries profiles - #:key (kind 'exact)) - "Display the search path environment variables that may need to be set for -ENTRIES, a list of manifest entries, in the context of PROFILE." - (let* ((profiles (map (compose user-friendly-profile absolutize) - profiles)) - (settings (search-path-environment-variables entries profiles - #:kind kind))) +(define (display-search-path-hint entries profile) + "Display a hint on how to set environment variables to use ENTRIES, a list +of manifest entries, in the context of PROFILE." + (let* ((profile (user-friendly-profile (absolutize profile))) + (settings (search-path-environment-variables entries (list profile) + #:kind 'prefix))) (unless (null? settings) - (format #t (G_ "The following environment variable definitions may be needed:~%")) - (format #t "~{ ~a~%~}" settings)))) + (display-hint (format #f (G_ "Consider setting the necessary environment +variables by running: + +@example +GUIX_PROFILE=\"~a\" +. \"$GUIX_PROFILE/etc/profile\" +@end example + +Alternately, see @command{guix package --search-paths -p ~s}.") + profile profile))))) ;;; -- cgit v1.2.3 From b7178c22bf642919345095aff9e34e02c00d5762 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 16:23:01 +0200 Subject: syscalls: Add 'with-file-lock' macro. * guix/scripts/offload.scm (lock-file, unlock-file, with-file-lock): Move to... * guix/build/syscalls.scm: ... here. --- .dir-locals.el | 2 ++ guix/build/syscalls.scm | 27 +++++++++++++++++++++++++++ guix/scripts/offload.scm | 25 ------------------------- 3 files changed, 29 insertions(+), 25 deletions(-) (limited to 'guix/scripts') diff --git a/.dir-locals.el b/.dir-locals.el index f1196fd781..228685a69f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -34,6 +34,8 @@ (eval . (put 'modify-services 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) + (eval . (put 'with-file-lock 'scheme-indent-function 1)) + (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) (eval . (put 'build-system 'scheme-indent-function 0)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3abe65bc4f..04fbebb8a2 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -81,7 +81,11 @@ fdatasync pivot-root scandir* + fcntl-flock + lock-file + unlock-file + with-file-lock set-thread-name thread-name @@ -1067,6 +1071,29 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) +(define (lock-file file) + "Wait and acquire an exclusive lock on FILE. Return an open port." + (let ((port (open-file file "w0"))) + (fcntl-flock port 'write-lock) + port)) + +(define (unlock-file port) + "Unlock PORT, a port returned by 'lock-file'." + (fcntl-flock port 'unlock) + (close-port port) + #t) + +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (let ((port (lock-file file))) + (dynamic-wind + (lambda () + #t) + (lambda () + exp ...) + (lambda () + (unlock-file port))))) + ;;; ;;; Miscellaneous, aka. 'prctl'. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index eb02672dbf..0c0dd9d516 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -236,30 +236,6 @@ instead of '~a' of type '~a'~%") ;;; Synchronization. ;;; -(define (lock-file file) - "Wait and acquire an exclusive lock on FILE. Return an open port." - (mkdir-p (dirname file)) - (let ((port (open-file file "w0"))) - (fcntl-flock port 'write-lock) - port)) - -(define (unlock-file lock) - "Unlock LOCK." - (fcntl-flock lock 'unlock) - (close-port lock) - #t) - -(define-syntax-rule (with-file-lock file exp ...) - "Wait to acquire a lock on FILE and evaluate EXP in that context." - (let ((port (lock-file file))) - (dynamic-wind - (lambda () - #t) - (lambda () - exp ...) - (lambda () - (unlock-file port))))) - (define (machine-slot-file machine slot) "Return the file name of MACHINE's file for SLOT." ;; For each machine we have a bunch of files representing each build slot. @@ -829,7 +805,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: -;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 2) ;;; End: -- 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 'guix/scripts') 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 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - "hello world" + '("hello world" "hi!") (marionette-eval `(begin (define slurp @@ -117,12 +117,16 @@ inside %DOCKER-OS." (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 @@ standard output device and then enters a new line.") (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 @@ (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 @@ #: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 @@ dependencies are registered." #:key target (profile-name "guix-profile") deduplicate? + entry-point (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -275,6 +276,10 @@ added to the pack." (_ #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 @@ added to the pack." #:key target (profile-name "guix-profile") (compressor (first %compressors)) + entry-point localstatedir? (symlinks '()) (archiver squashfs-tools-next)) @@ -315,6 +321,7 @@ added to the pack." (ice-9 match)) (define database #+database) + (define entry-point #$entry-point) (setenv "PATH" (string-append #$archiver "/bin")) @@ -371,6 +378,28 @@ added to the pack." 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 @@ added to the pack." #:key target (profile-name "guix-profile") (compressor (first %compressors)) + entry-point localstatedir? (symlinks '()) (archiver tar)) @@ -425,6 +455,8 @@ the image." #$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 @@ please email '~a'~%") (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 @@ Create a bundle of PACKAGE.\n")) -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 @@ Create a bundle of PACKAGE.\n")) (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 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:entry-point + entry-point #:profile-name profile-name #:archiver -- cgit v1.2.3 From c5f66d29311031d59424dd470ae6c3a315a79712 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 23:16:47 +0200 Subject: pack: Fix 'guix pack -f docker'. Regression introduced in a0f352b30f4869a7af7017b8a5011ac7602dd115. * guix/scripts/pack.scm (docker-image): Check whether ENTRY-POINT is true before returning (string-append #$profile ...). --- guix/scripts/pack.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 5da23e038b..c90b777222 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -455,8 +455,9 @@ the image." #$profile #:database #+database #:system (or #$target (utsname:machine (uname))) - #:entry-point (string-append #$profile "/" - #$entry-point) + #:entry-point #$(and entry-point + #~(string-append #$profile "/" + #$entry-point)) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) -- cgit v1.2.3