diff options
Diffstat (limited to 'guix')
46 files changed, 905 insertions, 1567 deletions
diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index ef6d1b3397..ac05ff420e 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -112,6 +113,7 @@ #:system ,system #:test-command ,test-command #:tests? ,tests? + #:parallel-tests? ,parallel-tests? #:phases ,phases #:outputs %outputs #:include ,include diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 1ec11c71d8..8304e3b222 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%haskell-build-system-modules haskell-build @@ -67,7 +69,7 @@ version REVISION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs)) + '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs #:outputs)) (define (cabal-revision->origin cabal-revision) (match cabal-revision @@ -95,9 +97,23 @@ version REVISION." ,@(standard-packages))) (build-inputs `(("haskell" ,haskell) ,@native-inputs)) - (outputs outputs) + ;; XXX: this is a hack to get around issue #41569. + (outputs (match outputs + (("out") (cons "static" outputs)) + (_ outputs))) (build haskell-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (arguments + (substitute-keyword-arguments + (strip-keyword-arguments private-keywords arguments) + ((#:extra-directories extra-directories) + `(list ,@(append-map + (lambda (name) + (match (assoc name inputs) + ((_ pkg) + (match (package-transitive-propagated-inputs pkg) + (((propagated-names . _) ...) + (cons name propagated-names)))))) + extra-directories)))))))) (define* (haskell-build store name inputs #:key source @@ -105,10 +121,12 @@ version REVISION." (haddock-flags ''()) (tests? #t) (test-target "test") + (parallel-build? #t) (configure-flags ''()) + (extra-directories ''()) (phases '(@ (guix build haskell-build-system) %standard-phases)) - (outputs '("out")) + (outputs '("out" "static")) (search-paths '()) (system (%current-system)) (guile #f) @@ -134,10 +152,12 @@ provides a 'Setup.hs' file as its build system." (derivation->output-path revision)) (revision revision)) #:configure-flags ,configure-flags + #:extra-directories ,extra-directories #:haddock-flags ,haddock-flags #:system ,system #:test-target ,test-target #:tests? ,tests? + #:parallel-build? ,parallel-build? #:haddock? ,haddock? #:phases ,phases #:outputs %outputs diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 377e428341..867f3c10bb 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -20,7 +20,7 @@ #:use-module (guix build download) #:use-module (guix build utils) #:use-module ((guix serialization) #:hide (dump-port*)) - #:use-module (guix zlib) + #:autoload (zlib) (call-with-gzip-input-port) #:use-module (guix progress) #:use-module (web uri) #:use-module (srfi srfi-11) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 91f62138d0..28253ce2f0 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org> -;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -73,37 +73,35 @@ and parameters ~s~%" (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) - #:allow-other-keys) + (extra-directories '()) #:allow-other-keys) "Configure a given Haskell package." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (lib (assoc-ref outputs "lib")) - (bin (assoc-ref outputs "bin")) (name-version (strip-store-file-name out)) - (input-dirs (match inputs - (((_ . dir) ...) - dir) - (_ '()))) + (extra-dirs (filter-map (cut assoc-ref inputs <>) extra-directories)) (ghc-path (getenv "GHC_PACKAGE_PATH")) - (params (append `(,(string-append "--prefix=" out)) - `(,(string-append "--libdir=" (or lib out) "/lib")) - `(,(string-append "--bindir=" (or bin out) "/bin")) - `(,(string-append - "--docdir=" (or doc out) - "/share/doc/" name-version)) - '("--libsubdir=$compiler/$pkg-$version") - `(,(string-append "--package-db=" %tmp-db-dir)) - '("--global") - `(,@(map - (cut string-append "--extra-include-dirs=" <>) - (search-path-as-list '("include") input-dirs))) - `(,@(map - (cut string-append "--extra-lib-dirs=" <>) - (search-path-as-list '("lib") input-dirs))) - (if tests? - '("--enable-tests") - '()) - configure-flags))) + (params `(,(string-append "--prefix=" out) + ,(string-append "--libdir=" (or lib out) "/lib") + ,(string-append "--docdir=" (or doc out) + "/share/doc/" name-version) + "--libsubdir=$compiler/$pkg-$version" + ,(string-append "--package-db=" %tmp-db-dir) + "--global" + ,@(map (cut string-append "--extra-include-dirs=" <>) + (search-path-as-list '("include") extra-dirs)) + ,@(map (cut string-append "--extra-lib-dirs=" <>) + (search-path-as-list '("lib") extra-dirs)) + ,@(if tests? + '("--enable-tests") + '()) + ;; Build and link with shared libraries + "--enable-shared" + "--enable-executable-dynamic" + "--ghc-option=-fPIC" + ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out) + "/lib/$compiler/$pkg-$version") + ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. (unsetenv "GHC_PACKAGE_PATH") @@ -121,13 +119,27 @@ and parameters ~s~%" (setenv "GHC_PACKAGE_PATH" ghc-path) #t)) -(define* (build #:rest empty) +(define* (build #:key parallel-build? #:allow-other-keys) "Build a given Haskell package." - (run-setuphs "build" '())) + (run-setuphs "build" + (if parallel-build? + `(,(string-append "--ghc-option=-j" (number->string (parallel-job-count)))) + '()))) -(define* (install #:rest empty) +(define* (install #:key outputs #:allow-other-keys) "Install a given Haskell package." - (run-setuphs "copy" '())) + (run-setuphs "copy" '()) + (when (assoc-ref outputs "static") + (let ((static (assoc-ref outputs "static")) + (lib (or (assoc-ref outputs "lib") + (assoc-ref outputs "out")))) + (for-each (lambda (static-lib) + (let* ((subdir (string-drop static-lib (string-length lib))) + (new (string-append static subdir))) + (mkdir-p (dirname new)) + (rename-file static-lib new))) + (find-files lib "\\.a$")))) + #t) (define (grep rx port) "Given a regular-expression RX including a group, read from PORT until the @@ -227,9 +239,10 @@ given Haskell package." (loop seen tail)))))) (let* ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) (name-verion (strip-store-file-name haskell)) - (lib (string-append out "/lib")) + (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) (config-dir (string-append lib "/" name-verion "/" name ".conf.d")) @@ -241,8 +254,25 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let* ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (let ((config-file-name+id + (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + + ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the + ;; "haddock-interfaces" field and removing the optional "haddock-html" + ;; field in the generated .conf file. + (when doc + (substitute* config-file + (("^haddock-html: .*") "\n") + (((format #f "^haddock-interfaces: ~a" doc)) + (string-append "haddock-interfaces: " lib))) + ;; Move the referenced file to the "lib" (or "out") output. + (match (find-files doc "\\.haddock$") + ((haddock-file . rest) + (let* ((subdir (string-drop haddock-file (string-length doc))) + (new (string-append lib subdir))) + (mkdir-p (dirname new)) + (rename-file haddock-file new))) + (_ #f))) (install-transitive-deps config-file %tmp-db-dir config-dir) (rename-file config-file (string-append config-dir "/" diff --git a/guix/channels.scm b/guix/channels.scm index bbabf654a9..ad2442f50e 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -40,10 +40,6 @@ #:use-module (guix sets) #:use-module (guix store) #:use-module (guix i18n) - #:use-module ((guix utils) - #:select (source-properties->location - &error-location - &fix-hint)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) @@ -382,16 +378,16 @@ their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated." ;; TODO: Warn for all the channels once the authentication interface ;; is public. (when (guix-channel? channel) - (raise (condition - (&message - (message (format #f (G_ "channel '~a' lacks an \ + (raise (make-compound-condition + (formatted-message (G_ "channel '~a' lacks an \ introduction and cannot be authenticated~%") - (channel-name channel)))) - (&fix-hint - (hint (G_ "Add the missing introduction to your + (channel-name channel)) + (condition + (&fix-hint + (hint (G_ "Add the missing introduction to your channels file to address the issue. Alternatively, you can pass @option{--disable-authentication}, at the risk of running unauthenticated and -thus potentially malicious code."))))))) +thus potentially malicious code.")))))))) (warning (G_ "channel authentication disabled~%"))) (when (guix-channel? channel) diff --git a/guix/config.scm.in b/guix/config.scm.in index 0ada0f3c38..b2901735d8 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -33,8 +33,6 @@ %config-directory %system - %libz - %liblz %gzip %bzip2 %xz)) @@ -88,12 +86,6 @@ (define %system "@guix_system@") -(define %libz - "@LIBZ@") - -(define %liblz - "@LIBLZ@") - (define %gzip "@GZIP@") diff --git a/guix/cve.scm b/guix/cve.scm index 7dd9005f09..ae9cca2341 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix http-client) #:use-module (guix json) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (json) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -194,15 +195,11 @@ records." (raise (condition (&message (message "invalid CVE feed"))))) (unless (equal? format "MITRE") - (raise (condition - (&message - (message (format #f (G_ "unsupported CVE format: '~a'") - format)))))) + (raise (formatted-message (G_ "unsupported CVE format: '~a'") + format))) (unless (equal? version "4.0") - (raise (condition - (&message - (message (format #f (G_ "unsupported CVE data version: '~a'") - version)))))) + (raise (formatted-message (G_ "unsupported CVE data version: '~a'") + version))) (map json->cve-item (vector->list (assoc-ref alist "CVE_Items"))))) diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index cb42103aae..76b3eac739 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -60,35 +60,26 @@ "Return a fixed-output derivation that fetches REF, a <cvs-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build cvs) - (guix build download-nar)))))) + (delete '(guix config) + (source-module-closure '((guix build cvs) + (guix build download-nar))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build cvs) - (guix build download-nar)) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (guix build cvs) + (guix build download-nar)) - (or (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs")) - (download-nar #$output))))) + (or (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs")) + (download-nar #$output)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6c0753aef4..7b9ffc61b5 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +19,10 @@ (define-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix i18n) - #:autoload (guix utils) (<location>) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (warning @@ -28,8 +30,29 @@ report-error leave + <location> + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties location->string + &error-location + error-location? + error-location + + formatted-message + formatted-message? + formatted-message-string + formatted-message-arguments + + &fix-hint + fix-hint? + condition-fix-hint + guix-warning-port program-name)) @@ -40,22 +63,22 @@ ;;; ;;; Code: +(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))))))) + (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. @@ -115,7 +138,15 @@ messages." args (... ...)) (free-identifier=? #'N-underscore #'N_) #'(name #f (N-underscore singular plural n) - args (... ...))))))))) + args (... ...))) + (id + (identifier? #'id) + ;; Run-time variant. + #'(lambda (location fmt . args) + (emit-diagnostic fmt args + #:location location + #:prefix prefix + #:colors colors))))))))) ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; @@ -130,6 +161,20 @@ messages." (report-error args ...) (exit 1))) +(define* (emit-diagnostic fmt args + #:key location (colors (color)) (prefix "")) + "Report diagnostic message FMT with the given ARGS and the specified +LOCATION, COLORS, and PREFIX. + +This procedure is used as a last resort when the format string is not known at +macro-expansion time." + (print-diagnostic-prefix (gettext prefix %gettext-domain) + location #:colors colors) + (apply format (guix-warning-port) fmt + (if (trivial-format-string? fmt) + (map %highlight-argument args) + args))) + (define %warning-color (color BOLD MAGENTA)) (define %info-color (color BOLD)) (define %error-color (color BOLD RED)) @@ -162,6 +207,45 @@ messages." (program-name) (program-name) (prefix-color prefix))))) + +;; A source location. +(define-record-type <location> + (make-location file line column) + location? + (file location-file) ; file name + (line location-line) ; 1-indexed line + (column location-column)) ; 0-indexed column + +(define (location file line column) + "Return the <location> object for the given FILE, LINE, and COLUMN." + (and line column file + (make-location file line column))) + +(define (source-properties->location loc) + "Return a location object based on the info in LOC, an alist as returned +by Guile's `source-properties', `frame-source', `current-source-location', +etc." + ;; In accordance with the GCS, start line and column numbers at 1. Note + ;; that unlike LINE and `port-column', COL is actually 1-indexed here... + (match loc + ((('line . line) ('column . col) ('filename . file)) ;common case + (and file line col + (make-location file (+ line 1) col))) + (#f + #f) + (_ + (let ((file (assq-ref loc 'filename)) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (location file (and line (+ line 1)) col))))) + +(define (location->source-properties loc) + "Return the source property association list based on the info in LOC, +a location object." + `((line . ,(and=> (location-line loc) 1-)) + (column . ,(location-column loc)) + (filename . ,(location-file loc)))) + (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc @@ -169,6 +253,73 @@ messages." (($ <location> file line column) (format #f "~a:~a:~a" file line column)))) +(define-condition-type &error-location &error + error-location? + (location error-location)) ;<location> + +(define-condition-type &fix-hint &condition + fix-hint? + (hint condition-fix-hint)) ;string + +(define-condition-type &formatted-message &error + formatted-message? + (format formatted-message-string) + (arguments formatted-message-arguments)) + +(define (check-format-string location format args) + "Check that FORMAT, a format string, contains valid escapes, and that the +number of arguments in ARGS matches the escapes in FORMAT." + (define actual-count + (length args)) + + (define allowed-chars ;for 'simple-format' + '(#\A #\S #\a #\s #\~ #\%)) + + (define (format-chars fmt) + (let loop ((chars (string->list fmt)) + (result '())) + (match chars + (() + (reverse result)) + ((#\~ opt rest ...) + (loop rest (cons opt result))) + ((chr rest ...) + (and (memv chr allowed-chars) + (loop rest result)))))) + + (match (format-chars format) + (#f + ;; XXX: In this case it could be that FMT contains invalid escapes, or it + ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9 + ;; format). Instead of implementing '-Wformat', do nothing. + #f) + (chars + (let ((count (fold (lambda (chr count) + (case chr + ((#\~ #\%) count) + (else (+ count 1)))) + 0 + chars))) + (unless (= count actual-count) + (warning location (G_ "format string got ~a arguments, expected ~a~%") + actual-count count)))))) + +(define-syntax formatted-message + (lambda (s) + "Return a '&formatted-message' error condition." + (syntax-case s (G_) + ((_ (G_ str) args ...) + (string? (syntax->datum #'str)) + (let ((str (syntax->datum #'str))) + ;; Implement a subset of '-Wformat'. + (check-format-string (source-properties->location + (syntax-source s)) + str #'(args ...)) + (with-syntax ((str (string-append str "\n"))) + #'(condition + (&formatted-message (format str) + (arguments (list args ...)))))))))) + (define guix-warning-port (make-parameter (current-warning-port))) diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 6cfc7fabe1..4ab5419bd6 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -24,6 +24,7 @@ #:use-module ((guix git) #:select (commit-difference false-if-git-not-found)) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix openpgp) #:use-module ((guix utils) #:select (cache-directory with-atomic-file-output)) @@ -105,23 +106,21 @@ not in KEYRING." (lambda _ (values #f #f))))) (unless signature - (raise (condition - (&unsigned-commit-error (commit commit-id)) - (&message - (message (format #f (G_ "commit ~a lacks a signature") - (oid->string commit-id))))))) + (raise (make-compound-condition + (condition (&unsigned-commit-error (commit commit-id))) + (formatted-message (G_ "commit ~a lacks a signature") + (oid->string commit-id))))) (let ((signature (string->openpgp-packet signature))) (when (memq (openpgp-signature-hash-algorithm signature) `(,@disallowed-hash-algorithms md5)) - (raise (condition - (&unsigned-commit-error (commit commit-id)) - (&message - (message (format #f (G_ "commit ~a has a ~a signature, \ + (raise (make-compound-condition + (condition (&unsigned-commit-error (commit commit-id))) + (formatted-message (G_ "commit ~a has a ~a signature, \ which is not permitted") - (oid->string commit-id) - (openpgp-signature-hash-algorithm - signature))))))) + (oid->string commit-id) + (openpgp-signature-hash-algorithm + signature))))) (with-fluids ((%default-port-encoding "UTF-8")) (let-values (((status data) @@ -130,23 +129,22 @@ which is not permitted") (match status ('bad-signature ;; There's a signature but it's invalid. - (raise (condition - (&signature-verification-error (commit commit-id) - (signature signature) - (keyring keyring)) - (&message - (message (format #f (G_ "signature verification failed \ + (raise (make-compound-condition + (condition + (&signature-verification-error (commit commit-id) + (signature signature) + (keyring keyring))) + (formatted-message (G_ "signature verification failed \ for commit ~a") - (oid->string commit-id))))))) + (oid->string commit-id))))) ('missing-key - (raise (condition - (&missing-key-error (commit commit-id) - (signature signature)) - (&message - (message (format #f (G_ "could not authenticate \ + (raise (make-compound-condition + (condition (&missing-key-error (commit commit-id) + (signature signature))) + (formatted-message (G_ "could not authenticate \ commit ~a: key ~a is missing") - (oid->string commit-id) - (openpgp-format-fingerprint data))))))) + (oid->string commit-id) + (openpgp-format-fingerprint data))))) ('good-signature data))))))) (define (read-authorizations port) @@ -179,13 +177,13 @@ does not specify anything, fall back to DEFAULT-AUTHORIZATIONS." ;; If COMMIT removes the '.guix-authorizations' file found in one of its ;; parents, raise an error. (when (parents-have-authorizations-file? commit) - (raise (condition - (&unauthorized-commit-error (commit (commit-id commit)) - (signing-key #f)) - (&message - (message (format #f (G_ "commit ~a attempts \ + (raise (make-compound-condition + (condition + (&unauthorized-commit-error (commit (commit-id commit)) + (signing-key #f))) + (formatted-message (G_ "commit ~a attempts \ to remove '.guix-authorizations' file") - (oid->string (commit-id commit))))))))) + (oid->string (commit-id commit))))))) (define (commit-authorizations commit) (catch 'git-error @@ -234,16 +232,16 @@ not specify anything, fall back to DEFAULT-AUTHORIZATIONS." (unless (member (openpgp-public-key-fingerprint signing-key) (commit-authorized-keys repository commit default-authorizations)) - (raise (condition - (&unauthorized-commit-error (commit id) - (signing-key signing-key)) - (&message - (message (format #f (G_ "commit ~a not signed by an authorized \ + (raise (make-compound-condition + (condition + (&unauthorized-commit-error (commit id) + (signing-key signing-key))) + (formatted-message (G_ "commit ~a not signed by an authorized \ key: ~a") - (oid->string id) - (openpgp-format-fingerprint - (openpgp-public-key-fingerprint - signing-key)))))))) + (oid->string id) + (openpgp-format-fingerprint + (openpgp-public-key-fingerprint + signing-key)))))) signing-key) @@ -366,13 +364,11 @@ EXPECTED-SIGNER." (commit-signing-key repository (commit-id commit) keyring))) (unless (bytevector=? expected-signer actual-signer) - (raise (condition - (&message - (message (format #f (G_ "initial commit ~a is signed by '~a' \ + (raise (formatted-message (G_ "initial commit ~a is signed by '~a' \ instead of '~a'") (oid->string (commit-id commit)) (openpgp-format-fingerprint actual-signer) - (openpgp-format-fingerprint expected-signer)))))))) + (openpgp-format-fingerprint expected-signer))))) (define* (authenticate-repository repository start signer #:key diff --git a/guix/git-download.scm b/guix/git-download.scm index 71ea1031c5..90634a8c4c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -84,35 +84,26 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ("tar" ,(module-ref (resolve-interface '(gnu packages base)) 'tar))))) - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3)) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) - (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build git) - (guix build utils) - (guix build download-nar) - (guix swh)))))) + (delete '(guix config) + (source-module-closure '((guix build git) + (guix build utils) + (guix build download-nar) + (guix swh))))) (define build (with-imported-modules modules - (with-extensions (list guile-json gnutls) ;for (guix swh) + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-zlib) #~(begin (use-modules (guix build git) (guix build utils) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index cd7109002b..08b2bcf758 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -36,7 +36,7 @@ #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (guix zlib) + #:use-module (zlib) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 4cdc1a780a..694105ceba 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -60,35 +60,26 @@ "Return a fixed-output derivation that fetches REF, a <hg-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build hg) - (guix build download-nar)))))) + (delete '(guix config) + (source-module-closure '((guix build hg) + (guix build download-nar))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build hg) - (guix build download-nar)) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (guix build hg) + (guix build download-nar)) - (or (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")) - (download-nar #$output))))) + (or (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")) + (download-nar #$output)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build diff --git a/guix/import/github.scm b/guix/import/github.scm index 95a792d0ca..888b148ffb 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -26,10 +26,13 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (guix utils) + #:use-module (guix i18n) + #:use-module (guix diagnostics) #:use-module ((guix download) #:prefix download:) #:use-module ((guix git-download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) + #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) @@ -162,12 +165,20 @@ empty list." `((Authorization . ,(string-append "token " (%github-token)))) '()))) - (match (json-fetch release-url #:headers headers) - (#() - ;; We got the empty list, presumably because the user didn't use GitHub's - ;; "release" mechanism, but hopefully they did use Git tags. - (json-fetch tag-url #:headers headers)) - (x x))) + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + (warning (G_ "~a is unreachable (~a)~%") + release-url (http-get-error-code c)) + '#())) ;return an empty release set + (let* ((port (http-fetch release-url #:headers headers)) + (result (json->scm port))) + (close-port port) + (match result + (#() + ;; We got the empty list, presumably because the user didn't use GitHub's + ;; "release" mechanism, but hopefully they did use Git tags. + (json-fetch tag-url #:headers headers)) + (x x))))) (define (latest-released-version url package-name) "Return a string of the newest released version name given a string URL like diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index a2b5d995ef..a4a2489688 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -34,8 +34,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module ((guix build utils) #:select ((package-name->name+version . hyphen-package-name->name+version) diff --git a/guix/inferior.scm b/guix/inferior.scm index d347754bbc..77820872b3 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -21,9 +21,10 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module ((guix diagnostics) + #:select (source-properties->location)) #:use-module ((guix utils) #:select (%current-system - source-properties->location call-with-temporary-directory version>? version-prefix? cache-directory)) diff --git a/guix/lint.scm b/guix/lint.scm index e7855678ca..ec43a4dcad 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -139,7 +139,7 @@ message-text message-data (or location - (package-field-location package field) + (and field (package-field-location package field)) (package-location package)))) (define-syntax make-warning @@ -668,7 +668,12 @@ patch could not be found." ;; Use %make-warning, as condition-mesasge is already ;; translated. (%make-warning package (condition-message c) - #:field 'patch-file-names)))) + #:field 'patch-file-names))) + ((formatted-message? c) + (list (%make-warning package + (apply format #f + (G_ (formatted-message-string c)) + (formatted-message-arguments c)))))) (define patches (match (package-source package) ((? origin? origin) (origin-patches origin)) @@ -789,6 +794,9 @@ descriptions maintained upstream." (#t ;; We found a working URL, so stop right away. '()) + (#f + ;; Unsupported URL or other error, skip. + (loop rest warnings)) ((? lint-warning? warning) (loop rest (cons warning warnings)))))))) @@ -955,7 +963,14 @@ descriptions maintained upstream." (make-warning package (G_ "failed to create ~a derivation: ~a") (list system - (condition-message c))))) + (condition-message c)))) + ((formatted-message? c) + (let ((str (apply format #f + (formatted-message-string c) + (formatted-message-arguments c)))) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system str))))) (parameterize ((%graft? #f)) (package-derivation store package system #:graft? #f) @@ -1340,12 +1355,20 @@ them for PACKAGE." "Check the formatting of the source code of PACKAGE." (let ((location (package-location package))) (if location - (and=> (search-path %load-path (location-file location)) - (lambda (file) - ;; Report issues starting from the line before the 'package' - ;; form, which usually contains the 'define' form. - (report-formatting-issues package file - (- (location-line location) 1)))) + ;; Report issues starting from the line before the 'package' + ;; form, which usually contains the 'define' form. + (let ((line (- (location-line location) 1))) + (match (search-path %load-path (location-file location)) + ((? string? file) + (report-formatting-issues package file line)) + (#f + ;; It could be that LOCATION lists a "true" relative file + ;; name--i.e., not relative to an element of %LOAD-PATH. + (let ((file (location-file location))) + (if (file-exists? file) + (report-formatting-issues package file line) + (list (make-warning package + (G_ "source file not found")))))))) '()))) diff --git a/guix/lzlib.scm b/guix/lzlib.scm deleted file mode 100644 index 2fc326ba34..0000000000 --- a/guix/lzlib.scm +++ /dev/null @@ -1,709 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; Copyright © 2019, 2020 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 lzlib) - #:use-module (rnrs bytevectors) - #:use-module (rnrs arithmetic bitwise) - #:use-module (ice-9 binary-ports) - #: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 - %default-compression-level - dictionary-size+match-length-limit)) - -;;; Commentary: -;;; -;;; Bindings to the lzlib / liblz API. Some convenience functions are also -;;; provided (see the export). -;;; -;;; While the bindings are complete, the convenience functions only support -;;; single member archives. To decompress single member archives, we loop -;;; until lz-decompress-read returns 0. This is simpler. To support multiple -;;; members properly, we need (among others) to call lz-decompress-finish and -;;; loop over lz-decompress-read until lz-decompress-finished? returns #t. -;;; Otherwise a multi-member archive starting with an empty member would only -;;; decompress the empty member and stop there, resulting in truncated output. - -;;; Code: - -(define %lzlib - ;; File name of lzlib's shared library. When updating via 'guix pull', - ;; '%liblz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%liblz) - %liblz - "liblz")))) - -(define (lzlib-available?) - "Return true if lzlib is available, #f otherwise." - (false-if-exception (force %lzlib))) - -(define (lzlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in liblz, or #f if -either lzlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %lzlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type <lz-decoder> - ;; Scheme counterpart of the 'LZ_Decoder' opaque type. - lz-decoder? - pointer->lz-decoder - lz-decoder->pointer - (lambda (obj port) - (format port "#<lz-decoder ~a>" - (number->string (object-address obj) 16)))) - -(define-wrapped-pointer-type <lz-encoder> - ;; Scheme counterpart of the 'LZ_Encoder' opaque type. - lz-encoder? - pointer->lz-encoder - lz-encoder->pointer - (lambda (obj port) - (format port "#<lz-encoder ~a>" - (number->string (object-address obj) 16)))) - -;; From lzlib.h -(define %error-number-ok 0) -(define %error-number-bad-argument 1) -(define %error-number-mem-error 2) -(define %error-number-sequence-error 3) -(define %error-number-header-error 4) -(define %error-number-unexpected-eof 5) -(define %error-number-data-error 6) -(define %error-number-library-error 7) - - -;; Compression bindings. - -(define lz-compress-open - (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64))) - ;; member-size is an "unsigned long long", and the C standard guarantees - ;; a minimum range of 0..2^64-1. - (unlimited-size (- (expt 2 64) 1))) - (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size)) - "Initialize the internal stream state for compression and returns a -pointer that can only be used as the encoder argument for the other -lz-compress functions, or a null pointer if the encoder could not be -allocated. - -See the manual: (lzlib) Compression functions." - (let ((encoder-ptr (proc dictionary-size match-length-limit member-size))) - (if (not (= (lz-compress-error encoder-ptr) -1)) - (pointer->lz-encoder encoder-ptr) - (throw 'lzlib-error 'lz-compress-open)))))) - -(define lz-compress-close - (let ((proc (lzlib-procedure int "LZ_compress_close" '(*)))) - (lambda (encoder) - "Close encoder. ENCODER can no longer be used as an argument to any -lz-compress function. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-close ret) - ret))))) - -(define lz-compress-finish - (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*)))) - (lambda (encoder) - "Tell that all the data for this member have already been written (with -the `lz-compress-write' function). It is safe to call `lz-compress-finish' as -many times as needed. After all the produced compressed data have been read -with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new -member can be started with 'lz-compress-restart-member'." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder)) - ret))))) - -(define lz-compress-restart-member - (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64)))) - (lambda (encoder member-size) - "Start a new member in a multimember data stream. -Call this function only after `lz-compress-member-finished?' indicates that the -current member has been fully read (with the `lz-compress-read' function)." - (let ((ret (proc (lz-encoder->pointer encoder) member-size))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-restart-member - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-sync-flush - (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*)))) - (lambda (encoder) - "Make available to `lz-compress-read' all the data already written with -the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then -call 'lz-compress-read' until it returns 0. - -Repeated use of `LZ-compress-sync-flush' may degrade compression ratio, -so use it only when needed. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-sync-flush - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-read - (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 positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer lzfile-bv start) - count))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write - (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int)))) - (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the encoder stream. Return the -number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write-size - (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*)))) - (lambda (encoder) - "The maximum number of bytes that can be immediately written through the -`lz-compress-write' function. - -It is guaranteed that an immediate call to `lz-compress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder)) - ret))))) - -(define lz-compress-error - (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*)))) - (lambda (encoder) - "ENCODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-encoder? encoder) - (lz-encoder->pointer encoder) - encoder)))) - error-number)))) - -(define lz-compress-finished? - (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*)))) - (lambda (encoder) - "Return #t if all the data have been read and `lz-compress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-member-finished? - (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*)))) - (lambda (encoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and 'lz-compress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*)))) - (lambda (encoder) - "Return the number of input bytes already compressed in the current -member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-data-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*)))) - (lambda (encoder) - "Return the number of compressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-member-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*)))) - (lambda (encoder) - "Return the total number of input bytes already compressed." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-in-size - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*)))) - (lambda (encoder) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-out-size - (lz-compress-error encoder)) - ret))))) - - -;; Decompression bindings. - -(define lz-decompress-open - (let ((proc (lzlib-procedure '* "LZ_decompress_open" '()))) - (lambda () - "Initializes the internal stream state for decompression and returns a -pointer that can only be used as the decoder argument for the other -lz-decompress functions, or a null pointer if the decoder could not be -allocated. - -See the manual: (lzlib) Decompression functions." - (let ((decoder-ptr (proc))) - (if (not (= (lz-decompress-error decoder-ptr) -1)) - (pointer->lz-decoder decoder-ptr) - (throw 'lzlib-error 'lz-decompress-open)))))) - -(define lz-decompress-close - (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*)))) - (lambda (decoder) - "Close decoder. DECODER can no longer be used as an argument to any -lz-decompress function. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-close ret) - ret))))) - -(define lz-decompress-finish - (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*)))) - (lambda (decoder) - "Tell that all the data for this stream have already been written (with -the `lz-decompress-write' function). It is safe to call -`lz-decompress-finish' as many times as needed." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-reset - (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*)))) - (lambda (decoder) - "Reset the internal state of DECODER as it was just after opening it -with the `lz-decompress-open' function. Data stored in the internal buffers -is discarded. Position counters are set to 0." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-reset - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-sync-to-member - (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*)))) - (lambda (decoder) - "Reset the error state of DECODER and enters a search state that lasts -until a new member header (or the end of the stream) is found. After a -successful call to `lz-decompress-sync-to-member', data written with -`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0 -until a header is found. - -This function is useful to discard any data preceding the first member, or to -discard the rest of the current member, for example in case of a data -error. If the decoder is already at the beginning of a member, this function -does nothing." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-sync-to-member - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-read - (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int)))) - (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv))) - "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV. -Return the number of uncompressed bytes written, a non-negative positive integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer file-bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write - (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int)))) - (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the decoder stream. Return the -number of uncompressed bytes written, a non-negative integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write-size - (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*)))) - (lambda (decoder) - "Return the maximum number of bytes that can be immediately written -through the `lz-decompress-write' function. - -It is guaranteed that an immediate call to `lz-decompress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-error - (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*)))) - (lambda (decoder) - "DECODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-decoder? decoder) - (lz-decoder->pointer decoder) - decoder)))) - error-number)))) - -(define lz-decompress-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*)))) - (lambda (decoder) - "Return #t if all the data have been read and `lz-decompress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*)))) - (lambda (decoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and `lz-decompress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-version - (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the version of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-dictionary-size - (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the dictionary size of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-crc - (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the 32 bit Cyclic Redundancy Check of the data decompressed -from the current member. The returned value is valid only when -`lz-decompress-member-finished' returns #t. " - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*)))) - (lambda (decoder) - "Return the number of decompressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*)))) - (lambda (decoder) - "Return the number of input bytes already decompressed in the current -member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of input bytes already compressed." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-in-size - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-out-size - (lz-decompress-error decoder)) - ret))))) - - -;; High level functions. - -(define* (lzread! decoder port bv - #:optional (start 0) (count (bytevector-length bv))) - "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." - (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))) - "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return -the number of uncompressed bytes written, a non-negative integer." - (let ((written 0) - (read 0)) - (while (and (< 0 (lz-compress-write-size encoder)) - (< written count)) - (set! written (+ written - (lz-compress-write encoder bv (+ start written) (- count written))))) - (when (= written 0) - (lz-compress-finish encoder)) - (let ((lz-bv (make-bytevector written))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector lz-port lz-bv 0 rd) - (set! read (+ read rd)) - (unless (= rd 0) - (loop rd)))) - ;; `written' is the total byte count of uncompressed data. - written)) - - -;;; -;;; Port interface. -;;; - -;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest. -;; See bbexample.c in lzlib's source. -(define %compression-levels - `((0 65535 16) - (1 ,(bitwise-arithmetic-shift-left 1 20) 5) - (2 ,(bitwise-arithmetic-shift-left 3 19) 6) - (3 ,(bitwise-arithmetic-shift-left 1 21) 8) - (4 ,(bitwise-arithmetic-shift-left 3 20) 12) - (5 ,(bitwise-arithmetic-shift-left 1 22) 20) - (6 ,(bitwise-arithmetic-shift-left 1 23) 36) - (7 ,(bitwise-arithmetic-shift-left 1 24) 68) - (8 ,(bitwise-arithmetic-shift-left 3 23) 132) - (9 ,(bitwise-arithmetic-shift-left 1 25) 273))) - -(define %default-compression-level - 6) - -(define (dictionary-size+match-length-limit level) - "Return two values: the dictionary size for LEVEL, and its match-length -limit. LEVEL must be a compression level, an integer between 0 and 9." - (match (assv-ref %compression-levels level) - ((dictionary-size match-length-limit) - (values dictionary-size match-length-limit)))) - -(define* (make-lzip-input-port port) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed." - (define decoder (lz-decompress-open)) - - (define (read! bv start count) - (lzread! decoder port bv start count)) - - (make-custom-binary-input-port "lzip-input" read! #f #f - (lambda () - (lz-decompress-close decoder) - (close-port port)))) - -(define* (make-lzip-output-port port - #:key - (level %default-compression-level)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define encoder - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (define (write! bv start count) - (lzwrite encoder bv port start count)) - - (make-custom-binary-output-port "lzip-output" write! #f #f - (lambda () - (lz-compress-finish encoder) - ;; "lz-read" the trailing metadata added by `lz-compress-finish'. - (let ((lz-bv (make-bytevector (* 64 1024)))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector port lz-bv 0 rd) - (unless (= rd 0) - (loop rd)))) - (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 - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (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." - (let ((lzip (make-lzip-input-port port))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -(define* (call-with-lzip-output-port port proc - #:key - (level %default-compression-level)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion." - (let ((lzip (make-lzip-output-port port - #:level level))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -;;; lzlib.scm ends here diff --git a/guix/man-db.scm b/guix/man-db.scm index 4cef874f8b..a6528e4431 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix man-db) - #:use-module (guix zlib) + #:use-module (zlib) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) diff --git a/guix/profiles.scm b/guix/profiles.scm index f34f73e17e..856a05eed1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -32,6 +32,7 @@ #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) #:select (package-name->name+version mkdir-p)) + #:use-module ((guix diagnostics) #:select (&fix-hint)) #:use-module (guix i18n) #:use-module (guix records) #:use-module (guix packages) @@ -1204,43 +1205,48 @@ and creates the dependency graph of all these kernel modules. This is meant to be used as a profile hook." (define kmod ; lazy reference (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - #~(begin - (use-modules (ice-9 ftw) - (ice-9 match) - (srfi srfi-1) ; append-map - (gnu build linux-modules)) - - (let* ((inputs '#$(manifest-inputs manifest)) - (module-directories - (map (lambda (directory) - (string-append directory "/lib/modules")) - inputs)) - (directory-entries - (lambda (directory) - (or (scandir directory - (lambda (basename) - (not (string-prefix? "." basename)))) - '()))) - ;; Note: Should usually result in one entry. - (versions (delete-duplicates - (append-map directory-entries - module-directories)))) - (match versions - ((version) - (let ((old-path (getenv "PATH"))) - (setenv "PATH" #+(file-append kmod "/bin")) - (make-linux-module-directory inputs version #$output) - (setenv "PATH" old-path))) - (() - ;; Nothing here, maybe because this is a kernel with - ;; CONFIG_MODULES=n. - (mkdir #$output)) - (_ (error "Specified Linux kernel and Linux kernel modules -are not all of the same version"))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) ; append-map + (gnu build linux-modules)) + + (let* ((inputs '#$(manifest-inputs manifest)) + (module-directories + (map (lambda (directory) + (string-append directory "/lib/modules")) + inputs)) + (directory-entries + (lambda (directory) + (or (scandir directory + (lambda (basename) + (not (string-prefix? "." basename)))) + '()))) + ;; Note: Should usually result in one entry. + (versions (delete-duplicates + (append-map directory-entries + module-directories)))) + (match versions + ((version) + (let ((old-path (getenv "PATH"))) + (setenv "PATH" #+(file-append kmod "/bin")) + (make-linux-module-directory inputs version #$output) + (setenv "PATH" old-path))) + (() + ;; Nothing here, maybe because this is a kernel with + ;; CONFIG_MODULES=n. + (mkdir #$output)) + (_ (error "Specified Linux kernel and Linux kernel modules +are not all of the same version")))))))) (gexp->derivation "linux-module-database" build #:local-build? #t #:substitutable? #f @@ -1411,27 +1417,18 @@ the entries in MANIFEST." (module-ref (resolve-interface '(gnu packages guile)) 'guile-gdbm-ffi)) - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module #$'(guix config) ;placate Geiser - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure `((guix build utils) - (guix man-db)))))) + (delete '(guix config) + (source-module-closure `((guix build utils) + (guix man-db))))) (define build (with-imported-modules modules - (with-extensions (list gdbm-ffi) ;for (guix man-db) + (with-extensions (list gdbm-ffi ;for (guix man-db) + guile-zlib) #~(begin (use-modules (guix man-db) (guix build utils) diff --git a/guix/quirks.scm b/guix/quirks.scm index d292f4e932..1cffe971fc 100644 --- a/guix/quirks.scm +++ b/guix/quirks.scm @@ -139,18 +139,30 @@ corresponds to the given Guix COMMIT, a SHA1 hexadecimal string." (define (accesses-guile-2.2-optimization-options? source commit) (catch 'system-error (lambda () - (match (call-with-input-file - (string-append source "/guix/build/compile.scm") - read) - (('define-module ('guix 'build 'compile) - _ ... - #:use-module ('language 'tree-il 'optimize) - #:use-module ('language 'cps 'optimize) - #:export ('%default-optimizations - '%lightweight-optimizations - 'compile-files)) - #t) - (_ #f))) + (call-with-input-file (string-append source + "/guix/build/compile.scm") + (lambda (port) + (match (read port) + (('define-module ('guix 'build 'compile) + _ ... + #:use-module ('language 'tree-il 'optimize) + #:use-module ('language 'cps 'optimize) + #:export ('%default-optimizations + '%lightweight-optimizations + 'compile-files)) + #t) + (_ + ;; Before v1.0.0 (ca. Dec. 2018), the 'use-modules' form + ;; would show up in a subsequent 'cond-expand' clause. + ;; See <https://bugs.gnu.org/42519>. + (match (read port) + (('cond-expand + ('guile-2.2 ('use-modules ('language 'tree-il 'optimize) + _ ...)) + _ ...) + #t) + (_ + #f))))))) (const #f))) (define (build-with-guile-2.2 source) diff --git a/guix/remote.scm b/guix/remote.scm index a227540728..f6adb22846 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix ssh) #:use-module (guix gexp) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix inferior) #:use-module (guix store) #:use-module (guix monads) @@ -72,11 +73,9 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (when (eof-object? (peek-char pipe)) (let ((status (channel-get-exit-status pipe))) (close-port pipe) - (raise (condition - (&message - (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ + (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \ with status ~a") - repl-command status))))))) + repl-command status)))) pipe)) (define* (%remote-eval lowered session #:optional become-command) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 41a2a42c21..f3b86fba14 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -380,6 +380,8 @@ output port." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (cond ((assoc-ref opts 'export) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8ff2fd1910..6286a43c02 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -961,6 +961,8 @@ needed." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((current-terminal-columns (terminal-columns)) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index f6f64d0a11..16d2de30f7 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -175,6 +175,8 @@ Copy ITEMS to or from the specified host over SSH.\n")) (set-build-options-from-command-line store opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 4466a0c632..4a68197620 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -140,18 +140,21 @@ Perform the deployment specified by FILE.\n")) (define (handle-argument arg result) (alist-cons 'file arg result)) - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) - (file (assq-ref opts 'file)) - (machines (or (and file (load-source-file file)) '()))) - (show-what-to-deploy machines) - - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-store store - (set-build-options-from-command-line store opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (map/accumulate-builds store - (cut deploy-machine* store <>) - machines))))))) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) + + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines)))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d3b8b57ccc..b8979cac19 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -708,6 +708,8 @@ message if any test fails." (with-store store (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 489931d5bb..73d9269de2 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -32,7 +32,8 @@ #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) - #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix diagnostics) + #:select (location-file formatted-message)) #:use-module ((guix scripts build) #:select (show-transformation-options-help options->transformation @@ -90,10 +91,8 @@ name." package) (x (raise - (condition - (&message - (message (format #f (G_ "~a: invalid argument (package name expected)") - x)))))))) + (formatted-message (G_ "~a: invalid argument (package name expected)") + x))))) (define nodes-from-package ;; The default conversion method. diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 97ffd57301..5168a1ca17 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -174,23 +174,24 @@ run the checkers on all packages.\n")) (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) - (let ((any-lint-checker-requires-store? - (any lint-checker-requires-store? checkers))) - - (define (call-maybe-with-store proc) - (if any-lint-checker-requires-store? - (with-store store - (proc store)) - (proc #f))) - - (call-maybe-with-store - (lambda (store) - (cond - ((null? args) - (fold-packages (lambda (p r) (run-checkers p checkers - #:store store)) '())) - (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers - #:store store)) - args)))))))) + (with-error-handling + (let ((any-lint-checker-requires-store? + (any lint-checker-requires-store? checkers))) + + (define (call-maybe-with-store proc) + (if any-lint-checker-requires-store? + (with-store store + (proc store)) + (proc #f))) + + (call-maybe-with-store + (lambda (store) + (cond + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers + #:store store)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers + #:store store)) + args))))))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e81b6c25f2..a56701f07a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,11 +34,12 @@ #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) #:use-module (guix nar) - #:use-module (guix utils) + #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) + #:use-module (guix diagnostics) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -65,14 +67,16 @@ ;;; ;;; Code: - (define-record-type* <build-machine> build-machine make-build-machine build-machine? (name build-machine-name) ; string (port build-machine-port ; number (default 22)) - (system build-machine-system) ; string + (systems %build-machine-systems ; list of strings + (default #f)) ; drop default after system is removed + (system %build-machine-system ; deprecated + (default #f)) (user build-machine-user) ; string (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) @@ -90,6 +94,19 @@ (features build-machine-features ; list of strings (default '()))) +;;; Deprecated. +(define (build-machine-system machine) + (warning (G_ "The 'system' field is deprecated, \ +please use 'systems' instead.~%")) + (%build-machine-system machine)) + +;;; TODO: Remove after the deprecated 'system' field is removed. +(define (build-machine-systems machine) + (or (%build-machine-systems machine) + (list (build-machine-system machine)) + (leave (G_ "The build-machine object lacks a value for its 'systems' +field.")))) + (define-record-type* <build-requirements> build-requirements make-build-requirements build-requirements? @@ -156,10 +173,9 @@ can interpret meaningfully." (lambda () (private-key-from-file file)) (lambda (key proc str . rest) - (raise (condition - (&message (message (format #f (G_ "failed to load SSH \ + (raise (formatted-message (G_ "failed to load SSH \ private key from '~a': ~a") - file str)))))))) + file str))))) (define* (open-ssh-session machine #:optional (max-silent-time -1)) "Open an SSH session for MACHINE and return it. Throw an error on failure." @@ -359,8 +375,8 @@ of free disk space on '~a'~%") (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." - (and (string=? (build-requirements-system requirements) - (build-machine-system machine)) + (and (member (build-requirements-system requirements) + (build-machine-systems machine)) (lset<= string=? (build-requirements-features requirements) (build-machine-features machine)))) @@ -779,7 +795,8 @@ machine." (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE + (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ +PRINT-BUILD-TRACE? BUILD-TIMEOUT Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") %machine-file) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 13ade37515..9d6881fdaf 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -744,11 +744,13 @@ last resort for relocation." (with-imported-modules (source-module-closure '((guix build utils) (guix build union) + (guix build gremlin) (guix elf))) #~(begin (use-modules (guix build utils) ((guix build union) #:select (relative-file-name)) (guix elf) + (guix build gremlin) (ice-9 binary-ports) (ice-9 ftw) (ice-9 match) @@ -786,6 +788,14 @@ last resort for relocation." bv 0 (bytevector-length bv)) (utf8->string bv))))) + (define (runpath file) + ;; Return the RUNPATH of FILE as a list of directories. + (let* ((bv (call-with-input-file file get-bytevector-all)) + (elf (parse-elf bv)) + (dyninfo (elf-dynamic-info elf))) + (or (and=> dyninfo elf-dynamic-info-runpath) + '()))) + (define (elf-loader-compile-flags program) ;; Return the cpp flags defining macros for the ld.so/fakechroot ;; wrapper of PROGRAM. @@ -807,6 +817,13 @@ last resort for relocation." (string-append "-DLOADER_AUDIT_MODULE=\"" #$(audit-module) "\"") + (string-append "-DLOADER_AUDIT_RUNPATH={ " + (string-join + (map object->string + (runpath + #$(audit-module))) + ", " 'suffix) + "NULL }") (if gconv (string-append "-DGCONV_DIRECTORY=\"" gconv "\"") @@ -875,7 +892,10 @@ last resort for relocation." (item (apply wrapped-package (manifest-entry-item entry) (manifest-entry-output entry) - args)))) + args)) + (dependencies (map (lambda (entry) + (apply wrapped-manifest-entry entry args)) + (manifest-entry-dependencies entry))))) ;;; @@ -1133,6 +1153,8 @@ Create a bundle of PACKAGE.\n")) (with-build-handler (build-notifier #:dry-run? (assoc-ref opts 'dry-run?) + #:verbosity + (assoc-ref opts 'verbosity) #:use-substitutes? (assoc-ref opts 'substitutes?)) (parameterize ((%graft? (assoc-ref opts 'graft?)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1246147798..ac8dedb5f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -965,6 +965,8 @@ option processing with 'parse-command-line'." (set-build-options-from-command-line (%store) opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((%guile-for-build diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 01f7213e8c..35698a0216 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -235,4 +235,7 @@ List the current Guix sessions and their processes.")) (for-each (lambda (session) (daemon-session->recutils session port) (newline port)) - (daemon-sessions)))) + (daemon-sessions)) + + ;; Pass 'R' (instead of 'r') so 'less' correctly estimates line length. + #:less-options "FRX")) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a00f08f9d9..61542f83a0 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -50,10 +50,9 @@ #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) - #:use-module (guix zlib) - #:autoload (guix lzlib) (lzlib-available? - call-with-lzip-output-port - make-lzip-output-port) + #:use-module (zlib) + #:autoload (lzlib) (call-with-lzip-output-port + make-lzip-output-port) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -880,8 +879,8 @@ blocking." "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)) + ("gzip" 'gzip) + ("lzip" 'lzip) (_ #f))) (define (effective-compression requested-type compressions) @@ -1032,9 +1031,7 @@ methods, return the applicable compression." opts) (() ;; Default to fast & low compression. - (list (if (zlib-available?) - %default-gzip-compression - %no-compression))) + (list %default-gzip-compression)) (lst (reverse lst)))) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 807daec593..5b4ccf13fe 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -773,6 +773,8 @@ Use '~/.config/guix/channels.scm' instead.")) (%graft? (assoc-ref opts 'graft?))) (with-build-handler (build-notifier #:use-substitutes? substitutes? + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? dry-run?) (set-build-options-from-command-line store opts) (ensure-default-profile) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ba2b2d2d4e..f9d19fd735 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -41,7 +41,6 @@ #: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) @@ -912,7 +911,7 @@ authorized substitutes." ;; Known compression methods and a thunk to determine whether they're ;; supported. See 'decompressed-port' in (guix utils). `(("gzip" . ,(const #t)) - ("lzip" . ,lzlib-available?) + ("lzip" . ,(const #t)) ("xz" . ,(const #t)) ("bzip2" . ,(const #t)) ("none" . ,(const #t)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 79bfcd7db2..f6d20382b6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -565,16 +565,14 @@ any, are available. Raise an error if they're not." (define fail? #f) (define (file-system-location* fs) - (location->string - (source-properties->location - (file-system-location fs)))) + (and=> (file-system-location fs) + source-properties->location)) (let-syntax ((error (syntax-rules () ((_ args ...) (begin (set! fail? #t) - (format (current-error-port) - args ...)))))) + (report-error args ...)))))) (for-each (lambda (fs) (catch 'system-error (lambda () @@ -582,9 +580,9 @@ any, are available. Raise an error if they're not." (lambda args (let ((errno (system-error-errno args)) (device (file-system-device fs))) - (error (G_ "~a: error: device '~a' not found: ~a~%") - (file-system-location* fs) device - (strerror errno)) + (error (file-system-location* fs) + (G_ "device '~a' not found: ~a~%") + device (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system label, write @code{(file-system-label ~s)} in your @code{device} field.") @@ -594,13 +592,14 @@ label, write @code{(file-system-label ~s)} in your @code{device} field.") (let ((label (file-system-label->string (file-system-device fs)))) (unless (find-partition-by-label label) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) label)))) + (error (file-system-location* fs) + (G_ "file system with label '~a' not found~%") + label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) - (error (G_ "~a: error: file system with UUID '~a' not found~%") - (file-system-location* fs) + (error (file-system-location* fs) + (G_ "file system with UUID '~a' not found~%") (uuid->string (file-system-device fs))))) uuid) @@ -1068,6 +1067,12 @@ Some ACTIONS support additional ARGS.\n")) (image-size . guess) (install-bootloader? . #t))) +(define (verbosity-level opts) + "Return the verbosity level based on OPTS, the alist of parsed options." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) + ;;; ;;; Entry point. @@ -1127,6 +1132,8 @@ resulting from command-line parsing." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) #:dry-run? (assoc-ref opts 'dry-run?)) (run-with-store store @@ -1283,8 +1290,7 @@ argument list and OPTS is the option alist." (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-verbosity (or (assoc-ref opts 'verbosity) - (if (eq? command 'build) 2 1)) + (with-status-verbosity (verbosity-level opts) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 9013e035f7..45bb1d5d3b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -39,7 +39,6 @@ #:autoload (guix git) (update-cached-checkout) #:use-module (guix i18n) #:use-module (guix diagnostics) - #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -340,24 +339,25 @@ to commits of channels in NEW." old)) (define* (check-forward-update #:optional - (validate-reconfigure ensure-forward-reconfigure)) + (validate-reconfigure + ensure-forward-reconfigure) + #:key + (current-channels + (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the -currently-deployed commit (as returned by 'guix system describe') and the -target commit (as returned by 'guix describe')." - ;; TODO: Make that functionality available to 'guix deploy'. +currently-deployed commit (from CURRENT-CHANNELS, which is as returned by +'guix system describe' by default) and the target commit (as returned by 'guix +describe')." (define new (or (and=> (current-profile) profile-channels) '())) - (define old - (system-provenance "/run/current-system")) - - (when (null? old) - (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (null? current-channels) + (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) - (channel-relations old new))) + (channel-relations current-channels new))) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index 7f14a2fdbe..d2784669be 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,7 +61,7 @@ This is an alias for 'guix package -u'.\n")) ;; Preserve some of the 'guix package' options. (append (filter (lambda (option) (any (cut member <> (option-names option)) - '("profile" "dry-run" "verbosity"))) + '("profile" "dry-run" "verbosity" "do-not-upgrade"))) %package-options) %transformation-options diff --git a/guix/self.scm b/guix/self.scm index f70b1ecdd8..6a1640acdf 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -53,10 +53,10 @@ ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) + ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) + ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'guile3.0-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)) @@ -727,8 +727,6 @@ Info manual." (name (string-append "guix-" version)) (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")) @@ -746,6 +744,12 @@ Info manual." (define guile-sqlite3 (specification->package "guile-sqlite3")) + (define guile-zlib + (specification->package "guile-zlib")) + + (define guile-lzlib + (specification->package "guile-lzlib")) + (define guile-gcrypt (specification->package "guile-gcrypt")) @@ -757,7 +761,7 @@ Info manual." (cons (list "x" package) (package-transitive-propagated-inputs package))) (list guile-gcrypt gnutls guile-git guile-json - guile-ssh guile-sqlite3)) + guile-ssh guile-sqlite3 guile-zlib guile-lzlib)) (((labels packages _ ...) ...) packages))) @@ -884,9 +888,7 @@ Info manual." '() #:extra-modules `(((guix config) - => ,(make-config.scm #:zlib zlib - #:lzlib lzlib - #:gzip gzip + => ,(make-config.scm #:gzip gzip #:bzip2 bzip2 #:xz xz #:package-name @@ -983,7 +985,7 @@ Info manual." (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir))) -(define* (make-config.scm #:key zlib lzlib gzip xz bzip2 +(define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -1004,8 +1006,6 @@ Info manual." %state-directory %store-database-directory %config-directory - %libz - %liblz %gzip %bzip2 %xz)) @@ -1048,15 +1048,7 @@ Info manual." (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))) - - (define %liblz - #+(and lzlib - (file-append lzlib "/lib/liblz")))) + #+(and xz (file-append xz "/bin/xz")))) ;; 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 b9e6ff8564..24db171374 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -20,7 +20,7 @@ #:use-module (guix store) #:use-module (guix inferior) #:use-module (guix i18n) - #:use-module ((guix utils) #:select (&fix-hint)) + #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) @@ -88,14 +88,12 @@ actual key does not match." ;; provided its Ed25519 key when we where expecting its RSA key. XXX: ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type' ;; returns #f in that case. - (raise (condition - (&message - (message (format #f (G_ "server at '~a' returned host key \ + (raise (formatted-message (G_ "server at '~a' returned host key \ '~a' of type '~a' instead of '~a' of type '~a'~%") (session-get session 'host) (public-key->string server) (get-key-type server) - key type)))))))) + key type))))) (define* (open-ssh-session host #:key user port identity host-key @@ -148,12 +146,10 @@ Throw an error on failure." (match (authenticate-server session) ('ok #f) (reason - (raise (condition - (&message - (message (format #f (G_ "failed to authenticate \ + (raise (formatted-message (G_ "failed to authenticate \ server at '~a': ~a") (session-get session 'host) - reason)))))))) + reason))))) ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) @@ -173,10 +169,8 @@ server at '~a': ~a") host (get-error session))))))))))) (x ;; Connection failed or timeout expired. - (raise (condition - (&message - (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") - host (get-error session)))))))))) + (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%") + host (get-error session))))))) (define* (remote-inferior session #:optional become-command) "Return a remote inferior for the given SESSION. If BECOME-COMMAND is @@ -187,11 +181,9 @@ given, use that to invoke the remote Guile REPL." (when (eof-object? (peek-char pipe)) (let ((status (channel-get-exit-status pipe))) (close-port pipe) - (raise (condition - (&message - (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ + (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \ with status ~a") - repl-command status))))))) + repl-command status)))) (port->inferior pipe))) (define* (inferior-remote-eval exp session #:optional become-command) @@ -291,6 +283,11 @@ can be written." ;; consumed. (define import `(begin + (eval-when (load expand eval) + (unless (resolve-module '(guix) #:ensure #f) + (write `(module-error)) + (exit 7))) + (use-modules (guix) (srfi srfi-34) (rnrs io ports) (rnrs bytevectors)) @@ -313,6 +310,9 @@ can be written." (consume-input (current-input-port)) (list 'protocol-error (nix-protocol-error-message c)))) (with-store store + (write '(importing)) ;we're ready + (force-output) + (setvbuf (current-input-port) 'none) (import-paths store (current-input-port)) '(success)))) @@ -409,24 +409,11 @@ to the system ACL file if it has not yet been authorized." "Send the subset of FILES from LOCAL (a local store) that's missing to REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. Return the list of store items actually sent." - (define (inferior-remote-eval* exp session) - (guard (c ((inferior-exception? c) - (match (inferior-exception-arguments c) - (('quit 7) - (report-module-error (remote-store-host remote))) - (_ - (report-inferior-exception c (remote-store-host remote)))))) - (inferior-remote-eval exp session))) - ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (store-connection-socket remote))) - (missing (inferior-remote-eval* + (missing (inferior-remote-eval `(begin - (eval-when (load expand eval) - (unless (resolve-module '(guix) #:ensure #f) - (exit 7))) - (use-modules (guix) (srfi srfi-1) (srfi srfi-26)) @@ -439,6 +426,13 @@ Return the list of store items actually sent." (path-info-nar-size (query-path-info local item))) missing)) (port (store-import-channel session))) + ;; Make sure everything alright on the remote side. + (match (read port) + (('importing) + #t) + (sexp + (handle-import/export-channel-error sexp remote))) + (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%" "sending ~a store items (~h MiB) to '~a'...~%" count) count @@ -513,6 +507,29 @@ to the length of FILES.)" (&message (message (format #f fmt args ...)))))))) +(define (handle-import/export-channel-error sexp remote) + "Report an error corresponding to SEXP, the EOF object or an sexp read from +REMOTE." + (match sexp + ((? eof-object?) + (report-guile-error (remote-store-host remote))) + (('module-error . _) + (report-module-error (remote-store-host remote))) + (('connection-error file code . _) + (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") + file (remote-store-host remote) (strerror code))) + (('invalid-items items . _) + (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" + "no such items on remote host '~A':~{ ~a~}" + (length items)) + (remote-store-host remote) items)) + (('protocol-error status message . _) + (raise-error (G_ "protocol error on remote host '~A': ~a") + (remote-store-host remote) message)) + (_ + (raise-error (G_ "failed to retrieve store items from '~a'") + (remote-store-host remote))))) + (define* (retrieve-files* files remote #:key recursive? (log-port (current-error-port)) (import (const #f))) @@ -533,24 +550,8 @@ from REMOTE. When RECURSIVE? is true, retrieve the closure of FILES." (import port)) (lambda () (close-port port)))) - ((? eof-object?) - (report-guile-error (remote-store-host remote))) - (('module-error . _) - (report-module-error (remote-store-host remote))) - (('connection-error file code . _) - (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") - file (remote-store-host remote) (strerror code))) - (('invalid-items items . _) - (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" - "no such items on remote host '~A':~{ ~a~}" - (length items)) - (remote-store-host remote) items)) - (('protocol-error status message . _) - (raise-error (G_ "protocol error on remote host '~A': ~a") - (remote-store-host remote) message)) - (_ - (raise-error (G_ "failed to retrieve store items from '~a'") - (remote-store-host remote)))))) + (sexp + (handle-import/export-channel-error sexp remote))))) (define* (retrieve-files local files remote #:key recursive? (log-port (current-error-port))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a742a142ee..df959bdd06 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -164,8 +164,10 @@ under STORE." ((file . properties) (unless (member file '("." "..")) (let* ((file (string-append path "/" file)) - (type (or (assq-ref properties 'type) - (stat:type (lstat file))))) + (type (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))) (loop file type (and (not (eq? 'directory type)) (nar-sha256 file))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 27bcade9dd..efc3f39186 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -388,12 +388,18 @@ ARGS is the list of arguments received by the 'throw' handler." (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (and (error-location? obj) - (error-location obj)) - (G_ "~a~%") - (gettext (condition-message obj) %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj)) + (cond ((message-condition? obj) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (apply report-error + (and (error-location? obj) (error-location obj)) + (gettext (formatted-message-string obj) %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj))) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) ((key args ...) @@ -420,12 +426,19 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (('unbound-variable _ ...) (report-unbound-variable-error args)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (warning (G_ "failed to load '~a': ~a~%") - file - (gettext (condition-message obj) %gettext-domain)) - (warning (G_ "failed to load '~a': exception thrown: ~s~%") - file obj))) + (cond ((message-condition? obj) + (warning (G_ "failed to load '~a': ~a~%") + file + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (warning (G_ "failed to load '~a': ~a~%") + (apply format #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj)))) + (else + (warning (G_ "failed to load '~a': exception thrown: ~s~%") + file obj)))) ((error args ...) (warning (G_ "failed to load '~a':~%") module) (apply display-error #f (current-error-port) args) @@ -782,17 +795,15 @@ directories:~{ ~a~}~%") (invoke-error-stop-signal c) (cons (invoke-error-program c) (invoke-error-arguments c)))) - ((and (error-location? c) (message-condition? c)) - (report-error (error-location c) (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) + + ((formatted-message? c) + (apply report-error + (and (error-location? c) (error-location c)) + (gettext (formatted-message-string c) %gettext-domain) + (formatted-message-arguments c)) (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1)) - ((and (message-condition? c) (fix-hint? c)) - (report-error (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) - (display-hint (condition-fix-hint c)) - (exit 1)) ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are ;; compound and include a '&message'. However, that message only @@ -810,8 +821,12 @@ directories:~{ ~a~}~%") ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. - (leave (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)))) + (report-error (and (error-location? c) (error-location c)) + (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) + (exit 1))) ;; Catch EPIPE and the likes. (catch 'system-error thunk @@ -862,11 +877,17 @@ similar." (('syntax-error proc message properties form . rest) (report-error (G_ "syntax error: ~a~%") message)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj))) + (cond ((message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain))) + ((formatted-message? obj) + (apply report-error #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj)))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) @@ -931,17 +952,25 @@ that the rest." (color DARK)) (string-drop file prefix))))) +(define %default-verbosity + ;; Default verbosity level for 'show-what-to-build'. + 2) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) + (verbosity %default-verbosity) (mode (build-mode normal))) "Show what will or would (depending on DRY-RUN?) be built in realizing the derivations listed in DRV using MODE, a 'build-mode' value. The elements of DRV can be either derivations or derivation inputs. Return two values: a Boolean indicating whether there's something to build, -and a Boolean indicating whether there's something to download. When -USE-SUBSTITUTES?, check and report what is prerequisites are available for -download." +and a Boolean indicating whether there's something to download. + +When USE-SUBSTITUTES?, check and report what is prerequisites are available +for download. VERBOSITY is an integer indicating the level of details to be +shown: level 2 and higher provide all the details, level 1 shows a high-level +summary, and level 0 shows nothing." (define inputs (map (match-lambda ((? derivation? drv) (derivation-input drv)) @@ -1000,71 +1029,104 @@ download." ;; display when we have information for all of DOWNLOAD. (not (any (compose zero? substitutable-download-size) download))) + ;; Combinatorial explosion ahead along two axes: DRY-RUN? and VERBOSITY. + ;; Unfortunately, this is hardly avoidable for proper i18n. (if dry-run? (begin - (format (current-error-port) - (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build)) - (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) - (format (current-error-port) - (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" - "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" - (length graft)) - (null? graft) (map colorized-store-item graft)) - (format (current-error-port) - (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" - "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" - (length hook)) - (null? hook) (map colorized-store-item hook))) + (unless (zero? verbosity) + (format (current-error-port) + (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) (map colorized-store-item build))) + (cond ((>= verbosity 2) + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") + (null? download) + download-size + (map (compose colorized-store-item substitutable-path) + download)) + (format (current-error-port) + (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" + "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) + (map (compose colorized-store-item substitutable-path) + download))) + (format (current-error-port) + (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) (map colorized-store-item graft)) + (format (current-error-port) + (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" + "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" + (length hook)) + (null? hook) (map colorized-store-item hook))) + ((= verbosity 1) + ;; Display the bare minimum; don't mention grafts and hooks. + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB would be downloaded~%~;~]") + (null? download) download-size) + (format (current-error-port) + (N_ "~:[~h item would be downloaded~%~;~]" + "~:[~h items would be downloaded~%~;~]" + (length download)) + (null? download) (length download)))))) + (begin - (format (current-error-port) - (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build)) - (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) - (format (current-error-port) - (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" - "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" - (length graft)) - (null? graft) (map colorized-store-item graft)) - (format (current-error-port) - (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" - "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" - (length hook)) - (null? hook) (map colorized-store-item hook)))) + (unless (zero? verbosity) + (format (current-error-port) + (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) (map colorized-store-item build))) + (cond ((>= verbosity 2) + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") + (null? download) + download-size + (map (compose colorized-store-item substitutable-path) + download)) + (format (current-error-port) + (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" + "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) + (map (compose colorized-store-item substitutable-path) + download))) + (format (current-error-port) + (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) (map colorized-store-item graft)) + (format (current-error-port) + (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" + "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" + (length hook)) + (null? hook) (map colorized-store-item hook))) + ((= verbosity 1) + ;; Display the bare minimum; don't mention grafts and hooks. + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB will be downloaded~%~;~]") + (null? download) download-size) + (format (current-error-port) + (N_ "~:[~h item will be downloaded~%~;~]" + "~:[~h items will be downloaded~%~;~]" + (length download)) + (null? download) (length download))))))) (check-available-space installed-size) @@ -1073,7 +1135,8 @@ download." (define show-what-to-build* (store-lift show-what-to-build)) -(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)) +(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t) + (verbosity %default-verbosity)) "Return a procedure suitable for 'with-build-handler' that, when 'build-things' is called, invokes 'show-what-to-build' to display the build plan. When DRY-RUN? is true, the 'with-build-handler' form returns without @@ -1107,6 +1170,7 @@ any build happening." (show-what-to-build store inputs #:dry-run? dry-run? #:use-substitutes? use-substitutes? + #:verbosity verbosity #:mode mode))) (unless (and (or build? download?) @@ -1587,13 +1651,18 @@ score, the more relevant OBJ is to REGEXPS." zero means that PACKAGE does not match any of REGEXPS." (relevance package regexps %package-metrics)) -(define (call-with-paginated-output-port proc) +(define* (call-with-paginated-output-port proc + #:key (less-options "FrX")) (if (isatty?* (current-output-port)) ;; Set 'LESS' so that 'less' exits if everything fits on the screen (F), ;; lets ANSI escapes through (r), does not send the termcap ;; initialization string (X). Set it unconditionally because some ;; distros set it to something that doesn't work here. - (let ((pager (with-environment-variables `(("LESS" "FrX")) + ;; + ;; For things that produce long lines, such as 'guix processes', use 'R' + ;; instead of 'r': this strips hyperlinks but allows 'less' to make a + ;; good estimate of the line length. + (let ((pager (with-environment-variables `(("LESS" ,less-options)) (open-pipe* OPEN_WRITE (or (getenv "GUIX_PAGER") (getenv "PAGER") "less"))))) @@ -1603,10 +1672,15 @@ zero means that PACKAGE does not match any of REGEXPS." (lambda () (close-pipe pager)))) (proc (current-output-port)))) -(define-syntax-rule (with-paginated-output-port port exp ...) - "Evaluate EXP... with PORT bound to a port that talks to the pager if +(define-syntax with-paginated-output-port + (syntax-rules () + "Evaluate EXP... with PORT bound to a port that talks to the pager if standard output is a tty, or with PORT set to the current output port." - (call-with-paginated-output-port (lambda (port) exp ...))) + ((_ port exp ... #:less-options opts) + (call-with-paginated-output-port (lambda (port) exp ...) + #:less-options opts)) + ((_ port exp ...) + (call-with-paginated-output-port (lambda (port) exp ...))))) (define* (display-search-results matches port #:key @@ -1776,9 +1850,7 @@ DURATION-RELATION with the current time." filter-by-duration) (else (raise - (condition (&message - (message (format #f (G_ "invalid syntax: ~a~%") - str)))))))) + (formatted-message (G_ "invalid syntax: ~a~%") str))))) (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." diff --git a/guix/upstream.scm b/guix/upstream.scm index 70cbfb45e8..6584d5e4c4 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -369,7 +369,7 @@ SOURCE, an <upstream-source>." (let*-values (((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) - (let ((type (file-extension (basename uri)))) + (let ((type (or (file-extension (basename uri)) ""))) ;; Sometimes we have URLs such as ;; "https://github.com/…/tarball/v0.1", in which case ;; we must not consider "1" as the extension. @@ -417,12 +417,13 @@ values: 'always', 'never', and 'interactive' (default)." #f)))) (match (assq method %method-updates) (#f - (raise (condition (&message - (message (format #f (G_ "cannot download for \ + (raise (make-compound-condition + (formatted-message (G_ "cannot download for \ this method: ~s") - method))) - (&error-location - (location (package-location package)))))) + method) + (condition + (&error-location + (location (package-location package))))))) ((_ . update) (update store package source #:key-download key-download))))) diff --git a/guix/utils.scm b/guix/utils.scm index 17a96370f1..b816c355dc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +30,6 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. @@ -37,13 +37,29 @@ #:use-module (guix memoization) #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) + #:use-module (guix diagnostics) ;<location>, &error-location, etc. #:use-module (ice-9 format) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (system foreign) - #:re-export (memoize) ; for backwards compatibility + #:re-export (<location> ;for backwards compatibility + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties + + &error-location + error-location? + error-location + + &fix-hint + fix-hint? + condition-fix-hint) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -51,23 +67,6 @@ current-source-directory - <location> - location - location? - location-file - location-line - location-column - source-properties->location - location->source-properties - - &error-location - error-location? - error-location - - &fix-hint - fix-hint? - condition-fix-hint - nix-system->gnu-triplet gnu-triplet->nix-system %current-system @@ -84,6 +83,7 @@ version>? version>=? version-prefix + version-major+minor+point version-major+minor version-major guile-version>? @@ -208,13 +208,8 @@ buffered data is lost." (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)))) + (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) + (values (make-port port) '()))) (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, @@ -566,6 +561,15 @@ or '= when they denote equal versions." For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\"" (string-join (take (string-split version-string #\.) num-parts) ".")) +(define (version-major+minor+point version-string) + "Return \"major>.<minor>.<point>\", where major, minor and point are the +major, minor and point version numbers from the version-string. For example, +(version-major+minor+point \"6.4.5.2\") returns \"6.4.5\" or +(version-major+minor+point \"1.19.2-2581-324ca14c3003\") returns \"1.19.2\"." + (let* ((3-dot (version-prefix version-string 3)) + (index (string-index 3-dot #\-))) + (or (false-if-exception (substring 3-dot 0 index)) + 3-dot))) (define (version-major+minor version-string) "Return \"<major>.<minor>\", where major and minor are the major and @@ -834,52 +838,6 @@ be determined." ;; raising an error would upset Geiser users #f)))))) -;; A source location. -(define-record-type <location> - (make-location file line column) - location? - (file location-file) ; file name - (line location-line) ; 1-indexed line - (column location-column)) ; 0-indexed column - -(define (location file line column) - "Return the <location> object for the given FILE, LINE, and COLUMN." - (and line column file - (make-location file line column))) - -(define (source-properties->location loc) - "Return a location object based on the info in LOC, an alist as returned -by Guile's `source-properties', `frame-source', `current-source-location', -etc." - ;; In accordance with the GCS, start line and column numbers at 1. Note - ;; that unlike LINE and `port-column', COL is actually 1-indexed here... - (match loc - ((('line . line) ('column . col) ('filename . file)) ;common case - (and file line col - (make-location file (+ line 1) col))) - (#f - #f) - (_ - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - (location file (and line (+ line 1)) col))))) - -(define (location->source-properties loc) - "Return the source property association list based on the info in LOC, -a location object." - `((line . ,(and=> (location-line loc) 1-)) - (column . ,(location-column loc)) - (filename . ,(location-file loc)))) - -(define-condition-type &error-location &error - error-location? - (location error-location)) ;<location> - -(define-condition-type &fix-hint &condition - fix-hint? - (hint condition-fix-hint)) ;string - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: diff --git a/guix/zlib.scm b/guix/zlib.scm deleted file mode 100644 index 3bd0ad86c9..0000000000 --- a/guix/zlib.scm +++ /dev/null @@ -1,241 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 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 zlib) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module (guix config) - #:export (zlib-available? - make-gzip-input-port - make-gzip-output-port - call-with-gzip-input-port - call-with-gzip-output-port - %default-buffer-size - %default-compression-level)) - -;;; Commentary: -;;; -;;; Bindings to the gzip-related part of zlib's API. The main limitation of -;;; this API is that it requires a file descriptor as the source or sink. -;;; -;;; Code: - -(define %zlib - ;; File name of zlib's shared library. When updating via 'guix pull', - ;; '%libz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%libz) - %libz - "libz")))) - -(define (zlib-available?) - "Return true if zlib is available, #f otherwise." - (false-if-exception (force %zlib))) - -(define (zlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in libz, or #f if -either zlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %zlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type <gzip-file> - ;; Scheme counterpart of the 'gzFile' opaque type. - gzip-file? - pointer->gzip-file - gzip-file->pointer - (lambda (obj port) - (format port "#<gzip-file ~a>" - (number->string (object-address obj) 16)))) - -(define gzerror - (let ((proc (zlib-procedure '* "gzerror" '(* *)))) - (lambda (gzfile) - (let* ((errnum* (make-bytevector (sizeof int))) - (ptr (proc (gzip-file->pointer gzfile) - (bytevector->pointer errnum*)))) - (values (bytevector-sint-ref errnum* 0 - (native-endianness) (sizeof int)) - (pointer->string ptr)))))) - -(define gzdopen - (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) - (lambda (fd mode) - "Open file descriptor FD as a gzip stream with the given MODE. MODE must -be a string denoting the how FD is to be opened, such as \"r\" for reading or -\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also -closes FD." - (let ((result (proc fd (string->pointer mode)))) - (if (null-pointer? result) - (throw 'zlib-error 'gzdopen) - (pointer->gzip-file result)))))) - -(define gzread! - (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from GZFILE 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." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'zlib-error 'gzread! ret) - ret))))) - -(define gzwrite - (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV at offset START into GZFILE. Return -the number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (<= ret 0) - (throw 'zlib-error 'gzwrite ret) - ret))))) - -(define gzbuffer! - (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) - (lambda (gzfile size) - "Change the internal buffer size of GZFILE to SIZE bytes." - (let ((ret (proc (gzip-file->pointer gzfile) size))) - (unless (zero? ret) - (throw 'zlib-error 'gzbuffer! ret)))))) - -(define gzeof? - (let ((proc (zlib-procedure int "gzeof" '(*)))) - (lambda (gzfile) - "Return true if the end-of-file has been reached on GZFILE." - (not (zero? (proc (gzip-file->pointer gzfile))))))) - -(define gzclose - (let ((proc (zlib-procedure int "gzclose" '(*)))) - (lambda (gzfile) - "Close GZFILE." - (let ((ret (proc (gzip-file->pointer gzfile)))) - (unless (zero? ret) - (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) - - - -;;; -;;; Port interface. -;;; - -(define %default-buffer-size - ;; Default buffer size, as documented in <zlib.h>. - 8192) - -(define %default-compression-level - ;; Z_DEFAULT_COMPRESSION. - -1) - -(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed. BUFFER-SIZE -is the size in bytes of the internal buffer, 8 KiB by default; using a larger -buffer increases decompression speed. An error is thrown if PORT contains -buffered input, which would be lost (and is lost anyway)." - (define gzfile - (match (drain-input port) - ("" ;PORT's buffer is empty - ;; 'gzclose' will eventually close the file descriptor beneath PORT. - ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, - ;; so that's no good; revealed ports are no good either because they - ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after - ;; 'gzclose' doesn't work either because it leads to a race condition - ;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right - ;; away. - (gzdopen (dup (fileno port)) "r")) - (_ - ;; This is unrecoverable but it's better than having the buffered input - ;; be lost, leading to unclear end-of-file or corrupt-data errors down - ;; the path. - (throw 'zlib-error 'make-gzip-input-port - "port contains buffered input" port)))) - - (define (read! bv start count) - (gzread! gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) ;we no longer need it - (make-custom-binary-input-port "gzip-input" read! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (make-gzip-output-port port - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define gzfile - (begin - (force-output port) ;empty PORT's buffer - (gzdopen (dup (fileno port)) - (string-append "w" (number->string level))))) - - (define (write! bv start count) - (gzwrite gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) - (make-custom-binary-output-port "gzip-output" write! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (call-with-gzip-input-port port proc - #:key (buffer-size %default-buffer-size)) - "Call PROC with a port that wraps PORT and decompresses data read from it. -PORT is closed upon completion. The gzip internal buffer size is set to -BUFFER-SIZE bytes." - (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -(define* (call-with-gzip-output-port port proc - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion. The gzip internal buffer size is set to BUFFER-SIZE -bytes." - (let ((gzip (make-gzip-output-port port - #:level level - #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -;;; zlib.scm ends here |