diff options
Diffstat (limited to 'guix')
45 files changed, 1402 insertions, 395 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f794bf006b..630b99e2bf 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -230,7 +230,10 @@ set up using CL source package conventions." ((#:phases phases) (list phases-transformer phases)))) (inputs (new-inputs package-inputs)) (propagated-inputs (new-propagated-inputs)) - (native-inputs (new-inputs package-native-inputs)) + (native-inputs (append (if target-is-source? + (list (list (package-name pkg) pkg)) + '()) + (new-inputs package-native-inputs))) (outputs (if target-is-source? '("out") (package-outputs pkg))))) diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 1e8b3a578e..6c8edf6bac 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -76,6 +77,7 @@ to NAME and VERSION." (vendor-dir "guix-vendor") (cargo-build-flags ''("--release")) (cargo-test-flags ''("--release")) + (features ''()) (skip-build? #f) (phases '(@ (guix build cargo-build-system) %standard-phases)) @@ -104,6 +106,7 @@ to NAME and VERSION." #:vendor-dir ,vendor-dir #:cargo-build-flags ,cargo-build-flags #:cargo-test-flags ,cargo-test-flags + #:features ,features #:skip-build? ,skip-build? #:tests? ,(and tests? (not skip-build?)) #:phases ,phases diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 1b916af8f9..f8ebaefb27 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Petter <petter@mykolab.ch> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,7 @@ (install-source? #t) (import-path "") (unpack-path "") + (build-flags ''()) (tests? #t) (allow-go-reference? #f) (system (%current-system)) @@ -109,6 +111,7 @@ #:install-source? ,install-source? #:import-path ,import-path #:unpack-path ,unpack-path + #:build-flags ,build-flags #:tests? ,tests? #:allow-go-reference? ,allow-go-reference? #:inputs %build-inputs))) diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 3693014694..45e735b987 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -29,6 +29,10 @@ #:export (%guile-build-system-modules guile-build-system)) +(define %scheme-file-regexp + ;; Regexp to match Scheme files. + "\\.(scm|sls)$") + (define %guile-build-system-modules ;; Build-side modules imported by default. `((guix build guile-build-system) @@ -80,6 +84,7 @@ (system (%current-system)) (source-directory ".") not-compiled-file-regexp + (scheme-file-regexp %scheme-file-regexp) (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) @@ -97,6 +102,7 @@ (source source)) #:source-directory ,source-directory + #:scheme-file-regexp ,scheme-file-regexp #:not-compiled-file-regexp ,not-compiled-file-regexp #:compile-flags ,compile-flags #:phases ,phases diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index ca104f7c75..1077215671 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -129,6 +129,7 @@ (phases '(@ (guix build linux-module-build-system) %standard-phases)) (outputs '("out")) + (make-flags ''()) (system (%current-system)) (guile #f) (substitutable? #t) @@ -156,6 +157,7 @@ #:arch ,(system->arch (or target system)) #:tests? ,tests? #:outputs %outputs + #:make-flags ,make-flags #:inputs %build-inputs))) (define guile-for-build @@ -181,6 +183,7 @@ target native-drvs target-drvs (guile #f) (outputs '("out")) + (make-flags ''()) (search-paths '()) (native-search-paths '()) (tests? #f) @@ -228,6 +231,7 @@ #:target ,target #:arch ,(system->arch (or target system)) #:outputs %outputs + #:make-flags ,make-flags #:inputs %build-target-inputs #:native-inputs %build-host-inputs #:search-paths diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 2d328764b0..c8ec9abd0d 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,7 +59,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.10" + (string-append "https://bioconductor.org/packages/3.11" type-url-part "/src/contrib/Archive/" name "_" version ".tar.gz")))) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index f3f4b49bcf..25dd031962 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -85,7 +85,8 @@ valid." ;; files before compiling. (for-each (lambda (file) (let ((s (lstat file))) - (unless (eq? (stat:type s) 'symlink) + (unless (or (eq? (stat:type s) 'symlink) + (not (access? file W_OK))) (utime file 0 0 0 0)))) (find-files source #:directories? #t)) (copy-recursively source target #:keep-mtime? #t) @@ -97,12 +98,53 @@ valid." (find-files target "\\.asd$")) #t)) -(define* (install #:key outputs #:allow-other-keys) - "Copy and symlink all the source files." +(define* (install #:key inputs outputs #:allow-other-keys) + "Copy and symlink all the source files. +The source files are taken from the corresponding compile package (e.g. SBCL) +if it's present in the native-inputs." (define output (assoc-ref outputs "out")) - (copy-files-to-output output - (package-name->name+version - (strip-store-file-name output)))) + (define package-name + (package-name->name+version + (strip-store-file-name output))) + (define (no-prefix pkgname) + (if (string-index pkgname #\-) + (string-drop pkgname (1+ (string-index pkgname #\-))) + pkgname)) + (define parent + (match (assoc package-name inputs + (lambda (key alist-car) + (let* ((alt-key (no-prefix key)) + (alist-car (no-prefix alist-car))) + (or (string=? alist-car key) + (string=? alist-car alt-key))))) + (#f #f) + (p (cdr p)))) + (define parent-name + (and parent + (package-name->name+version (strip-store-file-name parent)))) + (define parent-source + (and parent + (string-append parent "/share/common-lisp/" + (string-take parent-name + (string-index parent-name #\-)) + "-source"))) + + (define (first-subdirectory directory) ; From gnu-build-system. + "Return the file name of the first sub-directory of DIRECTORY." + (match (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" + file))))) + ((first . _) first))) + (define source-directory + (if (and parent-source + (file-exists? parent-source)) + (string-append parent-source "/" (first-subdirectory parent-source)) + ".")) + + (with-directory-excursion source-directory + (copy-files-to-output output package-name))) (define* (copy-source #:key outputs asd-system-name #:allow-other-keys) "Copy the source to the library output." diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0721989589..95e8dd772a 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> ;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -140,11 +141,14 @@ directory = '" port) (define* (build #:key skip-build? + features (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." (or skip-build? - (apply invoke `("cargo" "build" ,@cargo-build-flags)))) + (apply invoke "cargo" "build" + "--features" (string-join features) + cargo-build-flags))) (define* (check #:key tests? @@ -152,10 +156,10 @@ directory = '" port) #:allow-other-keys) "Run tests for a given Cargo package." (if tests? - (apply invoke `("cargo" "test" ,@cargo-test-flags)) + (apply invoke "cargo" "test" cargo-test-flags) #t)) -(define* (install #:key inputs outputs skip-build? #:allow-other-keys) +(define* (install #:key inputs outputs skip-build? features #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) (mkdir-p out) @@ -168,7 +172,8 @@ directory = '" port) ;; otherwise cargo will raise an error. (or skip-build? (not (has-executable-target?)) - (invoke "cargo" "install" "--path" "." "--root" out)))) + (invoke "cargo" "install" "--path" "." "--root" out + "--features" (string-join features))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 63f24fa7d4..ea7e1d2d03 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -98,7 +98,8 @@ (define (override-option option value lst) `(,option ,value ,@(strip-option option lst))) - (cond ((string-contains file "gnu/packages/") + (cond ((or (string-contains file "gnu/packages/") + (string-contains file "gnu/tests/")) ;; Level 0 is good enough but partial evaluation helps preserve the ;; "macro writer's bill of rights". (override-option #:partial-eval? #t diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 0d15f978cd..b9cb2bfd7b 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -214,18 +215,18 @@ unpacking." (_ #f)) inputs)))) -(define* (build #:key import-path #:allow-other-keys) +(define* (build #:key import-path build-flags #:allow-other-keys) "Build the package named by IMPORT-PATH." (with-throw-handler #t (lambda _ - (invoke "go" "install" + (apply invoke "go" "install" "-v" ; print the name of packages as they are compiled "-x" ; print each command as it is invoked ;; Respectively, strip the symbol table and debug ;; information, and the DWARF symbol table. "-ldflags=-s -w" - import-path)) + `(,@build-flags ,import-path))) (lambda (key . args) (display (string-append "Building '" import-path "' failed.\n" "Here are the results of `go env`:\n")) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 73d6b101f6..d51d76f94b 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -58,12 +58,13 @@ ;; This block was copied from make-linux-libre--only took the "modules_install" ;; part. -(define* (install #:key inputs native-inputs outputs #:allow-other-keys) +(define* (install #:key make-flags inputs native-inputs outputs + #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (moddir (string-append out "/lib/modules"))) ;; Install kernel modules (mkdir-p moddir) - (invoke "make" "-C" + (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") (string-append "M=" (getcwd)) @@ -76,7 +77,8 @@ (string-append "INSTALL_PATH=" out) (string-append "INSTALL_MOD_PATH=" out) "INSTALL_MOD_STRIP=1" - "modules_install"))) + "modules_install" + (or make-flags '())))) (define %standard-phases (modify-phases gnu:%standard-phases @@ -84,7 +86,8 @@ (replace 'build build) (replace 'install install))) -(define* (linux-module-build #:key inputs (phases %standard-phases) +(define* (linux-module-build #:key inputs + (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 563def88e9..92158a033f 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,8 +55,12 @@ (let* ((out (assoc-ref outputs "out")) (js (string-append out "/share/javascript/"))) (mkdir-p js) - (for-each (cut install-file <> js) - (find-files "guix/build" "\\.min\\.js$"))) + (for-each + (lambda (file) + (if (not (zero? (stat:size (stat file)))) + (install-file file js) + (error "File is empty: " file))) + (find-files "guix/build" "\\.min\\.js$"))) #t) (define %standard-phases diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 8070c5546f..85c1c45f81 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1218,7 +1218,7 @@ handler if the lock is already held by another process." ;; zero. 16) -(define (set-thread-name name) +(define (set-thread-name!/linux name) "Set the name of the calling thread to NAME. NAME is truncated to 15 bytes." (let ((ptr (string->pointer name))) @@ -1231,7 +1231,7 @@ bytes." (list (strerror err)) (list err)))))) -(define (thread-name) +(define (thread-name/linux) "Return the name of the calling thread as a string." (let ((buf (make-bytevector %max-thread-name-length))) (let-values (((ret err) @@ -1245,6 +1245,16 @@ bytes." (list (strerror err)) (list err)))))) +(define set-thread-name + (if (string-contains %host-type "linux") + set-thread-name!/linux + (const #f))) + +(define thread-name + (if (string-contains %host-type "linux") + thread-name/linux + (const ""))) + ;;; ;;; Network interfaces. @@ -1404,7 +1414,7 @@ bytevector BV at INDEX." (error "unsupported socket address" sockaddr))))) (define write-socket-address! - (if (string-suffix? "linux-gnu" %host-type) + (if (string-contains %host-type "linux-gnu") write-socket-address!/linux write-socket-address!/hurd)) @@ -1436,7 +1446,7 @@ bytevector BV at INDEX." (vector family))))) (define read-socket-address - (if (string-suffix? "linux-gnu" %host-type) + (if (string-contains %host-type "linux-gnu") read-socket-address/linux read-socket-address/hurd)) @@ -2052,8 +2062,8 @@ correspond to a terminal, return the value returned by FALL-BACK." ;; would return EINVAL instead in some cases: ;; <https://bugs.ruby-lang.org/issues/10494>. ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for - ;; that ioctl. - (if (memv errno (list ENOTTY EINVAL ENOSYS)) + ;; that ioctl, and bcachefs returns EPERM. + (if (memv errno (list ENOTTY EINVAL ENOSYS EPERM)) (fall-back) (apply throw args)))))) diff --git a/guix/channels.scm b/guix/channels.scm index f0174de767..84c47fc0d0 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -73,6 +73,7 @@ channel-instances->manifest %channel-profile-hooks channel-instances->derivation + ensure-forward-channel-update profile-channels @@ -212,15 +213,18 @@ result is unspecified." (loop rest))))) (define* (latest-channel-instance store channel - #:key (patches %patches)) - "Return the latest channel instance for CHANNEL." + #:key (patches %patches) + starting-commit) + "Return two values: the latest channel instance for CHANNEL, and its +relation to STARTING-COMMIT when provided." (define (dot-git? file stat) (and (string=? (basename file) ".git") (eq? 'directory (stat:type stat)))) - (let-values (((checkout commit) + (let-values (((checkout commit relation) (update-cached-checkout (channel-url channel) - #:ref (channel-reference channel)))) + #:ref (channel-reference channel) + #:starting-commit starting-commit))) (when (guix-channel? channel) ;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is ;; safe to do because 'switch-to-ref' eventually does a hard reset. @@ -229,12 +233,55 @@ result is unspecified." (let* ((name (url+commit->name (channel-url channel) commit)) (checkout (add-to-store store name #t "sha256" checkout #:select? (negate dot-git?)))) - (channel-instance channel commit checkout)))) - -(define* (latest-channel-instances store channels #:optional (previous-channels '())) + (values (channel-instance channel commit checkout) + relation)))) + +(define (ensure-forward-channel-update channel start instance relation) + "Raise an error if RELATION is not 'ancestor, meaning that START is not an +ancestor of the commit in INSTANCE, unless CHANNEL specifies a commit. + +This procedure implements a channel update policy meant to be used as a +#:validate-pull argument." + (match relation + ('ancestor #t) + ('self #t) + (_ + (raise (make-compound-condition + (condition + (&message (message + (format #f (G_ "\ +aborting update of channel '~a' to commit ~a, which is not a descendant of ~a") + (channel-name channel) + (channel-instance-commit instance) + start)))) + + ;; If the user asked for a specific commit, they might want + ;; that to happen nevertheless, so tell them about the + ;; relevant 'guix pull' option. + (if (channel-commit channel) + (condition + (&fix-hint + (hint (G_ "Use @option{--allow-downgrades} to force +this downgrade.")))) + (condition + (&fix-hint + (hint (G_ "This could indicate that the channel has +been tampered with and is trying to force a roll-back, preventing you from +getting the latest updates. If you think this is not the case, explicitly +allow non-forward updates.")))))))))) + +(define* (latest-channel-instances store channels + #:key + (current-channels '()) + (validate-pull + ensure-forward-channel-update)) "Return a list of channel instances corresponding to the latest checkouts of -CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list -of previously processed channels." +CHANNELS and the channels on which they depend. + +CURRENT-CHANNELS is the list of currently used channels. It is compared +against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called +for each channel update and can choose to emit warnings or raise an error, +depending on the policy it implements." ;; Only process channels that are unique, or that are more specific than a ;; previous channel specification. (define (ignore? channel others) @@ -245,38 +292,53 @@ of previously processed channels." (not (or (channel-commit a) (channel-commit b)))))))) - ;; Accumulate a list of instances. A list of processed channels is also - ;; accumulated to decide on duplicate channel specifications. - (define-values (resulting-channels instances) - (fold2 (lambda (channel previous-channels instances) - (if (ignore? channel previous-channels) - (values previous-channels instances) - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let ((instance (latest-channel-instance store channel))) - (let-values (((new-instances new-channels) - (latest-channel-instances - store - (channel-instance-dependencies instance) - previous-channels))) - (values (append (cons channel new-channels) - previous-channels) - (append (cons instance new-instances) - instances))))))) - previous-channels - '() ;instances - channels)) - - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - resulting-channels))) + (define (current-commit name) + ;; Return the current commit for channel NAME. + (any (lambda (channel) + (and (eq? (channel-name channel) name) + (channel-commit channel))) + current-channels)) + + (let loop ((channels channels) + (previous-channels '())) + ;; Accumulate a list of instances. A list of processed channels is also + ;; accumulated to decide on duplicate channel specifications. + (define-values (resulting-channels instances) + (fold2 (lambda (channel previous-channels instances) + (if (ignore? channel previous-channels) + (values previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let*-values (((current) + (current-commit (channel-name channel))) + ((instance relation) + (latest-channel-instance store channel + #:starting-commit + current))) + (when relation + (validate-pull channel current instance relation)) + + (let-values (((new-instances new-channels) + (loop (channel-instance-dependencies instance) + previous-channels))) + (values (append (cons channel new-channels) + previous-channels) + (append (cons instance new-instances) + instances))))))) + previous-channels + '() ;instances + channels)) + + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + resulting-channels)))) (define* (checkout->channel-instance checkout #:key commit @@ -618,10 +680,20 @@ channel instances." (define latest-channel-instances* (store-lift latest-channel-instances)) -(define* (latest-channel-derivation #:optional (channels %default-channels)) +(define* (latest-channel-derivation #:optional (channels %default-channels) + #:key + (current-channels '()) + (validate-pull + ensure-forward-channel-update)) "Return as a monadic value the derivation that builds the profile for the -latest instances of CHANNELS." - (mlet %store-monad ((instances (latest-channel-instances* channels))) +latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed +to 'latest-channel-instances'." + (mlet %store-monad ((instances + (latest-channel-instances* channels + #:current-channels + current-channels + #:validate-pull + validate-pull))) (channel-instances->derivation instances))) (define (profile-channels profile) diff --git a/guix/combinators.scm b/guix/combinators.scm index 11cad62ccf..4707b59363 100644 --- a/guix/combinators.scm +++ b/guix/combinators.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,7 +57,7 @@ (call-with-values (lambda () (proc (car lst1) (car lst2) result1 result2)) (lambda (result1 result2) - (fold2 proc result1 result2 (cdr lst1) (cdr lst2))))))))) + (loop result1 result2 (cdr lst1) (cdr lst2))))))))) (define (fold-tree proc init children roots) "Call (PROC NODE RESULT) for each node in the tree that is reachable from diff --git a/guix/download.scm b/guix/download.scm index c3dc5a208c..7d6edddbdd 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -141,8 +141,12 @@ "http://www.eu.apache.org/dist/" "http://www.us.apache.org/dist/" "http://apache.belnet.be/" + "http://apache.mirror.iweb.ca/" "http://mirrors.ircam.fr/pub/apache/" + "http://apache.mirrors.ovh.net/ftp.apache.org/dist/" "http://apache-mirror.rbc.ru/pub/apache/" + "ftp://ftp.osuosl.org/pub/apache/" + "http://mirrors.ibiblio.org/apache/" ;; As a last resort, try the archive. "http://archive.apache.org/dist/") diff --git a/guix/gexp.scm b/guix/gexp.scm index 7b3355450b..42a5e7f442 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -51,6 +51,7 @@ local-file-absolute-file-name local-file-name local-file-recursive? + local-file-select? plain-file plain-file? @@ -270,7 +271,9 @@ expand to file names, but it's possible to expand to a plain data type." (if (not expand) (loop lowered (lookup-expander lowered)) (return (expand obj lowered output))) - (return lowered))))))) ;self-quoting + (if (not expand) ;self-quoting + (return lowered) + (return (expand obj lowered output))))))))) (define-syntax define-gexp-compiler (syntax-rules (=> compiler expander) @@ -1440,6 +1443,7 @@ to the source files instead of copying them." #:system system #:guile-for-build guile #:local-build? #t + #:substitutable? #f ;; Avoid deprecation warnings about the use of the _IO* ;; constants in (guix build utils). diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm new file mode 100644 index 0000000000..0d6f696a0b --- /dev/null +++ b/guix/git-authenticate.scm @@ -0,0 +1,334 @@ +;;; GNU Guix --- Functional package management for GNU +;;; 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 git-authenticate) + #:use-module (git) + #:use-module (guix base16) + #:use-module ((guix git) #:select (false-if-git-not-found)) + #:use-module (guix i18n) + #:use-module (guix openpgp) + #:use-module ((guix utils) + #:select (cache-directory with-atomic-file-output)) + #:use-module ((guix build utils) + #:select (mkdir-p)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:autoload (ice-9 pretty-print) (pretty-print) + #:export (read-authorizations + commit-signing-key + commit-authorized-keys + authenticate-commit + authenticate-commits + load-keyring-from-reference + previously-authenticated-commits + cache-authenticated-commit + + git-authentication-error? + git-authentication-error-commit + unsigned-commit-error? + unauthorized-commit-error? + unauthorized-commit-error-signing-key + signature-verification-error? + signature-verification-error-keyring + signature-verification-error-signature + missing-key-error? + missing-key-error-signature)) + +;;; Commentary: +;;; +;;; This module provides tools to authenticate a range of Git commits. A +;;; commit is considered "authentic" if and only if it is signed by an +;;; authorized party. Parties authorized to sign a commit are listed in the +;;; '.guix-authorizations' file of the parent commit. +;;; +;;; Code: + +(define-condition-type &git-authentication-error &error + git-authentication-error? + (commit git-authentication-error-commit)) + +(define-condition-type &unsigned-commit-error &git-authentication-error + unsigned-commit-error?) + +(define-condition-type &unauthorized-commit-error &git-authentication-error + unauthorized-commit-error? + (signing-key unauthorized-commit-error-signing-key)) + +(define-condition-type &signature-verification-error &git-authentication-error + signature-verification-error? + (signature signature-verification-error-signature) + (keyring signature-verification-error-keyring)) + +(define-condition-type &missing-key-error &git-authentication-error + missing-key-error? + (signature missing-key-error-signature)) + + +(define* (commit-signing-key repo commit-id keyring + #:key (disallowed-hash-algorithms '(sha1))) + "Return the OpenPGP key that signed COMMIT-ID (an OID). Raise an exception +if the commit is unsigned, has an invalid signature, has a signature using one +of the hash algorithms in DISALLOWED-HASH-ALGORITHMS, or if its signing key is +not in KEYRING." + (let-values (((signature signed-data) + (catch 'git-error + (lambda () + (commit-extract-signature repo commit-id)) + (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))))))) + + (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, \ +which is not permitted") + (oid->string commit-id) + (openpgp-signature-hash-algorithm + signature))))))) + + (with-fluids ((%default-port-encoding "UTF-8")) + (let-values (((status data) + (verify-openpgp-signature signature keyring + (open-input-string signed-data)))) + (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 \ +for commit ~a") + (oid->string commit-id))))))) + ('missing-key + (raise (condition + (&missing-key-error (commit commit-id) + (signature signature)) + (&message + (message (format #f (G_ "could not authenticate \ +commit ~a: key ~a is missing") + (oid->string commit-id) + data)))))) + ('good-signature data))))))) + +(define (read-authorizations port) + "Read authorizations in the '.guix-authorizations' format from PORT, and +return a list of authorized fingerprints." + (match (read port) + (('authorizations ('version 0) + (((? string? fingerprints) _ ...) ...) + _ ...) + (map (lambda (fingerprint) + (base16-string->bytevector + (string-downcase (string-filter char-set:graphic fingerprint)))) + fingerprints)))) + +(define* (commit-authorized-keys repository commit + #:optional (default-authorizations '())) + "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on +authorizations listed in its parent commits. If one of the parent commits +does not specify anything, fall back to DEFAULT-AUTHORIZATIONS." + (define (parents-have-authorizations-file? commit) + ;; Return true if at least one of the parents of COMMIT has the + ;; '.guix-authorizations' file. + (find (lambda (commit) + (false-if-git-not-found + (tree-entry-bypath (commit-tree commit) + ".guix-authorizations"))) + (commit-parents commit))) + + (define (assert-parents-lack-authorizations commit) + ;; 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 \ +to remove '.guix-authorizations' file") + (oid->string (commit-id commit))))))))) + + (define (commit-authorizations commit) + (catch 'git-error + (lambda () + (let* ((tree (commit-tree commit)) + (entry (tree-entry-bypath tree ".guix-authorizations")) + (blob (blob-lookup repository (tree-entry-id entry)))) + (read-authorizations + (open-bytevector-input-port (blob-content blob))))) + (lambda (key error) + (if (= (git-error-code error) GIT_ENOTFOUND) + (begin + ;; Prevent removal of '.guix-authorizations' since it would make + ;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS. + (assert-parents-lack-authorizations commit) + default-authorizations) + (throw key error))))) + + (match (commit-parents commit) + (() default-authorizations) + (parents + (apply lset-intersection bytevector=? + (map commit-authorizations parents))))) + +(define* (authenticate-commit repository commit keyring + #:key (default-authorizations '())) + "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint. +Raise an error when authentication fails. If one of the parent commits does +not specify anything, fall back to DEFAULT-AUTHORIZATIONS." + (define id + (commit-id commit)) + + (define recent-commit? + (false-if-git-not-found + (tree-entry-bypath (commit-tree commit) ".guix-authorizations"))) + + (define signing-key + (commit-signing-key repository id keyring + ;; Reject SHA1 signatures unconditionally as suggested + ;; by the authors of "SHA-1 is a Shambles" (2019). + ;; Accept it for "historical" commits (there are such + ;; signatures from April 2020 in the repository). + #:disallowed-hash-algorithms + (if recent-commit? '(sha1) '()))) + + (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 \ +key: ~a") + (oid->string id) + (openpgp-format-fingerprint + (openpgp-public-key-fingerprint + signing-key)))))))) + + signing-key) + +(define (load-keyring-from-blob repository oid keyring) + "Augment KEYRING with the keyring available in the blob at OID, which may or +may not be ASCII-armored." + (let* ((blob (blob-lookup repository oid)) + (port (open-bytevector-input-port (blob-content blob)))) + (get-openpgp-keyring (if (port-ascii-armored? port) + (open-bytevector-input-port (read-radix-64 port)) + port) + keyring))) + +(define (load-keyring-from-reference repository reference) + "Load the '.key' files from the tree at REFERENCE in REPOSITORY and return +an OpenPGP keyring." + (let* ((reference (branch-lookup repository reference BRANCH-ALL)) + (target (reference-target reference)) + (commit (commit-lookup repository target)) + (tree (commit-tree commit))) + (fold (lambda (name keyring) + (if (string-suffix? ".key" name) + (let ((entry (tree-entry-bypath tree name))) + (load-keyring-from-blob repository + (tree-entry-id entry) + keyring)) + keyring)) + %empty-keyring + (tree-list tree)))) + +(define* (authenticate-commits repository commits + #:key + (default-authorizations '()) + (keyring-reference "keyring") + (report-progress (const #t))) + "Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for +each of them. Return an alist showing the number of occurrences of each key. +The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY." + (define keyring + (load-keyring-from-reference repository keyring-reference)) + + (fold (lambda (commit stats) + (report-progress) + (let ((signer (authenticate-commit repository commit keyring + #:default-authorizations + default-authorizations))) + (match (assq signer stats) + (#f (cons `(,signer . 1) stats)) + ((_ . count) (cons `(,signer . ,(+ count 1)) + (alist-delete signer stats)))))) + '() + commits)) + + +;;; +;;; Caching. +;;; + +(define (authenticated-commit-cache-file) + "Return the name of the file that contains the cache of +previously-authenticated commits." + (string-append (cache-directory) "/authentication/channels/guix")) + +(define (previously-authenticated-commits) + "Return the previously-authenticated commits as a list of commit IDs (hex +strings)." + (catch 'system-error + (lambda () + (call-with-input-file (authenticated-commit-cache-file) + read)) + (lambda args + (if (= ENOENT (system-error-errno args)) + '() + (apply throw args))))) + +(define (cache-authenticated-commit commit-id) + "Record in ~/.cache COMMIT-ID and its closure as authenticated (only +COMMIT-ID is written to cache, though)." + (define %max-cache-length + ;; Maximum number of commits in cache. + 200) + + (let ((lst (delete-duplicates + (cons commit-id (previously-authenticated-commits)))) + (file (authenticated-commit-cache-file))) + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (port) + (let ((lst (if (> (length lst) %max-cache-length) + (take lst %max-cache-length) ;truncate + lst))) + (chmod port #o600) + (display ";; List of previously-authenticated commits.\n\n" + port) + (pretty-print lst port)))))) diff --git a/guix/git.scm b/guix/git.scm index 92121156cf..0d8e617cc9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -39,10 +39,12 @@ honor-system-x509-certificates! with-repository + false-if-git-not-found update-cached-checkout url+commit->name latest-repository-commit commit-difference + commit-relation git-checkout git-checkout? @@ -242,18 +244,23 @@ Return true on success, false on failure." (G_ "Support for submodules is missing; \ please upgrade Guile-Git.~%")))) +(define-syntax-rule (false-if-git-not-found exp) + "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised." + (catch 'git-error + (lambda () + exp) + (lambda (key error . rest) + (if (= GIT_ENOTFOUND (git-error-code error)) + #f + (apply throw key error rest))))) + (define (reference-available? repository ref) "Return true if REF, a reference such as '(commit . \"cabba9e\"), is definitely available in REPOSITORY, false otherwise." (match ref (('commit . commit) - (catch 'git-error - (lambda () - (->bool (commit-lookup repository (string->oid commit)))) - (lambda (key error . rest) - (if (= GIT_ENOTFOUND (git-error-code error)) - #f - (apply throw key error rest))))) + (false-if-git-not-found + (->bool (commit-lookup repository (string->oid commit))))) (_ #f))) @@ -261,14 +268,16 @@ definitely available in REPOSITORY, false otherwise." #:key (ref '(branch . "master")) recursive? + starting-commit (log-port (%make-void-port "w")) (cache-directory (url-cache-directory url (%repository-cache-directory) #:recursive? recursive?))) - "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two + "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return three values: the cache directory name, and the SHA1 commit (a string) corresponding -to REF. +to REF, and the relation of the new commit relative to STARTING-COMMIT (if +provided) as returned by 'commit-relation'. REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value the associated data: [<branch name> | <sha1> | <tag name> | <string>]. @@ -301,7 +310,20 @@ When RECURSIVE? is true, check out submodules as well, if any." (remote-fetch (remote-lookup repository "origin")))) (when recursive? (update-submodules repository #:log-port log-port)) - (let ((oid (switch-to-ref repository canonical-ref))) + + ;; Note: call 'commit-relation' from here because it's more efficient + ;; than letting users re-open the checkout later on. + (let* ((oid (switch-to-ref repository canonical-ref)) + (new (and starting-commit + (commit-lookup repository oid))) + (old (and starting-commit + (false-if-git-not-found + (commit-lookup repository + (string->oid starting-commit))))) + (relation (and starting-commit + (if old + (commit-relation old new) + 'unrelated)))) ;; Reclaim file descriptors and memory mappings associated with ;; REPOSITORY as soon as possible. @@ -309,7 +331,7 @@ When RECURSIVE? is true, check out submodules as well, if any." 'repository-close!) (repository-close! repository)) - (values cache-directory (oid->string oid)))))) + (values cache-directory (oid->string oid) relation))))) (define* (latest-repository-commit store url #:key @@ -342,7 +364,7 @@ Log progress and checkout info to LOG-PORT." (format log-port "updating checkout of '~a'...~%" url) (let*-values - (((checkout commit) + (((checkout commit _) (update-cached-checkout url #:recursive? recursive? #:ref ref @@ -394,7 +416,9 @@ Essentially, this computes the set difference between the closure of NEW and that of OLD." (let loop ((commits (list new)) (result '()) - (visited (commit-closure old (list->setq excluded)))) + (visited (fold commit-closure + (setq) + (cons old excluded)))) (match commits (() (reverse result)) @@ -405,6 +429,21 @@ that of OLD." (cons head result) (set-insert head visited))))))) +(define (commit-relation old new) + "Return a symbol denoting the relation between OLD and NEW, two commit +objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or +'unrelated, or 'self (OLD and NEW are the same commit)." + (if (eq? old new) + 'self + (let ((newest (commit-closure new))) + (if (set-contains? newest old) + 'ancestor + (let* ((seen (list->setq (commit-parents new))) + (oldest (commit-closure old seen))) + (if (set-contains? oldest new) + 'descendant + 'unrelated)))))) + ;;; ;;; Checkouts. diff --git a/guix/grafts.scm b/guix/grafts.scm index 69d6fe4469..910dcadc8a 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -20,10 +20,12 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix records) + #:use-module (guix combinators) #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (guix sets) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -183,32 +185,47 @@ references." (set-current-state (vhash-cons key result cache)) (return result))))))) -(define (reference-origin drv item) - "Return the derivation/output pair among the inputs of DRV, recursively, -that produces ITEM. Return #f if ITEM is not produced by a derivation (i.e., -it's a content-addressed \"source\"), or if it's not produced by a dependency -of DRV." +(define (reference-origins drv items) + "Return the derivation/output pairs among the inputs of DRV, recursively, +that produce ITEMS. Elements of ITEMS not produced by a derivation (i.e., +it's a content-addressed \"source\"), or not produced by a dependency of DRV, +have no corresponding element in the resulting list." + (define (lookup-derivers drv result items) + ;; Return RESULT augmented by all the drv/output pairs producing one of + ;; ITEMS, and ITEMS stripped of matching items. + (fold2 (match-lambda* + (((output . file) result items) + (if (member file items) + (values (alist-cons drv output result) + (delete file items)) + (values result items)))) + result items + (derivation->output-paths drv))) + ;; Perform a breadth-first traversal of the dependency graph of DRV in - ;; search of the derivation that produces ITEM. + ;; search of the derivations that produce ITEMS. (let loop ((drv (list drv)) + (items items) + (result '()) (visited (setq))) (match drv (() - #f) + result) ((drv . rest) - (if (set-contains? visited drv) - (loop rest visited) - (let ((inputs (derivation-inputs drv))) - (or (any (lambda (input) - (let ((drv (derivation-input-derivation input))) - (any (match-lambda - ((output . file) - (and (string=? file item) - (cons drv output)))) - (derivation->output-paths drv)))) - inputs) - (loop (append rest (map derivation-input-derivation inputs)) - (set-insert drv visited))))))))) + (cond ((null? items) + result) + ((set-contains? visited drv) + (loop rest items result visited)) + (else + (let*-values (((inputs) + (map derivation-input-derivation + (derivation-inputs drv))) + ((result items) + (fold2 lookup-derivers + result items inputs))) + (loop (append rest inputs) + items result + (set-insert drv visited))))))))) (define* (cumulative-grafts store drv grafts #:key @@ -233,25 +250,27 @@ derivations to the corresponding set of grafts." (_ #f))) - (define (dependency-grafts item) - (match (reference-origin drv item) - ((drv . output) - ;; If GRAFTS already contains a graft from DRV, do not override it. - (if (find (cut graft-origin? drv <>) grafts) - (state-return grafts) - (cumulative-grafts store drv grafts - #:outputs (list output) - #:guile guile - #:system system))) - (#f - (state-return grafts)))) + (define (dependency-grafts items) + (mapm %store-monad + (lambda (drv+output) + (match drv+output + ((drv . output) + ;; If GRAFTS already contains a graft from DRV, do not + ;; override it. + (if (find (cut graft-origin? drv <>) grafts) + (state-return grafts) + (cumulative-grafts store drv grafts + #:outputs (list output) + #:guile guile + #:system system))))) + (reference-origins drv items))) (with-cache (cons (derivation-file-name drv) outputs) (match (non-self-references store drv outputs) (() ;no dependencies (return grafts)) (deps ;one or more dependencies - (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) + (mlet %state-monad ((grafts (dependency-grafts deps))) (let ((grafts (delete-duplicates (concatenate grafts) equal?))) (match (filter (lambda (graft) (member (graft-origin-file-name graft) deps)) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index ad66a644ee..b822fbc0ae 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -141,9 +141,9 @@ package definition." (define %cran-url "https://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.10. Bioconductor packages should be +;; The latest Bioconductor release is 3.11. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.10") +(define %bioconductor-version "3.11") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/opam.scm b/guix/import/opam.scm index ae7df8a8b5..9cda3da006 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -115,7 +115,7 @@ (define (get-opam-repository) "Update or fetch the latest version of the opam repository and return the path to the repository." - (receive (location commit) + (receive (location commit _) (update-cached-checkout "https://github.com/ocaml/opam-repository") location)) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 14150201b5..e04073d193 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -122,7 +122,7 @@ included in the Stackage LTS release." (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch))))) (lambda* (package) "Return an <upstream-source> for the latest Stackage LTS release of -PACKAGE or #f it the package is not inlucded in the Stackage LTS release." +PACKAGE or #f if the package is not included in the Stackage LTS release." (let* ((hackage-name (guix-package->hackage-name package)) (version (lts-package-version (pkgs-info) hackage-name)) (name-version (hackage-name-version hackage-name version))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 3809c3d074..0cfa1f8321 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -24,7 +24,7 @@ (define-module (guix import utils) #:use-module (guix base32) #:use-module ((guix build download) #:prefix build:) - #:use-module (gcrypt hash) + #:use-module ((gcrypt hash) #:hide (sha256)) #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) diff --git a/guix/lint.scm b/guix/lint.scm index e192f292a4..fa507546f5 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,8 @@ #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix memoization) + #:use-module (guix profiles) + #:use-module (guix monads) #:use-module (guix scripts) #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) #:use-module (guix gnu-maintenance) @@ -83,6 +86,7 @@ check-for-updates check-formatting check-archival + check-profile-collisions lint-warning lint-warning? @@ -669,13 +673,17 @@ patch could not be found." (or (and=> (package-source package) origin-patches) '())) + (define (starts-with-package-name? file-name) + (and=> (string-contains file-name (package-name package)) + zero?)) + (append (if (every (match-lambda ;patch starts with package name? ((? string? patch) - (and=> (string-contains (basename patch) - (package-name package)) - zero?)) - (_ #f)) ;must be an <origin> or something like that. + (starts-with-package-name? (basename patch))) + ((? origin? patch) + (starts-with-package-name? (origin-actual-file-name patch))) + (_ #f)) ;must be some other file-like object patches) '() (list @@ -965,6 +973,38 @@ descriptions maintained upstream." (with-store store (check-with-store store)))) +(define* (check-profile-collisions package #:key store) + "Check for collisions that would occur when installing PACKAGE as a result +of the propagated inputs it pulls in." + (define (do-check store) + (guard (c ((profile-collision-error? c) + (let ((first (profile-collision-error-entry c)) + (second (profile-collision-error-conflict c))) + (define format + (if (string=? (manifest-entry-version first) + (manifest-entry-version second)) + manifest-entry-item + (lambda (entry) + (string-append (manifest-entry-name entry) "@" + (manifest-entry-version entry))))) + + (list (make-warning package + (G_ "propagated inputs ~a and ~a collide") + (list (format first) + (format second))))))) + ;; Disable grafts to avoid building PACKAGE and its dependencies. + (parameterize ((%graft? #f)) + (run-with-store store + (mbegin %store-monad + (check-for-collisions (packages->manifest (list package)) + (%current-system)) + (return '())))))) + + (if store + (do-check store) + (with-store store + (do-check store)))) + (define (check-license package) "Warn about type errors of the 'license' field of PACKAGE." (match (package-license package) @@ -1154,15 +1194,18 @@ try again later") ((? origin? origin) ;; Since "save" origins are not supported for non-VCS source, all ;; we can do is tell whether a given tarball is available or not. - (if (origin-sha256 origin) ;XXX: for ungoogled-chromium - (match (lookup-content (origin-sha256 origin) "sha256") - (#f - (list (make-warning package - (G_ "source not archived on Software \ + (if (origin-hash origin) ;XXX: for ungoogled-chromium + (let ((hash (origin-hash origin))) + (match (lookup-content (content-hash-value hash) + (symbol->string + (content-hash-algorithm hash))) + (#f + (list (make-warning package + (G_ "source not archived on Software \ Heritage") - #:field 'source))) - ((? content?) - '())) + #:field 'source))) + ((? content?) + '()))) '())))) (match-lambda* ((key url method response) @@ -1342,6 +1385,11 @@ or a list thereof") (check check-derivation) (requires-store? #t)) (lint-checker + (name 'profile-collisions) + (description "Report collisions that would occur due to propagated inputs") + (check check-profile-collisions) + (requires-store? #t)) + (lint-checker (name 'patch-file-names) (description "Validate file names and availability of patches") (check check-patch-file-names)) diff --git a/guix/packages.scm b/guix/packages.scm index 3fff50a6e8..1e0ec41b76 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,12 +28,15 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix base32) + #:autoload (guix base64) (base64-decode) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix memoization) #:use-module (guix build-system) #:use-module (guix search-paths) #:use-module (guix sets) + #:use-module (guix deprecation) + #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 regex) @@ -43,16 +46,23 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (web uri) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience - #:export (origin + #:export (content-hash + content-hash? + content-hash-algorithm + content-hash-value + + origin origin? this-origin origin-uri origin-method - origin-sha256 + origin-hash + origin-sha256 ;deprecated origin-file-name origin-actual-file-name origin-patches @@ -62,6 +72,7 @@ origin-snippet origin-modules base32 + base64 package package? @@ -155,15 +166,79 @@ ;;; ;;; Code: +;; Crytographic content hash. +(define-immutable-record-type <content-hash> + (%content-hash algorithm value) + content-hash? + (algorithm content-hash-algorithm) ;symbol + (value content-hash-value)) ;bytevector + +(define-syntax-rule (define-content-hash-constructor name + (algorithm size) ...) + "Define NAME as a <content-hash> constructor that ensures that (1) its +second argument is among the listed ALGORITHM, and (2), when possible, that +its first argument has the right size for the chosen algorithm." + (define-syntax name + (lambda (s) + (syntax-case s (algorithm ...) + ((_ bv algorithm) + (let ((bv* (syntax->datum #'bv))) + (when (and (bytevector? bv*) + (not (= size (bytevector-length bv*)))) + (syntax-violation 'content-hash "invalid content hash length" s)) + #'(%content-hash 'algorithm bv))) + ...)))) + +(define-content-hash-constructor build-content-hash + (sha256 32) + (sha512 64)) + +(define-syntax content-hash + (lambda (s) + "Return a content hash with the given parameters. The default hash +algorithm is sha256. If the first argument is a literal string, it is decoded +as base32. Otherwise, it must be a bytevector." + ;; What we'd really want here is something like C++ 'constexpr'. + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + #'(content-hash str sha256)) + ((_ str algorithm) + (string? (syntax->datum #'str)) + (with-syntax ((bv (base32 (syntax->datum #'str)))) + #'(content-hash bv algorithm))) + ((_ (id str) algorithm) + (and (string? (syntax->datum #'str)) + (free-identifier=? #'id #'base32)) + (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str)))) + #'(content-hash bv algorithm))) + ((_ (id str) algorithm) + (and (string? (syntax->datum #'str)) + (free-identifier=? #'id #'base64)) + (with-syntax ((bv (base64-decode (syntax->datum #'str)))) + #'(content-hash bv algorithm))) + ((_ bv) + #'(content-hash bv sha256)) + ((_ bv hash) + #'(build-content-hash bv hash))))) + +(define (print-content-hash hash port) + (format port "#<content-hash ~a:~a>" + (content-hash-algorithm hash) + (bytevector->nix-base32-string (content-hash-value hash)))) + +(set-record-type-printer! <content-hash> print-content-hash) + + ;; The source of a package, such as a tarball URL and fetcher---called ;; "origin" to avoid name clash with `package-source', `source', etc. (define-record-type* <origin> - origin make-origin + %origin make-origin origin? this-origin (uri origin-uri) ; string (method origin-method) ; procedure - (sha256 origin-sha256) ; bytevector + (hash origin-hash) ; <content-hash> (file-name origin-file-name (default #f)) ; optional file name ;; Patches are delayed so that the 'search-patch' calls are made lazily, @@ -186,30 +261,60 @@ (patch-guile origin-patch-guile ; package or #f (default #f))) +(define-syntax origin-compatibility-helper + (syntax-rules (sha256) + ((_ () (fields ...)) + (%origin fields ...)) + ((_ ((sha256 exp) rest ...) (others ...)) + (%origin others ... + (hash (content-hash exp sha256)) + rest ...)) + ((_ (field rest ...) (others ...)) + (origin-compatibility-helper (rest ...) + (others ... field))))) + +(define-syntax-rule (origin fields ...) + "Build an <origin> record, automatically converting 'sha256' field +specifications to 'hash'." + (origin-compatibility-helper (fields ...) ())) + +(define-deprecated (origin-sha256 origin) + origin-hash + (let ((hash (origin-hash origin))) + (unless (eq? (content-hash-algorithm hash) 'sha256) + (raise (condition (&message + (message (G_ "no SHA256 hash for origin")))))) + (content-hash-value hash))) + (define (print-origin origin port) "Write a concise representation of ORIGIN to PORT." (match origin - (($ <origin> uri method sha256 file-name patches) + (($ <origin> uri method hash file-name patches) (simple-format port "#<origin ~s ~a ~s ~a>" - uri (bytevector->base32-string sha256) + uri hash (force patches) (number->string (object-address origin) 16))))) (set-record-type-printer! <origin> print-origin) -(define-syntax base32 - (lambda (s) - "Return the bytevector corresponding to the given Nix-base32 +(define-syntax-rule (define-compile-time-decoder name string->bytevector) + "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time +if possible." + (define-syntax name + (lambda (s) + "Return the bytevector corresponding to the given textual representation." - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) - ;; A literal string: do the conversion at expansion time. - (with-syntax ((bv (nix-base32-string->bytevector - (syntax->datum #'str)))) - #''bv)) - ((_ str) - #'(nix-base32-string->bytevector str))))) + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (with-syntax ((bv (string->bytevector (syntax->datum #'str)))) + #''bv)) + ((_ str) + #'(string->bytevector str)))))) + +(define-compile-time-decoder base32 nix-base32-string->bytevector) +(define-compile-time-decoder base64 base64-decode) (define (origin-actual-file-name origin) "Return the file name of ORIGIN, either its 'file-name' field or the file @@ -231,6 +336,7 @@ name of its URI." ;; git, svn, cvs, etc. reference #f)))) + (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. @@ -1088,39 +1194,39 @@ and return it." (make-weak-key-hash-table 200)) (define (input-graft store system) - "Return a procedure that, given a package with a graft, returns a graft, and -#f otherwise." - (match-lambda - ((? package? package) + "Return a procedure that, given a package with a replacement and an output name, +returns a graft, and #f otherwise." + (match-lambda* + (((? package? package) output) (let ((replacement (package-replacement package))) (and replacement - (cached (=> %graft-cache) package system + (cached (=> %graft-cache) package (cons output system) (let ((orig (package-derivation store package system #:graft? #f)) (new (package-derivation store replacement system #:graft? #t))) (graft (origin orig) - (replacement new))))))) - (x - #f))) + (origin-output output) + (replacement new) + (replacement-output output))))))))) (define (input-cross-graft store target system) "Same as 'input-graft', but for cross-compilation inputs." - (match-lambda - ((? package? package) - (let ((replacement (package-replacement package))) - (and replacement - (let ((orig (package-cross-derivation store package target system - #:graft? #f)) - (new (package-cross-derivation store replacement - target system - #:graft? #t))) - (graft - (origin orig) - (replacement new)))))) - (_ - #f))) + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (and replacement + (let ((orig (package-cross-derivation store package target system + #:graft? #f)) + (new (package-cross-derivation store replacement + target system + #:graft? #t))) + (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))))))) (define* (fold-bag-dependencies proc seed bag #:key (native? #t)) @@ -1137,26 +1243,21 @@ dependencies; otherwise, restrict to target dependencies." (bag-host-inputs bag)))) bag-host-inputs)) - (define nodes - (match (bag-direct-inputs* bag) - (((labels things _ ...) ...) - things))) - - (let loop ((nodes nodes) + (let loop ((inputs (bag-direct-inputs* bag)) (result seed) - (visited (setq))) - (match nodes + (visited vlist-null)) + (match inputs (() result) - (((? package? head) . tail) - (if (set-contains? visited head) - (loop tail result visited) - (let ((inputs (bag-direct-inputs* (package->bag head)))) - (loop (match inputs - (((labels things _ ...) ...) - (append things tail))) - (proc head result) - (set-insert head visited))))) + (((label (? package? head) . rest) . tail) + (let ((output (match rest (() "out") ((output) output))) + (outputs (vhash-foldq* cons '() head visited))) + (if (member output outputs) + (loop tail result visited) + (let ((inputs (bag-direct-inputs* (package->bag head)))) + (loop (append inputs tail) + (proc head output result) + (vhash-consq head output visited)))))) ((head . tail) (loop tail result visited))))) @@ -1171,23 +1272,27 @@ to (see 'graft-derivation'.)" (define native-grafts (let ((->graft (input-graft store system))) - (fold-bag-dependencies (lambda (package grafts) - (match (->graft package) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag))) + (parameterize ((%current-system system) + (%current-target-system #f)) + (fold-bag-dependencies (lambda (package output grafts) + (match (->graft package output) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag)))) (define target-grafts (if target (let ((->graft (input-cross-graft store target system))) - (fold-bag-dependencies (lambda (package grafts) - (match (->graft package) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag - #:native? #f)) + (parameterize ((%current-system system) + (%current-target-system target)) + (fold-bag-dependencies (lambda (package output grafts) + (match (->graft package output) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag + #:native? #f))) '())) ;; We can end up with several identical grafts if we stumble upon packages @@ -1381,14 +1486,19 @@ unless you know what you are doing." #:optional (system (%current-system))) "Return the derivation corresponding to ORIGIN." (match origin - (($ <origin> uri method sha256 name (= force ()) #f) + (($ <origin> uri method hash name (= force ()) #f) ;; No patches, no snippet: this is a fixed-output derivation. - (method uri 'sha256 sha256 name #:system system)) - (($ <origin> uri method sha256 name (= force (patches ...)) snippet + (method uri + (content-hash-algorithm hash) + (content-hash-value hash) + name #:system system)) + (($ <origin> uri method hash name (= force (patches ...)) snippet (flags ...) inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. - (mlet %store-monad ((source (method uri 'sha256 sha256 name - #:system system)) + (mlet %store-monad ((source (method uri + (content-hash-algorithm hash) + (content-hash-value hash) + name #:system system)) (guile (package->derivation (or guile-for-build (default-guile)) system diff --git a/guix/profiles.scm b/guix/profiles.scm index 25ff146bdf..9df63c97e9 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -41,7 +41,6 @@ #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix store) - #:use-module (guix sets) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -105,6 +104,7 @@ manifest-installed? manifest-matching-entries manifest-search-paths + check-for-collisions manifest-transaction manifest-transaction? @@ -260,17 +260,17 @@ field." recursively." (let loop ((entries (manifest-entries manifest)) (result '()) - (visited (set))) ;compare with 'equal?' + (visited vlist-null)) ;compare with 'manifest-entry=?' (match entries (() (reverse result)) ((head . tail) - (if (set-contains? visited head) + (if (vhash-assoc head visited manifest-entry=?) (loop tail result visited) (loop (append (manifest-entry-dependencies head) tail) (cons head result) - (set-insert head visited))))))) + (vhash-cons head #t visited))))))) (define (profile-manifest profile) "Return the PROFILE's manifest." diff --git a/guix/quirks.scm b/guix/quirks.scm index d180bd2c09..d292f4e932 100644 --- a/guix/quirks.scm +++ b/guix/quirks.scm @@ -57,6 +57,18 @@ #f (apply throw args))))) +(define (requires-guile-2.2? source) + "Return true if SOURCE uses Guile 2.2 for the shebang of +'compute-guix-derivation'." + (define content + (call-with-input-file (string-append source "/" %self-build-file) + read-string)) + + ;; The 'find-best-packages-by-name' call is inserted by %BUG-41214-PATCH. + (string-contains content + (object->string + '(find-best-packages-by-name "guile" "2.2")))) + (define (guile-2.2.4) (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2.4)) @@ -66,7 +78,8 @@ ;; about specific Guile versions that old Guix revisions might need to use ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See ;; <https://bugs.gnu.org/37506> - `((,syscalls-reexports-local-variables? . ,guile-2.2.4))) + `((,syscalls-reexports-local-variables? . ,guile-2.2.4) + (,requires-guile-2.2? . ,guile-2.2.4))) ;;; @@ -143,6 +156,7 @@ corresponds to the given Guix COMMIT, a SHA1 hexadecimal string." (define (build-with-guile-2.2 source) (substitute* (string-append source "/" %self-build-file) (("\\(default-guile\\)") + ;; Note: This goes hand in hand with the 'requires-guile-2.2?' quirk. (object->string '(car (find-best-packages-by-name "guile" "2.2")))) (("\\(find-best-packages-by-name \"guile-gcrypt\" #f\\)") (object->string '(find-best-packages-by-name "guile2.2-gcrypt" #f)))) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index f13f221da9..7a2dbc453a 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,14 +42,26 @@ ;;; ;;; Command-line options. ;;; +(define %available-formats '("human" "channels" "json" "recutils")) + +(define (list-formats) + (display (G_ "The available formats are:\n")) + (newline) + (for-each (lambda (f) + (format #t " - ~a~%" f)) + %available-formats)) (define %options ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels" "json" "recutils")) + (unless (member arg %available-formats) (leave (G_ "~a: unsupported output format~%") arg)) (alist-cons 'format (string->symbol arg) result))) + (option '("list-formats") #f #f + (lambda (opt name arg result) + (list-formats) + (exit 0))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) @@ -71,6 +84,8 @@ Display information about the channels currently in use.\n")) (display (G_ " -f, --format=FORMAT display information in the given FORMAT")) (display (G_ " + --list-formats display available formats")) + (display (G_ " -p, --profile=PROFILE display information about PROFILE")) (newline) (display (G_ " diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 22cd75ea0b..589f62da9d 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module (gcrypt hash) #:use-module (guix base16) #:use-module (guix base32) + #:autoload (guix base64) (base64-encode) #:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix build download) #:select (url-fetch)) @@ -77,19 +78,23 @@ (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) + (hash-algorithm . ,(hash-algorithm sha256)) (verify-certificate? . #t) (download-proc . ,download-to-store*))) (define (show-help) (display (G_ "Usage: guix download [OPTION] URL Download the file at URL to the store or to the given file, and print its -file name and the hash of its contents. - -Supported formats: 'nix-base32' (default), 'base32', and 'base16' -('hex' and 'hexadecimal' can be used as well).\n")) +file name and the hash of its contents.\n")) + (newline) + (display (G_ "\ +Supported formats: 'base64', 'nix-base32' (default), 'base32', +and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (G_ " -f, --format=FMT write the hash in the given format")) (format #t (G_ " + -H, --hash=ALGORITHM use the given hash ALGORITHM")) + (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) (format #t (G_ " @@ -108,6 +113,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (lambda (opt name arg result) (define fmt-proc (match arg + ("base64" + base64-encode) ("nix-base32" bytevector->nix-base32-string) ("base32" @@ -119,6 +126,13 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (alist-cons 'format fmt-proc (alist-delete 'format result)))) + (option '(#\H "hash") #t #f + (lambda (opt name arg result) + (match (lookup-hash-algorithm (string->symbol arg)) + (#f + (leave (G_ "~a: unknown hash algorithm~%") arg)) + (algo + (alist-cons 'hash-algorithm algo result))))) (option '("no-check-certificate") #f #f (lambda (opt name arg result) (alist-cons 'verify-certificate? #f result))) @@ -175,7 +189,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (or path (leave (G_ "~a: download failed~%") arg)) - port-sha256)) + (cute port-hash (assoc-ref opts 'hash-algorithm) <>))) (fmt (assq-ref opts 'format))) (format #t "~a~%~a~%" path (fmt hash)) #t))) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index b8b2158195..9b4f419a24 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> @@ -20,12 +20,13 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts hash) - #:use-module (guix base32) #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix base16) + #:use-module (guix base32) + #:autoload (guix base64) (base64-encode) #:use-module (ice-9 binary-ports) #:use-module (rnrs files) #:use-module (ice-9 match) @@ -42,17 +43,21 @@ (define %default-options ;; Alist of default option values. - `((format . ,bytevector->nix-base32-string))) + `((format . ,bytevector->nix-base32-string) + (hash-algorithm . ,(hash-algorithm sha256)))) (define (show-help) (display (G_ "Usage: guix hash [OPTION] FILE -Return the cryptographic hash of FILE. - -Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' -and 'hexadecimal' can be used as well).\n")) +Return the cryptographic hash of FILE.\n")) + (newline) + (display (G_ "\ +Supported formats: 'base64', 'nix-base32' (default), 'base32', +and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (G_ " -x, --exclude-vcs exclude version control directories")) (format #t (G_ " + -H, --hash=ALGORITHM use the given hash ALGORITHM")) + (format #t (G_ " -f, --format=FMT write the hash in the given format")) (format #t (G_ " -r, --recursive compute the hash on FILE recursively")) @@ -69,10 +74,19 @@ and 'hexadecimal' can be used as well).\n")) (list (option '(#\x "exclude-vcs") #f #f (lambda (opt name arg result) (alist-cons 'exclude-vcs? #t result))) + (option '(#\H "hash") #t #f + (lambda (opt name arg result) + (match (lookup-hash-algorithm (string->symbol arg)) + (#f + (leave (G_ "~a: unknown hash algorithm~%") arg)) + (algo + (alist-cons 'hash-algorithm algo result))))) (option '(#\f "format") #t #f (lambda (opt name arg result) (define fmt-proc (match arg + ("base64" + base64-encode) ("nix-base32" bytevector->nix-base32-string) ("base32" @@ -139,8 +153,11 @@ and 'hexadecimal' can be used as well).\n")) (force-output port) (get-hash)) (match file - ("-" (port-sha256 (current-input-port))) - (_ (call-with-input-file file port-sha256)))))) + ("-" (port-hash (assoc-ref opts 'hash-algorithm) + (current-input-port))) + (_ (call-with-input-file file + (cute port-hash (assoc-ref opts 'hash-algorithm) + <>))))))) (match args ((file) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a69efa365e..1246147798 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -675,12 +675,13 @@ doesn't need it." (define (process-query opts) "Process any query specified by OPTS. Return #t when a query was actually processed, #f otherwise." - (let* ((profiles (match (filter-map (match-lambda - (('profile . p) p) - (_ #f)) - opts) - (() (list %current-profile)) - (lst (reverse lst)))) + (let* ((profiles (delete-duplicates + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) (profile (match profiles ((head tail ...) head)))) (match (assoc-ref opts 'query) @@ -718,7 +719,8 @@ processed, #f otherwise." (('list-installed regexp) (let* ((regexp (and regexp (make-regexp* regexp regexp/icase))) - (manifest (profile-manifest profile)) + (manifest (concatenate-manifests + (map profile-manifest profiles))) (installed (manifest-entries manifest))) (leave-on-EPIPE (for-each (match-lambda @@ -729,8 +731,8 @@ processed, #f otherwise." name (or version "?") output path)))) ;; Show most recently installed packages last. - (reverse installed))) - #t)) + (reverse installed)))) + #t) (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp regexp/icase))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index f5b2f5fd4e..a00f08f9d9 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -851,6 +851,7 @@ blocking." size) client)) (output (response-port response))) + (setsockopt client SOL_SOCKET SO_SNDBUF (* 128 1024)) (if (file-port? output) (sendfile output input size) (dump-port input output)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index dfe7ee7ad5..c386d81b8e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -81,7 +81,8 @@ (multiplexed-build-output? . #t) (graft? . #t) (debug . 0) - (verbosity . 1))) + (verbosity . 1) + (validate-pull . ,ensure-forward-channel-update))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... @@ -95,6 +96,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) (display (G_ " + --allow-downgrades allow downgrades to earlier channel revisions")) + (display (G_ " -N, --news display news compared to the previous generation")) (display (G_ " -l, --list-generations[=PATTERN] @@ -158,6 +161,10 @@ Download and deploy the latest version of Guix.\n")) (option '("branch") #t #f (lambda (opt name arg result) (alist-cons 'ref `(branch . ,arg) result))) + (option '("allow-downgrades") #f #f + (lambda (opt name arg result) + (alist-cons 'validate-pull warn-about-backward-updates + result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) @@ -188,6 +195,21 @@ Download and deploy the latest version of Guix.\n")) %standard-build-options)) +(define (warn-about-backward-updates channel start instance relation) + "Warn about non-forward updates of CHANNEL from START to INSTANCE, without +aborting." + (match relation + ((or 'ancestor 'self) + #t) + ('descendant + (warning (G_ "rolling back channel '~a' from ~a to ~a~%") + (channel-name channel) start + (channel-instance-commit instance))) + ('unrelated + (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%") + (channel-name channel) start + (channel-instance-commit instance))))) + (define* (display-profile-news profile #:key concise? current-is-newer?) "Display what's up in PROFILE--new packages, and all that. If @@ -749,7 +771,9 @@ Use '~/.config/guix/channels.scm' instead.")) (substitutes? (assoc-ref opts 'substitutes?)) (dry-run? (assoc-ref opts 'dry-run?)) (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) %current-profile))) + (profile (or (assoc-ref opts 'profile) %current-profile)) + (current-channels (profile-channels profile)) + (validate-pull (assoc-ref opts 'validate-pull))) (cond ((assoc-ref opts 'query) (process-query opts profile)) ((assoc-ref opts 'generation) @@ -766,7 +790,12 @@ Use '~/.config/guix/channels.scm' instead.")) (ensure-default-profile) (honor-x509-certificates store) - (let ((instances (latest-channel-instances store channels))) + (let ((instances + (latest-channel-instances store channels + #:current-channels + current-channels + #:validate-pull + validate-pull))) (format (current-error-port) (N_ "Building from this channel:~%" "Building from these channels:~%" diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 2446b84587..c42f4f7782 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -230,8 +230,8 @@ the name of a PNG file." ;;; (define (show-help) - (display (G_ "Usage: guix size [OPTION]... PACKAGE -Report the size of PACKAGE and its dependencies.\n")) + (display (G_ "Usage: guix size [OPTION]... PACKAGE|STORE-ITEM +Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3efd113ac8..6769a602b1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -670,7 +671,7 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os action +(define* (system-derivation-for-action os base-image action #:key image-size file-system-type full-boot? container-shared-network? mappings) @@ -694,11 +695,12 @@ checking this by themselves in their 'check' procedure." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (system-image - (image - (inherit (find-image file-system-type)) - (size image-size) - (operating-system os)))) + (lower-object + (system-image + (image + (inherit base-image) + (size image-size) + (operating-system os))))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?)))) @@ -800,7 +802,9 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((sys (system-derivation-for-action os action + ((target (current-target-system)) + (image -> (find-image file-system-type target)) + (sys (system-derivation-for-action os image action #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? diff --git a/guix/self.scm b/guix/self.scm index a9568049b2..60fe6e6b01 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -213,7 +213,15 @@ record with the new file name." ;; itself. (local-file (string-append item "/" file) #:recursive? recursive?)) - ;; TODO: Add 'local-file?' case. + ((? local-file? base) + ;; Likewise, but with a <local-file>. + (if (local-file-recursive? base) + (local-file (string-append (local-file-absolute-file-name base) + "/" file) + (basename file) + #:recursive? recursive? + #:select? (local-file-select? base)) + (file-append base file))) (_ ;; In this case, anything that refers to the result also depends on ITEM, ;; which isn't great. diff --git a/guix/store.scm b/guix/store.scm index 014d08aaec..9b3879b4a7 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> +;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -821,8 +822,8 @@ encoding conversion errors." (locale (false-if-exception (setlocale LC_ALL)))) ;; Must be called after `open-connection'. - (define socket - (store-connection-socket server)) + (define buffered + (store-connection-output-port server)) (unless (unspecified? use-build-hook?) (warn-about-deprecation #:use-build-hook? #f @@ -831,9 +832,9 @@ encoding conversion errors." (let-syntax ((send (syntax-rules () ((_ (type option) ...) (begin - (write-arg type option socket) + (write-arg type option buffered) ...))))) - (write-int (operation-id set-options) socket) + (write-int (operation-id set-options) buffered) (send (boolean keep-failed?) (boolean keep-going?) (boolean fallback?) (integer verbosity)) (when (< (store-connection-minor-version server) #x61) @@ -896,6 +897,7 @@ encoding conversion errors." `(("locale" . ,locale)) '())))) (send (string-pairs pairs)))) + (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) @@ -1108,13 +1110,14 @@ path." ;; We don't use the 'operation' macro so we can pass SELECT? to ;; 'write-file'. (record-operation 'add-to-store) - (let ((port (store-connection-socket server))) - (write-int (operation-id add-to-store) port) - (write-string basename port) - (write-int 1 port) ;obsolete, must be #t - (write-int (if recursive? 1 0) port) - (write-string hash-algo port) - (write-file file-name port #:select? select?) + (let ((port (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id add-to-store) buffered) + (write-string basename buffered) + (write-int 1 buffered) ;obsolete, must be #t + (write-int (if recursive? 1 0) buffered) + (write-string hash-algo buffered) + (write-file file-name buffered #:select? select?) (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (loop (process-stderr server)))) @@ -1220,13 +1223,14 @@ an arbitrary directory layout in the store without creating a derivation." ;; We don't use the 'operation' macro so we can use 'write-file-tree' ;; instead of 'write-file'. (record-operation 'add-to-store/tree) - (let ((port (store-connection-socket server))) - (write-int (operation-id add-to-store) port) - (write-string basename port) - (write-int 1 port) ;obsolete, must be #t - (write-int (if recursive? 1 0) port) - (write-string hash-algo port) - (write-file-tree basename port + (let ((port (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id add-to-store) buffered) + (write-string basename buffered) + (write-int 1 buffered) ;obsolete, must be #t + (write-int (if recursive? 1 0) buffered) + (write-string hash-algo buffered) + (write-file-tree basename buffered #:file-type+size file-type+size #:file-port file-port #:symlink-target symlink-target @@ -1644,17 +1648,19 @@ the list of store paths to delete. IGNORE-LIVENESS? should always be #f. MIN-FREED is the minimum amount of disk space to be freed, in bytes, before the GC can stop. Return the list of store paths delete, and the number of bytes freed." - (let ((s (store-connection-socket server))) - (write-int (operation-id collect-garbage) s) - (write-int action s) - (write-store-path-list to-delete s) - (write-arg boolean #f s) ; ignore-liveness? - (write-long-long min-freed s) - (write-int 0 s) ; obsolete + (let ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id collect-garbage) buffered) + (write-int action buffered) + (write-store-path-list to-delete buffered) + (write-arg boolean #f buffered) ; ignore-liveness? + (write-long-long min-freed buffered) + (write-int 0 buffered) ; obsolete (when (>= (store-connection-minor-version server) 5) ;; Obsolete `use-atime' and `max-atime' parameters. - (write-int 0 s) - (write-int 0 s)) + (write-int 0 buffered) + (write-int 0 buffered)) + (write-buffered-output server) ;; Loop until the server is done sending error output. (let loop ((done? (process-stderr server))) @@ -1711,10 +1717,12 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-path server path port #:key (sign? #t)) "Export PATH to PORT. When SIGN? is true, sign it." - (let ((s (store-connection-socket server))) - (write-int (operation-id export-path) s) - (write-store-path path s) - (write-arg boolean sign? s) + (let ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id export-path) buffered) + (write-store-path path buffered) + (write-arg boolean sign? buffered) + (write-buffered-output server) (let loop ((done? (process-stderr server port))) (or done? (loop (process-stderr server port)))) (= 1 (read-int s)))) diff --git a/guix/store/database.scm b/guix/store/database.scm index ef52036ede..ad9ca68efe 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -99,27 +99,76 @@ create it and initialize it as a new database." ;; XXX: missing in guile-sqlite3@0.1.0 (define SQLITE_BUSY 5) -(define (call-with-transaction db proc) - "Start a transaction with DB (make as many attempts as necessary) and run -PROC. If PROC exits abnormally, abort the transaction, otherwise commit the -transaction after it finishes." +(define (call-with-SQLITE_BUSY-retrying thunk) + "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY +errors." (catch 'sqlite-error + thunk + (lambda (key who code errmsg) + (if (= code SQLITE_BUSY) + (call-with-SQLITE_BUSY-retrying thunk) + (throw key who code errmsg))))) + + + +(define* (call-with-transaction db proc #:key restartable?) + "Start a transaction with DB and run PROC. If PROC exits abnormally, abort +the transaction, otherwise commit the transaction after it finishes. +RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple +times. This may reduce contention for the database somewhat." + (define (exec sql) + (with-statement db sql stmt + (sqlite-fold cons '() stmt))) + ;; We might use begin immediate here so that if we need to retry, we figure + ;; that out immediately rather than because some SQLITE_BUSY exception gets + ;; thrown partway through PROC - in which case the part already executed + ;; (which may contain side-effects!) might have to be executed again for + ;; every retry. + (exec (if restartable? "begin;" "begin immediate;")) + (catch #t (lambda () - ;; We use begin immediate here so that if we need to retry, we - ;; figure that out immediately rather than because some SQLITE_BUSY - ;; exception gets thrown partway through PROC - in which case the - ;; part already executed (which may contain side-effects!) would be - ;; executed again for every retry. - (sqlite-exec db "begin immediate;") - (let ((result (proc))) - (sqlite-exec db "commit;") - result)) - (lambda (key who error description) - (if (= error SQLITE_BUSY) - (call-with-transaction db proc) - (begin - (sqlite-exec db "rollback;") - (throw 'sqlite-error who error description)))))) + (let-values ((result (proc))) + (exec "commit;") + (apply values result))) + (lambda args + ;; The roll back may or may not have occurred automatically when the + ;; error was generated. If it has occurred, this does nothing but signal + ;; an error. If it hasn't occurred, this needs to be done. + (false-if-exception (exec "rollback;")) + (apply throw args)))) + +(define* (call-with-savepoint db proc + #:optional (savepoint-name "SomeSavepoint")) + "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits +abnormally, rollback to that savepoint. In all cases, remove the savepoint +prior to returning." + (define (exec sql) + (with-statement db sql stmt + (sqlite-fold cons '() stmt))) + + (dynamic-wind + (lambda () + (exec (string-append "SAVEPOINT " savepoint-name ";"))) + (lambda () + (catch #t + proc + (lambda args + (exec (string-append "ROLLBACK TO " savepoint-name ";")) + (apply throw args)))) + (lambda () + (exec (string-append "RELEASE " savepoint-name ";"))))) + +(define* (call-with-retrying-transaction db proc #:key restartable?) + (call-with-SQLITE_BUSY-retrying + (lambda () + (call-with-transaction db proc #:restartable? restartable?)))) + +(define* (call-with-retrying-savepoint db proc + #:optional (savepoint-name + "SomeSavepoint")) + (call-with-SQLITE_BUSY-retrying + (lambda () + (call-with-savepoint db proc savepoint-name)))) (define %default-database-file ;; Default location of the store database. @@ -130,14 +179,37 @@ transaction after it finishes." If FILE doesn't exist, create it and initialize it as a new database." (call-with-database file (lambda (db) exp ...))) +(define (sqlite-finalize stmt) + ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when + ;; sqlite-finalize is invoked on them (see + ;; https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12). This can + ;; cause problems with automatically-started transactions, so we work around + ;; it by wrapping sqlite-finalize so that sqlite-reset is always called. + ;; This always works, because resetting a statement twice has no adverse + ;; effects. We can remove this once the fixed guile-sqlite3 is widespread. + (sqlite-reset stmt) + ((@ (sqlite3) sqlite-finalize) stmt)) + +(define (call-with-statement db sql proc) + (let ((stmt (sqlite-prepare db sql #:cache? #t))) + (dynamic-wind + (const #t) + (lambda () + (proc stmt)) + (lambda () + (sqlite-finalize stmt))))) + +(define-syntax-rule (with-statement db sql stmt exp ...) + "Run EXP... with STMT bound to a prepared statement corresponding to the sql +string SQL for DB." + (call-with-statement db sql + (lambda (stmt) exp ...))) + (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. - (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" - #:cache? #t)) - (result (sqlite-fold cons '() stmt))) - (sqlite-finalize stmt) - (match result + (with-statement db "SELECT last_insert_rowid();" stmt + (match (sqlite-fold cons '() stmt) ((#(id)) id) (_ #f)))) @@ -147,13 +219,11 @@ If FILE doesn't exist, create it and initialize it as a new database." (define* (path-id db path) "If PATH exists in the 'ValidPaths' table, return its numerical identifier. Otherwise, return #f." - (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) + (with-statement db path-id-sql stmt (sqlite-bind-arguments stmt #:path path) - (let ((result (sqlite-fold cons '() stmt))) - (sqlite-finalize stmt) - (match result - ((#(id) . _) id) - (_ #f))))) + (match (sqlite-fold cons '() stmt) + ((#(id) . _) id) + (_ #f)))) (define update-sql "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = @@ -168,22 +238,41 @@ VALUES (:path, :hash, :time, :deriver, :size)") doesn't exactly have... they've got something close, but it involves deleting and re-inserting instead of updating, which causes problems with foreign keys, of course. Returns the row id of the row that was modified or inserted." - (let ((id (path-id db path))) - (if id - (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) - (sqlite-bind-arguments stmt #:id id - #:deriver deriver - #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt) - (sqlite-finalize stmt) - (last-insert-row-id db)) - (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) - (sqlite-bind-arguments stmt - #:path path #:deriver deriver - #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt) ;execute it - (sqlite-finalize stmt) - (last-insert-row-id db))))) + + ;; It's important that querying the path-id and the insert/update operation + ;; take place in the same transaction, as otherwise some other + ;; process/thread/fiber could register the same path between when we check + ;; whether it's already registered and when we register it, resulting in + ;; duplicate paths (which, due to a 'unique' constraint, would cause an + ;; exception to be thrown). With the default journaling mode this will + ;; prevent writes from occurring during that sensitive time, but with WAL + ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs + ;; between the start of a read transaction and its upgrading to a write + ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot). + ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and + ;; immediately return (makes sense, since waiting won't change anything). + + ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep + ;; being returned every time we try to upgrade the same outermost + ;; transaction to a write transaction. So when retrying, we have to restart + ;; the *outermost* write transaction. We can't inherently tell whether + ;; we're the outermost write transaction, so we leave the retry-handling to + ;; the caller. + (call-with-savepoint db + (lambda () + (let ((id (path-id db path))) + (if id + (with-statement db update-sql stmt + (sqlite-bind-arguments stmt #:id id + #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt)) + (with-statement db insert-sql stmt + (sqlite-bind-arguments stmt + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt))) + (last-insert-row-id db))))) (define add-reference-sql "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") @@ -191,15 +280,13 @@ of course. Returns the row id of the row that was modified or inserted." (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list ids of items referred to." - (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) + (with-statement db add-reference-sql stmt (for-each (lambda (reference) (sqlite-reset stmt) (sqlite-bind-arguments stmt #:referrer referrer #:reference reference) - (sqlite-fold cons '() stmt) ;execute it - (last-insert-row-id db)) - references) - (sqlite-finalize stmt))) + (sqlite-fold cons '() stmt)) + references))) (define* (sqlite-register db #:key path (references '()) deriver hash nar-size time) @@ -354,7 +441,7 @@ Write a progress report to LOG-PORT." (mkdir-p db-dir) (parameterize ((sql-schema schema)) (with-database (string-append db-dir "/db.sqlite") db - (call-with-transaction db + (call-with-retrying-transaction db (lambda () (let* ((prefix (format #f "registering ~a items" (length items))) (progress (progress-reporter/bar (length items) diff --git a/guix/tests.scm b/guix/tests.scm index 95a7d7c4b8..3ccf049a7d 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -26,7 +26,7 @@ #:use-module (guix monads) #:use-module ((guix utils) #:select (substitute-keyword-arguments)) #:use-module ((guix build utils) #:select (mkdir-p)) - #:use-module (gcrypt hash) + #:use-module ((gcrypt hash) #:hide (sha256)) #:use-module (guix build-system gnu) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 566660e85e..b8e5f7e643 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -30,24 +30,6 @@ (define git-command (make-parameter "git")) -(define (call-with-environment-variables variables thunk) - "Call THUNK with the environment VARIABLES set." - (let ((environment (environ))) - (dynamic-wind - (lambda () - (for-each (match-lambda - ((variable value) - (setenv variable value))) - variables)) - thunk - (lambda () - (environ environment))))) - -(define-syntax-rule (with-environment-variables variables exp ...) - "Evaluate EXP with the given environment VARIABLES set." - (call-with-environment-variables variables - (lambda () exp ...))) - (define (populate-git-repository directory directives) "Initialize a new Git checkout and repository in DIRECTORY and apply DIRECTIVES. Each element of DIRECTIVES is an sexp like: @@ -94,9 +76,15 @@ Return DIRECTORY on success." port))) (git "add" file) (loop rest))) + ((('remove file) rest ...) + (git "rm" "-f" file) + (loop rest)) ((('commit text) rest ...) (git "commit" "-m" text) (loop rest)) + ((('commit text ('signer fingerprint)) rest ...) + (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint)) + (loop rest)) ((('tag name) rest ...) (git "tag" name) (loop rest)) @@ -108,6 +96,10 @@ Return DIRECTORY on success." (loop rest)) ((('merge branch message) rest ...) (git "merge" branch "-m" message) + (loop rest)) + ((('merge branch message ('signer fingerprint)) rest ...) + (git "merge" branch "-m" message + (string-append "--gpg-sign=" fingerprint)) (loop rest))))) (define (call-with-temporary-git-repository directives proc) diff --git a/guix/tests/gnupg.scm b/guix/tests/gnupg.scm new file mode 100644 index 0000000000..47c858d232 --- /dev/null +++ b/guix/tests/gnupg.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 tests gnupg) + #:use-module (guix utils) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:export (gpg-command + gpgconf-command + with-fresh-gnupg-setup)) + +(define gpg-command + (make-parameter "gpg")) + +(define gpgconf-command + (make-parameter "gpgconf")) + +(define (call-with-fresh-gnupg-setup imported thunk) + (call-with-temporary-directory + (lambda (home) + (with-environment-variables `(("GNUPGHOME" ,home)) + (dynamic-wind + (lambda () + (for-each (lambda (file) + (invoke (gpg-command) "--import" file)) + imported)) + thunk + (lambda () + ;; Terminate 'gpg-agent' & co. + (invoke (gpgconf-command) "--kill" "all"))))))) + +(define-syntax-rule (with-fresh-gnupg-setup imported exp ...) + "Evaluate EXP in the context of a fresh GnuPG setup where all the files +listed in IMPORTED, and only them, have been imported. This sets 'GNUPGHOME' +such that the user's real GnuPG files are left untouched. The 'gpg-agent' +process is terminated afterwards." + (call-with-fresh-gnupg-setup imported (lambda () exp ...))) diff --git a/guix/ui.scm b/guix/ui.scm index ea5f460865..7690f48660 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -69,6 +69,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:autoload (ice-9 popen) (open-pipe* close-pipe) #:autoload (system base compile) (compile-file) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) @@ -1557,6 +1558,27 @@ 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) + (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")) + (open-pipe* OPEN_WRITE + (or (getenv "GUIX_PAGER") (getenv "PAGER") + "less"))))) + (dynamic-wind + (const #t) + (lambda () (proc pager)) + (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 +standard output is a tty, or with PORT set to the current output port." + (call-with-paginated-output-port (lambda (port) exp ...))) + (define* (display-search-results matches port #:key (command "guix search") @@ -1573,30 +1595,17 @@ them. If PORT is a terminal, print at most a full screen of results." (define (line-count str) (string-count str #\newline)) - (let loop ((matches matches)) - (match matches - (((package . score) rest ...) - (let* ((links? (supports-hyperlinks? port)) - (text (call-with-output-string - (lambda (port) - (print package port - #:hyperlinks? links? - #:extra-fields - `((relevance . ,score))))))) - (if (and (not (getenv "INSIDE_EMACS")) - max-rows - (> (port-line port) first-line) ;print at least one result - (> (+ 4 (line-count text) (port-line port)) - max-rows)) - (unless (null? rest) - (display-hint (format #f (G_ "Run @code{~a ... | less} \ -to view all the results.") - command))) - (begin - (display text port) - (loop rest))))) - (() - #t)))) + (with-paginated-output-port paginated + (let loop ((matches matches)) + (match matches + (((package . score) rest ...) + (let* ((links? (supports-hyperlinks? port))) + (print package paginated + #:hyperlinks? links? + #:extra-fields `((relevance . ,score))) + (loop rest))) + (() + #t))))) (define (string->generations str) diff --git a/guix/upstream.scm b/guix/upstream.scm index c11de0b25b..67d0eeefbb 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -441,7 +441,8 @@ new version string if an update was made, and #f otherwise." (if version-loc (let* ((loc (package-location package)) (old-version (package-version package)) - (old-hash (origin-sha256 (package-source package))) + (old-hash (content-hash-value + (origin-hash (package-source package)))) (old-url (match (origin-uri (package-source package)) ((? string? url) url) (_ #f))) diff --git a/guix/utils.scm b/guix/utils.scm index d7b197fa44..17a96370f1 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -6,7 +6,7 @@ ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,6 +78,8 @@ target-aarch64? target-arm? target-64bit? + cc-for-target + version-compare version>? version>=? @@ -87,7 +89,6 @@ guile-version>? version-prefix? string-replace-substring - arguments-from-environment-variable file-extension file-sans-extension tarball-sans-extension @@ -97,6 +98,9 @@ call-with-temporary-directory with-atomic-file-output + with-environment-variables + arguments-from-environment-variable + config-directory cache-directory @@ -113,6 +117,38 @@ ;;; +;;; Environment variables. +;;; + +(define (call-with-environment-variables variables thunk) + "Call THUNK with the environment VARIABLES set." + (let ((environment (environ))) + (dynamic-wind + (lambda () + (for-each (match-lambda + ((variable value) + (setenv variable value))) + variables)) + thunk + (lambda () + (environ environment))))) + +(define-syntax-rule (with-environment-variables variables exp ...) + "Evaluate EXP with the given environment VARIABLES set." + (call-with-environment-variables variables + (lambda () exp ...))) + +(define (arguments-from-environment-variable variable) + "Retrieve value of environment variable denoted by string VARIABLE in the +form of a list of strings (`char-set:graphic' tokens) suitable for consumption +by `args-fold', if VARIABLE is defined, otherwise return an empty list." + (let ((env (getenv variable))) + (if env + (string-tokenize env char-set:graphic) + '()))) + + +;;; ;;; Filtering & pipes. ;;; @@ -506,6 +542,11 @@ a character other than '@'." (%current-system)))) (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))) +(define* (cc-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-gcc") + "gcc")) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) @@ -575,6 +616,11 @@ minor version numbers from version-string." (list-prefix? (string-tokenize v1 not-dot) (string-tokenize v2 not-dot))))) + +;;; +;;; Files. +;;; + (define (file-extension file) "Return the extension of FILE or #f if there is none." (let ((dot (string-rindex file #\.))) @@ -627,15 +673,6 @@ REPLACEMENT." (substring str start index) pieces)))))))) -(define (arguments-from-environment-variable variable) - "Retrieve value of environment variable denoted by string VARIABLE in the -form of a list of strings (`char-set:graphic' tokens) suitable for consumption -by `args-fold', if VARIABLE is defined, otherwise return an empty list." - (let ((env (getenv variable))) - (if env - (string-tokenize env char-set:graphic) - '()))) - (define (call-with-temporary-output-file proc) "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this |