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') 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 7fcb86da2b1923a9f7d3cd04ce922632f52af5a0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 May 2019 01:33:39 +0200 Subject: store: Fix 'hash-part->path' docstring. * guix/store.scm (hash-part->path): Adjust docstring to match reality. --- guix/store.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 5c6e4e0ca6..738c0fb5f3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -980,7 +980,7 @@ store directory (/gnu/store)." store-path))) (lambda (server hash-part) "Return the store path whose hash part is HASH-PART (a nix-base32 -string). Raise an error if no such path exists." +string). Return the empty string if no such path exists." ;; This RPC is primarily used by Hydra to reply to HTTP GETs of ;; /HASH.narinfo. (query-path-from-hash-part server hash-part)))) -- cgit v1.2.3 From 0607f890888d1212ed1005c067bab3e4b9759812 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sat, 25 May 2019 22:09:51 +0200 Subject: import: hackage: Recognize "BSD-3-Clause" and "PublicDomain". * guix/import/hackage.scm (string->license): Add two licenses. Signed-off-by: Marius Bakke --- guix/import/hackage.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2a51420d14..2731b4cbee 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -145,10 +145,12 @@ version." ("LGPL" "'lgpl??") ("BSD2" 'bsd-2) ("BSD3" 'bsd-3) + ("BSD-3-Clause" 'bsd-3) ("MIT" 'expat) ("ISC" 'isc) ("MPL" 'mpl2.0) ("Apache-2.0" 'asl2.0) + ("PublicDomain" 'public-domain) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) (_ #f))) -- cgit v1.2.3 From dfc69e4b6d4bbc41a4d37b3cc6ea12adb34aaafa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 May 2019 22:01:42 +0200 Subject: self: 'guix-daemon' honors %localstatedir, %sysconfdir, and %storedir. Fixes . Reported by Ricardo Wurmus . Previously, the 'guix-daemon' program provided by 'guix pull' would systematically use default directory locations for these. * guix/self.scm (whole-package)[wrap]: Set GUIX_STATE_DIRECTORY, GUIX_CONFIGURATION_DIRECTORY, and NIX_STORE_DIR. --- guix/self.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 6d7569ec19..8cc82de64c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -603,7 +603,21 @@ Info manual." (define (wrap daemon) (program-file "guix-daemon" #~(begin + ;; Refer to the right 'guix' command for 'guix + ;; substitute' & co. (setenv "GUIX" #$command) + + ;; Honor the user's settings rather than those hardcoded + ;; in the 'guix-daemon' package. + (unless (getenv "GUIX_STATE_DIRECTORY") + (setenv "GUIX_STATE_DIRECTORY" + #$(string-append %localstatedir "/guix"))) + (unless (getenv "GUIX_CONFIGURATION_DIRECTORY") + (setenv "GUIX_CONFIGURATION_DIRECTORY" + #$(string-append %sysconfdir "/guix"))) + (unless (getenv "NIX_STORE_DIR") + (setenv "NIX_STORE_DIR" %storedir)) + (apply execl #$(file-append daemon "/bin/guix-daemon") "guix-daemon" (cdr (command-line)))))) -- cgit v1.2.3 From 002d17dcaacba0f86265b34f2509419d9e21224d Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sat, 25 May 2019 08:40:38 +0200 Subject: discovery: 'all-modules' returns modules in path order. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A particular effect of this is that if there are ambiguous packages in a directory specified with `-L module_dir` and the distribution, the version from `module_dir` will be loaded, which is usually what would be expected. (E.g. for `guix build` or `guix package -i`.) * guix/discovery.scm (all-modules): Return modules in path order. * tests/guix-package.sh: Test local definitions take precedence. Signed-off-by: Ludovic Courtès --- guix/discovery.scm | 4 ++-- tests/guix-package.sh | 14 ++++++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/discovery.scm b/guix/discovery.scm index ef5ae73973..5bb494941b 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -145,8 +145,8 @@ Call (PROC MODULE RESULT) for each module that is found." "Return the list of package modules found in PATH, a list of directories to search. Entries in PATH can be directory names (strings) or (DIRECTORY . SUB-DIRECTORY) pairs, in which case modules are searched for beneath -SUB-DIRECTORY." - (fold-modules cons '() path #:warn warn)) +SUB-DIRECTORY. Modules are listed in the order they appear on the path." + (reverse (fold-modules cons '() path #:warn warn))) (define (fold-module-public-variables* proc init modules) "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES, diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 767c3f8a66..79d6ec65e4 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -280,6 +280,20 @@ export GUIX_PACKAGE_PATH guix package -A emacs-foo-bar | grep 42 guix package -i emacs-foo-bar@42 -n +# Make sure GUIX_PACKAGE_PATH/'-L' takes precedence in case of duplicate packages. +cat > "$module_dir/bar.scm"<&1 | grep choosing.*bar.scm +( unset GUIX_PACKAGE_PATH; \ + guix package -i hello -n -L "$module_dir" 2>&1 | grep choosing.*bar.scm ) + # Make sure patches that live under $GUIX_PACKAGE_PATH are found. cat > "$module_dir/emacs.patch"< Date: Sun, 26 May 2019 23:18:21 +0200 Subject: import: hackage: Fix Cabal test. * guix/import/hackage.scm (hackage->guix-package): Remove call to 'memoize'. (hackage->guix-package/m): New procedure. (hackage-recursive-import): Use it. * tests/hackage.scm ("hackage->guix-package test 6"): Adjust. Co-authored-by: Robert Vollmert --- guix/import/hackage.scm | 32 +++++++++++++++++--------------- tests/hackage.scm | 37 +++++++++++++++++++++++++++++++++++-- 2 files changed, 52 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2731b4cbee..bf7e99df18 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -279,13 +279,11 @@ representation of a Cabal file as produced by 'read-cabal'." (license ,(string->license (cabal-package-license cabal)))) (append hackage-dependencies hackage-native-dependencies)))) -(define hackage->guix-package - (memoize - (lambda* (package-name #:key - (include-test-dependencies? #t) - (port #f) - (cabal-environment '())) - "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the +(define* (hackage->guix-package package-name #:key + (include-test-dependencies? #t) + (port #f) + (cabal-environment '())) + "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the called with keyword parameter PORT, from PORT. Return the `package' S-expression corresponding to that package, or #f on failure. CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal @@ -295,18 +293,22 @@ symbol 'true' or 'false'. The value associated with other keys has to conform to the Cabal file format definition. The default value associated with the keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" respectively." - (let ((cabal-meta (if port - (read-cabal (canonical-newline-port port)) - (hackage-fetch package-name)))) - (and=> cabal-meta (compose (cut hackage-module->sexp <> - #:include-test-dependencies? - include-test-dependencies?) - (cut eval-cabal <> cabal-environment))))))) + (let ((cabal-meta (if port + (read-cabal (canonical-newline-port port)) + (hackage-fetch package-name)))) + (and=> cabal-meta (compose (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?) + (cut eval-cabal <> cabal-environment))))) + +(define hackage->guix-package/m ;memoized variant + (memoize hackage->guix-package)) (define* (hackage-recursive-import package-name . args) (recursive-import package-name #f #:repo->guix-package (lambda (name repo) - (apply hackage->guix-package (cons name args))) + (apply hackage->guix-package/m + (cons name args))) #:guix-name hackage-name->package-name)) (define (hackage-package? package) diff --git a/tests/hackage.scm b/tests/hackage.scm index e17851a213..0efad0638d 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -207,8 +207,41 @@ library #:cabal-environment '(("impl" . "ghc-7.8")))) (test-assert "hackage->guix-package test 6" - (eval-test-with-cabal test-cabal-6 - #:cabal-environment '(("impl" . "ghc-7.8")))) + (mock + ((guix import hackage) hackage-fetch + (lambda (name-version) + (call-with-input-string test-cabal-6 + read-cabal))) + (match (hackage->guix-package "foo") + (('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-b" ('unquote 'ghc-b)) + ("ghc-http" ('unquote 'ghc-http)) + ("ghc-mtl" ('unquote 'ghc-mtl))))) + ('native-inputs + ('quasiquote + (("ghc-haskell-gi" ('unquote 'ghc-haskell-gi))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'bsd-3)) + #t) + (x + (pk 'fail x #f))))) (test-assert "read-cabal test 1" (match (call-with-input-string test-read-cabal-1 read-cabal) -- cgit v1.2.3 From e13354a7ca5a0d5e28e02c4cfce6fecb1ab770e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 May 2019 22:27:02 +0200 Subject: lzlib: Adjust 'lz-compress-read' docstring. * guix/lzlib.scm (lz-compress-read): The integer return can be zero; adjust docstring accordingly. --- guix/lzlib.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lzlib.scm b/guix/lzlib.scm index a6dac46049..deb900f352 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -168,7 +168,7 @@ so use it only when needed. " (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int)))) (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv))) "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV. -Return the number of uncompressed bytes written, a strictly positive integer." +Return the number of uncompressed bytes written, a positive integer." (let ((ret (proc (lz-encoder->pointer encoder) (bytevector->pointer lzfile-bv start) count))) -- cgit v1.2.3 From 2a991f3ae4823730395c7970d83159e93d5f5fe2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 May 2019 21:35:47 +0200 Subject: lzlib: Add 'make-lzip-input-port/compressed'. * guix/lzlib.scm (lzwrite!, make-lzip-input-port/compressed): New procedures. * tests/lzlib.scm ("make-lzip-input-port/compressed"): New test. * guix/tests.scm (%seed): Export. --- guix/lzlib.scm | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/tests.scm | 1 + tests/lzlib.scm | 10 ++++++++ 3 files changed, 82 insertions(+) (limited to 'guix') diff --git a/guix/lzlib.scm b/guix/lzlib.scm index deb900f352..a484315c0e 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Pierre Neidhardt +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,9 +24,11 @@ #:use-module (ice-9 match) #:use-module (system foreign) #:use-module (guix config) + #:use-module (srfi srfi-11) #:export (lzlib-available? make-lzip-input-port make-lzip-output-port + make-lzip-input-port/compressed call-with-lzip-input-port call-with-lzip-output-port %default-member-length-limit @@ -515,6 +518,24 @@ the end-of-stream has been reached." (loop rd))) read)) +(define (lzwrite! encoder source source-offset source-count + target target-offset target-count) + "Write up to SOURCE-COUNT bytes from SOURCE to ENCODER, and read up to +TARGET-COUNT bytes into TARGET at TARGET-OFFSET. Return two values: the +number of bytes read from SOURCE, and the number of bytes written to TARGET, +possibly zero." + (define read + (if (> (lz-compress-write-size encoder) 0) + (match (lz-compress-write encoder source source-offset source-count) + (0 (lz-compress-finish encoder) 0) + (n n)) + 0)) + + (define written + (lz-compress-read encoder target target-offset target-count)) + + (values read written)) + (define* (lzwrite encoder bv lz-port #:optional (start 0) (count (bytevector-length bv))) "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return @@ -597,6 +618,56 @@ port is closed." (lz-compress-close encoder) (close-port port)))) +(define* (make-lzip-input-port/compressed port + #:key + (level %default-compression-level)) + "Return an input port that compresses data read from PORT, with the given LEVEL. +PORT is automatically closed when the resulting port is closed." + (define encoder (apply lz-compress-open + (car (assoc-ref %compression-levels level)))) + + (define input-buffer (make-bytevector 8192)) + (define input-len 0) + (define input-offset 0) + + (define input-eof? #f) + + (define (read! bv start count) + (cond + (input-eof? + (match (lz-compress-read encoder bv start count) + (0 (if (lz-compress-finished? encoder) + 0 + (read! bv start count))) + (n n))) + ((= input-offset input-len) + (match (get-bytevector-n! port input-buffer 0 + (bytevector-length input-buffer)) + ((? eof-object?) + (set! input-eof? #t) + (lz-compress-finish encoder)) + (count + (set! input-offset 0) + (set! input-len count))) + (read! bv start count)) + (else + (let-values (((read written) + (lzwrite! encoder + input-buffer input-offset + (- input-len input-offset) + bv start count))) + (set! input-offset (+ input-offset read)) + + ;; Make sure we don't return zero except on EOF. + (if (= 0 written) + (read! bv start count) + written))))) + + (make-custom-binary-input-port "lzip-input/compressed" + read! #f #f + (lambda () + (close-port port)))) + (define* (call-with-lzip-input-port port proc) "Call PROC with a port that wraps PORT and decompresses data read from it. PORT is closed upon completion." diff --git a/guix/tests.scm b/guix/tests.scm index 35ebf8464d..66d60e964e 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -33,6 +33,7 @@ #:use-module (web uri) #:export (open-connection-for-tests with-external-store + %seed random-text random-bytevector file=? diff --git a/tests/lzlib.scm b/tests/lzlib.scm index cf53a9417d..543622bb45 100644 --- a/tests/lzlib.scm +++ b/tests/lzlib.scm @@ -108,4 +108,14 @@ (test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)" (compress-and-decompress (random-bytevector (1+ (* 1024 1024))))) +(test-assert "make-lzip-input-port/compressed" + (let* ((len (pk 'len (+ 10 (random 4000 %seed)))) + (data (random-bytevector len)) + (compressed (make-lzip-input-port/compressed + (open-bytevector-input-port data))) + (result (call-with-lzip-input-port compressed + get-bytevector-all))) + (pk (bytevector-length result) (bytevector-length data)) + (bytevector=? result data))) + (test-end) -- cgit v1.2.3 From 4e48923e7523c863996bb616c6abb7e4cb78a3b5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 May 2019 22:14:53 +0200 Subject: utils: Support compression and decompression with lzip. * guix/utils.scm (lzip-port): New procedure. (decompressed-port, compressed-port, compressed-output-port): Add 'lzip case. * tests/utils.scm : Call 'test-compression/decompression' for 'lzip as well. --- guix/utils.scm | 27 ++++++++++++++++++++++----- tests/utils.scm | 3 ++- 2 files changed, 24 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index ed1a418cca..709cdf9353 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2014 Ian Denhardt @@ -169,6 +169,17 @@ buffered data is lost." (close-port out) (loop in (cons child pids))))))))) +(define (lzip-port proc port . args) + "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. +Raise an error if lzlib support is missing." + (let* ((lzlib (false-if-exception (resolve-interface '(guix lzlib)))) + (supported? (and lzlib + ((module-ref lzlib 'lzlib-available?))))) + (if supported? + (let ((make-port (module-ref lzlib proc))) + (values (make-port port) '())) + (error "lzip compression not supported" lzlib)))) + (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, a symbol such as 'xz." @@ -177,17 +188,21 @@ a symbol such as 'xz." ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) ('xz (filtered-port `(,%xz "-dc") input)) ('gzip (filtered-port `(,%gzip "-dc") input)) - (else (error "unsupported compression scheme" compression)))) + ('lzip (values (lzip-port 'make-lzip-input-port input) + '())) + (_ (error "unsupported compression scheme" compression)))) (define (compressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION, + "Return an input port where INPUT is compressed according to COMPRESSION, a symbol such as 'xz." (match compression ((or #f 'none) (values input '())) ('bzip2 (filtered-port `(,%bzip2 "-c") input)) ('xz (filtered-port `(,%xz "-c") input)) ('gzip (filtered-port `(,%gzip "-c") input)) - (else (error "unsupported compression scheme" compression)))) + ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + '())) + (_ (error "unsupported compression scheme" compression)))) (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data @@ -244,7 +259,9 @@ program--e.g., '(\"--fast\")." ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output)) ('xz (filtered-output-port `(,%xz "-c" ,@options) output)) ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) - (else (error "unsupported compression scheme" compression)))) + ('lzip (values (lzip-port 'make-lzip-output-port output) + '())) + (_ (error "unsupported compression scheme" compression)))) (define* (call-with-compressed-output-port compression port proc #:key (options '())) diff --git a/tests/utils.scm b/tests/utils.scm index a5141592a8..44861384ab 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -23,6 +23,7 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix search-paths) #:select (string-tokenize*)) + #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -214,7 +215,7 @@ skip these tests." (for-each test-compression/decompression '(gzip xz lzip) - (list (const #t) (const #t))) + (list (const #t) (const #t) lzlib-available?)) ;; This is actually in (guix store). (test-equal "store-path-package-name" -- 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') 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 73ac9098b17e515ab1215c3ada2b3b0c9fb5b28c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 May 2019 10:28:34 +0200 Subject: self: Add dependency on lzlib. * guix/self.scm (compiled-guix): Pass #:lzlib to 'make-config.scm'. (make-config.scm): Add #:lzlib and honor it. (specification->package): Add "lzlib". --- guix/self.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 8cc82de64c..b7d8f4ee91 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -57,6 +57,7 @@ ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'gnutls)) ("zlib" (ref '(gnu packages compression) 'zlib)) + ("lzlib" (ref '(gnu packages compression) 'lzlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) @@ -660,6 +661,7 @@ Info manual." (guile-version (effective-version)) (guile-for-build (default-guile)) (zlib (specification->package "zlib")) + (lzlib (specification->package "lzlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) (xz (specification->package "xz")) @@ -814,6 +816,7 @@ Info manual." #:extra-modules `(((guix config) => ,(make-config.scm #:zlib zlib + #:lzlib lzlib #:gzip gzip #:bzip2 bzip2 #:xz xz @@ -911,7 +914,7 @@ Info manual." (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir))) -(define* (make-config.scm #:key zlib gzip xz bzip2 +(define* (make-config.scm #:key zlib lzlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -933,7 +936,7 @@ Info manual." %store-database-directory %config-directory %libz - ;; TODO: %liblz + %liblz %gzip %bzip2 %xz)) @@ -980,7 +983,11 @@ Info manual." (define %libz #+(and zlib - (file-append zlib "/lib/libz")))) + (file-append zlib "/lib/libz"))) + + (define %liblz + #+(and lzlib + (file-append lzlib "/lib/liblz")))) ;; Guile 2.0 *requires* the 'define-module' to be at the ;; top-level or the 'toplevel-ref' in the resulting .go file are -- cgit v1.2.3 From c131bea2762ea0dd9e75e9340525dc54cd938647 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 May 2019 15:20:46 +0200 Subject: lzlib: 'lzread!' never returns more than it was asked for. Fixes a bug whereby 'lzread!' could return more than COUNT. * guix/lzlib.scm (lzread!): Rewrite in a semi-functional style. --- guix/lzlib.scm | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/lzlib.scm b/guix/lzlib.scm index a484315c0e..31d84971cb 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -494,29 +494,28 @@ perhaps not yet read." ;; High level functions. -(define* (lzread! decoder file-port bv + +(define* (lzread! decoder port bv #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from FILE-PORT into BV at offset START. Return the + "Read up to COUNT bytes from PORT into BV at offset START. Return the number of uncompressed bytes actually read; it is zero if COUNT is zero or if the end-of-stream has been reached." - ;; WARNING: Because we don't alternate between lz-reads and lz-writes, we can't - ;; process more than lz-decompress-write-size from the file-port. - (when (> count (lz-decompress-write-size decoder)) - (set! count (lz-decompress-write-size decoder))) - (let ((file-bv (get-bytevector-n file-port count))) - (unless (eof-object? file-bv) - (lz-decompress-write decoder file-bv 0 (bytevector-length file-bv)))) - (let ((read 0)) - (let loop ((rd 0)) - (if (< start (bytevector-length bv)) - (begin - (set! rd (lz-decompress-read decoder bv start (- (bytevector-length bv) start))) - (set! start (+ start rd)) - (set! read (+ read rd))) - (set! rd 0)) - (unless (= rd 0) - (loop rd))) - read)) + (define (feed-decoder! decoder) + ;; Feed DECODER with data read from PORT. + (match (get-bytevector-n port (lz-decompress-write-size decoder)) + ((? eof-object? eof) eof) + (bv (lz-decompress-write decoder bv)))) + + (let loop ((read 0) + (start start)) + (cond ((< read count) + (match (lz-decompress-read decoder bv start (- count read)) + (0 (if (eof-object? (feed-decoder! decoder)) + read + (loop read start))) + (n (loop (+ read n) (+ start n))))) + (else + read)))) (define (lzwrite! encoder source source-offset source-count target target-offset target-count) -- 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') 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 fa866548244e3a8ad65a19c40cb0d6f2c669cc6b Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 28 May 2019 23:21:27 +0200 Subject: self: Fix unquoting. This is a follow-up to commit dfc69e4b6d4bbc41a4d37b3cc6ea12adb34aaafa. * guix/self.scm (whole-package): Unquote %storedir in the daemon wrapper. --- guix/self.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index b7d8f4ee91..69e2381a8c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -617,7 +617,7 @@ Info manual." (setenv "GUIX_CONFIGURATION_DIRECTORY" #$(string-append %sysconfdir "/guix"))) (unless (getenv "NIX_STORE_DIR") - (setenv "NIX_STORE_DIR" %storedir)) + (setenv "NIX_STORE_DIR" #$%storedir)) (apply execl #$(file-append daemon "/bin/guix-daemon") "guix-daemon" (cdr (command-line)))))) -- cgit v1.2.3 From 531940d388b08318edbf243e3e5008288b1eb60e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 28 May 2019 23:56:59 +0200 Subject: import: cran: Ignore invalid packages from the system requirements. * guix/import/cran.scm (description->package): Filter invalid packages from the list of system requirements. --- guix/import/cran.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 4763fccd36..3240094444 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -313,7 +313,9 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (tarball (download source-url)) (sysdepends (append (if (needs-zlib? tarball) '("zlib") '()) - (map string-downcase (listify meta "SystemRequirements")))) + (filter (lambda (name) + (not (member name invalid-packages))) + (map string-downcase (listify meta "SystemRequirements"))))) (propagate (filter (lambda (name) (not (member name (append default-r-packages invalid-packages)))) -- 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') 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') 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 1cc12357a65e4479c2f4735e915941382ef82d94 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sat, 25 May 2019 22:11:02 +0200 Subject: import: hackage: Update list of ghc-included packages. Update the list of excepted dependencies for current ghc-8.4, based on the release notes at https://downloads.haskell.org/~ghc/8.4.3/docs/html/users_guide/8.4.3-notes.html Particularly, this adds `text` to the list, which is a dependency of `parsec` which was already on the list before, causing build failures with updated versions of the `text` package. * guix/import/hackage.scm (ghc-standard-libraries): Update list. Signed-off-by: Ricardo Wurmus --- guix/import/hackage.scm | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index bf7e99df18..366256b40d 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -51,34 +51,35 @@ hackage-package?)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as - ;; some packages list it. - '("array" + ;; List of libraries distributed with ghc (8.4.3). + ;; https://downloads.haskell.org/~ghc/8.4.3/docs/html/users_guide/8.4.3-notes.html + '("ghc" + "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but + ;; hackage-name->package-name takes this into account. + "win32" ;; similarly uppercased + "array" "base" - "bin-package-db" "binary" "bytestring" - "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but - ;; hackage-name->package-name takes this into account. "containers" "deepseq" "directory" "filepath" - "ghc" + "ghc-boot" + "ghc-compact" "ghc-prim" + "ghci" "haskeline" - "hoopl" "hpc" "integer-gmp" - "pretty" + "mtl" + "parsec" "process" - "rts" "template-haskell" - "terminfo" + "text" "time" "transformers" "unix" - "win32" "xhtml")) (define package-name-prefix "ghc-") -- cgit v1.2.3 From 87399dfc209fdec523947e7b45a1ad348afa4d46 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 1 Jun 2019 11:38:33 +0200 Subject: lzlib: 'make-lzip-input-port' better handles end of decompression. Suggested by Pierre Neidhardt . * guix/lzlib.scm (lzread!): Call 'lz-decompress-finish' when 'feed-decoder!' returns EOF. Call 'lz-decompress-finished?' to determine end of compression. --- guix/lzlib.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/lzlib.scm b/guix/lzlib.scm index 31d84971cb..24c7b4b448 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -510,9 +510,13 @@ the end-of-stream has been reached." (start start)) (cond ((< read count) (match (lz-decompress-read decoder bv start (- count read)) - (0 (if (eof-object? (feed-decoder! decoder)) - read - (loop read start))) + (0 (cond ((lz-decompress-finished? decoder) + read) + ((eof-object? (feed-decoder! decoder)) + (lz-decompress-finish decoder) + (loop read start)) + (else ;read again + (loop read start)))) (n (loop (+ read n) (+ start n))))) (else read)))) -- cgit v1.2.3 From 88bc3c89bf5145d24c2270d2192b7be547e0024f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 01:29:38 +0200 Subject: progress: Provide the proper type for %PROGRESS-INTERVAL. The (srfi srfi-19) module of Guile 2.9.2 catches the wrong type. * guix/progress.scm (%progress-interval): Change type to TIME-DURATION. --- guix/progress.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index 65080bcf24..f150b081d6 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu ;;; Copyright © 2015 Steve Sprang -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. @@ -229,7 +229,7 @@ throughput." (define %progress-interval ;; Default interval between subsequent outputs for rate-limited displays. - (make-time time-monotonic 200000000 0)) + (make-time time-duration 200000000 0)) (define* (progress-reporter/file file size #:optional (log-port (current-output-port)) -- cgit v1.2.3 From b2cddc6fb1df4bbde23149b3a36ac4cdfe1bd535 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 01:32:12 +0200 Subject: compile: Adjust for Guile 3. * guix/build/compile.scm (%default-optimizations): Adjust to the new names in Guile 2.9.2. --- guix/build/compile.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 9e31be93ff..794f12379c 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -40,8 +40,12 @@ (define %default-optimizations ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (append (tree-il-default-optimization-options) - (cps-default-optimization-options))) + (append (if (defined? 'tree-il-default-optimization-options) + (tree-il-default-optimization-options) ;Guile 2.2 + (tree-il-optimizations)) ;Guile 3 + (if (defined? 'cps-default-optimization-options) + (cps-default-optimization-options) ;Guile 2.2 + (cps-optimizations)))) ;Guile 3 (define %lightweight-optimizations ;; Lightweight optimizations (like -O0, but with partial evaluation). -- cgit v1.2.3 From abeb54c00b320f8c3a220f54b6413837f6deac35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 20:57:59 +0200 Subject: build-system/guile: Improve reporting of 'guild compile' failures. * guix/build/guile-build-system.scm (invoke-each)[processes]: New variable. [wait-for-one-process]: Check PROCESSES and update it. [fork-and-run-command]: Update PROCESSES. --- guix/build/guile-build-system.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 31f0d3d6f4..69819c87f1 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,11 +74,19 @@ Raise an error if one of the processes exit with non-zero." (define total (length commands)) + (define processes + (make-hash-table)) + (define (wait-for-one-process) (match (waitpid WAIT_ANY) - ((_ . status) - (unless (zero? (status:exit-val status)) - (error "process failed" status))))) + ((pid . status) + (let ((command (hashv-ref processes pid))) + (hashv-remove! processes command) + (unless (zero? (status:exit-val status)) + (format (current-error-port) + "process '~{~a ~}' failed with status ~a~%" + command status) + (exit 1)))))) (define (fork-and-run-command command) (match (primitive-fork) @@ -90,6 +98,7 @@ Raise an error if one of the processes exit with non-zero." (lambda () (primitive-exit 127)))) (pid + (hashv-set! processes pid command) #t))) (let loop ((commands commands) -- cgit v1.2.3 From 30eb73836684ff8502063c43f3b315174e0d3a0b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 20:59:34 +0200 Subject: build-system/guile: Add #:not-compiled-file-regexp. * guix/build/guile-build-system.scm (build): Add #:not-compiled-file-regexp and honor it. * guix/build-system/guile.scm (guile-build): Likewise. (guile-cross-build): Likewise. --- guix/build-system/guile.scm | 6 +++++- guix/build/guile-build-system.scm | 30 +++++++++++++++++++----------- 2 files changed, 24 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 77a5f00b01..2c5cc968ce 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,6 +75,7 @@ (search-paths '()) (system (%current-system)) (source-directory ".") + not-compiled-file-regexp (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) @@ -92,6 +93,7 @@ (source source)) #:source-directory ,source-directory + #:not-compiled-file-regexp ,not-compiled-file-regexp #:compile-flags ,compile-flags #:phases ,phases #:system ,system @@ -128,6 +130,7 @@ (phases '%standard-phases) (source-directory ".") + not-compiled-file-regexp (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) @@ -168,6 +171,7 @@ #:target ,target #:outputs %outputs #:source-directory ,source-directory + #:not-compiled-file-regexp ,not-compiled-file-regexp #:compile-flags ,compile-flags #:inputs %build-target-inputs #:native-inputs %build-host-inputs diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 69819c87f1..eb7a91840e 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -19,10 +19,12 @@ (define-module (guix build guile-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (guix build utils) #:export (target-guile-effective-version %standard-phases @@ -134,9 +136,12 @@ Raise an error if one of the processes exit with non-zero." (source-directory ".") (compile-flags '()) (scheme-file-regexp %scheme-file-regexp) + (not-compiled-file-regexp #f) target #:allow-other-keys) - "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP." + "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP. Files +matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are +installed; this is useful for files that are meant to be included." (let* ((out (assoc-ref outputs "out")) (guile (assoc-ref (or native-inputs inputs) "guile")) (effective (target-guile-effective-version guile)) @@ -171,16 +176,19 @@ Raise an error if one of the processes exit with non-zero." (with-directory-excursion source-directory (find-files "." scheme-file-regexp)))) (invoke-each - (map (lambda (file) - (cons* guild - "guild" "compile" - "-L" source-directory - "-o" (string-append go-dir - (file-sans-extension file) - ".go") - (string-append source-directory "/" file) - flags)) - source-files) + (filter-map (lambda (file) + (and (or (not not-compiled-file-regexp) + (not (string-match not-compiled-file-regexp + file))) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags))) + source-files) #:max-processes (parallel-job-count) #:report-progress report-build-progress) -- cgit v1.2.3 From e006f7493feb35044f4965181c9199d9fdde1843 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Jun 2019 21:07:24 +0200 Subject: build-system/guile: Display progress report as expected by (guix status). * guix/build/guile-build-system.scm (report-build-progress): Use a format string suitable for (guix status). --- guix/build/guile-build-system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index eb7a91840e..32a431d347 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) + #:use-module (ice-9 format) #:use-module (guix build utils) #:export (target-guile-effective-version %standard-phases @@ -128,8 +129,8 @@ Raise an error if one of the processes exit with non-zero." (define* (report-build-progress total completed #:optional (log-port (current-error-port))) "Report that COMPLETED out of TOTAL files have been completed." - (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n - (* 100. (/ completed total)) total) + (format log-port "[~2d/~2d] Compiling...~%" + completed total) (force-output log-port)) (define* (build #:key outputs inputs native-inputs -- 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') 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') 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 959c9d159da2c53b87ae0af1421aecac98b20f46 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sun, 2 Jun 2019 00:27:50 +0200 Subject: import: hackage: Parse braced properties. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds partial support for Cabal properties that use curly braces instead of the layout rule. See for example https://hackage.haskell.org/package/cassava/ * guix/import/cabal.scm (read-braced-value): New procedure. (is-property): Remove. (is-layout-property, is-braced-property): New variables. (lex-property): Rename to... (lex-layout-property): ... this. (lex-braced-property, lex-property): New procedures. (lex-token): Add call to 'lex-property'. * guix/tests/hackage.scm: Test braced description import. * tests/hackage.scm (test-cabal-multiline-desc): Rename to... (test-cabal-multiline-layout): ... this. ("hackage->guix-package test multiline desc"): Rename to... ("hackage->guix-package test multiline desc (layout)"): ... this. (test-cabal-multiline-braced): New variable. ("hackage->guix-package test multiline desc (braced)"): New test. Signed-off-by: Ludovic Courtès --- guix/import/cabal.scm | 35 ++++++++++++++++++++++++++++------- tests/hackage.scm | 25 ++++++++++++++++++++++--- 2 files changed, 50 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 13c2f3f48c..1a87be0b00 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -270,6 +270,10 @@ following lines with indentation larger than MIN-INDENT." (peek-next-line-indent port))) val))) +(define* (read-braced-value port) + "Read up to a closing brace." + (string-trim-both (read-delimited "}" port 'trim))) + (define (lex-white-space port bol) "Consume white spaces and comment lines on PORT. If a new line is started return #t, otherwise return BOL (beginning-of-line)." @@ -343,8 +347,11 @@ matching a string against the created regexp." (make-regexp pat)))) (cut regexp-exec rx <>))) -(define is-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?.*)$" - regexp/icase)) +(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)$" + regexp/icase)) + +(define is-braced-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*\\{[ \t]*$" + regexp/icase)) (define is-flag (make-rx-matcher "^flag +([a-z0-9_-]+)" regexp/icase)) @@ -435,13 +442,19 @@ string with the read characters." (begin (unread-char c) (list->string res))))) (else (list->string res))))) -(define (lex-property k-v-rx-res loc port) +(define (lex-layout-property k-v-rx-res loc port) (let ((key (string-downcase (match:substring k-v-rx-res 1))) (value (match:substring k-v-rx-res 2))) (make-lexical-token 'PROPERTY loc (list key `(,(read-value port value (current-indentation))))))) +(define (lex-braced-property k-rx-res loc port) + (let ((key (string-downcase (match:substring k-rx-res 1)))) + (make-lexical-token + 'PROPERTY loc + (list key `(,(read-braced-value port)))))) + (define (lex-rx-res rx-res token loc) (let ((name (string-downcase (match:substring rx-res 1)))) (make-lexical-token token loc name))) @@ -552,7 +565,6 @@ LOC is the current port location." the current port location." (let* ((s (read-delimited "\n{}" port 'peek))) (cond - ((is-property s) => (cut lex-property <> loc port)) ((is-flag s) => (cut lex-flag <> loc)) ((is-src-repo s) => (cut lex-src-repo <> loc)) ((is-exec s) => (cut lex-exec <> loc)) @@ -561,13 +573,22 @@ the current port location." ((is-benchmark s) => (cut lex-benchmark <> loc)) ((is-lib s) (lex-lib loc)) ((is-else s) (lex-else loc)) - (else - #f)))) + (else (unread-string s port) #f)))) + +(define (lex-property port loc) + (let* ((s (read-delimited "\n" port 'peek))) + (cond + ((is-braced-property s) => (cut lex-braced-property <> loc port)) + ((is-layout-property s) => (cut lex-layout-property <> loc port)) + (else #f)))) (define (lex-token port) (let* ((loc (make-source-location (cabal-file-name) (port-line port) (port-column port) -1 -1))) - (or (lex-single-char port loc) (lex-word port loc) (lex-line port loc)))) + (or (lex-single-char port loc) + (lex-word port loc) + (lex-line port loc) + (lex-property port loc)))) ;; Lexer- and error-function generators diff --git a/tests/hackage.scm b/tests/hackage.scm index 2f45194fab..38a5825af7 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -237,7 +237,7 @@ library (eval-test-with-cabal test-cabal-6 match-ghc-foo-6)) ;; Check multi-line layouted description -(define test-cabal-multiline-desc +(define test-cabal-multiline-layout "name: foo version: 1.0.0 homepage: http://test.org @@ -251,9 +251,28 @@ executable cabal mtl >= 2.0 && < 3 ") -(test-assert "hackage->guix-package test multiline desc" - (eval-test-with-cabal test-cabal-multiline-desc match-ghc-foo)) +(test-assert "hackage->guix-package test multiline desc (layout)" + (eval-test-with-cabal test-cabal-multiline-layout match-ghc-foo)) +;; Check multi-line braced description +(define test-cabal-multiline-braced + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: { +first line +second line +} +license: BSD3 +executable cabal + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +(test-assert "hackage->guix-package test multiline desc (braced)" + (eval-test-with-cabal test-cabal-multiline-braced match-ghc-foo)) (test-assert "read-cabal test 1" (match (call-with-input-string test-read-cabal-1 read-cabal) -- cgit v1.2.3 From 5b315f3ea93020df52bc11105064a1398687e572 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 27 May 2019 22:07:31 +0200 Subject: guix: import: simplify recursive import This simplifies the logic of recursive-import, intending no major functional changes. The package import function is no longer called twice per package. Failed imports now make it to the package stream as '() instead of #f. * guix/import/utils.scm (recursive-import): Simplify. Signed-off-by: Oleg Pykhalov --- guix/import/utils.scm | 87 +++++++++++++++++++-------------------------------- 1 file changed, 33 insertions(+), 54 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 516c0cfaa2..d0dffe9b04 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov +;;; Copyright © 2019 Robert Vollmert ;;; ;;; This file is part of GNU Guix. ;;; @@ -378,57 +379,35 @@ separated by PRED." #:allow-other-keys) "Generate a stream of package expressions for PACKAGE-NAME and all its dependencies." - (receive (package . dependencies) - (repo->guix-package package-name repo) - (if (not package) - stream-null - - ;; Generate a lazy stream of package expressions for all unknown - ;; dependencies in the graph. - (let* ((make-state (lambda (queue done) - (cons queue done))) - (next (match-lambda - (((next . rest) . done) next))) - (imported (match-lambda - ((queue . done) done))) - (done? (match-lambda - ((queue . done) - (zero? (length queue))))) - (unknown? (lambda* (dependency #:optional (done '())) - (and (not (member dependency - done)) - (null? (find-packages-by-name - (guix-name dependency)))))) - (update (lambda (state new-queue) - (match state - (((head . tail) . done) - (make-state (lset-difference - equal? - (lset-union equal? new-queue tail) - done) - (cons head done))))))) - (stream-cons - package - (stream-unfold - ;; map: produce a stream element - (lambda (state) - (repo->guix-package (next state) repo)) - - ;; predicate - (negate done?) - - ;; generator: update the queue - (lambda (state) - (receive (package . dependencies) - (repo->guix-package (next state) repo) - (if package - (update state (filter (cut unknown? <> - (cons (next state) - (imported state))) - (car dependencies))) - ;; TODO: Try the other archives before giving up - (update state (imported state))))) - - ;; initial state - (make-state (filter unknown? (car dependencies)) - (list package-name)))))))) + (define (exists? dependency) + (not (null? (find-packages-by-name (guix-name dependency))))) + (define initial-state (list #f (list package-name) (list))) + (define (step state) + (match state + ((prev (next . rest) done) + (define (handle? dep) + (and + (not (equal? dep next)) + (not (member dep done)) + (not (exists? dep)))) + (receive (package . dependencies) (repo->guix-package next repo) + (list + (if package package '()) ;; default #f on failure would interrupt + (if package + (lset-union equal? rest (filter handle? (car dependencies))) + rest) + (cons next done)))) + ((prev '() done) + (list #f '() done)))) + + ;; Generate a lazy stream of package expressions for all unknown + ;; dependencies in the graph. + (stream-unfold + ;; map: produce a stream element + (match-lambda ((latest queue done) latest)) + ;; predicate + (match-lambda ((latest queue done) latest)) + ;; generator: update the queue + step + ;; initial state + (step initial-state))) -- 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 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index c01eb3a656..a8f3a5ad27 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12232,10 +12232,19 @@ The TCP port to listen for connections. The host (and thus, network interface) to listen to. Use @code{"0.0.0.0"} to listen on all the network interfaces. -@item @code{compression-level} (default: @code{3}) -The gzip compression level at which substitutes are compressed. Use -@code{0} to disable compression altogether, and @code{9} to get the best -compression ratio at the expense of increased CPU usage. +@item @code{compression} (default: @code{'(("gzip" 3))}) +This is a list of compression method/level tuple used when compressing +substitutes. For example, to compress all substitutes with @emph{both} lzip +at level 7 and gzip at level 9, write: + +@example +'(("lzip" 7) ("gzip" 9)) +@end example + +Level 9 achieves the best compression ratio at the expense of increased CPU +usage, whereas level 1 achieves fast compression. + +An empty list disables compression altogether. @item @code{nar-path} (default: @code{"nar"}) The URL path at which ``nars'' can be fetched. @xref{Invoking guix diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f709ca5519..c88a6ddec6 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -142,7 +142,8 @@ guix-publish-configuration-guix guix-publish-configuration-port guix-publish-configuration-host - guix-publish-configuration-compression-level + guix-publish-configuration-compression + guix-publish-configuration-compression-level ;deprecated guix-publish-configuration-nar-path guix-publish-configuration-cache guix-publish-configuration-ttl @@ -1748,8 +1749,12 @@ archive' public keys, with GUIX." (default 80)) (host guix-publish-configuration-host ;string (default "localhost")) - (compression-level guix-publish-configuration-compression-level ;integer - (default 3)) + (compression guix-publish-configuration-compression + (thunked) + (default (default-compression this-record + (current-source-location)))) + (compression-level %guix-publish-configuration-compression-level ;deprecated + (default #f)) (nar-path guix-publish-configuration-nar-path ;string (default "nar")) (cache guix-publish-configuration-cache ;#f | string @@ -1759,42 +1764,68 @@ archive' public keys, with GUIX." (ttl guix-publish-configuration-ttl ;#f | integer (default #f))) -(define guix-publish-shepherd-service - (match-lambda - (($ guix port host compression - nar-path cache workers ttl) - (list (shepherd-service - (provision '(guix-publish)) - (requirement '(guix-daemon)) - (start #~(make-forkexec-constructor - (list #$(file-append guix "/bin/guix") - "publish" "-u" "guix-publish" - "-p" #$(number->string port) - "-C" #$(number->string compression) - (string-append "--nar-path=" #$nar-path) - (string-append "--listen=" #$host) - #$@(if workers - #~((string-append "--workers=" - #$(number->string - workers))) - #~()) - #$@(if ttl - #~((string-append "--ttl=" - #$(number->string ttl) - "s")) - #~()) - #$@(if cache - #~((string-append "--cache=" #$cache)) - #~())) - - ;; Make sure we run in a UTF-8 locale so we can produce - ;; nars for packages that contain UTF-8 file names such - ;; as 'nss-certs'. See . - #:environment-variables - (list (string-append "GUIX_LOCPATH=" - #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8"))) - (stop #~(make-kill-destructor))))))) +(define-deprecated (guix-publish-configuration-compression-level config) + "Return a compression level, the old way." + (match (guix-publish-configuration-compression config) + (((_ level) _ ...) level))) + +(define (default-compression config properties) + "Return the default 'guix publish' compression according to CONFIG, and +raise a deprecation warning if the 'compression-level' field was used." + (match (%guix-publish-configuration-compression-level config) + (#f + '(("gzip" 3))) + (level + (warn-about-deprecation 'compression-level properties + #:replacement 'compression) + `(("gzip" ,level))))) + +(define (guix-publish-shepherd-service config) + (define (config->compression-options config) + (match (guix-publish-configuration-compression config) + (() ;empty list means "no compression" + '("-C0")) + (lst + (append-map (match-lambda + ((type level) + `("-C" ,(string-append type ":" + (number->string level))))) + lst)))) + + (match-record config + (guix port host nar-path cache workers ttl) + (list (shepherd-service + (provision '(guix-publish)) + (requirement '(guix-daemon)) + (start #~(make-forkexec-constructor + (list #$(file-append guix "/bin/guix") + "publish" "-u" "guix-publish" + "-p" #$(number->string port) + #$@(config->compression-options config) + (string-append "--nar-path=" #$nar-path) + (string-append "--listen=" #$host) + #$@(if workers + #~((string-append "--workers=" + #$(number->string + workers))) + #~()) + #$@(if ttl + #~((string-append "--ttl=" + #$(number->string ttl) + "s")) + #~()) + #$@(if cache + #~((string-append "--cache=" #$cache)) + #~())) + + ;; Make sure we run in a UTF-8 locale so we can produce + ;; nars for packages that contain UTF-8 file names such + ;; as 'nss-certs'. See . + #:environment-variables + (list (string-append "GUIX_LOCPATH=" + #$glibc-utf8-locales "/lib/locale") + "LC_ALL=en_US.utf8"))) + (stop #~(make-kill-destructor)))))) (define %guix-publish-accounts (list (user-group (name "guix-publish") (system? #t)) diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 2f7c058940..d704e7ec61 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -21,6 +21,7 @@ #:use-module (ice-9 format) #:export (define-deprecated define-deprecated/alias + warn-about-deprecation deprecation-warning-port)) ;;; Commentary: -- cgit v1.2.3 From 1b5ee3bdaacf665ad1e7c6142122389fd7033ea2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 22:58:36 +0200 Subject: Add (guix diagnostics). * guix/ui.scm (warning, info, report-error, leave) (location->string, guix-warning-port, program-name) (highlight-argument, %highlight-argument, define-diagnostic) (%warning-color, %info-color, %error-color) (print-diagnostic-prefix): Move to... * guix/diagnostics.scm: ... here. New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/diagnostics.scm | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 152 ++++---------------------------------------- 3 files changed, 185 insertions(+), 141 deletions(-) create mode 100644 guix/diagnostics.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index ba4528ce87..80be73e4bf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -144,6 +144,7 @@ MODULES = \ guix/svn-download.scm \ guix/colors.scm \ guix/i18n.scm \ + guix/diagnostics.scm \ guix/ui.scm \ guix/status.scm \ guix/build/android-ndk-build-system.scm \ diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm new file mode 100644 index 0000000000..380cfbb613 --- /dev/null +++ b/guix/diagnostics.scm @@ -0,0 +1,173 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 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 (guix diagnostics) + #:use-module (guix colors) + #:use-module (guix i18n) + #:autoload (guix utils) () + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (warning + info + report-error + leave + + location->string + + guix-warning-port + program-name)) + +;;; Commentary: +;;; +;;; This module provides the tools to report diagnostics to the user in a +;;; consistent way: errors, warnings, and notes. +;;; +;;; Code: + +(define-syntax highlight-argument + (lambda (s) + "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT +is a trivial format string." + (define (trivial-format-string? fmt) + (define len + (string-length fmt)) + + (let loop ((start 0)) + (or (>= (+ 1 start) len) + (let ((tilde (string-index fmt #\~ start))) + (or (not tilde) + (case (string-ref fmt (+ tilde 1)) + ((#\a #\A #\%) (loop (+ tilde 2))) + (else #f))))))) + + ;; Be conservative: limit format argument highlighting to cases where the + ;; format string contains nothing but ~a escapes. If it contained ~s + ;; escapes, this strategy wouldn't work. + (syntax-case s () + ((_ "~a~%" arg) ;don't highlight whole messages + #'arg) + ((_ fmt arg) + (trivial-format-string? (syntax->datum #'fmt)) + #'(%highlight-argument arg)) + ((_ fmt arg) + #'arg)))) + +(define* (%highlight-argument arg #:optional (port (guix-warning-port))) + "Highlight ARG, a format string argument, if PORT supports colors." + (cond ((string? arg) + (highlight arg port)) + ((symbol? arg) + (highlight (symbol->string arg) port)) + (else arg))) + +(define-syntax define-diagnostic + (syntax-rules () + "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +messages." + ((_ name (G_ prefix) colors) + (define-syntax name + (lambda (x) + (syntax-case x () + ((name location (underscore fmt) args (... ...)) + (and (string? (syntax->datum #'fmt)) + (free-identifier=? #'underscore #'G_)) + #'(begin + (print-diagnostic-prefix prefix location + #:colors colors) + (format (guix-warning-port) (gettext fmt %gettext-domain) + (highlight-argument fmt args) (... ...)))) + ((name location (N-underscore singular plural n) + args (... ...)) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural)) + (free-identifier=? #'N-underscore #'N_)) + #'(begin + (print-diagnostic-prefix prefix location + #:colors colors) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) + (highlight-argument singular args) (... ...)))) + ((name (underscore fmt) args (... ...)) + (free-identifier=? #'underscore #'G_) + #'(name #f (underscore fmt) args (... ...))) + ((name (N-underscore singular plural n) + args (... ...)) + (free-identifier=? #'N-underscore #'N_) + #'(name #f (N-underscore singular plural n) + args (... ...))))))))) + +;; XXX: This doesn't work well for right-to-left languages. +;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; +;; "~a" is a placeholder for that phrase. +(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning +(define-diagnostic info (G_ "") %info-color) +(define-diagnostic report-error (G_ "error: ") %error-color) + +(define-syntax-rule (leave args ...) + "Emit an error message and exit." + (begin + (report-error args ...) + (exit 1))) + +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) + +(define* (print-diagnostic-prefix prefix #:optional location + #:key (colors (color))) + "Print PREFIX as a diagnostic line prefix." + (define color? + (color-output? (guix-warning-port))) + + (define location-color + (if color? + (cut colorize-string <> (color BOLD)) + identity)) + + (define prefix-color + (if color? + (lambda (prefix) + (colorize-string prefix colors)) + identity)) + + (let ((prefix (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (if location + (format (guix-warning-port) "~a: ~a" + (location-color (location->string location)) + (prefix-color prefix)) + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (prefix-color prefix))))) + +(define (location->string loc) + "Return a human-friendly, GNU-standard representation of LOC." + (match loc + (#f (G_ "")) + (($ file line column) + (format #f "~a:~a:~a" file line column)))) + + +(define guix-warning-port + (make-parameter (current-warning-port))) + +(define program-name + ;; Name of the command-line program currently executing, or #f. + (make-parameter #f)) diff --git a/guix/ui.scm b/guix/ui.scm index 529401eea8..0b4fe144b6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -32,6 +32,7 @@ (define-module (guix ui) #:use-module (guix i18n) #:use-module (guix colors) + #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix sets) #:use-module (guix utils) @@ -70,10 +71,14 @@ #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) - #:re-export (G_ N_ P_) ;backward compatibility - #:export (report-error - display-hint - leave + + ;; Re-exports for backward compatibility. + #:re-export (G_ N_ P_ ;now in (guix i18n) + + warning info report-error leave ;now in (guix diagnostics) + location->string + guix-warning-port program-name) + #:export (display-hint make-user-module load* warn-about-load-error @@ -93,7 +98,6 @@ read/eval read/eval-package-expression check-available-space - location->string fill-paragraph %text-width texi->plain-text @@ -115,10 +119,6 @@ delete-generation* run-guix-command run-guix - program-name - guix-warning-port - warning - info guix-main)) ;;; Commentary: @@ -127,124 +127,6 @@ ;;; ;;; Code: -(define-syntax highlight-argument - (lambda (s) - "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT -is a trivial format string." - (define (trivial-format-string? fmt) - (define len - (string-length fmt)) - - (let loop ((start 0)) - (or (>= (+ 1 start) len) - (let ((tilde (string-index fmt #\~ start))) - (or (not tilde) - (case (string-ref fmt (+ tilde 1)) - ((#\a #\A #\%) (loop (+ tilde 2))) - (else #f))))))) - - ;; Be conservative: limit format argument highlighting to cases where the - ;; format string contains nothing but ~a escapes. If it contained ~s - ;; escapes, this strategy wouldn't work. - (syntax-case s () - ((_ "~a~%" arg) ;don't highlight whole messages - #'arg) - ((_ fmt arg) - (trivial-format-string? (syntax->datum #'fmt)) - #'(%highlight-argument arg)) - ((_ fmt arg) - #'arg)))) - -(define* (%highlight-argument arg #:optional (port (guix-warning-port))) - "Highlight ARG, a format string argument, if PORT supports colors." - (cond ((string? arg) - (highlight arg port)) - ((symbol? arg) - (highlight (symbol->string arg) port)) - (else arg))) - -(define-syntax define-diagnostic - (syntax-rules () - "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all -messages." - ((_ name (G_ prefix) colors) - (define-syntax name - (lambda (x) - (syntax-case x () - ((name location (underscore fmt) args (... ...)) - (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'G_)) - #'(begin - (print-diagnostic-prefix prefix location - #:colors colors) - (format (guix-warning-port) (gettext fmt %gettext-domain) - (highlight-argument fmt args) (... ...)))) - ((name location (N-underscore singular plural n) - args (... ...)) - (and (string? (syntax->datum #'singular)) - (string? (syntax->datum #'plural)) - (free-identifier=? #'N-underscore #'N_)) - #'(begin - (print-diagnostic-prefix prefix location - #:colors colors) - (format (guix-warning-port) - (ngettext singular plural n %gettext-domain) - (highlight-argument singular args) (... ...)))) - ((name (underscore fmt) args (... ...)) - (free-identifier=? #'underscore #'G_) - #'(name #f (underscore fmt) args (... ...))) - ((name (N-underscore singular plural n) - args (... ...)) - (free-identifier=? #'N-underscore #'N_) - #'(name #f (N-underscore singular plural n) - args (... ...))))))))) - -;; XXX: This doesn't work well for right-to-left languages. -;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; -;; "~a" is a placeholder for that phrase. -(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning -(define-diagnostic info (G_ "") %info-color) -(define-diagnostic report-error (G_ "error: ") %error-color) - -(define-syntax-rule (leave args ...) - "Emit an error message and exit." - (begin - (report-error args ...) - (exit 1))) - -(define %warning-color (color BOLD MAGENTA)) -(define %info-color (color BOLD)) -(define %error-color (color BOLD RED)) -(define %hint-color (color BOLD CYAN)) - -(define* (print-diagnostic-prefix prefix #:optional location - #:key (colors (color))) - "Print PREFIX as a diagnostic line prefix." - (define color? - (color-output? (guix-warning-port))) - - (define location-color - (if color? - (cut colorize-string <> (color BOLD)) - identity)) - - (define prefix-color - (if color? - (lambda (prefix) - (colorize-string prefix colors)) - identity)) - - (let ((prefix (if (string-null? prefix) - prefix - (gettext prefix %gettext-domain)))) - (if location - (format (guix-warning-port) "~a: ~a" - (location-color (location->string location)) - (prefix-color prefix)) - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (prefix-color prefix))))) - (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. (match args @@ -393,6 +275,8 @@ VARIABLE and return it, or #f if none was found." (('gnu _ ...) head) ;must be that one (_ (loop next (cons head suggestions) visited))))))))))) +(define %hint-color (color BOLD CYAN)) + (define* (display-hint message #:optional (port (current-error-port))) "Display MESSAGE, a l10n message possibly containing Texinfo markup, to PORT." @@ -1192,13 +1076,6 @@ replacement if PORT is not Unicode-capable." (lambda () body ...))))) -(define (location->string loc) - "Return a human-friendly, GNU-standard representation of LOC." - (match loc - (#f (G_ "")) - (($ file line column) - (format #f "~a:~a:~a" file line column)))) - (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. @@ -1720,10 +1597,6 @@ Run COMMAND with ARGS.\n")) stringsymbol command) args)))) -(define guix-warning-port - (make-parameter (current-warning-port))) - (define (guix-main arg0 . args) (initialize-guix) (apply run-guix args)) -- cgit v1.2.3 From 69962ab7a8e07af77a2eb466be39615d139d5cf0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 23:00:42 +0200 Subject: deprecation: Use the 'warning' procedure for diagnostics. Until now, (guix deprecation) had its own warning mechanism, which was inconsistent (it did not use colors, etc.) * guix/deprecation.scm (deprecation-warning-port): Remove (source-properties->location-string): Remove. (warn-about-deprecation): Use 'warning' instead of 'format'. (define-deprecated, define-deprecated/alias): Adjust docstring. * guix/channels.scm (build-from-source): Refer to 'guix-warning-port' instead of 'deprecation-warning-port'. --- guix/channels.scm | 4 ++-- guix/deprecation.scm | 36 +++++++++++------------------------- 2 files changed, 13 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index e93879e1b4..e7278c6060 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -27,7 +27,7 @@ #:use-module (guix profiles) #:use-module (guix derivations) #:use-module (guix combinators) - #:use-module (guix deprecation) + #:use-module (guix diagnostics) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -280,7 +280,7 @@ package modules under SOURCE using CORE, an instance of Guix." ;; Disable deprecation warnings; it's OK for SCRIPT to ;; use deprecated APIs and the user doesn't have to know ;; about it. - (parameterize ((deprecation-warning-port + (parameterize ((guix-warning-port (%make-void-port "w"))) (primitive-load script)))))) ;; BUILD must be a monadic procedure of at least one argument: the diff --git a/guix/deprecation.scm b/guix/deprecation.scm index d704e7ec61..468b2e9b7b 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -18,40 +18,26 @@ (define-module (guix deprecation) #:use-module (guix i18n) - #:use-module (ice-9 format) + #:use-module (guix diagnostics) + #:autoload (guix utils) (source-properties->location) #:export (define-deprecated define-deprecated/alias - warn-about-deprecation - deprecation-warning-port)) + warn-about-deprecation)) ;;; Commentary: ;;; ;;; Provide a mechanism to mark bindings as deprecated. ;;; -;;; We don't reuse (guix ui) mostly to avoid pulling in too many things. -;;; ;;; Code: -(define deprecation-warning-port - ;; Port where deprecation warnings go. - (make-parameter (current-error-port))) - -(define (source-properties->location-string properties) - "Return a human-friendly, GNU-standard representation of PROPERTIES, a -source property alist." - (let ((file (assq-ref properties 'filename)) - (line (assq-ref properties 'line)) - (column (assq-ref properties 'column))) - (if (and file line column) - (format #f "~a:~a:~a" file (+ 1 line) column) - (G_ "")))) - (define* (warn-about-deprecation variable properties #:key replacement) - (format (deprecation-warning-port) - (G_ "~a: warning: '~a' is deprecated~@[, use '~a' instead~]~%") - (source-properties->location-string properties) - variable replacement)) + (let ((location (and properties (source-properties->location properties)))) + (if replacement + (warning location (G_ "'~a' is deprecated, use '~a' instead~%") + variable replacement) + (warning location (G_ "'~a' is deprecated~%") + variable)))) (define-syntax define-deprecated (lambda (s) @@ -60,7 +46,7 @@ source property alist." (define-deprecated foo bar 42) (define-deprecated (baz x y) qux (qux y x)) -This will write a deprecation warning to DEPRECATION-WARNING-PORT." +This will write a deprecation warning to GUIX-WARNING-PORT." (syntax-case s () ((_ (proc formals ...) replacement body ...) #'(define-deprecated proc replacement @@ -97,7 +83,7 @@ these lines: where 'nix-server?' is the deprecated name for 'store-connection?'. -This will write a deprecation warning to DEPRECATION-WARNING-PORT." +This will write a deprecation warning to GUIX-WARNING-PORT." (define-syntax deprecated (lambda (s) (warn-about-deprecation 'deprecated (syntax-source s) -- 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') 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') 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 89ceb86ad415ea92450ebda60359a7ee0ec79eb6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 16:24:31 +0200 Subject: syscalls: 'with-file-lock' expands to a call to 'call-with-file-lock'. * guix/build/syscalls.scm (call-with-file-lock): New procedure. (with-file-lock): Expand to a call to 'call-with-file-lock'. --- guix/build/syscalls.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 04fbebb8a2..3af41f2cf5 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1083,17 +1083,19 @@ exception if it's already taken." (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." +(define (call-with-file-lock file thunk) (let ((port (lock-file file))) (dynamic-wind (lambda () #t) - (lambda () - exp ...) + thunk (lambda () (unlock-file port))))) +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (call-with-file-lock file (lambda () exp ...))) + ;;; ;;; Miscellaneous, aka. 'prctl'. -- cgit v1.2.3 From 5f0cf1df710cca3eeff6b41ce8e665fb911cfb41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 17:13:30 +0200 Subject: syscalls: 'with-lock-file' catches ENOSYS. * guix/build/syscalls.scm (call-with-file-lock): Catch ENOSYS raised by 'lock-file'. --- guix/build/syscalls.scm | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3af41f2cf5..5c2eb3c14d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1084,13 +1084,24 @@ exception if it's already taken." #t) (define (call-with-file-lock file thunk) - (let ((port (lock-file file))) + (let ((port (catch 'system-error + (lambda () + (lock-file file)) + (lambda args + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno args)) + #f + (apply throw args)))))) (dynamic-wind (lambda () #t) thunk (lambda () - (unlock-file port))))) + (when port + (unlock-file port)))))) (define-syntax-rule (with-file-lock file exp ...) "Wait to acquire a lock on FILE and evaluate EXP in that context." -- cgit v1.2.3 From 70a7a1b5dc529de34304dea5aa4d2b58e7a5d305 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 17:18:41 +0200 Subject: nar: Really lock store files. Previously, 'lock-store-file' would immediately close the file descriptor of the '.lock' file, and thus it would immediately release the lock. * guix/nar.scm (lock-store-file, unlock-store-file): Remove. (finalize-store-file): Use 'lock-file' and 'unlock-file' instead. --- guix/nar.scm | 42 ++++++++++++++++-------------------------- 1 file changed, 16 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 8894f10d2b..29636aa0f8 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -76,16 +76,6 @@ ;; most of the daemon is in Scheme :-)). But note that we do use a couple of ;; RPCs for functionality not available otherwise, like 'valid-path?'. -(define (lock-store-file file) - "Acquire exclusive access to FILE, a store file." - (call-with-output-file (string-append file ".lock") - (cut fcntl-flock <> 'write-lock))) - -(define (unlock-store-file file) - "Release access to FILE." - (call-with-input-file (string-append file ".lock") - (cut fcntl-flock <> 'unlock))) - (define* (finalize-store-file source target #:key (references '()) deriver (lock? #t)) "Rename SOURCE to TARGET and register TARGET as a valid store item, with @@ -94,25 +84,25 @@ before attempting to register it; otherwise, assume TARGET's locks are already held." (with-database %default-database-file db (unless (path-id db target) - (when lock? - (lock-store-file target)) + (let ((lock (and lock? + (lock-file (string-append target ".lock"))))) - (unless (path-id db target) - ;; If FILE already exists, delete it (it's invalid anyway.) - (when (file-exists? target) - (delete-file-recursively target)) + (unless (path-id db target) + ;; If FILE already exists, delete it (it's invalid anyway.) + (when (file-exists? target) + (delete-file-recursively target)) - ;; Install the new TARGET. - (rename-file source target) + ;; Install the new TARGET. + (rename-file source target) - ;; Register TARGET. As a side effect, it resets the timestamps of all - ;; its files, recursively, and runs a deduplication pass. - (register-path target - #:references references - #:deriver deriver)) + ;; Register TARGET. As a side effect, it resets the timestamps of all + ;; its files, recursively, and runs a deduplication pass. + (register-path target + #:references references + #:deriver deriver)) - (when lock? - (unlock-store-file target))))) + (when lock? + (unlock-file lock)))))) (define (temporary-store-file) "Return the file name of a temporary file created in the store." -- cgit v1.2.3 From 5d9fe4311af7444ee02617c5d76d668a52d453d8 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 5 Jun 2019 20:56:14 +0200 Subject: guix: git-download: Remove explicit import. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit With guile-git version 0.2, repository-working-directory is no longer private. * guix/git-download.scm (git-file-list): Refer to public repository-working-directory. Signed-off-by: Ludovic Courtès --- guix/git-download.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 6cf267d6c8..f904d11c25 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -185,9 +185,7 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout." (directory (string-append (canonicalize-path directory) "/")) (dot-git (repository-discover directory)) (repository (repository-open dot-git)) - ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0. - (workdir ((@@ (git repository) repository-working-directory) - repository)) + (workdir (repository-working-directory repository)) (head (repository-head repository)) (oid (reference-target head)) (commit (commit-lookup repository oid)) -- 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') 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 c0a4db66976dc63decbd612aafb934f44629e321 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 7 Jun 2019 22:49:47 +0200 Subject: import: print: Honor the outputs of inputs (!). Fixes . Reported by Jesse Gibbons . * guix/import/print.scm (package->code)[package-lists->code]: Preserve OUT in the result. * tests/print.scm (define-with-source): New macro. (pkg): Use it. (pkg-source): New variable. (pkg-with-inputs, pkg-with-inputs-source): New variables. ("simple package"): Refer to 'pkg-source'. ("package with inputs"): New test. --- guix/import/print.scm | 13 +++++++------ tests/print.scm | 48 +++++++++++++++++++++++++++++++----------------- 2 files changed, 38 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 0bec32c8dc..4c2a91fa4f 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -94,12 +94,13 @@ when evaluated." (map (match-lambda ((label pkg . out) (let ((mod (package-module-name pkg))) - (list label - ;; FIXME: using '@ certainly isn't pretty, but it - ;; avoids having to import the individual package - ;; modules. - (list 'unquote - (list '@ mod (variable-name pkg mod))))))) + (cons* label + ;; FIXME: using '@ certainly isn't pretty, but it + ;; avoids having to import the individual package + ;; modules. + (list 'unquote + (list '@ mod (variable-name pkg mod))) + out)))) lsts))) (let ((name (package-name package)) diff --git a/tests/print.scm b/tests/print.scm index 305807c1d1..d4b2cca93f 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -24,9 +24,31 @@ #:use-module (guix licenses) #:use-module (srfi srfi-64)) +(define-syntax-rule (define-with-source object source expr) + (begin + (define object expr) + (define source 'expr))) + (test-begin "print") -(define pkg +(define-with-source pkg pkg-source + (package + (name "test") + (version "1.2.3") + (source (origin + (method url-fetch) + (uri (string-append "file:///tmp/test-" + version ".tar.gz")) + (sha256 + (base32 + "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) + (build-system gnu-build-system) + (home-page "http://gnu.org") + (synopsis "Dummy") + (description "This is a dummy package.") + (license gpl3+))) + +(define-with-source pkg-with-inputs pkg-with-inputs-source (package (name "test") (version "1.2.3") @@ -38,27 +60,19 @@ (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) (build-system gnu-build-system) + (inputs `(("coreutils" ,(@ (gnu packages base) coreutils)) + ("glibc" ,(@ (gnu packages base) glibc) "debug"))) (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") (license gpl3+))) (test-equal "simple package" - (package->code pkg) - '(package - (name "test") - (version "1.2.3") - (source (origin - (method url-fetch) - (uri (string-append "file:///tmp/test-" - version ".tar.gz")) - (sha256 - (base32 - "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) - (build-system gnu-build-system) - (home-page "http://gnu.org") - (synopsis "Dummy") - (description "This is a dummy package.") - (license gpl3+))) + pkg-source + (package->code pkg)) + +(test-equal "package with inputs" + pkg-with-inputs-source + (package->code pkg-with-inputs)) (test-end "print") -- cgit v1.2.3 From f54cab2784493f4e9c51d3d7bcd38f155dc0fe7d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 7 Jun 2019 22:55:50 +0200 Subject: import: utils: 'specs->package-lists' correctly matches "out". * guix/import/utils.scm (specs->package-lists): Match "out", not ("out"). --- guix/import/utils.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index d0dffe9b04..63fc9bbb27 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Ricardo Wurmus @@ -287,7 +287,7 @@ package value." (map (lambda (spec) (let-values (((pkg out) (specification->package+output spec))) (match out - (("out") (list (package-name pkg) pkg)) + ("out" (list (package-name pkg) pkg)) (_ (list (package-name pkg) pkg out))))) specs)) -- cgit v1.2.3 From 0defdb636f63cd7cb8f89fd1f8d5ad4c0381a382 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Mon, 10 Jun 2019 13:58:24 +0200 Subject: gnu-maintenance: Switch to ftp.mirrorservice.org for KDE updater. mirrors.mit.edu seems no longer available over FTP. * guix/gnu-maintenance.scm (latest-kde-release): Change from mirrors.mit.edu to ftp.mirrorservice.org. --- guix/gnu-maintenance.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index a434a39f2d..d63d44f629 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -621,9 +621,9 @@ releases are on gnu.org." (false-if-ftp-error (latest-ftp-release (package-upstream-name package) - #:server "mirrors.mit.edu" - #:directory - (string-append "/kde" (dirname (dirname (uri-path uri)))))))) + #:server "ftp.mirrorservice.org" + #:directory (string-append "/sites/ftp.kde.org/pub/kde/" + (dirname (dirname (uri-path uri)))))))) (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." -- cgit v1.2.3 From 883dc11c3ab9d3e17fa1332bf24ad1de4ea828ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 9 Jun 2019 22:13:19 +0200 Subject: download: Update list of content-addressed mirrors. * guix/download.scm (%content-addressed-mirrors): Change "berlin.guixsd.org" to "ci.guix.gnu.org" and move it first. --- guix/download.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 11984cf671..cd5d61cd13 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -393,8 +393,8 @@ (module-autoload! (current-module) '(guix base16) '(bytevector->base16-string)) - (list (guix-publish "mirror.hydra.gnu.org") - (guix-publish "berlin.guixsd.org") + (list (guix-publish "ci.guix.gnu.org") + (guix-publish "mirror.hydra.gnu.org") (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. (string-append "https://tarballs.nixos.org/" -- cgit v1.2.3 From 416a7c69f1d788670f0c4a7ffaed3e032eadc91d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 22:12:28 +0200 Subject: ssh: Add missing import. * guix/ssh.scm: Use (ice-9 format). --- guix/ssh.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 2b286a67b2..9b9baf54ea 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -33,6 +33,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (ice-9 binary-ports) #:export (open-ssh-session remote-inferior -- 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 'guix') 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 @@ recursively." (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 @@ an arbitrary directory layout in the store without creating a derivation." "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 @@ (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 @@ (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 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') 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 From a6ab6b787722a81f6079e56e3412192172c80aa3 Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Tue, 16 Apr 2019 03:37:44 -0700 Subject: build-system/cargo: Expand transitive crate sources. * guix/build/cargo: (package-cargo-inputs): Add it. (package-cargo-development-inputs): Add it. (crate-closure): Add it. (expand-crate-sources): Add it. (lower)[private-keywords]: Add #:cargo-inputs and [bag]: Use expand-crate-sources to augment build-inputs. Signed-off-by: Chris Marusich --- guix/build-system/cargo.scm | 115 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 114 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index dc137421e9..828382678d 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -29,6 +29,8 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%cargo-build-system-modules %cargo-utils-modules @@ -121,15 +123,125 @@ to NAME and VERSION." #:outputs (cons "src" outputs) #:guile-for-build guile-for-build)) +(define (package-cargo-inputs p) + (apply + (lambda* (#:key (cargo-inputs '()) #:allow-other-keys) + cargo-inputs) + (package-arguments p))) + +(define (package-cargo-development-inputs p) + (apply + (lambda* (#:key (cargo-development-inputs '()) #:allow-other-keys) + cargo-development-inputs) + (package-arguments p))) + +(define (crate-closure inputs) + "Return the closure of INPUTS when considering the 'cargo-inputs' and +'cargod-dev-deps' edges. Omit duplicate inputs, except for those +already present in INPUTS itself. + +This is implemented as a breadth-first traversal such that INPUTS is +preserved, and only duplicate extracted inputs are removed. + +Forked from ((guix packages) transitive-inputs) since this extraction +uses slightly different rules compared to the rest of Guix (i.e. we +do not extract the conventional inputs)." + (define (seen? seen item) + ;; FIXME: We're using pointer identity here, which is extremely sensitive + ;; to memoization in package-producing procedures; see + ;; . + (vhash-assq item seen)) + + (let loop ((inputs inputs) + (result '()) + (propagated '()) + (first? #t) + (seen vlist-null)) + (match inputs + (() + (if (null? propagated) + (reverse result) + (loop (reverse (concatenate propagated)) result '() #f seen))) + (((and input (label (? package? package))) rest ...) + (if (and (not first?) (seen? seen package)) + (loop rest result propagated first? seen) + (loop rest + (cons input result) + (cons (package-cargo-inputs package) + propagated) + first? + (vhash-consq package package seen)))) + ((input rest ...) + (loop rest (cons input result) propagated first? seen))))) + +(define (expand-crate-sources cargo-inputs cargo-development-inputs) + "Extract all transitive sources for CARGO-INPUTS and CARGO-DEVELOPMENT-INPUTS +along their 'cargo-inputs' edges. + +Cargo requires all transitive crate dependencies' sources to be available +in its index, even if they are optional (this is so it can generate +deterministic Cargo.lock files regardless of the target platform or enabled +features). Thus we need all transitive crate dependencies for any cargo +dev-dependencies, but this is only needed when building/testing a crate directly +(i.e. we will never need transitive dev-dependencies for any dependency crates). + +Another complication arises due potential dependency cycles from Guix's +perspective: Although cargo does not permit cyclic dependencies between crates, +however, it permits cycles to occur via dev-dependencies. For example, if crate +X depends on crate Y, crate Y's tests could pull in crate X to to verify +everything builds properly (this is a rare scenario, but it it happens for +example with the `proc-macro2` and `quote` crates). This is allowed by cargo +because tests are built as a pseudo-crate which happens to depend on the +X and Y crates, forming an acyclic graph. + +We can side step this problem by only considering regular cargo dependencies +since they are guaranteed to not have cycles. We can further resolve any +potential dev-dependency cycles by extracting package sources (which never have +any dependencies and thus no cycles can exist). + +There are several implications of this decision: +* Building a package definition does not require actually building/checking +any dependent crates. This can be a benefits: + - For example, sometimes a crate may have an optional dependency on some OS + specific package which cannot be built or run on the current system. This + approach means that the build will not fail if cargo ends up internally ignoring + the dependency. + - It avoids waiting for quadratic builds from source: cargo always builds + dependencies within the current workspace. This is largely due to Rust not + having a stable ABI and other resolutions that cargo applies. This means that + if we have a depencency chain of X -> Y -> Z and we build each definition + independently the following will happen: + * Cargo will build and test crate Z + * Cargo will build crate Z in Y's workspace, then build and test Y + * Cargo will build crates Y and Z in X's workspace, then build and test X +* But there are also some downsides with this approach: + - If a dependent crate is subtly broken on the system (i.e. it builds but its + tests fail) the consuming crates may build and test successfully but + actually fail during normal usage (however, the CI will still build all + packages which will give visibility in case packages suddenly break). + - Because crates aren't declared as regular inputs, other Guix facilities + such as tracking package graphs may not work by default (however, this is + something that can always be extended or reworked in the future)." + (filter-map + (match-lambda + ((label (? package? p)) + (list label (package-source p))) + ((label input) + (list label input))) + (crate-closure (append cargo-inputs cargo-development-inputs)))) + (define* (lower name #:key source inputs native-inputs outputs system target (rust (default-rust)) + (cargo-inputs '()) + (cargo-development-inputs '()) #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:rust #:inputs #:native-inputs #:outputs)) + '(#:source #:target #:rust #:inputs #:native-inputs #:outputs + #:cargo-inputs #:cargo-development-inputs)) (and (not target) ;; TODO: support cross-compilation (bag @@ -145,6 +257,7 @@ to NAME and VERSION." ,@(standard-packages))) (build-inputs `(("cargo" ,rust "cargo") ("rustc" ,rust) + ,@(expand-crate-sources cargo-inputs cargo-development-inputs) ,@native-inputs)) (outputs outputs) (build cargo-build) -- cgit v1.2.3 From efdf2ae14eec429f5602ad03511ea5f7d8bc12b7 Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Thu, 16 May 2019 23:02:12 -0700 Subject: build-system/cargo: Use sources from package sources. * guix/build/cargo-build-system.scm (crate-src?): New procedure. (configure): Use the new procedure to expand crate tarballs in the vendor directory. Signed-off-by: Chris Marusich --- guix/build/cargo-build-system.scm | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 9f44bd6ee9..b368074e8a 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -54,6 +54,22 @@ (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) (find bin-dep? (manifest-targets)))) +(define (crate-src? path) + "Check if PATH refers to a crate source, namely a gzipped tarball with a +Cargo.toml file present at its root." + (and (gzip-file? path) + ;; First we print out all file names within the tarball to see if it + ;; looks like the source of a crate. However, the tarball will include + ;; an extra path component which we would like to ignore (since we're + ;; interested in checking if a Cargo.toml exists at the root of the + ;; archive, but not nested anywhere else). We do this by cutting up + ;; each output line and only looking at the second component. We then + ;; check if it matches Cargo.toml exactly and short circuit if it does. + (zero? (apply system* (list "sh" "-c" + (string-append "tar -tf " path + " | cut -d/ -f2" + " | grep -q '^Cargo.toml$'")))))) + (define* (configure #:key inputs (vendor-dir "guix-vendor") #:allow-other-keys) @@ -67,14 +83,21 @@ (for-each (match-lambda ((name . path) - (let* ((rust-share (string-append path "/share/rust-source")) - (basepath (basename path)) - (link-dir (string-append vendor-dir "/" basepath))) - (and (file-exists? rust-share) + (let* ((basepath (basename path)) + (crate-dir (string-append vendor-dir "/" basepath))) + (and (crate-src? path) ;; Gracefully handle duplicate inputs - (not (file-exists? link-dir)) - (symlink rust-share link-dir))))) + (not (file-exists? crate-dir)) + (mkdir-p crate-dir) + ;; Cargo crates are simply gzipped tarballs but with a .crate + ;; extension. We expand the source to a directory name we control + ;; so that we can generate any cargo checksums. + ;; The --strip-components argument is needed to prevent creating + ;; an extra directory within `crate-dir`. + (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1") + (generate-checksums crate-dir))))) inputs) + ;; Configure cargo to actually use this new directory. (mkdir-p ".cargo") (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) -- cgit v1.2.3 From d608e231e3c1c6db0e1e3db17c4435d3d7eb5969 Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Thu, 16 May 2019 23:05:50 -0700 Subject: build-system/cargo: Don't copy source as an output. * guix/build-system/cargo.scm: (cargo-build)[build-expression->derivation]: Don't add "src" output. * guix/build/cargo-build-system.scm: (install-source): Delete it. (%standard-phases): Delete 'install-source. Signed-off-by: Chris Marusich --- guix/build-system/cargo.scm | 2 +- guix/build/cargo-build-system.scm | 19 ------------------- 2 files changed, 1 insertion(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 828382678d..fa211d456d 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -120,7 +120,7 @@ to NAME and VERSION." #:inputs inputs #:system system #:modules imported-modules - #:outputs (cons "src" outputs) + #:outputs outputs #:guile-for-build guile-for-build)) (define (package-cargo-inputs p) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index b368074e8a..1f36304b15 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -140,24 +140,6 @@ directory = '" port) (define (touch file-name) (call-with-output-file file-name (const #t))) -(define* (install-source #:key inputs outputs #:allow-other-keys) - "Install the source for a given Cargo package." - (let* ((out (assoc-ref outputs "out")) - (src (assoc-ref inputs "source")) - (rsrc (string-append (assoc-ref outputs "src") - "/share/rust-source"))) - (mkdir-p rsrc) - ;; Rust doesn't have a stable ABI yet. Because of this - ;; Cargo doesn't have a search path for binaries yet. - ;; Until this changes we are working around this by - ;; vendoring the crates' sources by symlinking them - ;; to store paths. - (copy-recursively "." rsrc) - (touch (string-append rsrc "/.cargo-ok")) - (generate-checksums rsrc) - (install-file "Cargo.toml" rsrc) - #t)) - (define* (install #:key inputs outputs skip-build? #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) @@ -179,7 +161,6 @@ directory = '" port) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) - (add-before 'configure 'install-source install-source) (replace 'configure configure) (replace 'build build) (replace 'check check) -- cgit v1.2.3 From 5a9ef8a960706a55764f5bbc67ac83dd48516016 Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Fri, 17 May 2019 00:26:07 -0700 Subject: import: crate: Define dependencies as arguments. * guix/import/crate.scm: (crate-fetch)[input-crates]: Rename to dev-crates. [native-input-crates]: Rename to dev-dep-crates. [inputs]: Rename to cargo-inputs. [native-inputs]: Rename to cargo-development-inputs. (maybe-cargo-inputs, maybe-cargo-development-inputs, maybe-arguments): Add them. (make-crate-sexp)[inputs]: Rename to cargo-inputs. [native-inputs]: Rename to cargo-development-inputs. [maybe-native-inputs, maybe-inputs]: Replace with maybe-arguments. * guix/import/utils.scm: (package-names->package-inputs): Make public. Add docstring. * tests/crate.scm (crate->guix-package): Update the match pattern. Signed-off-by: Chris Marusich --- guix/import/crate.scm | 47 ++++++++++++++++++++++++++++++++++++----------- guix/import/utils.scm | 4 ++++ tests/crate.scm | 4 ++-- 3 files changed, 42 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index e0b400d054..9a73d9fe16 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -65,29 +65,53 @@ (path (string-append "/" version "/dependencies")) (deps-json (json-fetch-alist (string-append crate-url name path))) (deps (assoc-ref deps-json "dependencies")) - (input-crates (filter (crate-kind-predicate "normal") deps)) - (native-input-crates + (dep-crates (filter (crate-kind-predicate "normal") deps)) + (dev-dep-crates (filter (lambda (dep) (not ((crate-kind-predicate "normal") dep))) deps)) - (inputs (crates->inputs input-crates)) - (native-inputs (crates->inputs native-input-crates)) + (cargo-inputs (crates->inputs dep-crates)) + (cargo-development-inputs (crates->inputs dev-dep-crates)) (home-page (match homepage (() repository) (_ homepage)))) (callback #:name name #:version version - #:inputs inputs #:native-inputs native-inputs + #:cargo-inputs cargo-inputs + #:cargo-development-inputs cargo-development-inputs #:home-page home-page #:synopsis synopsis #:description description #:license license))) -(define* (make-crate-sexp #:key name version inputs native-inputs +(define (maybe-cargo-inputs package-names) + (match (package-names->package-inputs package-names) + (() + '()) + ((package-inputs ...) + `((#:cargo-inputs ,package-inputs))))) + +(define (maybe-cargo-development-inputs package-names) + (match (package-names->package-inputs package-names) + (() + '()) + ((package-inputs ...) + `((#:cargo-development-inputs ,package-inputs))))) + +(define (maybe-arguments arguments) + (match arguments + (() + '()) + ((args ...) + `((arguments (,'quasiquote ,args)))))) + +(define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs home-page synopsis description license #:allow-other-keys) "Return the `package' s-expression for a rust package with the given NAME, -VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." +VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, +and LICENSE." (let* ((port (http-fetch (crate-uri name version))) (guix-name (crate-name->package-name name)) - (inputs (map crate-name->package-name inputs)) - (native-inputs (map crate-name->package-name native-inputs)) + (cargo-inputs (map crate-name->package-name cargo-inputs)) + (cargo-development-inputs (map crate-name->package-name + cargo-development-inputs)) (pkg `(package (name ,guix-name) (version ,version) @@ -99,8 +123,9 @@ VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (base32 ,(bytevector->nix-base32-string (port-sha256 port)))))) (build-system cargo-build-system) - ,@(maybe-native-inputs native-inputs "src") - ,@(maybe-inputs inputs "src") + ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs) + (maybe-cargo-development-inputs + cargo-development-inputs))) (home-page ,(match home-page (() "") (_ home-page))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 63fc9bbb27..84503ab907 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -52,6 +52,7 @@ url-fetch guix-hash-url + package-names->package-inputs maybe-inputs maybe-native-inputs package->definition @@ -236,6 +237,9 @@ into a proper sentence and by using two spaces between sentences." cleaned 'pre ". " 'post))) (define* (package-names->package-inputs names #:optional (output #f)) + "Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a +quoted list of inputs, as suitable to use in an 'inputs' field of a package +definition." (map (lambda (input) (cons* input (list 'unquote (string->symbol input)) (or (and output (list output)) diff --git a/tests/crate.scm b/tests/crate.scm index a1dcfd5e52..a4a328d507 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -89,9 +89,9 @@ ('base32 (? string? hash))))) ('build-system 'cargo-build-system) - ('inputs + ('arguments ('quasiquote - (("rust-bar" ('unquote 'rust-bar) "src")))) + (('#:cargo-inputs (("rust-bar" ('unquote rust-bar))))))) ('home-page "http://example.com") ('synopsis "summary") ('description "summary") -- cgit v1.2.3