diff options
Diffstat (limited to 'guix')
36 files changed, 1174 insertions, 601 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index dc137421e9..fa211d456d 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 @@ -118,18 +120,128 @@ 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) + (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 + ;; <https://bugs.gnu.org/30155>. + (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) 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 <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/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 9f44bd6ee9..1f36304b15 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"))) @@ -117,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"))) @@ -156,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) 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). diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 31f0d3d6f4..32a431d347 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/build/syscalls.scm b/guix/build/syscalls.scm index 3abe65bc4f..5c2eb3c14d 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,42 @@ 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 (call-with-file-lock file thunk) + (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 () + (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." + (call-with-file-lock file (lambda () exp ...))) + ;;; ;;; Miscellaneous, aka. 'prctl'. 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 2f7c058940..468b2e9b7b 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -18,39 +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 - 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_ "<unknown location>")))) - (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) @@ -59,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 @@ -96,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) 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 <derivation> objects or .drv file names, using -the specified MODE." + "Build DERIVATIONS, a list of <derivation> 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>)) - (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/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 <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix diagnostics) + #:use-module (guix colors) + #:use-module (guix i18n) + #:autoload (guix utils) (<location>) + #: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_ "<unknown location>")) + (($ <location> 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/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/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/" 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)) 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." 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/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)))) 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/hackage.scm b/guix/import/hackage.scm index 2a51420d14..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-") @@ -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/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/guix/import/utils.scm b/guix/import/utils.scm index 516c0cfaa2..84503ab907 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,9 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,6 +52,7 @@ url-fetch guix-hash-url + package-names->package-inputs maybe-inputs maybe-native-inputs package->definition @@ -235,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)) @@ -286,7 +291,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)) @@ -378,57 +383,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))) diff --git a/guix/lzlib.scm b/guix/lzlib.scm index a6dac46049..24c7b4b448 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/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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; 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." 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 <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 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 <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/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: diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 802b26c64c..c8cb7b959d 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,9 @@ the image." #$profile #:database #+database #:system (or #$target (utsname:machine (uname))) + #:entry-point #$(and entry-point + #~(string-append #$profile "/" + #$entry-point)) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) @@ -689,6 +722,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 @@ -766,6 +802,9 @@ Create a bundle of PACKAGE.\n")) (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_ " --localstatedir include /var/guix in the resulting pack")) @@ -889,6 +928,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 +959,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:entry-point + entry-point #:profile-name profile-name #:archiver 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))))) ;;; diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a236f3e45c..b4334b3f16 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))) - - (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)))) + (delete-file* nar) + (delete-file* mapping))) + + (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))) - - (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))))) - - (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 @@ -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 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 <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 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/guix/self.scm b/guix/self.scm index 6d7569ec19..69e2381a8c 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/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 diff --git a/guix/store.scm b/guix/store.scm index 5c6e4e0ca6..8fa16499f8 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)))) @@ -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/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/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_ "<unknown location>")) - (($ <location> 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")) string<?)) (show-bug-report-information)) -(define program-name - ;; Name of the command-line program currently executing, or #f. - (make-parameter #f)) - (define (run-guix-command command . args) "Run COMMAND with the given ARGS. Report an error when COMMAND is not found." @@ -1783,9 +1656,6 @@ and signal handling has already been set up." (string->symbol command) args)))) -(define guix-warning-port - (make-parameter (current-warning-port))) - (define (guix-main arg0 . args) (initialize-guix) (apply run-guix args)) 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 <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 '())) |