diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/guile.scm | 6 | ||||
| -rw-r--r-- | guix/build/compile.scm | 8 | ||||
| -rw-r--r-- | guix/build/guile-build-system.scm | 52 | ||||
| -rw-r--r-- | guix/discovery.scm | 4 | ||||
| -rw-r--r-- | guix/import/cabal.scm | 35 | ||||
| -rw-r--r-- | guix/import/cran.scm | 4 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 59 | ||||
| -rw-r--r-- | guix/lzlib.scm | 116 | ||||
| -rw-r--r-- | guix/progress.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 351 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 141 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 5 | ||||
| -rw-r--r-- | guix/self.scm | 27 | ||||
| -rw-r--r-- | guix/store.scm | 2 | ||||
| -rw-r--r-- | guix/tests.scm | 1 | ||||
| -rw-r--r-- | guix/utils.scm | 27 |
17 files changed, 601 insertions, 245 deletions
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 77a5f00b0..2c5cc968c 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 <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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/compile.scm b/guix/build/compile.scm index 9e31be93f..794f12379 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). diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 31f0d3d6f..32a431d34 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 <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,10 +19,13 @@ (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 (ice-9 format) #:use-module (guix build utils) #:export (target-guile-effective-version %standard-phases @@ -74,11 +77,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 +101,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) @@ -117,17 +129,20 @@ 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 (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)) @@ -162,16 +177,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) diff --git a/guix/discovery.scm b/guix/discovery.scm index ef5ae7397..5bb494941 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/guix/import/cabal.scm b/guix/import/cabal.scm index 13c2f3f48..1a87be0b0 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/guix/import/cran.scm b/guix/import/cran.scm index 4763fccd3..324009444 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)))) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2a51420d1..366256b40 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-") @@ -145,10 +146,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))) @@ -277,13 +280,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 @@ -293,18 +294,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/guix/lzlib.scm b/guix/lzlib.scm index a6dac4604..24c7b4b44 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 @@ -168,7 +171,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))) @@ -491,29 +494,50 @@ 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 (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)))) + +(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))) @@ -597,6 +621,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/progress.scm b/guix/progress.scm index 65080bcf2..f150b081d 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> -;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; 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)) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 65de42053..17e87f029 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 <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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/publish.scm b/guix/scripts/publish.scm index a236f3e45..b4334b3f1 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 <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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,11 +122,14 @@ Publish ~a over HTTP.\n") %store-directory) ;; Since we compress on the fly, default to fast compression. (compression 'gzip 3)) -(define (actual-compression item requested) - "Return the actual compression used for ITEM, which may be %NO-COMPRESSION +(define (default-compression type) + (compression type 3)) + +(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 @@ -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))) @@ -203,11 +217,6 @@ compression disabled~%")) (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)) @@ -235,29 +244,40 @@ compression disabled~%")) (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 + (($ <compression> 'none) + '()) + (($ <compression> 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 - (($ <compression> 'none) - '()) - (($ <compression> 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)) " ")) @@ -265,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) @@ -318,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 @@ -334,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 @@ -350,6 +374,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,8 +430,29 @@ 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) + #:key ttl (compressions (list %no-compression)) (nar-path "nar") cache pool) "Respond to the narinfo request for REQUEST. If the narinfo is available in @@ -412,17 +460,22 @@ 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)) - (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) @@ -446,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 @@ -463,47 +516,75 @@ 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 <https://bugs.gnu.org/28664>.) + (with-atomic-file-output nar + (lambda (port) + (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))) + (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))))) - (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)) - ('none - ;; Cache nars even when compression is disabled so that we can - ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.) - (with-atomic-file-output nar - (lambda (port) - (write-file item port))))) + (let ((compression (actual-compressions item compressions))) - (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)))))) + (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 @@ -687,6 +768,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (make-gzip-output-port (response-port response) #:level level #:buffer-size (* 64 1024))) + (($ <compression> 'lzip level) + (make-lzip-output-port (response-port response) + #:level level)) (($ <compression> 'none) (response-port response)) (#f @@ -761,12 +845,33 @@ 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 (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 + (($ <compression> 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) + (define nar-path? (let ((expected (split-and-decode-uri-path nar-path))) (cut equal? expected <>))) @@ -785,19 +890,17 @@ blocking." (render-home-page request)) ;; /<hash>.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 #: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) @@ -815,13 +918,11 @@ blocking." ;; is restarted with different compression parameters. ;; /nar/gzip/<store-item> - ((components ... "gzip" store-item) - (if (and (nar-path? components) (zlib-available?)) - (let ((compression (match compression - (($ <compression> 'gzip) - compression) - (_ - %default-gzip-compression)))) + ((components ... (? compression-type? type) store-item) + (if (nar-path? components) + (let* ((compression-type (string->compression-type type)) + (compression (effective-compression compression-type + compressions))) (if cache (render-nar/cached store cache request store-item #:ttl narinfo-ttl @@ -845,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 @@ -853,7 +955,7 @@ blocking." #:pool pool #:nar-path nar-path #:narinfo-ttl narinfo-ttl - #:compression compression) + #:compressions compressions) concurrent-http-server `(#:socket ,socket))) @@ -892,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) @@ -919,10 +1031,17 @@ 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)) + + (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))) @@ -936,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/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 135398ba4..dba08edf5 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 <narinfo> - (%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 <narinfo> 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<? c1 c2) + (match c1 + ((uri1 compression1 (? integer? file-size1)) + (match c2 + ((uri2 compression2 (? integer? file-size2)) + (< file-size1 file-size2)) + (_ #t))) + ((uri compression1 #f) + (match c2 + ((uri2 compression2 _) + (compresses-better? compression1 compression2)))) + (_ #f))) ;we can't tell + + (match (sort choices file-size<?) + (((uri compression file-size) _ ...) + (values uri compression file-size)))) + (define* (process-substitution store-item destination #:key cache-urls acl print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." - (let* ((narinfo (lookup-narinfo cache-urls store-item - (cut valid-narinfo? <> 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 78b8674e0..1701772bc 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/guix/self.scm b/guix/self.scm index 6d7569ec1..69e2381a8 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)) @@ -603,7 +604,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)))))) @@ -646,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")) @@ -800,6 +816,7 @@ Info manual." #:extra-modules `(((guix config) => ,(make-config.scm #:zlib zlib + #:lzlib lzlib #:gzip gzip #:bzip2 bzip2 #:xz xz @@ -897,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") @@ -919,7 +936,7 @@ Info manual." %store-database-directory %config-directory %libz - ;; TODO: %liblz + %liblz %gzip %bzip2 %xz)) @@ -966,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 diff --git a/guix/store.scm b/guix/store.scm index 5c6e4e0ca..738c0fb5f 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)))) diff --git a/guix/tests.scm b/guix/tests.scm index 35ebf8464..66d60e964 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/guix/utils.scm b/guix/utils.scm index ed1a418cc..709cdf935 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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -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 '())) |