diff options
Diffstat (limited to 'guix')
140 files changed, 8944 insertions, 4573 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index dbfa626a19..211fd11311 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix search-paths) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -34,62 +36,51 @@ (guix build syscalls) ,@%gnu-build-system-modules)) -(define* (android-ndk-build store name inputs - #:key - (tests? #t) - (test-target #f) - (phases '(@ (guix build android-ndk-build-system) - %standard-phases)) - (outputs '("out")) - (make-flags ''()) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %android-ndk-build-system-modules) - (modules '((guix build android-ndk-build-system) - (guix build utils)))) +(define* (android-ndk-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (phases '%standard-phases) + (outputs '("out")) + (make-flags #~'()) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %android-ndk-build-system-modules) + (modules '((guix build android-ndk-build-system) + (guix build utils)))) "Build SOURCE using Android NDK, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (android-ndk-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:make-flags (cons* "-f" - ,(string-append - (derivation->output-path - (car (assoc-ref inputs "android-build"))) - "/share/android/build/core/main.mk") - ,make-flags) - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (android-ndk-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:bootstrap-scripts '() ;no autotools machinery + #:make-flags + (cons* "-f" + #$(file-append (gexp-input-thing + (car (assoc-ref inputs + "android-build"))) + "/share/android/build/core/main.mk") + #$make-flags) + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -98,7 +89,7 @@ "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs #:outputs)) + '(#:target #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 1809d1f3d2..08a4c996f9 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -73,7 +75,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:jdk #:ant #:zip #:inputs #:native-inputs)) + '(#:target #:jdk #:ant #:zip #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -94,8 +96,9 @@ (build ant-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ant-build store name inputs +(define* (ant-build name inputs #:key + source (tests? #t) (test-target "check") (configure-flags ''()) @@ -107,8 +110,7 @@ (test-exclude (list "**/Abstract*.java")) (source-dir "src") (test-dir "src/test") - (phases '(@ (guix build ant-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -119,49 +121,35 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (ant-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:make-flags ,make-flags - #:configure-flags ,configure-flags - #:system ,system - #:tests? ,tests? - #:test-target ,test-target - #:build-target ,build-target - #:jar-name ,jar-name - #:main-class ,main-class - #:test-include (list ,@test-include) - #:test-exclude (list ,@test-exclude) - #:source-dir ,source-dir - #:test-dir ,test-dir - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (ant-build #:name #$name + #:source #+source + #:make-flags #$make-flags + #:configure-flags #$configure-flags + #:system #$system + #:tests? #$tests? + #:test-target #$test-target + #:build-target #$build-target + #:jar-name #$jar-name + #:main-class #$main-class + #:test-include (list #$@test-include) + #:test-exclude (list #$@test-exclude) + #:source-dir #$source-dir + #:test-dir #$test-dir + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define ant-build-system (build-system diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index b4e40ee8c2..a0f4634db0 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,8 @@ #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module ((guix build utils) #:select ((package-name->name+version @@ -92,46 +94,33 @@ (build asdf-build/source) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (asdf-build/source store name inputs +(define* (asdf-build/source name inputs #:key source outputs - (phases '(@ (guix build asdf-build-system) - %standard-phases/source)) + (phases '%standard-phases/source) (search-paths '()) (system (%current-system)) (guile #f) (imported-modules %asdf-build-system-modules) (modules %asdf-build-modules)) (define builder - `(begin - (use-modules ,@modules) - (asdf-build/source #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (asdf-build/source #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define* (package-with-build-system from-build-system to-build-system from-prefix to-prefix @@ -162,7 +151,8 @@ set up using CL source package conventions." name)) (define (has-from-build-system? pkg) - (eq? from-build-system (package-build-system pkg))) + (and (package? pkg) + (eq? from-build-system (package-build-system pkg)))) (define (find-input-package pkg) (let* ((name (package-name pkg)) @@ -277,19 +267,18 @@ set up using CL source package conventions." (arguments (strip-keyword-arguments private-keywords arguments)))))) (define (asdf-build lisp-type) - (lambda* (store name inputs - #:key source outputs - (tests? #t) - (asd-files ''()) - (asd-systems ''()) - (test-asd-file #f) - (phases '(@ (guix build asdf-build-system) - %standard-phases)) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %asdf-build-system-modules) - (modules %asdf-build-modules)) + (lambda* (name inputs + #:key source outputs + (tests? #t) + (asd-files ''()) + (asd-systems ''()) + (test-asd-file #f) + (phases '%standard-phases) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) (define systems (if (null? (cadr asd-systems)) @@ -304,44 +293,32 @@ set up using CL source package conventions." asd-systems)) (define builder - `(begin - (use-modules ,@modules) - (parameterize ((%lisp (string-append - (assoc-ref %build-inputs ,lisp-type) - "/bin/" ,lisp-type)) - (%lisp-type ,lisp-type)) - (asdf-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:asd-files ,asd-files - #:asd-systems ,systems - #:test-asd-file ,test-asd-file - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs)))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (parameterize ((%lisp (search-input-file + #$(input-tuples->gexp inputs) + (string-append "bin/" #$lisp-type))) + (%lisp-type #$lisp-type)) + (asdf-build #:name #$name + #:source #+source + #:asd-files #$asd-files + #:asd-systems #$systems + #:test-asd-file #$test-asd-file + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs)))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile)))) (define asdf-build-system/sbcl (build-system diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index e53d2a7523..60c35eed07 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -26,7 +26,8 @@ #:use-module (guix search-paths) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -71,8 +72,9 @@ to NAME and VERSION." (guix build json) ,@%cargo-utils-modules)) -(define* (cargo-build store name inputs +(define* (cargo-build name inputs #:key + source (tests? #t) (test-target #f) (vendor-dir "guix-vendor") @@ -82,8 +84,7 @@ to NAME and VERSION." (features ''()) (skip-build? #f) (install-source? #t) - (phases '(@ (guix build cargo-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -94,47 +95,35 @@ to NAME and VERSION." "Build SOURCE using CARGO, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (cargo-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-target ,test-target - #:vendor-dir ,vendor-dir - #:cargo-build-flags ,cargo-build-flags - #:cargo-test-flags ,cargo-test-flags - #:cargo-package-flags ,cargo-package-flags - #:features ,features - #:skip-build? ,skip-build? - #:install-source? ,install-source? - #:tests? ,(and tests? (not skip-build?)) - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (cargo-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:vendor-dir #$vendor-dir + #:cargo-build-flags #$(sexp->gexp cargo-build-flags) + #:cargo-test-flags #$(sexp->gexp cargo-test-flags) + #:cargo-package-flags #$(sexp->gexp cargo-package-flags) + #:features #$(sexp->gexp features) + #:skip-build? #$skip-build? + #:install-source? #$install-source? + #:tests? #$(and tests? (not skip-build?)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define (package-cargo-inputs p) (apply @@ -222,7 +211,7 @@ any dependent crates. This can be a benefits: - It avoids waiting for quadratic builds from source: cargo always builds dependencies within the current workspace. This is largely due to Rust not having a stable ABI and other resolutions that cargo applies. This means that - if we have a depencency chain of X -> Y -> Z and we build each definition + if we have a dependency chain of X -> Y -> Z and we build each definition independently the following will happen: * Cargo will build and test crate Z * Cargo will build crate Z in Y's workspace, then build and test Y @@ -253,7 +242,7 @@ any dependent crates. This can be a benefits: "Return a bag for NAME." (define private-keywords - '(#:source #:target #:rust #:inputs #:native-inputs #:outputs + '(#:target #:rust #:inputs #:native-inputs #:outputs #:cargo-inputs #:cargo-development-inputs)) (and (not target) ;; TODO: support cross-compilation diff --git a/guix/build-system/chicken.scm b/guix/build-system/chicken.scm index 10f1469e88..07666d1321 100644 --- a/guix/build-system/chicken.scm +++ b/guix/build-system/chicken.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 raingloom <raingloom@riseup.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. @@ -19,7 +20,9 @@ (define-module (guix build-system chicken) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -55,7 +58,7 @@ EXTENSION is the file name extension, such as '.tar.gz'." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:chicken #:inputs #:native-inputs)) + '(#:target #:chicken #:inputs #:native-inputs)) ;; TODO: cross-compilation support (and (not target) @@ -77,60 +80,45 @@ EXTENSION is the file name extension, such as '.tar.gz'." (build chicken-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (chicken-build store name inputs - #:key - (phases '(@ (guix build chicken-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (egg-name "") - (unpack-path "") - (build-flags ''()) - (tests? #t) - (system (%current-system)) - (guile #f) - (imported-modules %chicken-build-system-modules) - (modules '((guix build chicken-build-system) - (guix build union) - (guix build utils)))) +(define* (chicken-build name inputs + #:key + source + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (egg-name "") + (unpack-path "") + (build-flags ''()) + (tests? #t) + (system (%current-system)) + (guile #f) + (imported-modules %chicken-build-system-modules) + (modules '((guix build chicken-build-system) + (guix build union) + (guix build utils)))) (define builder - `(begin - (use-modules ,@modules) - (chicken-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:egg-name ,egg-name - #:unpack-path ,unpack-path - #:build-flags ,build-flags - #:tests? ,tests? - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (chicken-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:egg-name #$egg-name + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system - #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define chicken-build-system (build-system diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm index 607f67aaec..2a0713d297 100644 --- a/guix/build-system/clojure.scm +++ b/guix/build-system/clojure.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,9 @@ #:select (standard-packages) #:prefix gnu:) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix packages) #:use-module ((guix search-paths) #:select @@ -79,8 +81,7 @@ #:allow-other-keys #:rest arguments) "Return a bag for NAME." - (let ((private-keywords '(#:source #:target - #:inputs #:native-inputs + (let ((private-keywords '(#:target #:inputs #:native-inputs #:clojure #:jdk #:zip))) (if target @@ -102,29 +103,14 @@ (arguments (strip-keyword-arguments private-keywords arguments)))))) -(define-with-docs source->output-path - "Convert source input to output path." - (match-lambda - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source))) - -(define-with-docs maybe-guile->guile - "Find the right guile." - (match-lambda - ((and maybe-guile (? package?)) - maybe-guile) - (#f ; default - (@* (gnu packages commencement) guile-final)))) - -(define* (clojure-build store name inputs +(define* (clojure-build name inputs #:key + source (source-dirs `',%source-dirs) + (java-source-dirs `',%java-source-dirs) (test-dirs `',%test-dirs) (compile-dir %compile-dir) + (java-compile-dir %java-compile-dir) (jar-names `',(package-name->jar-names name)) (main-class %main-class) @@ -133,7 +119,7 @@ (aot-include `',%aot-include) (aot-exclude `',%aot-exclude) - doc-dirs ; no sensible default + doc-dirs ; no sensible default (doc-regex %doc-regex) (tests? %tests?) @@ -149,48 +135,47 @@ (imported-modules %clojure-build-system-modules) (modules %default-modules)) "Build SOURCE with INPUTS." - (let ((builder `(begin - (use-modules ,@modules) - (clojure-build #:name ,name - #:source ,(source->output-path - (assoc-ref inputs "source")) - - #:source-dirs ,source-dirs - #:test-dirs ,test-dirs - #:compile-dir ,compile-dir + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - #:jar-names ,jar-names - #:main-class ,main-class - #:omit-source? ,omit-source? + (clojure-build #:name #$name + #:source #+source - #:aot-include ,aot-include - #:aot-exclude ,aot-exclude + #:source-dirs #$source-dirs + #:java-source-dirs #$java-source-dirs + #:test-dirs #$test-dirs + #:compile-dir #$compile-dir + #:java-compile-dir #$java-compile-dir + + #:jar-names #$jar-names + #:main-class #$main-class + #:omit-source? #$omit-source? - #:doc-dirs ,doc-dirs - #:doc-regex ,doc-regex + #:aot-include #$aot-include + #:aot-exclude #$aot-exclude - #:tests? ,tests? - #:test-include ,test-include - #:test-exclude ,test-exclude + #:doc-dirs #$doc-dirs + #:doc-regex #$doc-regex - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-spec->sexp - search-paths) - #:system ,system - #:inputs %build-inputs))) + #:tests? #$tests? + #:test-include #$test-include + #:test-exclude #$test-exclude - (guile-for-build (package-derivation store - (maybe-guile->guile guile) - system - #:graft? #f))) + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-spec->sexp + search-paths)) + #:system #$system + #:inputs #$(input-tuples->gexp inputs))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define clojure-build-system (build-system diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index f590b6ea42..0aabc95b90 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2015, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> @@ -21,7 +21,9 @@ (define-module (guix build-system cmake) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -61,7 +63,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:cmake #:inputs #:native-inputs #:outputs + `(#:cmake #:inputs #:native-inputs ,@(if target '() '(#:target)))) (bag @@ -95,8 +97,8 @@ (build (if target cmake-cross-build cmake-build)) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (cmake-build store name inputs - #:key (guile #f) +(define* (cmake-build name inputs + #:key guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -111,8 +113,7 @@ (strip-flags ''("--strip-debug")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build cmake-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (substitutable? #t) (imported-modules %cmake-build-system-modules) @@ -120,62 +121,57 @@ (guix build utils)))) "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (cmake-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(cmake-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:configure-flags #$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags) + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:build-type #$build-type + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories)))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:substitutable? substitutable? - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:graft? #f + #:substitutable? substitutable? + #:guile-for-build guile))) ;;; ;;; Cross-compilation. ;;; -(define* (cmake-cross-build store name +(define* (cmake-cross-build name #:key - target native-drvs target-drvs - (guile #f) + target + build-inputs target-inputs host-inputs + source guile (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -193,8 +189,7 @@ provides a 'CMakeLists.txt' file as its build system." "--enable-deterministic-archives")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build cmake-build-system) - %standard-phases)) + (phases '%standard-phases) (substitutable? #t) (system (%current-system)) (build (nix-system->gnu-triplet system)) @@ -205,78 +200,59 @@ provides a 'CMakeLists.txt' file as its build system." with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) - (cmake-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:target ,target - #:outputs %outputs - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories)))) + (define %outputs + #$(outputs->gexp outputs)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (cmake-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:phases #$phases + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:build-type #$build-type + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:make-dynamic-linker-cache? #f ;cross-compiling + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:substitutable? substitutable? + #:guile-for-build guile))) (define cmake-build-system (build-system diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index d1bf8fb654..4894ba46fb 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ (define-module (guix build-system copy) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -59,7 +61,7 @@ #:rest arguments) "Return a bag for NAME from the given arguments." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:target #:inputs #:native-inputs)) (bag (name name) @@ -75,8 +77,9 @@ (build copy-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (copy-build store name inputs - #:key (guile #f) +(define* (copy-build name inputs + #:key + guile source (outputs '("out")) (install-plan ''(("." "./"))) (search-paths '()) @@ -90,49 +93,43 @@ (phases '(@ (guix build copy-build-system) %standard-phases)) (system (%current-system)) + (target #f) (imported-modules %copy-build-system-modules) (modules '((guix build copy-build-system) (guix build utils)))) "Build SOURCE using INSTALL-PLAN, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (copy-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:install-plan ,install-plan - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:out-of-source? ,out-of-source? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(copy-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:install-plan #$(if (pair? install-plan) + (sexp->gexp install-plan) + install-plan) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:out-of-source? #$out-of-source? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories)))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile))) (define copy-build-system (build-system diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 5a31a2f51a..55ad7decb8 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -24,7 +24,8 @@ #:use-module (guix search-paths) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -56,57 +57,43 @@ (guix build syscalls) ,@%gnu-build-system-modules)) -(define* (dub-build store name inputs - #:key - (tests? #t) - (test-target #f) - (dub-build-flags ''()) - (phases '(@ (guix build dub-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %dub-build-system-modules) - (modules '((guix build dub-build-system) - (guix build utils)))) +(define* (dub-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (dub-build-flags ''()) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %dub-build-system-modules) + (modules '((guix build dub-build-system) + (guix build utils)))) "Build SOURCE using DUB, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (dub-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-target ,test-target - #:dub-build-flags ,dub-build-flags - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (dub-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:dub-build-flags #$dub-build-flags + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -118,7 +105,7 @@ "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs)) + '(#:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 5b33ef6841..12100fd8e8 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 pukkamustard <pukkamustard@posteo.net> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +22,7 @@ (define-module (guix build-system dune) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module ((guix build-system gnu) #:prefix gnu:) @@ -72,7 +73,7 @@ "--profile" "release"))) (define private-keywords - '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs)) + '(#:target #:dune #:findlib #:ocaml #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (let ((base (ocaml:lower name @@ -94,8 +95,9 @@ `(#:dune-release-flags ,dune-release-flags) (strip-keyword-arguments private-keywords arguments))))))) -(define* (dune-build store name inputs - #:key (guile #f) +(define* (dune-build name inputs + #:key + guile source (outputs '("out")) (search-paths '()) (build-flags ''()) @@ -122,51 +124,40 @@ "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE provides a 'setup.ml' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (dune-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:test-flags ,test-flags - #:build-flags ,build-flags - #:out-of-source? ,out-of-source? - #:jbuild? ,jbuild? - #:package ,package - #:dune-release-flags ,dune-release-flags - #:tests? ,tests? - #:test-target ,test-target - #:install-target ,install-target - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (dune-build #:source #$source + #:system #$system + #:outputs (list #$@(map (lambda (name) + #~(cons #$name + (ungexp output name))) + outputs)) + #:inputs (map (lambda (tuple) + (apply cons tuple)) + '#$inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:test-flags #$test-flags + #:build-flags #$build-flags + #:out-of-source? #$out-of-source? + #:jbuild? #$jbuild? + #:package #$package + #:dune-release-flags #$dune-release-flags + #:tests? #$tests? + #:test-target #$test-target + #:install-target #$install-target + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define dune-build-system (build-system diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index ac05ff420e..3df68789ff 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -23,7 +23,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -81,13 +82,12 @@ (build emacs-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (emacs-build store name inputs +(define* (emacs-build name inputs #:key source (tests? #f) (parallel-tests? #t) (test-command ''("make" "check")) - (phases '(@ (guix build emacs-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (include (quote %default-include)) (exclude (quote %default-exclude)) @@ -100,43 +100,29 @@ (guix build emacs-utils)))) "Build SOURCE using EMACS, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (emacs-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-command ,test-command - #:tests? ,tests? - #:parallel-tests? ,parallel-tests? - #:phases ,phases - #:outputs %outputs - #:include ,include - #:exclude ,exclude - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (emacs-build #:name #$name + #:source #+source + #:system #$system + #:test-command #$test-command + #:tests? #$tests? + #:parallel-tests? #$parallel-tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:include #$include + #:exclude #$exclude + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define emacs-build-system (build-system diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index d40a4985f8..74dc80b5db 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -17,6 +17,9 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system font) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) @@ -69,13 +72,12 @@ (build font-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (font-build store name inputs +(define* (font-build name inputs #:key source (tests? #t) (test-target "test") (configure-flags ''()) - (phases '(@ (guix build font-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -85,41 +87,32 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (font-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:configure-flags ,configure-flags - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(font-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile))) (define font-build-system (build-system diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index fb1f8fb930..aa9703829b 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,15 +22,21 @@ (define-module (guix build-system glib-or-gtk) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) + #:use-module ((guix build glib-or-gtk-build-system) + #:select (%gdk-pixbuf-loaders-cache-file)) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) #:use-module (ice-9 match) #:export (%glib-or-gtk-build-system-modules glib-or-gtk-build - glib-or-gtk-build-system)) + glib-or-gtk-cross-build + glib-or-gtk-build-system) + #:re-export (%gdk-pixbuf-loaders-cache-file)) ;for convenience ;; Commentary: ;; @@ -80,33 +87,45 @@ #:key source inputs native-inputs outputs system target (glib (default-glib)) (implicit-inputs? #t) + (implicit-cross-inputs? #t) (strip-binaries? #t) #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:glib #:inputs #:native-inputs - #:outputs #:implicit-inputs?)) + `(#:glib #:inputs #:native-inputs + #:outputs #:implicit-inputs? #:implicit-cross-inputs? + ,@(if target '() '(#:target)))) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs (if source - `(("source" ,source)) - '())) - (build-inputs `(,@native-inputs - ,@inputs - ("glib:bin" ,glib "bin") ; to compile schemas - ,@(if implicit-inputs? - (standard-packages) - '()))) - (outputs outputs) - (build glib-or-gtk-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (bag + (name name) + (system system) (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@(if target + inputs + '()))) + (build-inputs `(,@native-inputs + ,@(if target '() inputs) + ("glib:bin" ,glib "bin") ; to compile schemas + ;; Keep standard inputs of gnu-build-system. + ,@(if (and target implicit-cross-inputs?) + (standard-cross-packages target 'host) + '()) + ,@(if implicit-inputs? + (standard-packages) + '()))) + ;; Keep standard inputs of 'gnu-build-system'. + (target-inputs (if (and target implicit-cross-inputs?) + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target glib-or-gtk-cross-build glib-or-gtk-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (glib-or-gtk-build store name inputs - #:key (guile #f) +(define* (glib-or-gtk-build name inputs + #:key guile source (outputs '("out")) (search-paths '()) (configure-flags ''()) @@ -132,70 +151,143 @@ allowed-references disallowed-references) "Build SOURCE with INPUTS. See GNU-BUILD for more details." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system) - output)) - ((? string? output) - output))) + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + #$(with-build-variables inputs outputs + #~(glib-or-gtk-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:glib-or-gtk-wrap-excluded-outputs + #$glib-or-gtk-wrap-excluded-outputs + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories + #$(sexp->gexp strip-directories)))))) + + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:graft? #f + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) + +(define* (glib-or-gtk-cross-build name + #:key + target + build-inputs target-inputs host-inputs + guile source + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (configure-flags ''()) + ;; Disable icon theme cache generation. + (make-flags ''("gtk_update_icon_cache=true")) + (out-of-source? #f) + (tests? #f) + (test-target "check") + (parallel-build? #t) + (parallel-tests? #t) + (validate-runpath? #t) + (make-dynamic-linker-cache? #f) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build glib-or-gtk-build-system) + %standard-phases)) + (glib-or-gtk-wrap-excluded-outputs ''()) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules %glib-or-gtk-build-system-modules) + (modules %default-modules) + allowed-references + disallowed-references) + "Cross-build SOURCE with INPUTS. See GNU-BUILD for more details." (define builder - `(begin - (use-modules ,@modules) - (glib-or-gtk-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:glib-or-gtk-wrap-excluded-outputs - ,glib-or-gtk-wrap-excluded-outputs - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (define %outputs + #$(outputs->gexp outputs)) + + (glib-or-gtk-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(sexp->gexp + (map search-path-specification->sexp + native-search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:glib-or-gtk-wrap-excluded-outputs + #$glib-or-gtk-wrap-excluded-outputs + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories + #$(sexp->gexp strip-directories)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)) - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:modules imported-modules + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) (define glib-or-gtk-build-system (build-system diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 6b481ad45c..651415098e 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -215,7 +217,7 @@ use `--strip-all' as the arguments to `strip'." (arguments (let ((a (default-keyword-arguments (package-arguments p) '(#:configure-flags '() - #:strip-flags '("--strip-debug"))))) + #:strip-flags '("--strip-unneeded"))))) (substitute-keyword-arguments a ((#:configure-flags flags) `(cons* "--disable-shared" "LDFLAGS=-static" ,flags)) @@ -281,7 +283,7 @@ standard packages used as implicit inputs of the GNU build system." #:rest arguments) "Return a bag for NAME from the given arguments." (define private-keywords - `(#:source #:inputs #:native-inputs #:outputs + `(#:inputs #:native-inputs #:outputs #:implicit-inputs? #:implicit-cross-inputs? ,@(if target '() '(#:target)))) @@ -324,10 +326,22 @@ standard packages used as implicit inputs of the GNU build system." ;; Regexp matching license files. "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$") -(define* (gnu-build store name input-drvs - #:key (guile #f) +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + #~%bootstrap-scripts) + +(define %strip-flags + #~'("--strip-unneeded" "--enable-deterministic-archives")) + +(define %strip-directories + #~'("lib" "lib64" "libexec" "bin" "sbin")) + +(define* (gnu-build name inputs + #:key + guile source (outputs '("out")) (search-paths '()) + (bootstrap-scripts %bootstrap-scripts) (configure-flags ''()) (make-flags ''()) (out-of-source? #f) @@ -337,11 +351,10 @@ standard packages used as implicit inputs of the GNU build system." (parallel-tests? #t) (patch-shebangs? #t) (strip-binaries? #t) - (strip-flags ''("--strip-debug" - "--enable-deterministic-archives")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) + (strip-flags %strip-flags) + (strip-directories %strip-directories) (validate-runpath? #t) + (make-dynamic-linker-cache? #t) (license-file-regexp %license-file-regexp) (phases '%standard-phases) (locale "en_US.utf8") @@ -368,78 +381,58 @@ SUBSTITUTABLE? determines whether users may be able to use substitutes of the returned derivations, or whether they should always build it locally. ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs -are allowed to refer to. Likewise for DISALLOWED-REFERENCES, which lists -packages that must not be referenced." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system - #:graft? #f))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system - #:graft? #f) - output)) - ((? string? output) - output))) - +are allowed to refer to." (define builder - `(begin - (use-modules ,@modules) - (gnu-build #:source ,(match (assoc-ref input-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:locale ,locale - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:validate-runpath? ,validate-runpath? - #:license-file-regexp ,license-file-regexp - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system - #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(gnu-build #:source #+source + #:system #$system + #:build #$build + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #:configure-flags #$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags) + #:make-flags #$(if (pair? make-flags) + (sexp->gexp make-flags) + make-flags) + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))))) - (build-expression->derivation store name builder - #:system system - #:inputs input-drvs - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)) - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + ;; Note: Always pass #:graft? #f. Without it, ALLOWED-REFERENCES & + ;; co. would be interpreted as referring to grafted packages. + (gexp->derivation name builder + #:system system + #:target #f + #:graft? #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) ;;; @@ -475,15 +468,16 @@ is one of `host' or `target'." `(("cross-libc:static" ,libc "static")) '())))))))) -(define* (gnu-cross-build store name +(define* (gnu-cross-build name #:key - target native-drvs target-drvs - (guile #f) - source + target + build-inputs target-inputs host-inputs + guile source (outputs '("out")) (search-paths '()) (native-search-paths '()) + (bootstrap-scripts %bootstrap-scripts) (configure-flags ''()) (make-flags ''()) (out-of-source? #f) @@ -492,11 +486,15 @@ is one of `host' or `target'." (parallel-build? #t) (parallel-tests? #t) (patch-shebangs? #t) (strip-binaries? #t) - (strip-flags ''("--strip-debug" - "--enable-deterministic-archives")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) + (strip-flags %strip-flags) + (strip-directories %strip-directories) (validate-runpath? #t) + + ;; We run 'ldconfig' to generate ld.so.cache and it + ;; generally can't do that for cross-built binaries + ;; ("ldconfig: foo.so is for unknown machine 40."). + (make-dynamic-linker-cache? #f) + (license-file-regexp %license-file-regexp) (phases '%standard-phases) (locale "en_US.utf8") @@ -510,102 +508,67 @@ is one of `host' or `target'." "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are cross-built inputs, and NATIVE-INPUTS are inputs that run on the build platform." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-cross-derivation store p - target system))) - (((? package? p) output) - (derivation->output-path (package-cross-derivation store p - target system) - output)) - ((? string? output) - output))) - (define builder - `(begin - (use-modules ,@modules) + #~(begin + (use-modules #$@(sexp->gexp modules)) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (gnu-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:target ,target - #:outputs %outputs - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases - #:locale ,locale - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:validate-runpath? ,validate-runpath? - #:license-file-regexp ,license-file-regexp - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories)))) + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (define %outputs + #$(outputs->gexp outputs)) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? + (gnu-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(sexp->gexp + (map + search-path-specification->sexp + native-search-paths)) + #:phases #$phases + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))) - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)) - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:modules imported-modules + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) (define gnu-build-system (build-system diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 4c1a732107..5e0e5bbad3 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -2,7 +2,9 @@ ;;; Copyright © 2016 Petter <petter@mykolab.ch> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +23,9 @@ (define-module (guix build-system go) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -109,6 +113,9 @@ commit hash and its date rather than a proper release tag." (let ((go (resolve-interface '(gnu packages golang)))) (module-ref go 'go))) +(define (make-go-std) + (module-ref (resolve-interface '(gnu packages golang)) 'make-go-std)) + (define* (lower name #:key source inputs native-inputs outputs system target (go (default-go)) @@ -116,7 +123,15 @@ commit hash and its date rather than a proper release tag." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:go #:inputs #:native-inputs)) + '(#:target #:go #:inputs #:native-inputs)) + + (define inputs-with-cache + ;; XXX: Avoid a circular dependency. This should be rewritten with + ;; 'package-mapping' or similar. + (let ((go-std-name (string-append (package-name go) "-std"))) + (if (string-prefix? go-std-name name) + inputs + (cons `(,go-std-name ,((make-go-std) go)) inputs)))) (bag (name name) @@ -127,7 +142,7 @@ commit hash and its date rather than a proper release tag." '()) ,@`(("go" ,go)) ,@native-inputs - ,@(if target '() inputs) + ,@(if target '() inputs-with-cache) ,@(if target ;; Use the standard cross inputs of ;; 'gnu-build-system'. @@ -135,7 +150,7 @@ commit hash and its date rather than a proper release tag." '()) ;; Keep the standard inputs of 'gnu-build-system'. ,@(standard-packages))) - (host-inputs (if target inputs '())) + (host-inputs (if target inputs-with-cache '())) ;; The cross-libc is really a target package, but for bootstrapping ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a @@ -150,10 +165,10 @@ commit hash and its date rather than a proper release tag." (build (if target go-cross-build go-build)) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (go-build store name inputs +(define* (go-build name inputs #:key - (phases '(@ (guix build go-build-system) - %standard-phases)) + source + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (install-source? #t) @@ -163,61 +178,48 @@ commit hash and its date rather than a proper release tag." (tests? #t) (allow-go-reference? #f) (system (%current-system)) - (goarch (first (go-target (%current-system)))) - (goos (last (go-target (%current-system)))) + (goarch #f) + (goos #f) (guile #f) (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) (guix build union) - (guix build utils)))) + (guix build utils))) + (substitutable? #t)) (define builder - `(begin - (use-modules ,@modules) - (go-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:goarch ,goarch - #:goos ,goos - #:search-paths ',(map search-path-specification->sexp - search-paths) - #: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))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (go-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:substitutable? #$substitutable? + #:goarch #$goarch + #:goos #$goos + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #: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 #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system - #:graft? #f))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) - -(define* (go-cross-build store name +(define* (go-cross-build name #:key - target native-drvs target-drvs - (phases '(@ (guix build go-build-system) - %standard-phases)) + source target + build-inputs target-inputs host-inputs + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (native-search-paths '()) @@ -225,7 +227,7 @@ commit hash and its date rather than a proper release tag." (import-path "") (unpack-path "") (build-flags ''()) - (tests? #f) ; nothing can be done + (tests? #f) ; nothing can be done (allow-go-reference? #f) (system (%current-system)) (goarch (first (go-target target))) @@ -234,76 +236,58 @@ commit hash and its date rather than a proper release tag." (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) (guix build union) - (guix build utils)))) + (guix build utils))) + (substitutable? #t)) "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (go-build #:name ,name - #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:target ,target - #:goarch ,goarch - #:goos ,goos - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #: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)))) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (define %outputs + #$(outputs->gexp outputs)) + + (go-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs %outputs + #:target #$target + #:goarch #$goarch + #:goos #$goos + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:install-source? #$install-source? + #:import-path #$import-path + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:make-dynamic-linker-cache? #f ;cross-compiling + #:allow-go-reference? #$allow-go-reference? + #:inputs %build-inputs))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:substitutable? substitutable? + #:guile-for-build guile))) (define go-build-system (build-system diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 45e735b987..36a88e181a 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2019, 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +20,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -75,7 +76,7 @@ ;; denominator between Guile 2.0 and 2.2. ''("-Wunbound-variable" "-Warity-mismatch" "-Wformat")) -(define* (guile-build store name inputs +(define* (guile-build name inputs #:key source (guile #f) (phases '%standard-phases) @@ -91,47 +92,34 @@ (guix build utils)))) "Build SOURCE using Guile taken from the native inputs, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (guile-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (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 - #:system ,system - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (guile-build #:name #$name + #: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 + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile))) -(define* (guile-cross-build store name +(define* (guile-cross-build name #:key (system (%current-system)) target - native-drvs target-drvs + build-inputs target-inputs host-inputs (guile #f) source (outputs '("out")) @@ -146,68 +134,43 @@ (modules '((guix build guile-build-system) (guix build utils)))) (define builder - `(begin - (use-modules ,@modules) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (guile-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:target ,target - #:outputs %outputs - #:source-directory ,source-directory - #:not-compiled-file-regexp ,not-compiled-file-regexp - #:compile-flags ,compile-flags - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases)))) + (define %outputs + #$(outputs->gexp outputs)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (guile-build #:source #+source + #:system #$system + #:target #$target + #:outputs %outputs + #:source-directory #$source-directory + #:not-compiled-file-regexp #$not-compiled-file-regexp + #:compile-flags #$compile-flags + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:make-dynamic-linker-cache? #f ;cross-compiling + #:phases #$phases)))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:guile-for-build guile))) (define guile-build-system (build-system diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 18a584f782..dc83512d30 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +24,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix download) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -30,7 +33,9 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (%haskell-build-system-modules + #:export (hackage-uri + + %haskell-build-system-modules haskell-build haskell-build-system)) @@ -41,6 +46,12 @@ ;; ;; Code: +(define (hackage-uri name version) + "Return a URI string for the Haskell package hosted on Hackage corresponding +to NAME and VERSION." + (string-append "https://hackage.haskell.org/package/" name "/" + name "-" version ".tar.gz")) + (define %haskell-build-system-modules ;; Build-side modules imported by default. `((guix build haskell-build-system) @@ -116,7 +127,7 @@ version REVISION." (cons name propagated-names)))))) extra-directories)))))))) -(define* (haskell-build store name inputs +(define* (haskell-build name inputs #:key source (haddock? #t) (haddock-flags ''()) @@ -127,8 +138,7 @@ version REVISION." (parallel-build? #f) (configure-flags ''()) (extra-directories ''()) - (phases '(@ (guix build haskell-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out" "static")) (search-paths '()) (system (%current-system)) @@ -139,50 +149,43 @@ version REVISION." "Build SOURCE using HASKELL, and with INPUTS. This assumes that SOURCE provides a 'Setup.hs' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (haskell-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:cabal-revision ,(match (assoc-ref inputs - "cabal-revision") - (((? derivation? revision)) - (derivation->output-path revision)) - (revision revision)) - #:configure-flags ,configure-flags - #:extra-directories ,extra-directories - #:haddock-flags ,haddock-flags - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:parallel-build? ,parallel-build? - #:haddock? ,haddock? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(haskell-build #:name #$name + #:source #+source + + ;; XXX: INPUTS contains <gexp-input> records as + ;; opposed to raw lowerable objects, hence the + ;; use of ungexp-splicing. + #:cabal-revision + #$@(match (assoc-ref inputs "cabal-revision") + (#f '(#f)) + (lst lst)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #:configure-flags #$configure-flags + #:extra-directories #$extra-directories + #:extra-directories #$extra-directories + #:haddock-flags #$haddock-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:haddock? #$haddock? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs)))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define haskell-build-system (build-system diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 63cb7cd864..6261f8a55a 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -1,5 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +23,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -73,55 +77,44 @@ (build julia-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (julia-build store name inputs +(define* (julia-build name inputs #:key source (tests? #t) - (phases '(@ (guix build julia-build-system) - %standard-phases)) + (parallel-tests? #t) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) (guile #f) (julia-package-name #f) + (julia-package-uuid #f) (imported-modules %julia-build-system-modules) (modules '((guix build julia-build-system) (guix build utils)))) "Build SOURCE using Julia, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (julia-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs - #:julia-package-name ,julia-package-name))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (julia-build #:name #$name + #:source #+source + #:system #$system + #:tests? #$tests? + #:parallel-tests? #$parallel-tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs) + #:julia-package-name #$julia-package-name + #:julia-package-uuid #$julia-package-uuid)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define julia-build-system (build-system diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 548ed7a9aa..e82a9ca65c 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +22,8 @@ (define-module (guix build-system linux-module) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -59,53 +61,52 @@ `(("linux" ,linux))) (arguments (substitute-keyword-arguments (package-arguments linux) - ((#:phases phases) - `(modify-phases ,phases - (replace 'build - (lambda _ - (invoke "make" "modules_prepare"))) - (delete 'strip) ; faster. - (replace 'install - (lambda* (#:key inputs outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (out-lib-build (string-append out "/lib/modules/build"))) - ;; Delete some huge items that we probably don't need. - ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, - ;; scripts, include, ".config". - (copy-recursively "." out-lib-build) - (for-each (lambda (name) - (when (file-exists? name) - (delete-file-recursively name))) - (map (lambda (name) - (string-append out-lib-build "/" name)) - '("arch" ; 137 MB - ;"tools" ; 44 MB ; Note: is built by our 'build phase. - "tools/testing" ; 14 MB - "tools/perf" ; 17 MB - "drivers" ; 600 MB - "Documentation" ; 52 MB - "fs" ; 43 MB - "net" ; 33 MB - "samples" ; 2 MB - "sound"))) ; 40 MB - ;; Reinstate arch/**/dts since "scripts/dtc" depends on it. - ;; Reinstate arch/**/include directories. - ;; Reinstate arch/**/Makefile. - ;; Reinstate arch/**/module.lds. - (for-each - (lambda (name) - (mkdir-p (dirname (string-append out-lib-build "/" name))) - (copy-recursively name - (string-append out-lib-build "/" name))) - (append (find-files "arch" "^(dts|include)$" #:directories? #t) - (find-files "arch" "^(Makefile|module.lds)$"))) - (let* ((linux (assoc-ref inputs "linux"))) - (install-file (string-append linux "/System.map") - out-lib-build) - (let ((source (string-append linux "/Module.symvers"))) - (when (file-exists? source) - (install-file source out-lib-build)))) - #t))))))))) + ((#:phases phases) + #~(modify-phases #$phases + (replace 'build + (lambda _ + (invoke "make" "modules_prepare"))) + (delete 'strip) ; faster + (replace 'install + (lambda* (#:key inputs #:allow-other-keys) + (let ((out-lib-build (string-append #$output "/lib/modules/build"))) + ;; Delete some huge items that we probably don't need. + ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, + ;; scripts, include, ".config". + (copy-recursively "." out-lib-build) + (for-each (lambda (name) + (when (file-exists? name) + (delete-file-recursively name))) + (map (lambda (name) + (string-append out-lib-build "/" name)) + '("arch" ; 137 MB + ;;"tools" ; 44 MB built by our 'build phase + "tools/testing" ; 14 MB + "tools/perf" ; 17 MB + "drivers" ; 600 MB + "Documentation" ; 52 MB + "fs" ; 43 MB + "net" ; 33 MB + "samples" ; 2 MB + "sound"))) ; 40 MB + ;; Reinstate arch/**/dts since "scripts/dtc" depends on it. + ;; Reinstate arch/**/include directories. + ;; Reinstate arch/**/Makefile. + ;; Reinstate arch/**/module.lds. + (for-each + (lambda (name) + (mkdir-p (dirname (string-append out-lib-build "/" name))) + (copy-recursively name + (string-append out-lib-build "/" name))) + (append (find-files "arch" "^(dts|include)$" + #:directories? #t) + (find-files "arch" "^(Makefile|module.lds)$"))) + (let* ((linux #$(this-package-input "linux"))) + (install-file (string-append linux "/System.map") + out-lib-build) + (let ((source (string-append linux "/Module.symvers"))) + (when (file-exists? source) + (install-file source out-lib-build))))))))))))) (define* (lower name #:key source inputs native-inputs outputs @@ -115,7 +116,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs + `(#:target #:gcc #:kmod #:linux #:inputs #:native-inputs ,@(if target '() '(#:target)))) (bag @@ -149,13 +150,12 @@ (build (if target linux-module-build-cross linux-module-build)) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (linux-module-build store name inputs +(define* (linux-module-build name inputs #:key - target + source target (search-paths '()) (tests? #t) - (phases '(@ (guix build linux-module-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (make-flags ''()) (parallel-build? #t) @@ -169,50 +169,38 @@ (guix build utils)))) "Build SOURCE using LINUX, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (linux-module-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:source-directory ,source-directory - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:system ,system - #:target ,target - #:arch ,(system->arch (or target system)) - #:tests? ,tests? - #:outputs %outputs - #:make-flags ,make-flags - #:parallel-build? ,parallel-build? - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + #$(with-build-variables inputs outputs + #~(linux-module-build #:name #$name + #:source #+source + #:source-directory #$source-directory + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:system #$system + #:target #$target + #:arch #$(system->arch (or target system)) + #:tests? #$tests? + #:outputs #$(outputs->gexp outputs) + #:make-flags #$make-flags + #:parallel-build? #$parallel-build? + #:inputs #$(input-tuples->gexp inputs)))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define* (linux-module-build-cross - store name + name #:key - target native-drvs target-drvs + source target + build-inputs target-inputs host-inputs (guile #f) (outputs '("out")) (make-flags ''()) @@ -220,8 +208,7 @@ (search-paths '()) (native-search-paths '()) (tests? #f) - (phases '(@ (guix build linux-module-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (substitutable? #t) (imported-modules @@ -229,70 +216,43 @@ (modules '((guix build linux-module-build-system) (guix build utils)))) (define builder - `(begin - (use-modules ,@modules) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-host-inputs + '#+(input-tuples->gexp build-inputs)) - (linux-module-build #:name ,name - #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #: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 - ',(map search-path-specification->sexp - search-paths) - #:native-search-paths - ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases - #:tests? ,tests?)))) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (linux-module-build #:name #$name + #:source #+source + #:system #$system + #:target #$target + #:arch #$(system->arch (or target system)) + #:outputs #$(outputs->gexp outputs) + #:make-flags #$make-flags + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(map + search-path-specification->sexp + native-search-paths) + #:phases #$phases + #:tests? #$tests?)))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define linux-module-build-system (build-system diff --git a/guix/build-system/maven.scm b/guix/build-system/maven.scm index 2dceefccc1..0af5922692 100644 --- a/guix/build-system/maven.scm +++ b/guix/build-system/maven.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system maven) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -119,7 +121,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:jdk #:maven #:maven-plugins #:inputs #:native-inputs)) + '(#:target #:jdk #:maven #:maven-plugins #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -140,70 +142,56 @@ (build maven-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (maven-build store name inputs - #:key (guile #f) - (outputs '("out")) - (search-paths '()) - (out-of-source? #t) - (validate-runpath? #t) - (patch-shebangs? #t) - (strip-binaries? #t) - (exclude %default-exclude) - (local-packages '()) - (tests? #t) - (strip-flags ''("--strip-debug")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) - (phases '(@ (guix build maven-build-system) - %standard-phases)) - (system (%current-system)) - (imported-modules %maven-build-system-modules) - (modules '((guix build maven-build-system) - (guix build maven pom) - (guix build utils)))) +(define* (maven-build name inputs + #:key + source (guile #f) + (outputs '("out")) + (search-paths '()) + (out-of-source? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (exclude %default-exclude) + (local-packages '()) + (tests? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '%standard-phases) + (system (%current-system)) + (imported-modules %maven-build-system-modules) + (modules '((guix build maven-build-system) + (guix build maven pom) + (guix build utils)))) "Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE provides its own binaries." (define builder - `(begin - (use-modules ,@modules) - (maven-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:exclude (quote ,exclude) - #:local-packages (quote ,local-packages) - #:tests? ,tests? - #:out-of-source? ,out-of-source? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (maven-build #:source #+source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:exclude '#$exclude + #:local-packages '#$local-packages + #:tests? #$tests? + #:out-of-source? #$out-of-source? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define maven-build-system (build-system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index b68bcb80de..ad604f8871 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +20,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system meson) - #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -28,7 +31,8 @@ #:use-module (guix packages) #:use-module (ice-9 match) #:export (%meson-build-system-modules - meson-build-system)) + meson-build-system + make-cross-file)) ;; Commentary: ;; @@ -38,6 +42,68 @@ ;; ;; Code: +(define (make-machine-alist triplet) + "Make an association list describing what should go into +the ‘host_machine’ section of the cross file when cross-compiling +for TRIPLET." + `((system . ,(cond ((target-hurd? triplet) "gnu") + ((target-linux? triplet) "linux") + ((target-mingw? triplet) "windows") + (#t (error "meson: unknown operating system")))) + (cpu_family . ,(cond ((target-x86-32? triplet) "x86") + ((target-x86-64? triplet) "x86_64") + ((target-arm32? triplet) "arm") + ((target-aarch64? triplet) "aarch64") + ((target-powerpc? triplet) + (if (target-64bit? triplet) + "ppc64" + "ppc")) + (#t (error "meson: unknown architecture")))) + (cpu . ,(cond ((target-x86-32? triplet) ; i386, ..., i686 + (substring triplet 0 4)) + ((target-x86-64? triplet) "x86_64") + ((target-aarch64? triplet) "armv8-a") + ((target-arm32? triplet) "armv7") + ;; According to #mesonbuild on OFTC, there does not appear + ;; to be an official-ish list of CPU types recognised by + ;; Meson, the "cpu" field is not used by Meson itself and + ;; most software doesn't look at this field, except perhaps + ;; for selecting optimisations, so set it to something + ;; arbitrary. + (#t "strawberries"))) + (endian . ,(cond ((string-prefix? "powerpc64le-" triplet) "little") + ((string-prefix? "mips64el-" triplet) "little") + ((target-x86-32? triplet) "little") + ((target-x86-64? triplet) "little") + ;; At least in Guix. Aarch64 and 32-bit arm + ;; have a big-endian mode as well. + ((target-arm? triplet) "little") + (#t (error "meson: unknown architecture")))))) + +(define (make-binaries-alist triplet) + "Make an associatoin list describing what should go into +the ‘binaries’ section of the cross file when cross-compiling for +TRIPLET." + `((c . ,(cc-for-target triplet)) + (cpp . ,(cxx-for-target triplet)) + (pkgconfig . ,(pkg-config-for-target triplet)) + (objcopy . ,(string-append triplet "-objcopy")) + (ar . ,(string-append triplet "-ar")) + (ld . ,(string-append triplet "-ld")) + (strip . ,(string-append triplet "-strip")))) + +(define (make-cross-file triplet) + (computed-file "cross-file" + (with-imported-modules '((guix build meson-configuration)) + #~(begin + (use-modules (guix build meson-configuration)) + (call-with-output-file #$output + (lambda (port) + (write-section-header port "host_machine") + (write-assignments port '#$(make-machine-alist triplet)) + (write-section-header port "binaries") + (write-assignments port '#$(make-binaries-alist triplet)))))))) + (define %meson-build-system-modules ;; Build-side modules imported by default. `((guix build meson-build-system) @@ -55,7 +121,7 @@ "Return the default meson package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((module (resolve-interface '(gnu packages build-tools)))) - (module-ref module 'meson-for-build))) + (module-ref module 'meson))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -66,33 +132,44 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:meson #:ninja #:inputs #:native-inputs #:outputs #:target)) + `(#:meson #:ninja #:inputs #:native-inputs #:outputs + ,@(if target + '() + '(#:target)))) - (and (not target) ;; TODO: add support for cross-compilation. - (bag - (name name) - (system system) - (build-inputs `(("meson" ,meson) - ("ninja" ,ninja) - ,@native-inputs - ,@inputs - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (host-inputs (if source - `(("source" ,source)) - '())) - (outputs outputs) - (build meson-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (bag + (name name) + (system system) (target target) + (build-inputs `(("meson" ,meson) + ("ninja" ,ninja) + ,@native-inputs + ,@(if target '() inputs) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(if target + (standard-cross-packages target 'host) + '()) + ,@(standard-packages))) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@(if target inputs '()))) + ;; Keep the standard inputs of 'gnu-buid-system'. + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target meson-cross-build meson-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (meson-build store name inputs - #:key (guile #f) +(define* (meson-build name inputs + #:key + guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) (build-type "debugoptimized") (tests? #t) - (test-target "test") + (test-options ''()) (glib-or-gtk? #f) (parallel-build? #t) (parallel-tests? #f) @@ -104,8 +181,7 @@ "bin" "sbin")) (elf-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build meson-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (imported-modules %meson-build-system-modules) (modules '((guix build meson-build-system) @@ -114,76 +190,167 @@ disallowed-references) "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE has a 'meson.build' file." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define build-phases + #$(let ((phases (if (pair? phases) (sexp->gexp phases) phases))) + (if glib-or-gtk? + phases + #~(modify-phases #$phases + (delete 'glib-or-gtk-compile-schemas) + (delete 'glib-or-gtk-wrap))))) - ;; TODO: Copied from build-system/gnu, factorize this! - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system - #:graft? #f))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system - #:graft? #f) - output)) - ((? string? output) - output))) + #$(with-build-variables inputs outputs + #~(meson-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases build-phases + #:configure-flags + #$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags) + #:build-type #$build-type + #:tests? #$tests? + #:test-options #$(sexp->gexp test-options) + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories) + #:elf-directories #$(sexp->gexp elf-directories)))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:graft? #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) + +(define* (meson-cross-build name + #:key + target + build-inputs host-inputs target-inputs + guile source + (outputs '("out")) + (configure-flags ''()) + (search-paths '()) + (native-search-paths '()) + + (build-type "debugoptimized") + (tests? #f) + (test-options ''()) + (glib-or-gtk? #f) + (parallel-build? #t) + (parallel-tests? #f) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (elf-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + ;; See 'gnu-cross-build' for why this needs to be + ;; disabled when cross-compiling. + (make-dynamic-linker-cache? #f) + (phases '%standard-phases) + (system (%current-system)) + (imported-modules %meson-build-system-modules) + (modules '((guix build meson-build-system) + (guix build utils))) + allowed-references + disallowed-references) + "Cross-build SOURCE for TARGET using MESON, and with INPUTS, assuming that +SOURCE has a 'meson.build' file." + (define cross-file + (make-cross-file target)) + (define inputs + (if (null? target-inputs) + (input-tuples->gexp host-inputs) + #~(append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs)))) (define builder - `(let ((build-phases (if ,glib-or-gtk? - ,phases - (modify-phases ,phases - (delete 'glib-or-gtk-compile-schemas) - (delete 'glib-or-gtk-wrap))))) - (use-modules ,@modules) - (meson-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases build-phases - #:configure-flags ,configure-flags - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories - #:elf-directories ,elf-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (define %outputs + #$(outputs->gexp outputs)) + + (define build-phases + #$(let ((phases (if (pair? phases) (sexp->gexp phases) phases))) + (if glib-or-gtk? + phases + #~(modify-phases #$phases + (delete 'glib-or-gtk-compile-schemas) + (delete 'glib-or-gtk-wrap))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + ;; Do not use 'with-build-variables', as there should be + ;; no reason to use %build-inputs and friends. + (meson-build #:source #+source + #:system #$system + #:build #$(nix-system->gnu-triplet system) + #:target #$target + #:outputs #$(outputs->gexp outputs) + #:inputs #$inputs + #:native-inputs #+(input-tuples->gexp build-inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(sexp->gexp + (map search-path-specification->sexp + native-search-paths)) + #:phases build-phases + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:configure-flags `("--cross-file" #+cross-file + ,@#$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags)) + #:build-type #$build-type + #:tests? #$tests? + #:test-options #$(sexp->gexp test-options) + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories) + #:elf-directories #$(sexp->gexp elf-directories))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) (define meson-build-system (build-system diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index 9d53760685..7d4745ab32 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -54,7 +56,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:target #:inputs #:native-inputs)) (bag (name name) @@ -70,11 +72,11 @@ (build minify-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (minify-build store name inputs +(define* (minify-build name inputs #:key + source (javascript-files #f) - (phases '(@ (guix build minify-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (system (%current-system)) search-paths @@ -84,38 +86,24 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (minify-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:javascript-files ,javascript-files - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (minify-build #:name #$name + #:source #+source + #:javascript-files #$javascript-files + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define minify-build-system (build-system diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 98f63f87ef..24bd677bfc 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -1,6 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Philip McGrath <philip@philipmcgrath.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +21,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system node) + #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -48,7 +53,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:node #:inputs #:native-inputs)) + '(#:target #:node #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -58,21 +63,27 @@ `(("source" ,source)) '()) ,@inputs - ;; Keep the standard inputs of 'gnu-build-system'. ,@(standard-packages))) (build-inputs `(("node" ,node) + ;; Many packages with native addons need + ;; libuv headers. The libuv version must + ;; be exactly the same as for the node + ;; package we are adding implicitly, + ;; so we take care of adding libuv, too. + ("libuv" ,@(assoc-ref (package-inputs node) "libuv")) ,@native-inputs)) (outputs outputs) (build node-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (node-build store name inputs +(define* (node-build name inputs #:key + source + (npm-flags ''()) (test-target "test") (tests? #t) - (phases '(@ (guix build node-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -82,38 +93,27 @@ (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder - `(begin - (use-modules ,@modules) - (node-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (node-build #:name #$name + #:source #+source + #:system #$system + #:npm-flags #$npm-flags + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define node-build-system (build-system diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 5513216c25..e7d6d96f0e 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,7 @@ (define-module (guix build-system ocaml) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -206,7 +207,7 @@ pre-defined variants." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ocaml #:findlib #:inputs #:native-inputs)) + '(#:target #:ocaml #:findlib #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -226,8 +227,9 @@ pre-defined variants." (build ocaml-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ocaml-build store name inputs - #:key (guile #f) +(define* (ocaml-build name inputs + #:key + guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -253,51 +255,35 @@ pre-defined variants." "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE provides a 'setup.ml' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (ocaml-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:configure-flags ,configure-flags - #:test-flags ,test-flags - #:make-flags ,make-flags - #:build-flags ,build-flags - #:out-of-source? ,out-of-source? - #:use-make? ,use-make? - #:tests? ,tests? - #:test-target ,test-target - #:install-target ,install-target - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (ocaml-build #:source #$source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:configure-flags #$configure-flags + #:test-flags #$test-flags + #:make-flags #$make-flags + #:build-flags #$build-flags + #:out-of-source? #$out-of-source? + #:use-make? #$use-make? + #:tests? #$tests? + #:test-target #$test-target + #:install-target #$install-target + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define ocaml-build-system (build-system diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 06af1dd20e..db0a916fb2 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,8 @@ (define-module (guix build-system perl) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -57,7 +59,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:perl #:inputs #:native-inputs)) + '(#:target #:perl #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -76,8 +78,8 @@ (build perl-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (perl-build store name inputs - #:key +(define* (perl-build name inputs + #:key source (search-paths '()) (tests? #t) (parallel-build? #t) @@ -95,46 +97,37 @@ (guix build utils)))) "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE provides a `Makefile.PL' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (perl-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:make-maker? ,make-maker? - #:make-maker-flags ,make-maker-flags - #:module-build-flags ,module-build-flags - #:phases ,phases - #:system ,system - #:test-target "test" - #:tests? ,tests? - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:outputs %outputs - #:inputs %build-inputs))) + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(perl-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:make-maker? #$make-maker? + #:make-maker-flags #$make-maker-flags + #:module-build-flags #$(sexp->gexp module-build-flags) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:system #$system + #:test-target "test" + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:outputs %outputs + #:inputs %build-inputs))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:guile-for-build guile))) (define perl-build-system (build-system diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 80895162f8..efade6f74b 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,9 +20,13 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system python) + #:use-module ((gnu packages) #:select (search-auxiliary-file)) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -70,6 +75,10 @@ extension, such as '.tar.gz'." (let ((python (resolve-interface '(gnu packages python)))) (module-ref python 'python-2))) +(define sanity-check.py + ;; The script used to validate the installation of a Python package. + (search-auxiliary-file "python/sanity-check.py")) + (define* (package-with-explicit-python python old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package with @@ -140,7 +149,7 @@ pre-defined variants." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:python #:inputs #:native-inputs)) + '(#:target #:python #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -154,19 +163,19 @@ pre-defined variants." ;; Keep the standard inputs of 'gnu-build-system'. ,@(standard-packages))) (build-inputs `(("python" ,python) + ("sanity-check.py" ,(local-file sanity-check.py)) ,@native-inputs)) (outputs outputs) (build python-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (python-build store name inputs - #:key +(define* (python-build name inputs + #:key source (tests? #t) (test-target "test") (use-setuptools? #t) (configure-flags ''()) - (phases '(@ (guix build python-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -176,43 +185,35 @@ pre-defined variants." (guix build utils)))) "Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE provides a 'setup.py' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (python-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:configure-flags ,configure-flags - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:use-setuptools? ,use-setuptools? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(python-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:use-setuptools? #$use-setuptools? + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:guile-for-build guile))) (define python-build-system (build-system diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index e1368db1d9..a0b968cef3 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2015, 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -23,9 +23,10 @@ (define-module (guix build-system qt) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module ((guix build qt-utils) #:select (%qt-wrap-excluded-inputs)) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system cmake) @@ -75,7 +76,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:cmake #:inputs #:native-inputs #:outputs + `(#:cmake #:inputs #:native-inputs #:outputs ,@(if target '() '(#:target)))) (bag @@ -109,8 +110,9 @@ (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (qt-build store name inputs - #:key (guile #f) +(define* (qt-build name inputs + #:key + source (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -125,8 +127,7 @@ (strip-flags ''("--strip-debug")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build qt-build-system) - %standard-phases)) + (phases '%standard-phases) (qt-wrap-excluded-outputs ''()) (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) (system (%current-system)) @@ -136,61 +137,50 @@ "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (qt-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs - #:qt-wrap-excluded-inputs ,qt-wrap-excluded-inputs - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (qt-build #:source #+source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs + #:qt-wrap-excluded-inputs #$qt-wrap-excluded-inputs + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:build-type #$build-type + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) ;;; ;;; Cross-compilation. ;;; -(define* (qt-cross-build store name +(define* (qt-cross-build name #:key - target native-drvs target-drvs + source target + build-inputs target-inputs host-inputs (guile #f) (outputs '("out")) (configure-flags ''()) @@ -199,7 +189,7 @@ provides a 'CMakeLists.txt' file as its build system." (make-flags ''()) (out-of-source? #t) (build-type "RelWithDebInfo") - (tests? #f) ; nothing can be done + (tests? #f) ; nothing can be done (test-target "test") (parallel-build? #t) (parallel-tests? #f) (validate-runpath? #t) @@ -209,8 +199,7 @@ provides a 'CMakeLists.txt' file as its build system." "--enable-deterministic-archives")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build qt-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (build (nix-system->gnu-triplet system)) (imported-modules %qt-build-system-modules) @@ -220,77 +209,54 @@ provides a 'CMakeLists.txt' file as its build system." with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name (? package? pkg) sub ...) - (let ((drv (package-cross-derivation store pkg - target system))) - `(,name . ,(apply derivation->output-path drv sub)))) - ((name path) - `(,name . ,path))) - target-drvs)) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (qt-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:target ,target - #:outputs %outputs - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories)))) + (define %outputs + #$(outputs->gexp outputs)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + (qt-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:phases #$phases + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:build-type #$build-type + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:make-dynamic-linker-cache? #f ;cross-compiling + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define qt-build-system (build-system diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 5e4b23c77e..2c82390ba6 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -59,7 +61,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.13" + (string-append "https://bioconductor.org/packages/3.14" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) @@ -82,7 +84,7 @@ release corresponding to NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:r #:inputs #:native-inputs)) + '(#:target #:r #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -101,13 +103,13 @@ release corresponding to NAME and VERSION." (build r-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (r-build store name inputs +(define* (r-build name inputs #:key + source (tests? #t) (test-target "tests") (configure-flags ''()) - (phases '(@ (guix build r-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -118,42 +120,28 @@ release corresponding to NAME and VERSION." (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (r-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:configure-flags ,configure-flags - #:system ,system - #:tests? ,tests? - #:test-target ,test-target - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (r-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:tests? #$tests? + #:test-target #$test-target + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define r-build-system (build-system diff --git a/guix/build-system/rakudo.scm b/guix/build-system/rakudo.scm index a02e2bad3a..05a4d9c2ad 100644 --- a/guix/build-system/rakudo.scm +++ b/guix/build-system/rakudo.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system rakudo) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -71,7 +73,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:rakudo #:prove6 #:zef #:inputs #:native-inputs)) + '(#:target #:rakudo #:prove6 #:zef #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -96,12 +98,12 @@ (build rakudo-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (rakudo-build store name inputs +(define* (rakudo-build name inputs #:key + source (search-paths '()) (tests? #t) - (phases '(@ (guix build rakudo-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (system (%current-system)) (guile #f) @@ -112,39 +114,25 @@ (guix build utils)))) "Build SOURCE using PERL6, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (rakudo-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:system ,system - #:tests? ,tests? - #:outputs %outputs - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (rakudo-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:system #$system + #:tests? #$tests? + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define rakudo-build-system (build-system diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 5ed59bf5a5..f1070951ee 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -1,4 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +23,8 @@ #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -53,7 +56,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:renpy #:inputs #:native-inputs)) + '(#:target #:renpy #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -72,57 +75,43 @@ (build renpy-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (renpy-build store name inputs - #:key - (phases '(@ (guix build renpy-build-system) - %standard-phases)) - (configure-flags ''()) - (outputs '("out")) - (output "out") - (game "game") - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %renpy-build-system-modules) - (modules '((guix build renpy-build-system) - (guix build utils)))) +(define* (renpy-build name inputs + #:key + source + (phases '%standard-phases) + (configure-flags ''()) + (outputs '("out")) + (output "out") + (game "game") + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %renpy-build-system-modules) + (modules '((guix build renpy-build-system) + (guix build utils)))) "Build SOURCE using RENPY, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (renpy-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:configure-flags ,configure-flags - #:system ,system - #:phases ,phases - #:outputs %outputs - #:output ,output - #:game ,game - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (renpy-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:output #$output + #:game #$game + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define renpy-build-system (build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 8142e8551a..342daf7978 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,8 @@ (define-module (guix build-system ruby) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -54,7 +56,7 @@ NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ruby #:inputs #:native-inputs)) + '(#:target #:ruby #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -73,13 +75,12 @@ NAME and VERSION." (build ruby-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ruby-build store name inputs - #:key +(define* (ruby-build name inputs + #:key source (gem-flags ''()) (test-target "test") (tests? #t) - (phases '(@ (guix build ruby-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -88,42 +89,33 @@ NAME and VERSION." (modules '((guix build ruby-build-system) (guix build utils)))) "Build SOURCE using RUBY and INPUTS." - (define builder - `(begin - (use-modules ,@modules) - (ruby-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:gem-flags ,gem-flags - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (define build + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(ruby-build #:name #$name + #:source #+source + #:system #$system + #:gem-flags #$gem-flags + #:test-target #$test-target + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs)))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:modules imported-modules + #:guile-for-build guile))) (define ruby-build-system (build-system diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index aad455c419..74901b3478 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system scons) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -53,7 +55,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:scons #:inputs #:native-inputs)) + '(#:target #:scons #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -72,15 +74,15 @@ (build scons-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (scons-build store name inputs +(define* (scons-build name inputs #:key + (source #f) (tests? #t) (scons-flags ''()) - (build-targets ''()) + (build-targets #~'()) (test-target "test") - (install-targets ''("install")) - (phases '(@ (guix build scons-build-system) - %standard-phases)) + (install-targets #~'("install")) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -91,43 +93,33 @@ "Build SOURCE using SCons, and with INPUTS. This assumes that SOURCE provides a 'SConstruct' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (scons-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:scons-flags ,scons-flags - #:system ,system - #:build-targets ,build-targets - #:test-target ,test-target - #:tests? ,tests? - #:install-targets ,install-targets - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(scons-build #:name #$name + #:source #+source + #:scons-flags #$(sexp->gexp scons-flags) + #:system #$system + #:build-targets #$build-targets + #:test-target #$test-target + #:tests? #$tests? + #:install-targets #$install-targets + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:inputs %build-inputs + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths))))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define scons-build-system (build-system diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 8bbca0ccb7..09907c67d8 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +22,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -42,8 +45,8 @@ ;; These variables specify the SVN tag and the matching SVN revision. They ;; are taken from https://www.tug.org/svn/texlive/tags/ -(define %texlive-tag "texlive-2019.3") -(define %texlive-revision 51265) +(define %texlive-tag "texlive-2021.3") +(define %texlive-revision 59745) (define (texlive-origin name version locations hash) "Return an <origin> object for a TeX Live package consisting of multiple @@ -59,13 +62,17 @@ name for the checkout directory." (file-name (string-append name "-" version "-checkout")) (sha256 hash))) -(define (texlive-ref component id) +(define* (texlive-ref component #:optional id) "Return a <svn-reference> object for the package ID, which is part of the -given Texlive COMPONENT." +given Texlive COMPONENT. If ID is not provided, COMPONENT is used as the top +level package ID." (svn-reference (url (string-append "svn://www.tug.org/texlive/tags/" %texlive-tag "/Master/texmf-dist/" - "source/" component "/" id)) + "source/" component + (if id + (string-append "/" id) + ""))) (revision %texlive-revision))) (define %texlive-build-system-modules @@ -96,7 +103,7 @@ given Texlive COMPONENT." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs + '(#:target #:inputs #:native-inputs #:texlive-latex-base #:texlive-bin)) (bag @@ -110,18 +117,29 @@ given Texlive COMPONENT." ;; Keep the standard inputs of 'gnu-build-system'. ,@(standard-packages))) (build-inputs `(("texlive-bin" ,texlive-bin) - ("texlive-latex-base" ,texlive-latex-base) + ,@(if texlive-latex-base + `(("texlive-latex-base" ,texlive-latex-base)) + '()) ,@native-inputs)) (outputs outputs) (build texlive-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (texlive-build store name inputs +(define* (texlive-build name inputs #:key + source (tests? #f) tex-directory (build-targets #f) - (tex-format "luatex") + (tex-engine #f) + + ;; FIXME: This would normally default to "luatex" but + ;; LuaTeX has a bug where sometimes it corrupts the + ;; heap and aborts. This causes the build of texlive + ;; packages to fail at random. The problem is being + ;; tracked at <https://issues.guix.gnu.org/48064>. + (tex-format "pdftex") + (phases '(@ (guix build texlive-build-system) %standard-phases)) (outputs '("out")) @@ -135,43 +153,34 @@ given Texlive COMPONENT." (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (texlive-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:tex-directory ,tex-directory - #:build-targets ,build-targets - #:tex-format ,tex-format - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(texlive-build #:name #$name + #:source #+source + #:tex-directory #$tex-directory + #:build-targets #$build-targets + #:tex-engine #$(if tex-engine + tex-engine + tex-format) + #:tex-format #$tex-format + #:system #$system + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths))))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (gexp->derivation name builder + #:system system + #:target #f + #:substitutable? substitutable?)) (define texlive-build-system (build-system diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index b50ef7cd92..378ae481b9 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2018, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,24 +19,16 @@ (define-module (guix build-system trivial) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) #:use-module (ice-9 match) #:export (trivial-build-system)) -(define (guile-for-build store guile system) - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - (define* (lower name #:key source inputs native-inputs outputs system target - guile builder modules allowed-references) + guile builder (modules '()) allowed-references) "Return a bag for NAME." (bag (name name) @@ -54,65 +46,50 @@ #:modules ,modules #:allowed-references ,allowed-references)))) -(define* (trivial-build store name inputs +(define* (trivial-build name inputs #:key - outputs guile system builder (modules '()) + outputs guile + system builder (modules '()) search-paths allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system - #:graft? #f))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system - #:graft? #f) - output)) - ((? string? output) - output))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:outputs outputs - #:modules modules - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f)) + (builder -> (if (pair? builder) + (sexp->gexp builder) + builder))) + (gexp->derivation name (with-build-variables inputs outputs builder) + #:system system + #:target #f + #:graft? #f + #:modules modules + #:allowed-references allowed-references + #:guile-for-build guile))) -(define* (trivial-cross-build store name +(define* (trivial-cross-build name #:key - target native-drvs target-drvs + target + source build-inputs target-inputs host-inputs outputs guile system builder (modules '()) search-paths native-search-paths allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-cross-derivation store p system))) - (((? package? p) output) - (derivation->output-path (package-cross-derivation store p system) - output)) - ((? string? output) - output))) - - (build-expression->derivation store name builder - #:inputs (append native-drvs target-drvs) - #:system system - #:outputs outputs - #:modules modules - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f)) + (builder -> (if (pair? builder) + (sexp->gexp builder) + builder))) + (gexp->derivation name (with-build-variables + (append build-inputs target-inputs host-inputs) + outputs + builder) + #:system system + #:target target + #:graft? #f + #:modules modules + #:allowed-references allowed-references + #:guile-for-build guile))) (define trivial-build-system (build-system diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index 044d2a0829..e8cd5520b8 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -19,6 +19,8 @@ (define-module (guix build-system waf) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -52,7 +54,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:python #:inputs #:native-inputs)) + '(#:target #:python #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -71,58 +73,46 @@ (build waf-build) ; only change compared to 'lower' in python.scm (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (waf-build store name inputs - #:key - (tests? #t) - (test-target "check") - (configure-flags ''()) - (phases '(@ (guix build waf-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %waf-build-system-modules) - (modules '((guix build waf-build-system) - (guix build utils)))) +(define* (waf-build name inputs + #:key source + (tests? #t) + (test-target "check") + (configure-flags #~'()) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %waf-build-system-modules) + (modules '((guix build waf-build-system) + (guix build utils)))) "Build SOURCE with INPUTS. This assumes that SOURCE provides a 'waf' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (waf-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:configure-flags ,configure-flags - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (define build + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(waf-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs)))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:target #f + #:modules imported-modules + #:guile-for-build guile))) (define waf-build-system (build-system diff --git a/guix/build/clojure-build-system.scm b/guix/build/clojure-build-system.scm index d8f7c89f85..7d494078ea 100644 --- a/guix/build/clojure-build-system.scm +++ b/guix/build/clojure-build-system.scm @@ -34,8 +34,24 @@ ;; ;; Code: +(define* (compile-java #:key + java-source-dirs java-compile-dir + #:allow-other-keys) + "Compile java sources for use in clojure-build-system." + (let ((java-files (append-map (lambda (dir) + (find-files dir "\\.java$")) + java-source-dirs))) + (mkdir-p java-compile-dir) + (when (not (null? java-files)) + (apply invoke + "javac" + "-verbose" + "-d" java-compile-dir + java-files)))) + (define* (build #:key - source-dirs compile-dir + source-dirs java-source-dirs + compile-dir java-compile-dir jar-names main-class omit-source? aot-include aot-exclude #:allow-other-keys) @@ -46,19 +62,24 @@ #:all-list libs))) (mkdir-p compile-dir) (eval-with-clojure `(run! compile ',libs*) - source-dirs) + (cons* compile-dir + java-compile-dir + source-dirs)) (let ((source-dir-files-alist (map (lambda (dir) (cons dir (find-files* dir))) - source-dirs)) + (append source-dirs + java-source-dirs))) ;; workaround transitive compilation in Clojure (classes (filter (lambda (class) (any (cut compiled-from? class <>) libs*)) (find-files* compile-dir)))) - (for-each (cut create-jar <> (cons (cons compile-dir classes) - (if omit-source? - '() - source-dir-files-alist)) + (for-each (cut create-jar <> (cons* (cons compile-dir classes) + (cons java-compile-dir + (find-files* java-compile-dir)) + (if omit-source? + '() + source-dir-files-alist)) #:main-class main-class) jar-names) #t))) @@ -78,8 +99,11 @@ priority over TEST-INCLUDE." (for-each (lambda (jar) (eval-with-clojure `(do (apply require '(clojure.test ,@libs*)) - (apply clojure.test/run-tests - ',libs*)) + (if (clojure.test/successful? + (apply clojure.test/run-tests + ',libs*)) + (System/exit 0) + (System/exit 1))) (cons jar test-dirs))) jar-names))) #t) @@ -91,6 +115,7 @@ priority over TEST-INCLUDE." (define-with-docs %standard-phases "Standard build phases for clojure-build-system." (modify-phases %standard-phases@ant + (add-before 'build 'compile-java compile-java) (replace 'build build) (replace 'check check) (replace 'install install) diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index a9ffad3c8f..c5322141d3 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -32,8 +32,10 @@ install-doc %source-dirs + %java-source-dirs %test-dirs %compile-dir + %java-compile-dir package-name->jar-names %main-class %omit-source? @@ -101,6 +103,10 @@ DOC-REGEX can be compiled or uncompiled." "A default list of source directories." '("src/")) +(define-with-docs %java-source-dirs + "A default list of java source directories." + '()) + (define-with-docs %test-dirs "A default list of test directories." '("test/")) @@ -109,6 +115,10 @@ DOC-REGEX can be compiled or uncompiled." "Default directory for holding class files." "classes/") +(define-with-docs %java-compile-dir + "Default directory for holding java class files." + "java-classes/") + (define (package-name->jar-names name) "Given NAME, a package name like \"foo-0.9.1b\", return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")." @@ -135,7 +145,7 @@ all libraries found under the source directories." (define-with-docs %aot-exclude "A default list of symbols deciding what not to compile. See the doc string of '%aot-include' for more details." - '()) + '(data-readers)) (define-with-docs %tests? "Enable tests by default." diff --git a/guix/build/compile.scm b/guix/build/compile.scm index b86ec3b743..5b27b55d02 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2014, 2016-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -37,6 +37,21 @@ ;;; ;;; Code: +(define (clear-keyword-arguments keywords args) + "Set to #f the value associated with each of the KEYWORDS in ARGS." + (let loop ((args args) + (result '())) + (match args + (() + (reverse result)) + (((? keyword? kw) arg . rest) + (loop rest + (if (memq kw keywords) + (cons* #f kw result) + (cons* arg kw result)))) + ((head . tail) + (loop tail (cons head result)))))) + (define optimizations-for-level (or (and=> (false-if-exception (resolve-interface '(system base optimize))) @@ -60,9 +75,18 @@ (loop rest `(#f ,kw ,@result)))))) (lambda (level) - (if (<= level 1) - %lightweight-optimizations - %default-optimizations))))) + ;; In the upcoming Guile 3.0.8, .go files include code of their + ;; inlinable exports and free variables are resolved at compile time + ;; (both are enabled at -O1) to permit cross-module inlining + ;; (enabled at -O2). Unfortunately, this currently leads to + ;; non-reproducible and more expensive builds, so we turn it off + ;; here: + ;; <https://wingolog.org/archives/2021/05/13/cross-module-inlining-in-guile>. + (clear-keyword-arguments '(#:inlinable-exports? #:resolve-free-vars? + #:cross-module-inlining?) + (if (<= level 1) + %lightweight-optimizations + %default-optimizations)))))) (define (supported-warning-type? type) "Return true if TYPE, a symbol, denotes a supported warning type." diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm index a86f0cde29..fb2d1db056 100644 --- a/guix/build/copy-build-system.scm +++ b/guix/build/copy-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> +;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -58,7 +59,7 @@ In the above, FILTERS are optional. one of the elements in the list. - With `#:include-regexp`, install subpaths matching the regexps in the list. - The `#:exclude*` FILTERS work similarly. Without `#:include*` flags, - install every subpath but the files matching the `#:exlude*` filters. + install every subpath but the files matching the `#:exclude*` filters. If both `#:include*` and `#:exclude*` are specified, the exclusion is done on the inclusion list. @@ -133,8 +134,8 @@ given, then the predicate always returns DEFAULT-VALUE." file-list)))) (define* (install source target #:key include exclude include-regexp exclude-regexp) - (set! target (string-append (assoc-ref outputs "out") "/" target)) - (let ((filters? (or include exclude include-regexp exclude-regexp))) + (let ((final-target (string-append (assoc-ref outputs "out") "/" target)) + (filters? (or include exclude include-regexp exclude-regexp))) (when (and (not (file-is-directory? source)) filters?) (error "Cannot use filters when SOURCE is a file.")) @@ -143,12 +144,12 @@ given, then the predicate always returns DEFAULT-VALUE." (and (file-is-directory? source) filters?)))) (if multi-files-in-source? - (install-file-list source target + (install-file-list source final-target #:include include #:exclude exclude #:include-regexp include-regexp #:exclude-regexp exclude-regexp) - (install-simple source target))))) + (install-simple source final-target))))) (for-each (lambda (plan) (apply install plan)) install-plan) #t) diff --git a/guix/build/download.scm b/guix/build/download.scm index 1ed623034b..7c310e94f1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -36,7 +36,7 @@ #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) #:autoload (guix base16) (bytevector->base16-string) - #:autoload (guix swh) (swh-download-directory) + #:autoload (guix swh) (swh-download-directory %verify-swh-certificate?) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -646,6 +646,8 @@ and write the output to FILE." #:verify-certificate? verify-certificate? #:timeout timeout))) + (format #t "Retrieving Disarchive spec from ~a ...~%" + (uri->string uri)) (let ((specification (read port))) (close-port port) specification)))) @@ -674,7 +676,8 @@ and write the output to FILE." (match (fetch-specification uris) (#f (format #t "could not find its Disarchive specification~%") #f) - (spec (parameterize ((%disarchive-log-port (current-output-port))) + (spec (parameterize ((%disarchive-log-port (current-output-port)) + (%verify-swh-certificate? verify-certificate?)) (false-if-exception* (disarchive-assemble spec file #:resolver resolve)))))))) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index e41e9a6595..ab77e57f33 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -53,8 +53,7 @@ ;; These are the default inclusion/exclusion regexps for the install phase. (define %default-include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) -(define %default-exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" - "^[^/]*tests?\\.el$")) +(define %default-exclude '("^\\.dir-locals\\.el$" "^[^/]*tests?\\.el$")) (define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack)) @@ -111,7 +110,7 @@ environment variable\n" source-directory)) (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out"))) (setenv "SHELL" "sh") (parameterize ((%emacs emacs)) @@ -121,24 +120,10 @@ environment variable\n" source-directory)) "Substitute the absolute \"/bin/\" directory with the right location in the store in '.el' files." - (define (file-contains-nul-char? file) - (call-with-input-file file - (lambda (in) - (let loop ((line (read-line in 'concat))) - (cond - ((eof-object? line) #f) - ((string-index line #\nul) #t) - (else (loop (read-line in 'concat)))))) - #:binary #t)) - (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (el-dir (string-append out %install-dir "/" elpa-name-ver)) - ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with - ;; strings containing NULs. Filter out such files. TODO: Remove - ;; this workaround when <https://bugs.gnu.org/30116> is fixed. - (el-files (remove file-contains-nul-char? - (find-files (getcwd) "\\.el$")))) + (el-files (find-files (getcwd) "\\.el$"))) (define (substitute-program-names) (substitute* el-files (("\"/bin/([^.]\\S*)\"" _ cmd-name) @@ -234,7 +219,7 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (define* (make-autoloads #:key outputs inputs #:allow-other-keys) "Generate the autoloads file." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (elpa-name (package-name->name+version elpa-name-ver)) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index ba680fd1a9..475a94ae4f 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +29,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + %gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache glib-or-gtk-build)) ;; Commentary: @@ -50,12 +54,24 @@ "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list with all found directories." (let* ((version - (if (string-match "gtk\\+-3" - (or (assoc-ref inputs "gtk+") - (assoc-ref inputs "source") - "gtk+-3")) ; we default to version 3 - "3.0" - "2.0")) + (cond + ((string-match "gtk-4" + (or (assoc-ref inputs "gtk") + (assoc-ref inputs "source") + "")) + "4.0") + ((string-match "gtk\\+-3" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "3.0") + ((string-match "gtk\\+-2" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "2.0") + (else + "4.0"))) ; We default to version 4.0. (gtk-module (lambda (input prev) (let* ((in (match input @@ -136,69 +152,41 @@ Wrapping is not applied to outputs whose name is listed in GLIB-OR-GTK-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not to contain any GLib or GTK+ binaries, and where wrapping would gratuitously add a dependency of that output on GLib and GTK+." + ;; Do not require bash to be present in the package inputs + ;; even when there is nothing to wrap. + ;; Also, calculate (sh) only once to prevent some I/O. + (define %sh (delay (search-input-file inputs "bin/bash"))) + (define (sh) (force %sh)) (define handle-output (match-lambda - ((output . directory) - (unless (member output glib-or-gtk-wrap-excluded-outputs) - (let* ((bindir (string-append directory "/bin")) - (libexecdir (string-append directory "/libexec")) - (bin-list (append (find-files bindir ".*") - (find-files libexecdir ".*"))) - (datadirs (data-directories - (alist-cons output directory inputs))) - (gtk-mod-dirs (gtk-module-directories - (alist-cons output directory inputs))) - (gio-mod-dirs (gio-module-directories - (alist-cons output directory inputs))) - (data-env-var - (if (not (null? datadirs)) - `("XDG_DATA_DIRS" ":" prefix ,datadirs) - #f)) - (gtk-mod-env-var - (if (not (null? gtk-mod-dirs)) - `("GTK_PATH" ":" prefix ,gtk-mod-dirs) - #f)) - (gio-mod-env-var - (if (not (null? gio-mod-dirs)) - `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs) - #f))) - (cond - ((and data-env-var gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> - data-env-var - gtk-mod-env-var - gio-mod-env-var) - bin-list)) - ((and data-env-var gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> - data-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> - data-env-var - gio-mod-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> - gio-mod-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var)) - (for-each (cut wrap-program <> - data-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> - gtk-mod-env-var) - bin-list)) - ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> - gio-mod-env-var) - bin-list)))))))) + ((output . directory) + (unless (member output glib-or-gtk-wrap-excluded-outputs) + (let* ((bindir (string-append directory "/bin")) + (libexecdir (string-append directory "/libexec")) + (bin-list (filter (negate wrapped-program?) + (append (find-files bindir ".*") + (find-files libexecdir ".*")))) + (datadirs (data-directories + (alist-cons output directory inputs))) + (gtk-mod-dirs (gtk-module-directories + (alist-cons output directory inputs))) + (gio-mod-dirs (gio-module-directories + (alist-cons output directory inputs))) + (env-vars `(,@(if (not (null? datadirs)) + (list `("XDG_DATA_DIRS" ":" prefix ,datadirs)) + '()) + ,@(if (not (null? gtk-mod-dirs)) + (list `("GTK_PATH" ":" prefix ,gtk-mod-dirs)) + '()) + ,@(if (not (null? gio-mod-dirs)) + (list `("GIO_EXTRA_MODULES" ":" + prefix ,gio-mod-dirs)) + '())))) + (for-each (lambda (program) + (apply wrap-program program #:sh (sh) env-vars)) + bin-list)))))) - (for-each handle-output outputs) - #t) + (for-each handle-output outputs)) (define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas @@ -211,11 +199,58 @@ if needed." (not (file-exists? (string-append schemasdir "/gschemas.compiled")))) (invoke "glib-compile-schemas" schemasdir))))) - outputs) - #t) + outputs)) + +;; This file is to be generated by the +;; `generate-gdk-pixbuf-loaders-cache' build phase defined below. +(define %gdk-pixbuf-loaders-cache-file + "lib/gdk-pixbuf-2.0/2.10.0/loaders.cache") + +(define (generate-gdk-pixbuf-loaders-cache directories outputs) + "Generate the loaders.cache file used by gdk-pixbuf to locate the available +loaders among DIRECTORIES, and set the GDK_PIXBUF_MODULE_FILE environment +variable. The cache file is installed under OUTPUTS. Return the first cache +file name if one was created else #f." + (let* ((loaders (append-map + (cut find-files <> "^libpixbufloader-.*\\.so$") + directories)) + (outputs* (map (cut string-append <> "/" + %gdk-pixbuf-loaders-cache-file) + outputs)) + (loaders.cache (first outputs*)) + (loaders.cache-copies (cdr outputs*))) + (if (not (null? loaders)) + (begin + (mkdir-p (dirname loaders.cache)) + (setenv "GDK_PIXBUF_MODULE_FILE" loaders.cache) + (apply invoke "gdk-pixbuf-query-loaders" "--update-cache" loaders) + (for-each (lambda (f) + (mkdir-p (dirname f)) + (copy-file loaders.cache f)) + loaders.cache-copies) + loaders.cache) + #f))) + +(define* (generate-gdk-pixbuf-loaders-cache-file #:key inputs outputs + #:allow-other-keys) + "Build phase that Wraps the GENERATE-GDK-PIXBUF-LOADERS-CACHE procedure." + ;; Conditionally compute the cache file if the gdk-pixbuf command is + ;; available on PATH (it comes with gdk-pixbuf). + (when (which "gdk-pixbuf-query-loaders") + (let ((loaders.cache (generate-gdk-pixbuf-loaders-cache + (map cdr inputs) + (filter-map identity + (list + (assoc-ref outputs "out") + (assoc-ref outputs "bin") + (assoc-ref outputs "lib")))))) + (when loaders.cache + (format #t "GDK_PIXBUF_MODULE_FILE set to `~a'~%" loaders.cache))))) (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'generate-gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache-file) (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas) (add-after 'install 'glib-or-gtk-wrap wrap-all-programs))) diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 2e7dff2034..d84411c090 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ #:use-module (rnrs io ports) #:export (%standard-phases %license-file-regexp + %bootstrap-scripts dump-file-contents gnu-build)) @@ -57,23 +59,26 @@ "Set the 'SOURCE_DATE_EPOCH' environment variable. This is used by tools that incorporate timestamps as a way to tell them to use a fixed timestamp. See https://reproducible-builds.org/specs/source-date-epoch/." - (setenv "SOURCE_DATE_EPOCH" "1") - #t) + (setenv "SOURCE_DATE_EPOCH" "1")) (define (first-subdirectory directory) - "Return the file name of the first sub-directory of DIRECTORY." + "Return the file name of the first sub-directory of DIRECTORY or false, when +there are none." (match (scandir directory (lambda (file) (and (not (member file '("." ".."))) (file-is-directory? (string-append directory "/" file))))) - ((first . _) first))) + ((first . _) first) + (_ #f))) (define* (set-paths #:key target inputs native-inputs (search-paths '()) (native-search-paths '()) #:allow-other-keys) (define input-directories - (match inputs + ;; The "source" input can be a directory, but we don't want it for search + ;; paths. See <https://issues.guix.gnu.org/44924>. + (match (alist-delete "source" inputs) (((_ . dir) ...) dir))) @@ -113,9 +118,7 @@ See https://reproducible-builds.org/specs/source-date-epoch/." #:separator separator #:type type #:pattern pattern))) - native-search-paths)) - - #t) + native-search-paths))) (define* (install-locale #:key (locale "en_US.utf8") @@ -134,15 +137,13 @@ chance to be set." (setenv (locale-category->string locale-category) locale) (format (current-error-port) "using '~a' locale for category ~s~%" - locale (locale-category->string locale-category)) - #t) + locale (locale-category->string locale-category))) (lambda args ;; This is known to fail for instance in early bootstrap where locales ;; are not available. (format (current-error-port) "warning: failed to install '~a' locale: ~a~%" - locale (strerror (system-error-errno args))) - #t))) + locale (strerror (system-error-errno args)))))) (define* (unpack #:key source #:allow-other-keys) "Unpack SOURCE in the working directory, and change directory within the @@ -156,13 +157,25 @@ working directory." ;; Preserve timestamps (set to the Epoch) on the copied tree so that ;; things work deterministically. (copy-recursively source "." - #:keep-mtime? #t)) + #:keep-mtime? #t) + ;; Make the source checkout files writable, for convenience. + (for-each (lambda (f) + (false-if-exception (make-file-writable f))) + (find-files "."))) (begin - (if (string-suffix? ".zip" source) - (invoke "unzip" source) - (invoke "tar" "xvf" source)) - (chdir (first-subdirectory ".")))) - #t) + (cond + ((string-suffix? ".zip" source) + (invoke "unzip" source)) + ((tarball? source) + (invoke "tar" "xvf" source)) + (else + (let ((name (strip-store-file-name source)) + (command (compressor source))) + (copy-file source name) + (when command + (invoke command "--decompress" name))))) + ;; Attempt to change into child directory. + (and=> (first-subdirectory ".") chdir)))) (define %bootstrap-scripts ;; Typical names of Autotools "bootstrap" scripts. @@ -205,8 +218,7 @@ working directory." (invoke "autoreconf" "-vif") (format #t "no 'configure.ac' or anything like that, \ doing nothing~%")))) - (format #t "GNU build system bootstrapping not needed~%")) - #t) + (format #t "GNU build system bootstrapping not needed~%"))) ;; See <http://bugs.gnu.org/17840>. (define* (patch-usr-bin-file #:key native-inputs inputs @@ -220,8 +232,7 @@ things like the ABI being used." (for-each (lambda (file) (when (executable-file? file) (patch-/usr/bin/file file))) - (find-files "." "^configure$"))) - #t) + (find-files "." "^configure$")))) (define* (patch-source-shebangs #:key source #:allow-other-keys) "Patch shebangs in all source files; this includes non-executable @@ -233,8 +244,7 @@ $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's (lambda (file stat) ;; Filter out symlinks. (eq? 'regular (stat:type stat))) - #:stat lstat)) - #t) + #:stat lstat))) (define (patch-generated-file-shebangs . rest) "Patch shebangs in generated files, including `SHELL' variables in @@ -249,9 +259,7 @@ makefiles." #:stat lstat)) ;; Patch `SHELL' in generated makefiles. - (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")) - - #t) + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) (define* (configure #:key build target native-inputs inputs outputs (configure-flags '()) out-of-source? @@ -381,8 +389,7 @@ makefiles." `("-j" ,(number->string (parallel-job-count))) '()) ,@make-flags))) - (format #t "test suite not run~%")) - #t) + (format #t "test suite not run~%"))) (define* (install #:key (make-flags '()) #:allow-other-keys) (apply invoke "make" "install" make-flags)) @@ -400,7 +407,8 @@ makefiles." (match-lambda ((_ . dir) (list (string-append dir "/bin") - (string-append dir "/sbin"))))) + (string-append dir "/sbin") + (string-append dir "/libexec"))))) (define output-bindirs (append-map bin-directories outputs)) @@ -415,8 +423,7 @@ makefiles." (for-each (lambda (dir) (let ((files (list-of-files dir))) (for-each (cut patch-shebang <> path) files))) - output-bindirs))) - #t) + output-bindirs)))) (define* (strip #:key target outputs (strip-binaries? #t) (strip-command (if target @@ -425,7 +432,7 @@ makefiles." (objcopy-command (if target (string-append target "-objcopy") "objcopy")) - (strip-flags '("--strip-debug" + (strip-flags '("--strip-unneeded" "--enable-deterministic-archives")) (strip-directories '("lib" "lib64" "libexec" "bin" "sbin")) @@ -514,8 +521,7 @@ makefiles." (let ((sub (string-append dir "/" d))) (and (directory-exists? sub) sub))) strip-directories))) - outputs))) - #t) + outputs)))) (define* (validate-runpath #:key (validate-runpath? #t) @@ -560,9 +566,7 @@ phase after stripping." outputs))) (unless (every* validate dirs) (error "RUNPATH validation failed"))) - (format (current-error-port) "skipping RUNPATH validation~%")) - - #t) + (format (current-error-port) "skipping RUNPATH validation~%"))) (define* (validate-documentation-location #:key outputs #:allow-other-keys) @@ -582,8 +586,7 @@ and 'man/'. This phase moves directories to the right place if needed." (match outputs (((names . directories) ...) - (for-each validate-output directories))) - #t) + (for-each validate-output directories)))) (define* (reset-gzip-timestamps #:key outputs #:allow-other-keys) "Reset embedded timestamps in gzip files found in OUTPUTS." @@ -595,12 +598,13 @@ and 'man/'. This phase moves directories to the right place if needed." (string-suffix? ".tgz" file)) (gzip-file? file))) #:stat lstat))) + ;; Ensure the files are writable. + (for-each make-file-writable files) (for-each reset-gzip-timestamp files))) (match outputs (((names . directories) ...) - (for-each process-directory directories))) - #t) + (for-each process-directory directories)))) (define* (compress-documentation #:key outputs (compress-documentation? #t) @@ -616,7 +620,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (let ((target (readlink link))) (delete-file link) (symlink (string-append target compressed-documentation-extension) - link))) + (string-append link compressed-documentation-extension)))) (define (has-links? file) ;; Return #t if FILE has hard links. @@ -679,8 +683,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (match outputs (((names . directories) ...) (for-each maybe-compress directories))) - (format #t "not compressing documentation~%")) - #t) + (format #t "not compressing documentation~%"))) (define* (delete-info-dir-file #:key outputs #:allow-other-keys) "Delete any 'share/info/dir' file from OUTPUTS." @@ -689,8 +692,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (let ((info-dir-file (string-append directory "/share/info/dir"))) (when (file-exists? info-dir-file) (delete-file info-dir-file))))) - outputs) - #t) + outputs)) (define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys) @@ -730,8 +732,74 @@ which cannot be found~%" (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) (string-append "TryExec=" (which binary) rest))))))))) - outputs) - #t) + outputs)) + +(define* (make-dynamic-linker-cache #:key outputs + (make-dynamic-linker-cache? #t) + #:allow-other-keys) + "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the +OUTPUTS. This reduces application startup time by avoiding the 'stat' storm +that traversing all the RUNPATH entries entails." + (define (make-cache-for-output directory) + (define bin-directories + (filter-map (lambda (sub-directory) + (let ((directory (string-append directory "/" + sub-directory))) + (and (directory-exists? directory) + directory))) + '("bin" "sbin" "libexec"))) + + (define programs + ;; Programs that can benefit from the ld.so cache. + (append-map (lambda (directory) + (if (directory-exists? directory) + (find-files directory + (lambda (file stat) + (and (executable-file? file) + (elf-file? file)))) + '())) + bin-directories)) + + (define library-path + ;; Directories containing libraries that PROGRAMS depend on, + ;; recursively. + (delete-duplicates + (append-map (lambda (program) + (map dirname (file-needed/recursive program))) + programs))) + + (define cache-file + (string-append directory "/etc/ld.so.cache")) + + (define ld.so.conf + (string-append (or (getenv "TMPDIR") "/tmp") + "/ld.so.conf")) + + (unless (null? library-path) + (mkdir-p (dirname cache-file)) + (guard (c ((invoke-error? c) + ;; Do not treat 'ldconfig' failure as an error. + (format (current-error-port) + "warning: 'ldconfig' failed:~%") + (report-invoke-error c (current-error-port)))) + ;; Create a config file to tell 'ldconfig' where to look for the + ;; libraries that PROGRAMS need. + (call-with-output-file ld.so.conf + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + library-path))) + + (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file) + (format #t "created '~a' from ~a library search path entries~%" + cache-file (length library-path))))) + + (if make-dynamic-linker-cache? + (match outputs + (((_ . directories) ...) + (for-each make-cache-for-output directories))) + (format #t "ld.so cache not built~%"))) (define %license-file-regexp ;; Regexp matching license files. @@ -796,8 +864,7 @@ which cannot be found~%" package)) (map (cut string-append source "/" <>) files))) (format (current-error-port) - "failed to find license files~%")) - #t)) + "failed to find license files~%")))) (define %standard-phases ;; Standard build phases, as a list of symbol/procedure pairs. @@ -813,6 +880,7 @@ which cannot be found~%" validate-documentation-location delete-info-dir-file patch-dot-desktop-files + make-dynamic-linker-cache install-license-files reset-gzip-timestamps compress-documentation))) @@ -840,26 +908,30 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." (exit 1))) ;; The trick is to #:allow-other-keys everywhere, so that each procedure in ;; PHASES can pick the keyword arguments it's interested in. - (every (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) + (for-each (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (define (end-of-phase success?) + (let ((end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name success? + (elapsed-time end start)) - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ -## WARNING: phase `~a' returned `~s'. Return values other than #t -## are deprecated. Please migrate this package so that its phase -## procedures report errors by raising an exception, and otherwise -## always return #t.~%" - name result)) + ;; Dump the environment variables as a shell script, + ;; for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables"))) - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases))) + (format #t "starting phase `~a'~%" name) + (with-throw-handler #t + (lambda () + (apply proc args) + (end-of-phase #t)) + (lambda args + ;; This handler executes before the stack is unwound. + ;; The exception is automatically re-thrown from here, + ;; and we should get a proper backtrace. + (format (current-error-port) + "error: in phase '~a': uncaught exception: +~{~s ~}~%" name args) + (end-of-phase #f)))))) + phases))) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 645d2fe680..7f25e05d0d 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -138,9 +139,28 @@ of the package being built and its dependencies, and GOBIN, which determines where executables (\"commands\") are installed to. This phase is sometimes used by packages that use (guix build-system gnu) but have a handful of Go dependencies, so it should be self-contained." - ;; The Go cache is required starting in Go 1.12. We don't actually use it but - ;; we need it to be a writable directory. - (setenv "GOCACHE" "/tmp/go-cache") + (define (search-input-directories dir) + (filter directory-exists? + (map (match-lambda + ((name . directory) + (string-append directory "/" dir))) + inputs))) + + ;; Seed the Go build cache with the build caches from input packages. + (let ((cache (string-append (getcwd) "/go-build"))) + (setenv "GOCACHE" cache) + (union-build cache + (search-input-directories "/var/cache/go/build") + ;; Creating all directories isn't that bad, because there are + ;; only ever 256 of them. + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + + ;; Tell Go that the cache was recently trimmed, so it doesn't try to. + (call-with-output-file (string-append cache "/trim.txt") + (lambda (port) + (format port "~a" (current-time))))) + ;; Using the current working directory as GOPATH makes it easier for packagers ;; who need to manipulate the unpacked source code. (setenv "GOPATH" (getcwd)) @@ -152,8 +172,10 @@ dependencies, so it should be self-contained." ;; Make sure we're building for the correct architecture and OS targets ;; that Guix targets. - (setenv "GOARCH" goarch) - (setenv "GOOS" goos) + (setenv "GOARCH" (or goarch + (getenv "GOHOSTARCH"))) + (setenv "GOOS" (or goos + (getenv "GOHOSTOS"))) (match goarch ("arm" (setenv "GOARM" "7")) diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index e8ea66dfb3..2a74d51dd9 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +41,17 @@ elf-dynamic-info-runpath expand-origin + file-dynamic-info + file-runpath + file-needed + file-needed/recursive + + missing-runpath-error? + missing-runpath-error-file + runpath-too-long-error? + runpath-too-long-error-file + set-file-runpath + validate-needed-in-runpath strip-runpath)) @@ -215,7 +226,9 @@ string table if the type is a string." (#f #f) ((? elf-segment? dynamic) (let ((entries (dynamic-entries elf dynamic))) - (%elf-dynamic-info (find (matching-entry DT_SONAME) entries) + (%elf-dynamic-info (and=> (find (matching-entry DT_SONAME) + entries) + dynamic-entry-value) (filter-map (lambda (entry) (and (= (dynamic-entry-type entry) DT_NEEDED) @@ -232,6 +245,63 @@ string table if the type is a string." dynamic-entry-value)) '())))))) +(define (file-dynamic-info file) + "Return the <elf-dynamic-info> record of FILE, or #f if FILE lacks dynamic +info." + (call-with-input-file file + (lambda (port) + (elf-dynamic-info (parse-elf (get-bytevector-all port)))))) + +(define (file-runpath file) + "Return the DT_RUNPATH dynamic entry of FILE as a list of strings, or #f if +FILE lacks dynamic info." + (and=> (file-dynamic-info file) elf-dynamic-info-runpath)) + +(define (file-needed file) + "Return the list of DT_NEEDED dynamic entries of FILE, or #f if FILE lacks +dynamic info." + (and=> (file-dynamic-info file) elf-dynamic-info-needed)) + +(define (file-needed/recursive file) + "Return two values: the list of absolute .so file names FILE depends on, +recursively, and the list of .so file names that could not be found. File +names are resolved by searching the RUNPATH of the file that NEEDs them. + +This is similar to the info returned by the 'ldd' command." + (let loop ((files (list file)) + (result '()) + (not-found '())) + (match files + (() + (values (reverse result) + (reverse (delete-duplicates not-found)))) + ((file . rest) + (match (file-dynamic-info file) + (#f + (loop rest result not-found)) + (info + (let ((runpath (elf-dynamic-info-runpath info)) + (needed (elf-dynamic-info-needed info))) + (if (and runpath needed) + (let* ((runpath (map (cute expand-origin <> (dirname file)) + runpath)) + (resolved (map (cut search-path runpath <>) + needed)) + (failed (filter-map (lambda (needed resolved) + (and (not resolved) + (not (libc-library? needed)) + needed)) + needed resolved)) + (needed (remove (lambda (value) + (or (not value) + ;; XXX: quadratic + (member value result))) + resolved))) + (loop (append rest needed) + (append needed result) + (append failed not-found))) + (loop rest result not-found))))))))) + (define %libc-libraries ;; List of libraries as of glibc 2.21 (there are more but those are ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.) @@ -364,4 +434,49 @@ according to DT_NEEDED." (false-if-exception (close-port port)) (apply throw key args)))) -;;; gremlin.scm ends here + +(define-condition-type &missing-runpath-error &elf-error + missing-runpath-error? + (file missing-runpath-error-file)) + +(define-condition-type &runpath-too-long-error &elf-error + runpath-too-long-error? + (file runpath-too-long-error-file)) + +(define (set-file-runpath file path) + "Set the value of the DT_RUNPATH dynamic entry of FILE, which must name an +ELF file, to PATH, a list of strings. Raise a &missing-runpath-error or +&runpath-too-long-error when appropriate." + (define (call-with-input+output-file file proc) + (let ((port (open-file file "r+b"))) + (guard (c (#t (close-port port) (raise c))) + (proc port) + (close-port port)))) + + (call-with-input+output-file file + (lambda (port) + (let* ((elf (parse-elf (get-bytevector-all port))) + (entries (dynamic-entries elf (dynamic-link-segment elf))) + (runpath (find (lambda (entry) + (= DT_RUNPATH (dynamic-entry-type entry))) + entries)) + (path (string->utf8 (string-join path ":")))) + (unless runpath + (raise (condition (&missing-runpath-error (elf elf) + (file file))))) + + ;; There might be padding left beyond RUNPATH in the string table, but + ;; we don't know, so assume there's no padding. + (unless (<= (bytevector-length path) + (bytevector-length + (string->utf8 (dynamic-entry-value runpath)))) + (raise (condition (&runpath-too-long-error (elf #f #;elf) + (file file))))) + + (seek port (dynamic-entry-offset runpath) SEEK_SET) + (put-bytevector port path) + (put-u8 port 0))))) + +;;; Local Variables: +;;; eval: (put 'call-with-input+output-file 'scheme-indent-function 1) +;;; End: diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 28253ce2f0..ef6cb316ee 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org> ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,13 +64,14 @@ ((file-exists? "Setup.lhs") "Setup.lhs") (else - #f)))) + #f))) + (pkgdb (string-append "-package-db=" %tmp-db-dir))) (if setup-file (begin (format #t "running \"runhaskell Setup.hs\" with command ~s \ and parameters ~s~%" command params) - (apply invoke "runhaskell" setup-file command params)) + (apply invoke "runhaskell" pkgdb setup-file command params)) (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) @@ -141,17 +143,6 @@ and parameters ~s~%" (find-files lib "\\.a$")))) #t) -(define (grep rx port) - "Given a regular-expression RX including a group, read from PORT until the -first match and return the content of the group." - (let ((line (read-line port))) - (if (eof-object? line) - #f - (let ((rx-result (regexp-exec rx line))) - (if rx-result - (match:substring rx-result 1) - (grep rx port)))))) - (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." (let* ((haskell (assoc-ref inputs "haskell")) @@ -173,15 +164,8 @@ first match and return the content of the group." "Generate the GHC package database." (let* ((haskell (assoc-ref inputs "haskell")) (name-version (strip-store-file-name haskell)) - (input-dirs (match inputs - (((_ . dir) ...) - dir) - (_ '()))) ;; Silence 'find-files' (see 'evaluate-search-paths') - (conf-dirs (with-null-error-port - (search-path-as-list - `(,(string-append "lib/" name-version)) - input-dirs #:pattern ".*\\.conf.d$"))) + (conf-dirs (search-path-as-string->list (getenv "GHC_PACKAGE_PATH"))) (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) (mkdir-p %tmp-db-dir) (for-each (lambda (file) @@ -233,6 +217,8 @@ given Haskell package." (if (not (vhash-assoc id seen)) (let ((dep-conf (string-append src "/" id ".conf")) (dep-conf* (string-append dest "/" id ".conf"))) + (when (not (file-exists? dep-conf)) + (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file))) (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead? (loop (vhash-cons id #t seen) (append lst (conf-depends dep-conf)))) @@ -241,12 +227,13 @@ given Haskell package." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) - (name-verion (strip-store-file-name haskell)) + (name-version (strip-store-file-name haskell)) + (version (last (string-split name-version #\-))) (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) (config-dir (string-append lib - "/" name-verion + "/ghc-" version "/" name ".conf.d")) - (id-rx (make-regexp "^id: *(.*)$")) + (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) (config-file (string-append out "/" name ".conf")) (params (list (string-append "--gen-pkg-config=" config-file)))) @@ -254,8 +241,15 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (let* ((contents (call-with-input-file config-file read-string)) + (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1))) + + (when (or + (and + (string? config-file-name+id) + (string-null? config-file-name+id)) + (not config-file-name+id)) + (error (format #f "The package id for ~a is empty. This is a bug." config-file))) ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the ;; "haddock-interfaces" field and removing the optional "haddock-html" diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index d74acf2a05..03d669be64 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021, 2022 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,11 +22,13 @@ (define-module (guix build julia-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 popen) + #:use-module (srfi srfi-1) #:export (%standard-phases - julia-create-package-toml julia-build)) ;; Commentary: @@ -37,7 +41,7 @@ (invoke "julia" "-e" code)) ;; subpath where we store the package content -(define %package-path "/share/julia/packages/") +(define %package-path "/share/julia/loadpath/") (define (project.toml->name file) "Look for Julia package name in the TOML file FILE (usually named @@ -51,6 +55,18 @@ Project.toml)." (if m (match:substring m 1) (loop (read-line in 'concat))))))))) +(define (project.toml->uuid file) + "Look for Julia package uuid in the TOML file FILE (usually named +Project.toml)." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #f + (let ((m (string-match "uuid\\s*=\\s*\"(.*)\"" line))) + (if m (match:substring m 1) + (loop (read-line in 'concat))))))))) + (define* (install #:key source inputs outputs julia-package-name #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -59,8 +75,7 @@ Project.toml)." julia-package-name (project.toml->name "Project.toml"))))) (mkdir-p package-dir) - (copy-recursively (getcwd) package-dir)) - #t) + (copy-recursively (getcwd) package-dir))) (define* (precompile #:key source inputs outputs julia-package-name #:allow-other-keys) @@ -73,7 +88,7 @@ Project.toml)." (setenv "JULIA_DEPOT_PATH" builddir) ;; Add new package dir to the load path. (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) ;; Actual precompilation: @@ -84,39 +99,84 @@ Project.toml)." ;; element of DEPOT_PATH. Once the cache file exists, this hack is not ;; needed anymore (like in the check phase). If the user install new ;; packages, those will be installed and precompiled in the home dir. - (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package))) - #t) + (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " + package)))) (define* (check #:key tests? source inputs outputs julia-package-name - #:allow-other-keys) + parallel-tests? #:allow-other-keys) (when tests? (let* ((out (assoc-ref outputs "out")) (package (or julia-package-name (project.toml->name "Project.toml"))) - (builddir (string-append out "/share/julia/"))) + (builddir (string-append out "/share/julia/")) + (job-count (if parallel-tests? + (parallel-job-count) + 1)) + ;; The --proc argument of Julia *adds* extra processors rather than + ;; specify the exact count to use, so zero must be specified to + ;; disable parallel processing... + (additional-procs (max 0 (1- job-count)))) ;; With a patch, SOURCE_DATE_EPOCH is honored (setenv "SOURCE_DATE_EPOCH" "1") (setenv "JULIA_DEPOT_PATH" builddir) (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) + (setenv "JULIA_CPU_THREADS" (number->string job-count)) (setenv "HOME" "/tmp") - (invoke "julia" "--depwarn=yes" - (string-append builddir "packages/" - package "/test/runtests.jl")))) - #t) + (apply invoke "julia" + `("--depwarn=yes" + ,@(if parallel-tests? + ;; XXX: ... but '--procs' doesn't accept 0 as a valid + ;; value, so just omit the argument entirely. + (list (string-append "--procs=" + (number->string additional-procs))) + '()) + ,(string-append builddir "loadpath/" + package "/test/runtests.jl")))))) + +(define* (link-depot #:key source inputs outputs + julia-package-name julia-package-uuid #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (name+version (strip-store-file-name out)) + (version (last (string-split name+version #\-))) + (package-name (or + julia-package-name + (project.toml->name "Project.toml"))) + (package-dir (string-append out %package-path package-name)) + (uuid (or julia-package-uuid (project.toml->uuid "Project.toml"))) + (pipe (open-pipe* OPEN_READ "julia" "-e" + (format #f "using Pkg; +println(Base.version_slug(Base.UUID(\"~a\"), + Base.SHA1(Pkg.GitTools.tree_hash(\".\"))))" uuid))) + (slug (string-trim-right (get-string-all pipe)))) + ;; Few packages do not have the regular Project.toml file, then when they + ;; are propagated, dependencies do not find them and an raise error. + (unless (file-exists? "Project.toml") + (julia-create-package-toml (getcwd) + julia-package-name julia-package-uuid + version + #:file "Project.toml")) + + ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH + ;; for a path like packages/PACKAGE/XXXX + ;; Where XXXX is a slug encoding the package UUID and SHA1 of the files + ;; Here we create a link with the correct path to enable julia to find the + ;; package + (mkdir-p (string-append out "/share/julia/packages/" package-name)) + (symlink package-dir (string-append out "/share/julia/packages/" + package-name "/" slug)))) -(define (julia-create-package-toml outputs source - name uuid version - deps) - "Some packages are not using the new Package.toml dependency specifications. -Write this file manually, so that Julia can find its dependencies." +(define* (julia-create-package-toml location + name uuid version + #:optional + (deps '()) + #:key + (file "Project.toml")) + "Some packages are not using the new Project.toml dependency specifications. +Write this FILE manually, so that Julia can find its dependencies." (let ((f (open-file - (string-append - (assoc-ref outputs "out") - %package-path - (string-append - name "/Project.toml")) + (string-append location "/" file) "w"))) (display (string-append " @@ -130,14 +190,14 @@ version = \"" version "\" (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") f)) deps)) - (close-port f)) - #t) + (close-port f))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'check) ; tests must be run after installation (replace 'install install) (add-after 'install 'precompile precompile) + (add-after 'unpack 'link-depot link-depot) (add-after 'install 'check check) ;; TODO: In the future we could add a "system-image-generation" phase ;; where we use PackageCompiler.jl to speed up package loading times @@ -146,11 +206,12 @@ version = \"" version "\" (delete 'patch-usr-bin-file) (delete 'build))) -(define* (julia-build #:key inputs julia-package-name +(define* (julia-build #:key inputs julia-package-name julia-package-uuid (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Julia package, applying all of PHASES in order." (apply gnu:gnu-build #:inputs inputs #:phases phases #:julia-package-name julia-package-name + #:julia-package-uuid julia-package-uuid args)) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 8a02cb68dd..17d2637f87 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -281,7 +281,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained." type compress? #:allow-other-keys) - "Generate an executable by using asdf operation TYPE, containing whithin the + "Generate an executable by using asdf operation TYPE, containing within the image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are retained." diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm index 9e35e47a7f..193a76b7cb 100644 --- a/guix/build/maven/pom.scm +++ b/guix/build/maven/pom.scm @@ -293,7 +293,7 @@ this repository contains." #:key with-plugins? with-build-dependencies? with-modules? (excludes '()) (local-packages '())) - "Open @var{pom-file}, and override its content, rewritting its dependencies + "Open @var{pom-file}, and override its content, rewriting its dependencies to set their version to the latest version available in the @var{inputs}. @var{#:with-plugins?} controls whether plugins are also overridden. diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index 8043a84abb..61ce45367d 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,16 +64,17 @@ (number->string (parallel-job-count)) "1"))) -(define* (check #:key test-target parallel-tests? tests? +(define* (check #:key tests? test-options parallel-tests? #:allow-other-keys) - (setenv "MESON_TESTTHREADS" - (if parallel-tests? - (number->string (parallel-job-count)) - "1")) (if tests? - (invoke "ninja" test-target) - (format #t "test suite not run~%")) - #t) + (begin + (setenv "MESON_TESTTHREADS" + (if parallel-tests? + (number->string (parallel-job-count)) + "1")) + ;; Always provide "-t 0" to disable the 30 s default timeout. + (apply invoke "meson" "test" "--print-errorlogs" "-t" "0" test-options)) + (format #t "test suite not run~%"))) (define* (install #:rest args) (invoke "ninja" "install")) @@ -100,7 +102,7 @@ for example libraries only needed for the tests." (find-files dir elf-pred)) existing-elf-dirs)))) (for-each strip-runpath elf-list))))) - (for-each handle-output outputs) + (for-each handle-output (alist-delete "debug" outputs)) #t) (define %standard-phases diff --git a/guix/build/meson-configuration.scm b/guix/build/meson-configuration.scm new file mode 100644 index 0000000000..1aac5f8f0a --- /dev/null +++ b/guix/build/meson-configuration.scm @@ -0,0 +1,56 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; +;;; 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 build meson-configuration) + #:use-module (ice-9 match) + #:export (write-section-header write-assignment write-assignments)) + +;; Commentary: +;; +;; Utilities for generating a ‘Cross build definition file’ for +;; the Meson build system. Configuration values are currently +;; never escaped. In practice this is unlikely to be a problem +;; in the build environment. +;; +;; Code: + +(define (write-section-header port section-name) + "Write a section header for a section named SECTION-NAME to PORT." + (format port "[~a]~%" section-name)) + +(define (write-assignment port key value) + "Write an assignment of VALUE to KEY to PORT. + +VALUE must be a string (without any special characters such as quotes), +a boolean or an integer. Lists are currently not supported" + (match value + ((? string?) + (format port "~a = '~a'~%" key value)) + ((? integer?) + (format port "~a = ~a~%" key value)) + (#f + (format port "~a = true~%" key)) + (#t + (format port "~a = false~%" key)))) + +(define* (write-assignments port alist) + "Write the assignments in ALIST, an association list, to PORT." + (for-each (match-lambda + ((key . value) + (write-assignment port key value))) + alist)) diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm index 477cc3d1d0..5f68686067 100644 --- a/guix/build/minetest-build-system.scm +++ b/guix/build/minetest-build-system.scm @@ -23,6 +23,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (ice-9 exceptions) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module ((guix build copy-build-system) #:prefix copy:) #:export (%standard-phases @@ -40,7 +41,7 @@ ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt> ;; for an incomple list of files that can be found in mods. #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt" - "description.txt") + "description.txt" "config.txt" "_config.txt") #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$" ".mts$")))) @@ -199,20 +200,24 @@ auth_backend = sqlite3 (define (stop? line) (and (string? line) (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game."))) - (let loop () - (match (read-line port) - ((? error? line) - (error "minetest raised an error: ~a" line)) - ((? stop?) + (let loop ((has-errors? #f)) + (match `(,(read-line port) ,has-errors?) + (((? error? line) _) + (display line) + (newline) + (loop #t)) + (((? stop?) #f) (kill pid SIGINT) (close-port port) (waitpid pid)) - ((? string? line) + (((? eof-object?) #f) + (error "minetest didn't start")) + (((or (? stop?) (? eof-object?)) #t) + (error "minetest raised an error")) + (((? string? line) has-error?) (display line) (newline) - (loop)) - ((? eof-object?) - (error "minetest didn't start")))))))) + (loop has-error?)))))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index c5a876726f..5789ca3f0f 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -23,6 +23,7 @@ #:use-module (guix build utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (ice-9 popen) #:export (%standard-phases minify-build @@ -42,14 +43,17 @@ (minified (open-pipe* OPEN_READ "uglifyjs" file))) (call-with-output-file installed (cut dump-port minified <>)) - #t)) + (match (close-pipe minified) + (0 #t) + (status + (error "uglify-js failed" status))))) (define* (build #:key javascript-files #:allow-other-keys) (let ((files (or javascript-files (find-files "src" "\\.js$")))) (mkdir-p "guix/build") - (every (cut minify <> #:directory "guix/build/") files))) + (for-each (cut minify <> #:directory "guix/build/") files))) (define* (install #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -60,8 +64,7 @@ (if (not (zero? (stat:size (stat file)))) (install-file file js) (error "File is empty: " file))) - (find-files "guix/build" "\\.min\\.js$"))) - #t) + (find-files "guix/build" "\\.min\\.js$")))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 70a367618e..bee3792e93 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2021, 2022 Philip McGrath <philip@philipmcgrath.com> +;;; Copyright © 2022 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,16 +25,108 @@ #:use-module (guix build utils) #:use-module (guix build json) #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:export (%standard-phases + with-atomic-json-file-replacement + delete-dependencies node-build)) -;; Commentary: -;; -;; Builder-side code of the standard Node/NPM package install procedure. -;; -;; Code: +(define (with-atomic-json-file-replacement file proc) + "Like 'with-atomic-file-replacement', but PROC is called with a single +argument---the result of parsing FILE's contents as json---and should a value +to be written as json to the replacement FILE." + (with-atomic-file-replacement file + (lambda (in out) + (write-json (proc (read-json in)) out)))) + +(define* (assoc-ref* alist key #:optional default) + "Like assoc-ref, but return DEFAULT instead of #f if no value exists." + (match (assoc key alist) + (#f default) + ((_ . value) value))) + +(define* (jsobject-ref obj key #:optional default) + (match obj + (('@ . alist) (assoc-ref* alist key default)))) + +(define* (alist-pop alist key #:optional (= equal?)) + "Return two values, the first pair in ALIST with key KEY, and the other +elements. Equality calls are made as (= KEY ALISTCAR)." + (define (found? pair) + (= key (car pair))) + + (let ((before after (break found? alist))) + (if (pair? after) + (values (car after) (append before (cdr after))) + (values #f before)))) + +(define* (alist-update alist key proc #:optional default (= equal?)) + "Return an association list like ALIST, but with KEY mapped to the result of +PROC applied to the first value found under the comparison (= KEY ALISTCAR). +If no such value exists, use DEFAULT instead. +Unlike acons, this removes the previous association of KEY (assuming it is +unique), but the result may still share storage with ALIST." + (let ((pair rest (alist-pop alist key =))) + (acons key + (proc (if (pair? pair) + (cdr pair) + default)) + rest))) + +(define (jsobject-update* js . updates) + "Return a json object like JS, but with all UPDATES applied. Each update is +a list (KEY PROC [DEFAULT]), so that KEY is mapped to the result of PROC +applied to the value to which KEY is mapped in JS. If no such mapping exists, +PROC is instead applied to DEFAULT, or to '#f' is no DEFAULT is specified. +The update takes place from left to right, so later UPDATERs will receive the +values returned by earlier UPDATERs for the same KEY." + (match js + (('@ . alist) + (let loop ((alist alist) + (updates updates)) + (match updates + (() (cons '@ alist)) + (((key proc) . updates) + (loop (alist-update alist key proc #f equal?) updates)) + (((key proc default) . updates) + (loop (alist-update alist key proc default equal?) updates))))))) + +(define (jsobject-union combine seed . objects) + "Merge OBJECTS into SEED by applying (COMBINE KEY VAL0 VAL), where VAL0 +is the value found in the (possibly updated) SEED and VAL is the new value +found in one of the OBJECTS." + (match seed + (('@ . aseed) + (match objects + (() seed) + ((('@ . alists) ...) + (cons + '@ + (fold (lambda (alist aseed) + (if (null? aseed) alist + (fold + (match-lambda* + (((k . v) aseed) + (let ((pair tail (alist-pop alist k))) + (match pair + (#f (acons k v aseed)) + ((_ . v0) (acons k (combine k v0 v) aseed)))))) + aseed + alist))) + aseed + alists))))))) + +;; Possibly useful helper functions: +;; (define (newest key val0 val) val) +;; (define (unkeyed->keyed proc) (lambda (_key val0 val) (proc val0 val))) + + +;;; +;;; Phases. +;;; (define (set-home . _) (with-directory-excursion ".." @@ -49,7 +143,7 @@ (define (module-name module) (let* ((package.json (string-append module "/package.json")) (package-meta (call-with-input-file package.json read-json))) - (assoc-ref package-meta "name"))) + (jsobject-ref package-meta "name"))) (define (index-modules input-paths) (define (list-modules directory) @@ -73,27 +167,58 @@ (define index (index-modules (map cdr inputs))) - (define (resolve-dependencies package-meta meta-key) - (fold (lambda (key+value acc) - (match key+value - ('@ acc) - ((key . value) (acons key (hash-ref index key value) acc)))) - '() - (or (assoc-ref package-meta meta-key) '()))) + (define resolve-dependencies + (match-lambda + (('@ . alist) + (cons '@ (map (match-lambda + ((key . value) + (cons key (hash-ref index key value)))) + alist))))) - (with-atomic-file-replacement "package.json" - (lambda (in out) - (let ((package-meta (read-json in))) - (assoc-set! package-meta "dependencies" - (append - '(@) - (resolve-dependencies package-meta "dependencies") - (resolve-dependencies package-meta "peerDependencies"))) - (assoc-set! package-meta "devDependencies" - (append - '(@) - (resolve-dependencies package-meta "devDependencies"))) - (write-json package-meta out)))) + (with-atomic-json-file-replacement "package.json" + (lambda (pkg-meta) + (jsobject-update* + pkg-meta + `("devDependencies" ,resolve-dependencies (@)) + `("dependencies" ,(lambda (deps) + (resolve-dependencies + (jsobject-union + (lambda (k a b) b) + (jsobject-ref pkg-meta "peerDependencies" '(@)) + deps))) + (@))))) + #t) + +(define (delete-dependencies absent) + "Rewrite 'package.json' to allow the build to proceed without packages +listed in ABSENT, a list of strings naming npm packages. + +To prevent the deleted dependencies from being reintroduced, use this function +only after the 'patch-dependencies' phase." + (define delete-from-jsobject + (match-lambda + (('@ . alist) + (cons '@ (filter (match-lambda + ((k . _) + (not (member k absent)))) + alist))))) + + (with-atomic-json-file-replacement "package.json" + (lambda (pkg-meta) + (jsobject-update* + pkg-meta + `("devDependencies" ,delete-from-jsobject (@)) + `("dependencies" ,delete-from-jsobject (@)))))) + +(define* (delete-lockfiles #:key inputs #:allow-other-keys) + "Delete 'package-lock.json', 'yarn.lock', and 'npm-shrinkwrap.json', if they +exist." + (for-each (lambda (pth) + (when (file-exists? pth) + (delete-file pth))) + '("package-lock.json" + "yarn.lock" + "npm-shrinkwrap.json")) #t) (define* (configure #:key outputs inputs #:allow-other-keys) @@ -103,9 +228,7 @@ (define* (build #:key inputs #:allow-other-keys) (let ((package-meta (call-with-input-file "package.json" read-json))) - (if (and=> (assoc-ref package-meta "scripts") - (lambda (scripts) - (assoc-ref scripts "build"))) + (if (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f) (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) (invoke npm "run" "build")) (format #t "there is no build script to run~%")) @@ -142,15 +265,68 @@ "install" "../package.tgz") #t)) +(define* (avoid-node-gyp-rebuild #:key outputs #:allow-other-keys) + "Adjust the installed 'package.json' to remove an 'install' script that +would try to run 'node-gyp rebuild'." + ;; We want to take advantage of `npm install`'s automatic support for + ;; building native addons with node-gyp: in particular, it helps us avoid + ;; hard-coding the specifics of how npm's internal copy of node-gyp is + ;; currently packaged. However, the mechanism by which the automatic support + ;; is implemented causes problems for us. + ;; + ;; If a package contains a 'binding.gyp' file and does not define an + ;; 'install' or 'preinstall' script, 'npm install' runs a default install + ;; script consisting of 'node-gyp rebuild'. In our 'install' phase, this + ;; implicit 'install' script, if it is applicable, is explicitly added to + ;; the "package.json" file. However, if another Guix package were to use a + ;; Node.js package with such an 'install' script, the dependent package's + ;; build process would fail, because 'node-gyp rebuild' would try to write + ;; to the store. + ;; + ;; Here, if the installed "package.json" defines scripts.install as + ;; "node-gyp rebuild", we replace it with a no-op. Importantly, deleting the + ;; install script definition would not be enough, because the default + ;; install script would cause the same problem. + ;; + ;; For further details, see: + ;; - https://docs.npmjs.com/cli/v8/configuring-npm/package-json#default-values + ;; - https://docs.npmjs.com/cli/v8/using-npm/scripts#best-practices + (define installed-package.json + (search-input-file outputs (string-append "/lib/node_modules/" + (module-name ".") + "/package.json"))) + ;; We don't want to use an atomic replacement here, because we often don't + ;; even need to overwrite this file. Therefore, let's use some helpers + ;; that we'd otherwise not need. + (define pkg-meta + (call-with-input-file installed-package.json read-json)) + (define scripts + (jsobject-ref pkg-meta "scripts" '(@))) + (define (jsobject-set js key val) + (jsobject-update* js (list key (const val)))) + + (when (equal? "node-gyp rebuild" (jsobject-ref scripts "install" #f)) + (call-with-output-file installed-package.json + (lambda (out) + (write-json + (jsobject-set pkg-meta + "scripts" + (jsobject-set scripts + "install" + "echo Guix: avoiding node-gyp rebuild")) + out))))) + (define %standard-phases (modify-phases gnu:%standard-phases (add-after 'unpack 'set-home set-home) (add-before 'configure 'patch-dependencies patch-dependencies) + (add-after 'patch-dependencies 'delete-lockfiles delete-lockfiles) (replace 'configure configure) (replace 'build build) (replace 'check check) (add-before 'install 'repack repack) - (replace 'install install))) + (replace 'install install) + (add-after 'install 'avoid-node-gyp-rebuild avoid-node-gyp-rebuild))) (define* (node-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/po.scm b/guix/build/po.scm index eb9690ad1a..7f88164cd8 100644 --- a/guix/build/po.scm +++ b/guix/build/po.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2019, 2021 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -20,17 +20,23 @@ (define-module (guix build po) #:use-module (ice-9 match) #:use-module (ice-9 peg) + #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) - #:export (read-po-file)) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:export (read-po-file + translate-cross-references)) ;; A small parser for po files -(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern po-file body (* (or entry whitespace))) (define-peg-pattern whitespace body (or " " "\t" "\n")) (define-peg-pattern comment-chr body (range #\space #\頋)) (define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern flags all (and (ignore "#, ") (* comment-chr) (ignore "\n"))) (define-peg-pattern entry all - (and (ignore (* whitespace)) (ignore "msgid ") msgid - (ignore (* whitespace)) (ignore "msgstr ") msgstr)) + (and (* (or flags comment (ignore (* whitespace)))) + (ignore "msgid ") msgid (ignore (* whitespace)) + (ignore "msgstr ") msgstr)) (define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) (define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") "\\n" (and (ignore "\\") "\\") @@ -53,7 +59,24 @@ (append (list "\n" prefix) result))))))) (define (parse-tree->assoc parse-tree) - "Converts a po PARSE-TREE to an association list." + "Converts a po PARSE-TREE to an association list, where the key is the msgid +and the value is the msgstr. The result only contains non fuzzy strings." + (define (comments->flags comments) + (match comments + (('flags flags) + (map (lambda (flag) (string->symbol (string-trim-both flag #\space))) + (string-split flags #\,))) + ((? list? comments) + (fold + (lambda (comment res) + (match comment + ((? string? _) res) + (flags + (append (comments->flags flags) + res)))) + '() + comments)))) + (match parse-tree (() '()) ((entry . parse-tree) @@ -66,10 +89,22 @@ ;; empty msgstr (('entry ('msgid msgid) 'msgstr) (parse-tree->assoc parse-tree)) + (('entry _ ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree))) (('entry ('msgid msgid) ('msgstr msgstr)) (acons (interpret-newline-escape msgid) (interpret-newline-escape msgstr) - (parse-tree->assoc parse-tree))))))) + (parse-tree->assoc parse-tree))) + (('entry comments ('msgid msgid) ('msgstr msgstr)) + (if (member 'fuzzy (comments->flags comments)) + (parse-tree->assoc parse-tree) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree)))))))) (define (read-po-file port) "Read a .po file from PORT and return an alist of msgid and msgstr." @@ -77,3 +112,71 @@ po-file (get-string-all port))))) (parse-tree->assoc tree))) + +(define (canonicalize-whitespace str) + "Change whitespace (newlines, etc.) in STR to @code{#\\space}." + (string-map (lambda (chr) + (if (char-set-contains? char-set:whitespace chr) + #\space + chr)) + str)) + +(define xref-regexp + ;; Texinfo cross-reference regexp. + (make-regexp "@(px|x)?ref\\{([^,}]+)")) + +(define (translate-cross-references texi pofile) + "Translate the cross-references that appear in @var{texi}, the initial +translation of a Texinfo file, using the msgid/msgstr pairs from @var{pofile}." + (define translations + (call-with-input-file pofile read-po-file)) + + (define content + (call-with-input-file texi get-string-all)) + + (define matches + (list-matches xref-regexp content)) + + (define translation-map + (fold (match-lambda* + (((msgid . str) result) + (vhash-cons msgid str result))) + vlist-null + translations)) + + (define translated + ;; Iterate over MATCHES and replace cross-references with their + ;; translation found in TRANSLATION-MAP. (We can't use + ;; 'substitute*' because matches can span multiple lines.) + (let loop ((matches matches) + (offset 0) + (result '())) + (match matches + (() + (string-concatenate-reverse + (cons (string-drop content offset) result))) + ((head . tail) + (let ((prefix (match:substring head 1)) + (ref (canonicalize-whitespace (match:substring head 2)))) + (define translated + (string-append "@" (or prefix "") + "ref{" + (match (vhash-assoc ref translation-map) + (#f ref) + ((_ . str) str)))) + + (loop tail + (match:end head) + (append (list translated + (string-take + (string-drop content offset) + (- (match:start head) offset))) + result))))))) + + (format (current-error-port) + "translated ~a cross-references in '~a'~%" + (length matches) texi) + + (call-with-output-file texi + (lambda (port) + (display translated port)))) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 09bd8465c8..08871f60cd 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -6,6 +6,11 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2019, 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +32,7 @@ #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 ftw) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -128,6 +134,15 @@ (apply invoke "python" "./setup.py" command params))) (error "no setup.py found"))) +(define* (sanity-check #:key tests? inputs outputs #:allow-other-keys) + "Ensure packages depending on this package via setuptools work properly, +their advertised endpoints work and their top level modules are importable +without errors." + (let ((sanity-check.py (assoc-ref inputs "sanity-check.py"))) + ;; Make sure the working directory is empty (i.e. no Python modules in it) + (with-directory-excursion "/tmp" + (invoke "python" sanity-check.py (site-packages inputs outputs))))) + (define* (build #:key use-setuptools? #:allow-other-keys) "Build a given Python package." (call-setuppy "build" '() use-setuptools?) @@ -154,65 +169,86 @@ (major+minor (take components 2))) (string-join major+minor "."))) +(define (python-output outputs) + "Return the path of the python output, if there is one, or fall-back to out." + (or (assoc-ref outputs "python") + (assoc-ref outputs "out"))) + (define (site-packages inputs outputs) "Return the path of the current output's Python site-package." - (let* ((out (assoc-ref outputs "out")) + (let* ((out (python-output outputs)) (python (assoc-ref inputs "python"))) - (string-append out "/lib/python" - (python-version python) - "/site-packages/"))) + (string-append out "/lib/python" (python-version python) "/site-packages"))) (define (add-installed-pythonpath inputs outputs) - "Prepend the Python site-package of OUTPUT to PYTHONPATH. This is useful -when running checks after installing the package." - (let ((old-path (getenv "PYTHONPATH")) - (add-path (site-packages inputs outputs))) - (setenv "PYTHONPATH" - (string-append add-path - (if old-path (string-append ":" old-path) ""))) - #t)) + "Prepend the site-package of OUTPUT to GUIX_PYTHONPATH. This is useful when +running checks after installing the package." + (setenv "GUIX_PYTHONPATH" (string-append (site-packages inputs outputs) ":" + (getenv "GUIX_PYTHONPATH")))) + +(define* (add-install-to-pythonpath #:key inputs outputs #:allow-other-keys) + "A phase that just wraps the 'add-installed-pythonpath' procedure." + (add-installed-pythonpath inputs outputs)) -(define* (install #:key outputs (configure-flags '()) use-setuptools? +(define* (add-install-to-path #:key outputs #:allow-other-keys) + "Adding Python scripts to PATH is also often useful in tests." + (setenv "PATH" (string-append (assoc-ref outputs "out") + "/bin:" + (getenv "PATH")))) + +(define* (install #:key inputs outputs (configure-flags '()) use-setuptools? #:allow-other-keys) "Install a given Python package." - (let* ((out (assoc-ref outputs "out")) - (params (append (list (string-append "--prefix=" out)) + (let* ((out (python-output outputs)) + (python (assoc-ref inputs "python")) + (major-minor (map string->number + (take (string-split (python-version python) #\.) 2))) + (<3.7? (match major-minor + ((major minor) + (or (< major 3) (and (= major 3) (< minor 7)))))) + (params (append (list (string-append "--prefix=" out) + "--no-compile") (if use-setuptools? ;; distutils does not accept these flags (list "--single-version-externally-managed" - "--root=/") + "--root=/") '()) configure-flags))) (call-setuppy "install" params use-setuptools?) - #t)) + ;; Rather than produce potentially non-reproducible .pyc files on Pythons + ;; older than 3.7, whose 'compileall' module lacks the + ;; '--invalidation-mode' option, do not generate any. + (unless <3.7? + (invoke "python" "-m" "compileall" "--invalidation-mode=unchecked-hash" + out)))) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) (find-files dir (lambda (file stat) (and (eq? 'regular (stat:type stat)) - (not (wrapper? file)))))) + (not (wrapped-program? file)))))) (define bindirs (append-map (match-lambda - ((_ . dir) - (list (string-append dir "/bin") - (string-append dir "/sbin")))) + ((_ . dir) + (list (string-append dir "/bin") + (string-append dir "/sbin")))) outputs)) - (let* ((out (assoc-ref outputs "out")) - (python (assoc-ref inputs "python")) - (var `("PYTHONPATH" prefix - ,(cons (string-append out "/lib/python" - (python-version python) - "/site-packages") - (search-path-as-string->list - (or (getenv "PYTHONPATH") "")))))) + ;; Do not require "bash" to be present in the package inputs + ;; even when there is nothing to wrap. + ;; Also, calculate (sh) only once to prevent some I/O. + (define %sh (delay (search-input-file inputs "bin/bash"))) + (define (sh) (force %sh)) + + (let* ((var `("GUIX_PYTHONPATH" prefix + ,(search-path-as-string->list + (or (getenv "GUIX_PYTHONPATH") ""))))) (for-each (lambda (dir) (let ((files (list-of-files dir))) - (for-each (cut wrap-program <> var) + (for-each (cut wrap-program <> #:sh (sh) var) files))) - bindirs) - #t)) + bindirs))) (define* (rename-pth-file #:key name inputs outputs #:allow-other-keys) "Rename easy-install.pth to NAME.pth to avoid conflicts between packages @@ -220,16 +256,11 @@ installed with setuptools." ;; Even if the "easy-install.pth" is not longer created, we kept this phase. ;; There still may be packages creating an "easy-install.pth" manually for ;; some good reason. - (let* ((out (assoc-ref outputs "out")) - (python (assoc-ref inputs "python")) - (site-packages (string-append out "/lib/python" - (python-version python) - "/site-packages")) + (let* ((site-packages (site-packages inputs outputs)) (easy-install-pth (string-append site-packages "/easy-install.pth")) (new-pth (string-append site-packages "/" name ".pth"))) (when (file-exists? easy-install-pth) - (rename-file easy-install-pth new-pth)) - #t)) + (rename-file easy-install-pth new-pth)))) (define* (ensure-no-mtimes-pre-1980 #:rest _) "Ensure that there are no mtimes before 1980-01-02 in the source tree." @@ -241,32 +272,49 @@ installed with setuptools." (ftw "." (lambda (file stat flag) (unless (<= early-1980 (stat:mtime stat)) (utime file early-1980 early-1980)) - #t)) - #t)) + #t)))) (define* (enable-bytecode-determinism #:rest _) "Improve determinism of pyc files." ;; Use deterministic hashes for strings, bytes, and datetime objects. (setenv "PYTHONHASHSEED" "0") - #t) + ;; Prevent Python from creating .pyc files when loading modules (such as + ;; when running a test suite). + (setenv "PYTHONDONTWRITEBYTECODE" "1")) + +(define* (ensure-no-cythonized-files #:rest _) + "Check the source code for @code{.c} files which may have been pre-generated +by Cython." + (for-each + (lambda (file) + (let ((generated-file + (string-append (string-drop-right file 3) "c"))) + (when (file-exists? generated-file) + (format #t "Possible Cythonized file found: ~a~%" generated-file)))) + (find-files "." "\\.pyx$"))) (define %standard-phases ;; The build phase only builds C extensions and copies the Python sources, - ;; while the install phase byte-compiles and copies them to the prefix - ;; directory. The tests are run after the install phase because otherwise - ;; the cached .pyc generated during the tests execution seem to interfere - ;; with the byte compilation of the install phase. + ;; while the install phase copies then byte-compiles the sources to the + ;; prefix directory. The check phase is moved after the installation phase + ;; to ease testing the built package. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism enable-bytecode-determinism) + (add-after 'enable-bytecode-determinism 'ensure-no-cythonized-files + ensure-no-cythonized-files) (delete 'bootstrap) (delete 'configure) ;not needed (replace 'build build) (delete 'check) ;moved after the install phase (replace 'install install) - (add-after 'install 'check check) - (add-after 'install 'wrap wrap) + (add-after 'install 'add-install-to-pythonpath add-install-to-pythonpath) + (add-after 'add-install-to-pythonpath 'add-install-to-path + add-install-to-path) + (add-after 'add-install-to-path 'wrap wrap) + (add-after 'wrap 'check check) + (add-after 'check 'sanity-check sanity-check) (add-before 'strip 'rename-pth-file rename-pth-file))) (define* (python-build #:key inputs (phases %standard-phases) diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index a6955ce4c2..c63bd5ed21 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index c2b80cab7d..fa018a93ac 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,7 +110,7 @@ (define* (wrap-qt-program program-name #:key inputs output (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) - "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" + "Wrap the specified program (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. This is like qt-build-systems's phase \"qt-wrap\", but only the named program @@ -133,7 +134,10 @@ add a dependency of that output on Qt." (define (find-files-to-wrap output-dir) (append-map (lambda (dir) - (if (directory-exists? dir) (find-files dir ".*") (list))) + (if (directory-exists? dir) + (find-files dir (lambda (file stat) + (not (wrapped-program? file)))) + (list))) (list (string-append output-dir "/bin") (string-append output-dir "/sbin") (string-append output-dir "/libexec") diff --git a/guix/build/rakudo-build-system.scm b/guix/build/rakudo-build-system.scm index dbdeb1ccd2..5cf1cc55bc 100644 --- a/guix/build/rakudo-build-system.scm +++ b/guix/build/rakudo-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,7 +98,8 @@ (map (cut string-append dir "/" <>) (or (scandir dir (lambda (f) (let ((s (stat (string-append dir "/" f)))) - (eq? 'regular (stat:type s))))) + (and (eq? 'regular (stat:type s)) + (not (wrapped-program? f)))))) '()))) (define bindirs @@ -107,6 +109,12 @@ (string-append dir "/sbin")))) outputs)) + ;; Do not require bash to be present in the package inputs + ;; even when there is nothing to wrap. + ;; Also, calculate (sh) only once to prevent some I/O. + (define %sh (delay (search-input-file inputs "bin/bash"))) + (define (sh) (force %sh)) + (let* ((out (assoc-ref outputs "out")) (var `("PERL6LIB" "," prefix ,(cons (string-append out "/share/perl6/lib," @@ -116,7 +124,7 @@ (or (getenv "PERL6LIB") "") #\,))))) (for-each (lambda (dir) (let ((files (list-of-files dir))) - (for-each (cut wrap-program <> var) + (for-each (cut wrap-program <> #:sh (sh) var) files))) bindirs) #t)) diff --git a/guix/build/rpath.scm b/guix/build/rpath.scm deleted file mode 100644 index 75a1fef5ef..0000000000 --- a/guix/build/rpath.scm +++ /dev/null @@ -1,59 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 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 build rpath) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) - #:export (%patchelf - file-rpath - augment-rpath)) - -;;; Commentary: -;;; -;;; Tools to manipulate the RPATH and RUNPATH of ELF binaries. Currently they -;;; rely on PatchELF. -;;; -;;; Code: - -(define %patchelf - ;; The `patchelf' command. - (make-parameter "patchelf")) - -(define %not-colon - (char-set-complement (char-set #\:))) - -(define (file-rpath file) - "Return the RPATH (or RUNPATH) of FILE as a list of directory names, or #f -on failure." - (let* ((p (open-pipe* OPEN_READ (%patchelf) "--print-rpath" file)) - (l (read-line p))) - (and (zero? (close-pipe p)) - (string-tokenize l %not-colon)))) - -(define (augment-rpath file dir) - "Add DIR to the front of the RPATH and RUNPATH of FILE. Return the new -RPATH as a list, or #f on failure." - (let* ((rpath (or (file-rpath file) '())) - (rpath* (cons dir rpath))) - (format #t "~a: changing RPATH from ~s to ~s~%" - file rpath rpath*) - (and (zero? (system* (%patchelf) "--set-rpath" - (string-join rpath* ":") file)) - rpath*))) - -;;; rpath.scm ends here diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index c957a61115..9aceb187a4 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Pjotr Prins <pjotr.public01@thebird.nl> ;;; Copyright © 2015, 2016 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,13 +74,19 @@ directory." (define* (replace-git-ls-files #:key source #:allow-other-keys) "Many gemspec files downloaded from outside rubygems.org use `git ls-files` -to list of the files to be included in the built gem. However, since this +to list the files to be included in the built gem. However, since this operation is not deterministic, we replace it with `find`." - (when (not (gem-archive? source)) + (unless (gem-archive? source) (let ((gemspec (first-gemspec))) + ;; Do not include the freshly built .gem itself as it causes problems. + ;; Strip the first 2 characters ("./") to more exactly match the output + ;; given by 'git ls-files'. This is useful to prevent breaking regexps + ;; that could be used to filter the list of files. (substitute* gemspec - (("`git ls-files`") "`find . -type f |sort`") - (("`git ls-files -z`") "`find . -type f -print0 |sort -z`")))) + (("`git ls-files`") + "`find . -type f -not -regex '.*\\.gem$' | sort | cut -c3-`") + (("`git ls-files -z`") + "`find . -type f -not -regex '.*\\.gem$' -print0 | sort -z | cut -zc3-`")))) #t) (define* (extract-gemspec #:key source #:allow-other-keys) @@ -129,11 +136,7 @@ is #f." #:allow-other-keys) "Install the gem archive SOURCE to the output store item. Additional GEM-FLAGS are passed to the 'gem' invocation, if present." - (let* ((ruby-version - (match:substring (string-match "ruby-(.*)\\.[0-9]$" - (assoc-ref inputs "ruby")) - 1)) - (out (assoc-ref outputs "out")) + (let* ((out (assoc-ref outputs "out")) (vendor-dir (string-append out "/lib/ruby/vendor_ruby")) (gem-file (first-matching-file "\\.gem$")) (gem-file-basename (basename gem-file)) @@ -144,8 +147,8 @@ GEM-FLAGS are passed to the 'gem' invocation, if present." (setenv "GEM_VENDOR" vendor-dir) (or (zero? - ;; 'zero? system*' allows the custom error handling to function as - ;; expected, while 'invoke' raises its own exception. + ;; 'zero? system*' allows the custom error handling to function as + ;; expected, while 'invoke' raises its own exception. (apply system* "gem" "install" gem-file "--verbose" "--local" "--ignore-dependencies" "--vendor" diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 99a3b45004..a7401fd73f 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -71,6 +71,11 @@ mounts mount-points + SWAP_FLAG_PREFER + SWAP_FLAG_PRIO_MASK + SWAP_FLAG_PRIO_SHIFT + SWAP_FLAG_DISCARD + swapon swapoff @@ -120,11 +125,14 @@ with-file-lock with-file-lock/no-wait + set-child-subreaper! + set-thread-name thread-name CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID + CLONE_NEWCGROUP CLONE_NEWNS CLONE_NEWUTS CLONE_NEWIPC @@ -180,6 +188,8 @@ terminal-window-size terminal-columns terminal-rows + openpty + login-tty utmpx? utmpx-login-type @@ -422,15 +432,21 @@ expansion-time error is raised if FIELD does not exist in TYPE." "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." (call-with-restart-on-EINTR (lambda () expr))) -(define (syscall->procedure return-type name argument-types) +(define* (syscall->procedure return-type name argument-types + #:key library) "Return a procedure that wraps the C function NAME using the dynamic FFI, -and that returns two values: NAME's return value, and errno. +and that returns two values: NAME's return value, and errno. When LIBRARY is +specified, look up NAME in that library rather than in the global symbol name +space. If an error occurs while creating the binding, defer the error report until the returned procedure is called." (catch #t (lambda () - (let ((ptr (dynamic-func name (dynamic-link)))) + (let ((ptr (dynamic-func name + (if library + (dynamic-link library) + (dynamic-link))))) ;; The #:return-errno? facility was introduced in Guile 2.0.12. (pointer->procedure return-type ptr argument-types #:return-errno? #t))) @@ -677,6 +693,13 @@ current process." "Return the mounts points for currently mounted file systems." (map mount-point (mounts))) +;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h + +(define SWAP_FLAG_PREFER #x8000) ;; Set if swap priority is specified. +(define SWAP_FLAG_PRIO_MASK #x7fff) +(define SWAP_FLAG_PRIO_SHIFT 0) +(define SWAP_FLAG_DISCARD #x10000) ;; Discard swap cluster after use. + (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) @@ -1003,6 +1026,7 @@ caller lacks root privileges." ;; Linux clone flags, from linux/sched.h (define CLONE_CHILD_CLEARTID #x00200000) (define CLONE_CHILD_SETTID #x01000000) +(define CLONE_NEWCGROUP #x02000000) (define CLONE_NEWNS #x00020000) (define CLONE_NEWUTS #x04000000) (define CLONE_NEWIPC #x08000000) @@ -1413,6 +1437,11 @@ handler if the lock is already held by another process." (define PR_SET_NAME 15) ;<linux/prctl.h> (define PR_GET_NAME 16) +(define PR_SET_CHILD_SUBREAPER 36) + +(define (set-child-subreaper!) + "Set the CHILD_SUBREAPER capability for the current process." + (%prctl PR_SET_CHILD_SUBREAPER 1 0 0 0)) (define %max-thread-name-length ;; Maximum length in bytes of the process name, including the terminating @@ -2286,6 +2315,41 @@ PORT, trying to guess a reasonable value if all else fails. The result is always a positive integer." (terminal-dimension window-size-rows port (const 25))) +(define openpty + (let ((proc (syscall->procedure int "openpty" '(* * * * *) + #:library "libutil"))) + (lambda () + "Return two file descriptors: one for the pseudo-terminal control side, +and one for the controlled side." + (let ((head (make-bytevector (sizeof int))) + (inferior (make-bytevector (sizeof int)))) + (let-values (((ret err) + (proc (bytevector->pointer head) + (bytevector->pointer inferior) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + (throw 'system-error "openpty" "~A" + (list (strerror err)) + (list err)))) + + (let ((* (lambda (bv) + (bytevector-sint-ref bv 0 (native-endianness) + (sizeof int))))) + (values (* head) (* inferior))))))) + +(define login-tty + (let* ((proc (syscall->procedure int "login_tty" (list int) + #:library "libutil"))) + (lambda (fd) + "Make FD the controlling terminal of the current process (with the +TIOCSCTTY ioctl), redirect standard input, standard output and standard error +output to this terminal, and close FD." + (let-values (((ret err) (proc fd))) + (unless (zero? ret) + (throw 'system-error "login-pty" "~A" + (list (strerror err)) + (list err))))))) + ;;; ;;; utmpx. diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index 841c631dae..353fb934a6 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,46 +35,19 @@ ;; ;; Code: -(define (compile-with-latex format file) - (invoke format +(define (compile-with-latex engine format file) + (invoke engine "-interaction=nonstopmode" "-output-directory=build" - (string-append "&" format) + (if format (string-append "&" format) "-ini") file)) -(define* (configure #:key inputs #:allow-other-keys) - (let* ((out (string-append (getcwd) "/.texlive-union")) - (texmf.cnf (string-append out "/share/texmf-dist/web2c/texmf.cnf"))) - ;; Build a modifiable union of all inputs (but exclude bash) - (match inputs - (((names . directories) ...) - (union-build out (filter directory-exists? directories) - #:create-all-directories? #t - #:log-port (%make-void-port "w")))) - - ;; The configuration file "texmf.cnf" is provided by the - ;; "texlive-bin" package. We take it and override only the - ;; setting for TEXMFROOT and TEXMF. This file won't be consulted - ;; by default, though, so we still need to set TEXMFCNF. - (substitute* texmf.cnf - (("^TEXMFROOT = .*") - (string-append "TEXMFROOT = " out "/share\n")) - (("^TEXMF = .*") - "TEXMF = $TEXMFROOT/share/texmf-dist\n")) - (setenv "TEXMFCNF" (dirname texmf.cnf)) - (setenv "TEXMF" (string-append out "/share/texmf-dist")) - - ;; Don't truncate lines. - (setenv "error_line" "254") ; must be less than 255 - (setenv "half_error_line" "238") ; must be less than error_line - 15 - (setenv "max_print_line" "1000")) +(define* (build #:key inputs build-targets tex-engine tex-format + #:allow-other-keys) (mkdir "build") - #t) - -(define* (build #:key inputs build-targets tex-format #:allow-other-keys) - (every (cut compile-with-latex tex-format <>) - (if build-targets build-targets - (scandir "." (cut string-suffix? ".ins" <>))))) + (for-each (cut compile-with-latex tex-engine tex-format <>) + (if build-targets build-targets + (scandir "." (cut string-suffix? ".ins" <>))))) (define* (install #:key outputs tex-directory #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -81,13 +56,12 @@ (mkdir-p target) (for-each delete-file (find-files "." "\\.(log|aux)$")) (for-each (cut install-file <> target) - (find-files "build" ".*")) - #t)) + (find-files "build" ".*")))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) - (replace 'configure configure) + (delete 'configure) (replace 'build build) (delete 'check) (replace 'install install))) diff --git a/guix/build/union.scm b/guix/build/union.scm index 961ac3298b..bf75c67c52 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -99,8 +99,9 @@ identical, #f otherwise." ;; a warning doesn't make sense. For example, "icon-theme.cache" is ;; regenerated by a profile hook which shadows the file provided by ;; individual packages, and "gschemas.compiled" is made available to - ;; applications via 'glib-or-gtk-build-system'. - '("icon-theme.cache" "gschemas.compiled")) + ;; applications via 'glib-or-gtk-build-system'; "etc/ld.so.cache" is created + ;; for most packages. + '("icon-theme.cache" "gschemas.compiled" "ld.so.cache")) (define (warn-about-collision files) "Handle the collision among FILES by emitting a warning and choosing the diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 419c10195b..dd5a91f52f 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,10 +1,14 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018, 2021 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,9 +53,14 @@ package-name->name+version parallel-job-count + compressor + tarball? + %xz-parallel-args + directory-exists? executable-file? symbolic-link? + call-with-temporary-output-file call-with-ascii-input-file elf-file? ar-file? @@ -72,6 +81,11 @@ search-path-as-string->list list->search-path-as-string which + search-input-file + search-input-directory + search-error? + search-error-path + search-error-file every* alist-cons-before @@ -89,7 +103,7 @@ patch-/usr/bin/file fold-port-matches remove-store-references - wrapper? + wrapped-program? wrap-program wrap-script @@ -134,12 +148,39 @@ ;;; +;;; Compression helpers. +;;; + +(define (compressor file-name) + "Return the name of the compressor package/binary used to compress or +decompress FILE-NAME, based on its file extension, else false." + (cond ((string-suffix? "gz" file-name) "gzip") + ((string-suffix? "Z" file-name) "gzip") + ((string-suffix? "bz2" file-name) "bzip2") + ((string-suffix? "lz" file-name) "lzip") + ((string-suffix? "zip" file-name) "unzip") + ((string-suffix? "xz" file-name) "xz") + (else #f))) ;no compression used/unknown file extension + +(define (tarball? file-name) + "True when FILE-NAME has a tar file extension." + (string-match "\\.(tar(\\..*)?|tgz|tbz)$" file-name)) + +(define (%xz-parallel-args) + "The xz arguments required to enable bit-reproducible, multi-threaded +compression." + (list "--memlimit=50%" + (format #f "--threads=~a" (max 2 (parallel-job-count))))) + + +;;; ;;; Directories. ;;; (define (%store-directory) "Return the directory name of the store." - (or (getenv "NIX_STORE") + (or (getenv "NIX_STORE_DIR") ;outside of builder + (getenv "NIX_STORE") ;inside builder, set by the daemon "/gnu/store")) (define (store-file-name? file) @@ -197,6 +238,22 @@ introduce the version part." "Return #t if FILE is a symbolic link (aka. \"symlink\".)" (eq? (stat:type (lstat file)) 'symlink)) +(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 +call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + (define (call-with-ascii-input-file file proc) "Open FILE as an ASCII or binary file, and pass the resulting port to PROC. FILE is closed when PROC's dynamic extent is left. Return the @@ -322,11 +379,13 @@ name." #:key (log (current-output-port)) (follow-symlinks? #f) - keep-mtime?) + (copy-file copy-file) + keep-mtime? keep-permissions?) "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the -modification time of the files in SOURCE on those of DESTINATION. Write -verbose output to the LOG port." +is true; otherwise, just preserve them. Call COPY-FILE to copy regular files. +When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on +those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file +permissions. Write verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -343,16 +402,21 @@ verbose output to the LOG port." (symlink target dest))) (else (copy-file file dest) - (when keep-mtime? - (set-file-time dest stat)))))) + (when keep-permissions? + (chmod dest (stat:perms stat))))) + (when keep-mtime? + (set-file-time dest stat)))) (lambda (dir stat result) ; down (let ((target (string-append destination (strip-source dir)))) - (mkdir-p target) - (when keep-mtime? - (set-file-time target stat)))) + (mkdir-p target))) (lambda (dir stat result) ; up - result) + (let ((target (string-append destination + (strip-source dir)))) + (when keep-mtime? + (set-file-time target stat)) + (when keep-permissions? + (chmod target (stat:perms stat))))) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) "i/o error: ~a: ~a~%" @@ -365,6 +429,16 @@ verbose output to the LOG port." stat lstat))) +(define-syntax-rule (warn-on-error expr file) + (catch 'system-error + (lambda () + expr) + (lambda args + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror + (system-error-errno args)))))) + (define* (delete-file-recursively dir #:key follow-mounts?) "Delete DIR recursively, like `rm -rf', without following symlinks. Don't @@ -375,10 +449,10 @@ errors." (or follow-mounts? (= dev (stat:dev stat)))) (lambda (file stat result) ; leaf - (delete-file file)) + (warn-on-error (delete-file file) file)) (const #t) ; down (lambda (dir stat result) ; up - (rmdir dir)) + (warn-on-error (rmdir dir) dir)) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) @@ -546,6 +620,40 @@ PROGRAM could not be found." (search-path (search-path-as-string->list (getenv "PATH")) program)) +(define-condition-type &search-error &error + search-error? + (path search-error-path) + (file search-error-file)) + +(define (search-input-file inputs file) + "Find a file named FILE among the INPUTS and return its absolute file name. + +FILE must be a string like \"bin/sh\". If FILE is not found, an exception is +raised." + (match inputs + (((_ . directories) ...) + ;; Accept both "bin/sh" and "/bin/sh" as FILE argument. + (let ((file (string-trim file #\/))) + (or (search-path directories file) + (raise + (condition (&search-error (path directories) (file file))))))))) + +(define (search-input-directory inputs directory) + "Find a sub-directory named DIRECTORY among the INPUTS and return its +absolute file name. + +DIRECTORY must be a string like \"xml/dtd/docbook\". If DIRECTORY is not +found, an exception is raised." + (match inputs + (((_ . directories) ...) + (or (any (lambda (parent) + (let ((directory (string-append parent "/" directory))) + (and (directory-exists? directory) + directory))) + directories) + (raise (condition + (&search-error (path directories) (file directory)))))))) + ;;; ;;; Phases. @@ -746,6 +854,31 @@ PROC's result is returned." (lambda (key . args) (false-if-exception (delete-file template)))))) +(define (unused-private-use-code-point s) + "Find a code point within a Unicode Private Use Area that is not +present in S, and return the corresponding character object. If one +cannot be found, return false." + (define (scan lo hi) + (and (<= lo hi) + (let ((c (integer->char lo))) + (if (string-index s c) + (scan (+ lo 1) hi) + c)))) + (or (scan #xE000 #xF8FF) + (scan #xF0000 #xFFFFD) + (scan #x100000 #x10FFFD))) + +(define (replace-char c1 c2 s) + "Return a string which is equal to S except with all instances of C1 +replaced by C2. If C1 and C2 are equal, return S." + (if (char=? c1 c2) + s + (string-map (lambda (c) + (if (char=? c c1) + c2 + c)) + s))) + (define (substitute file pattern+procs) "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each line of FILE, and for each PATTERN that it matches, call the corresponding @@ -764,16 +897,26 @@ end of a line; by itself it won't match the terminating newline of a line." (let loop ((line (read-line in 'concat))) (if (eof-object? line) #t - (let ((line (fold (lambda (r+p line) - (match r+p - ((regexp . proc) - (match (list-matches regexp line) - ((and m+ (_ _ ...)) - (proc line m+)) - (_ line))))) - line - rx+proc))) - (display line out) + ;; Work around the fact that Guile's regexp-exec does not handle + ;; NUL characters (a limitation of the underlying GNU libc's + ;; regexec) by temporarily replacing them by an unused private + ;; Unicode code point. + ;; TODO: Use SRFI-115 instead, once available in Guile. + (let* ((nul* (or (and (string-index line #\nul) + (unused-private-use-code-point line)) + #\nul)) + (line* (replace-char #\nul nul* line)) + (line1* (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line* + rx+proc)) + (line1 (replace-char nul* #\nul line1*))) + (display line1 out) (loop (read-line in 'concat))))))))) @@ -800,7 +943,7 @@ sub-expression. For example: ((\"hello\") \"good morning\\n\") ((\"foo([a-z]+)bar(.*)$\" all letters end) - (string-append \"baz\" letter end))) + (string-append \"baz\" letters end))) Here, anytime a line of FILE contains \"hello\", it is replaced by \"good morning\". Anytime a line of FILE matches the second regexp, ALL is bound to @@ -853,29 +996,45 @@ match the terminating newline of a line." ;;; (define* (dump-port in out + #:optional len #:key (buffer-size 16384) (progress (lambda (t k) (k)))) - "Read as much data as possible from IN and write it to OUT, using chunks of -BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful -transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes -transferred and the continuation of the transfer as a thunk." + "Read LEN bytes from IN or as much data as possible if LEN is #f, and write +it to OUT, using chunks of BUFFER-SIZE bytes. Call PROGRESS at the beginning +and after each successful transfer of BUFFER-SIZE bytes or less, passing it +the total number of bytes transferred and the continuation of the transfer as +a thunk." (define buffer (make-bytevector buffer-size)) (define (loop total bytes) (or (eof-object? bytes) + (and len (= total len)) (let ((total (+ total bytes))) (put-bytevector out buffer 0 bytes) (progress total (lambda () (loop total - (get-bytevector-n! in buffer 0 buffer-size))))))) + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size)))))))) ;; Make sure PROGRESS is called when we start so that it can measure ;; throughput. (progress 0 (lambda () - (loop 0 (get-bytevector-n! in buffer 0 buffer-size))))) + (loop 0 (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))))) + +(define AT_SYMLINK_NOFOLLOW + ;; Guile 2.0 did not define this constant, hence this hack. + (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW))) + (if variable + (variable-ref variable) + 256))) ;for GNU/Linux (define (set-file-time file stat) "Set the atime/mtime of FILE to that specified by STAT." @@ -883,7 +1042,8 @@ transferred and the continuation of the transfer as a thunk." (stat:atime stat) (stat:mtime stat) (stat:atimensec stat) - (stat:mtimensec stat))) + (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW)) (define (get-char* p) ;; We call it `get-char', but that's really a binary version @@ -1108,14 +1268,14 @@ known as `nuke-refs' in Nixpkgs." (program wrap-error-program) (type wrap-error-type)) -(define (wrapper? prog) - "Return #t if PROG is a wrapper as produced by 'wrap-program'." +(define (wrapped-program? prog) + "Return #t if PROG is a program that was moved and wrapped by 'wrap-program'." (and (file-exists? prog) (let ((base (basename prog))) (and (string-prefix? "." base) (string-suffix? "-real" base))))) -(define* (wrap-program prog #:rest vars) +(define* (wrap-program prog #:key (sh (which "bash")) #:rest vars) "Make a wrapper for PROG. VARS should look like this: '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES) @@ -1142,7 +1302,12 @@ programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or modules in $GUILE_LOAD_PATH, etc. If PROG has previously been wrapped by 'wrap-program', the wrapper is extended -with definitions for VARS." +with definitions for VARS. If it is not, SH will be used as interpreter." + (define vars/filtered + (match vars + ((#:sh _ . vars) vars) + (vars vars))) + (define wrapped-file (string-append (dirname prog) "/." (basename prog) "-real")) @@ -1184,6 +1349,9 @@ with definitions for VARS." (format #f "export ~a=\"$~a${~a:+:}~a\"" var var var (string-join rest ":"))))) + (when (wrapped-program? prog) + (error (string-append prog " is a wrapper. Refusing to wrap."))) + (if already-wrapped? ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just @@ -1193,7 +1361,7 @@ with definitions for VARS." (for-each (lambda (var) (display (export-variable var) port) (newline port)) - vars) + vars/filtered) (display last port) (close-port port)) @@ -1205,8 +1373,8 @@ with definitions for VARS." (lambda (port) (format port "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%" - (which "bash") - (string-join (map export-variable vars) "\n") + sh + (string-join (map export-variable vars/filtered) "\n") (canonicalize-path wrapped-file)))) (chmod prog-tmp #o755) @@ -1295,10 +1463,9 @@ not supported." `(let ((cl (command-line))) (apply execl ,interpreter (car cl) - (cons (car cl) - (append - ',(string-split args #\space) - cl)))))) + (append + ',(string-tokenize args char-set:graphic) + cl))))) (template (string-append prog ".XXXXXX")) (out (mkstemp! template)) (st (stat prog)) @@ -1307,7 +1474,7 @@ not supported." (lambda () (call-with-ascii-input-file prog (lambda (p) - (format out header) + (display header out) (dump-port p out) (close out) (chmod template mode) diff --git a/guix/cache.scm b/guix/cache.scm index 0401a9d428..51009809bd 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -101,7 +101,13 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." #:now now #:entry-expiration entry-expiration #:delete-entry delete-entry) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) + (catch 'system-error + (lambda () + (call-with-output-file expiry-file + (cute write (time-second now) <>))) + (lambda args + ;; ENOENT means CACHE does not exist. + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))))) ;;; cache.scm ends here diff --git a/guix/channels.scm b/guix/channels.scm index e4e0428eb5..5f47834c10 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -1009,6 +1010,7 @@ true, include its introduction, if any." `(channel (name ',(channel-name channel)) (url ,(channel-url channel)) + (branch ,(channel-branch channel)) (commit ,(channel-commit channel)) ,@(if intro `((introduction (make-channel-introduction diff --git a/guix/ci.scm b/guix/ci.scm index 01b493b3af..88b80f781d 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -208,7 +208,7 @@ api-agnostic." (map json->build (vector->list queue)))) (define* (latest-builds url #:optional (limit %query-limit) - #:key evaluation system job status) + #:key evaluation system job jobset status) "Return the latest builds performed by the CI server at URL. If EVALUATION is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system string such as \"x86_64-linux\"), restrict to builds for SYSTEM." @@ -218,6 +218,7 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM." `("evaluation" ,evaluation) `("system" ,system) `("job" ,job) + `("jobset" ,jobset) `("status" ,status)))) ;; Note: Hydra does not provide a "derivation" field for entries in ;; 'latestbuilds', but Cuirass does. @@ -286,6 +287,7 @@ definitions at URL. Return false if no commit were found." (let* ((job-name (string-append "guix." (%current-system))) (build (match (latest-builds url 1 #:job job-name + #:jobset "guix" #:status 0) ;success ((build) build) (_ #f))) diff --git a/guix/combinators.scm b/guix/combinators.scm index 88ad09dbe6..261d6bb57e 100644 --- a/guix/combinators.scm +++ b/guix/combinators.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2017, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; @@ -24,7 +24,9 @@ #:export (fold2 fold-tree fold-tree-leaves - compile-time-value)) + compile-time-value + procedure-call-location + define-compile-time-procedure)) ;;; Commentary: ;;; @@ -100,4 +102,48 @@ evaluate to a simple datum." (_ #`'#,(datum->syntax s val))))))) v)))) +(define-syntax-parameter procedure-call-location + (lambda (s) + (syntax-violation 'procedure-call-location + "'procedure-call-location' may only be used \ +within 'define-compile-time-procedure'" + s))) + +(define-syntax-rule (define-compile-time-procedure (proc (arg pred) ...) + body ...) + "Define PROC as a macro such that, if every actual argument in a \"call\" +matches PRED, then BODY is evaluated at macro-expansion time. BODY must +return a single value in a type that has read syntax--e.g., numbers, strings, +lists, etc. + +BODY can refer to 'procedure-call-location', which is bound to a source +property alist corresponding to the call site. + +This macro is meant to be used primarily for small procedures that validate or +process its arguments in a way that may be equally well performed at +macro-expansion time." + (define-syntax proc + (lambda (s) + (define loc + #`(identifier-syntax + '#,(datum->syntax #'s (syntax-source s)))) + + (syntax-case s () + ((_ arg ...) + (and (pred (syntax->datum #'arg)) ...) + (let ((arg (syntax->datum #'arg)) ...) + (syntax-parameterize ((procedure-call-location + (identifier-syntax (syntax-source s)))) + body ...))) + ((_ actual (... ...)) + #`((lambda (arg ...) + (syntax-parameterize ((procedure-call-location #,loc)) + body ...)) + actual (... ...))) + (id + (identifier? #'id) + #`(lambda (arg ...) + (syntax-parameterize ((procedure-call-location #,loc)) + body ...))))))) + ;;; combinators.scm ends here diff --git a/guix/cpu.scm b/guix/cpu.scm new file mode 100644 index 0000000000..e1911f52a8 --- /dev/null +++ b/guix/cpu.scm @@ -0,0 +1,143 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 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 cpu) + #:use-module (guix sets) + #:use-module (guix memoization) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:export (current-cpu + cpu? + cpu-architecture + cpu-family + cpu-model + cpu-flags + + cpu->gcc-architecture)) + +;;; Commentary: +;;; +;;; This module provides tools to determine the micro-architecture supported +;;; by the CPU and to map it to a name known to GCC's '-march'. +;;; +;;; Code: + +;; CPU description. +(define-record-type <cpu> + (cpu architecture family model flags) + cpu? + (architecture cpu-architecture) ;string, from 'uname' + (family cpu-family) ;integer + (model cpu-model) ;integer + (flags cpu-flags)) ;set of strings + +(define current-cpu + (mlambda () + "Return a <cpu> record representing the host CPU." + (define (prefix? prefix) + (lambda (str) + (string-prefix? prefix str))) + + (call-with-input-file "/proc/cpuinfo" + (lambda (port) + (let loop ((family #f) + (model #f)) + (match (read-line port) + ((? eof-object?) + #f) + ((? (prefix? "cpu family") str) + (match (string-tokenize str) + (("cpu" "family" ":" family) + (loop (string->number family) model)))) + ((? (prefix? "model") str) + (match (string-tokenize str) + (("model" ":" model) + (loop family (string->number model))) + (_ + (loop family model)))) + ((? (prefix? "flags") str) + (match (string-tokenize str) + (("flags" ":" flags ...) + (cpu (utsname:machine (uname)) + family model (list->set flags))))) + (_ + (loop family model)))))))) + +(define (cpu->gcc-architecture cpu) + "Return the architecture name, suitable for GCC's '-march' flag, that +corresponds to CPU, a record as returned by 'current-cpu'." + (match (cpu-architecture cpu) + ("x86_64" + ;; Transcribed from GCC's 'host_detect_local_cpu' in driver-i386.c. + (or (and (= 6 (cpu-family cpu)) ;the "Pentium Pro" family + (letrec-syntax ((model (syntax-rules (=>) + ((_) #f) + ((_ (candidate => integers ...) rest + ...) + (or (and (= (cpu-model cpu) integers) + candidate) + ... + (model rest ...)))))) + (model ("bonnel" => #x1c #x26) + ("silvermont" => #x37 #x4a #x4d #x5a #x5d) + ("core2" => #x0f #x17 #x1d) + ("nehalem" => #x1a #x1e #x1f #x2e) + ("westmere" => #x25 #x2c #x2f) + ("sandybridge" => #x2a #x2d) + ("ivybridge" => #x3a #x3e) + ("haswell" => #x3c #x3f #x45 #x46) + ("broadwell" => #x3d #x47 #x4f #x56) + ("skylake" => #x4e #x5e #x8e #x9e) + ("skylake-avx512" => #x55) ;TODO: cascadelake + ("knl" => #x57) + ("cannonlake" => #x66) + ("knm" => #x85)))) + + ;; Fallback case for non-Intel processors or for Intel processors not + ;; recognized above. + (letrec-syntax ((if-flags (syntax-rules (=>) + ((_) + #f) + ((_ (flags ... => name) rest ...) + (if (every (lambda (flag) + (set-contains? (cpu-flags cpu) + flag)) + '(flags ...)) + name + (if-flags rest ...)))))) + (if-flags ("avx512" => "knl") + ("adx" => "broadwell") + ("avx2" => "haswell") + ;; TODO: tigerlake, cooperlake, etc. + ("avx" => "sandybridge") + ("sse4_2" "gfni" => "tremont") + ("sse4_2" "sgx" => "goldmont-plus") + ("sse4_2" "xsave" => "goldmont") + ("sse4_2" "movbe" => "silvermont") + ("sse4_2" => "nehalem") + ("ssse3" "movbe" => "bonnell") + ("ssse3" => "core2"))) + + ;; TODO: Recognize AMD models (bdver*, znver*, etc.)? + + "x86_64")) + (architecture + ;; TODO: AArch64. + architecture))) diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 04d4d4a337..c66c9367f6 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,8 @@ #:use-module (guix diagnostics) #:autoload (guix utils) (source-properties->location) #:export (define-deprecated + + define-deprecated/public define-deprecated/alias warn-about-deprecation)) @@ -39,6 +41,8 @@ (warning location (G_ "'~a' is deprecated~%") variable)))) +(define-syntax public (syntax-rules ())) ;private syntactic keyword + (define-syntax define-deprecated (lambda (s) "Define a deprecated variable or procedure, along these lines: @@ -53,6 +57,8 @@ This will write a deprecation warning to GUIX-WARNING-PORT." #'(define-deprecated proc replacement (lambda* (formals ...) body ...))) ((_ variable replacement exp) + #'(define-deprecated private variable replacement exp)) + ((_ visibility variable replacement exp) (identifier? #'variable) (with-syntax ((real (datum->syntax #'variable @@ -74,11 +80,23 @@ This will write a deprecation warning to GUIX-WARNING-PORT." #'(real args (... ...))) (id (identifier? #'id) - #'real))))))) + #'real)))) + + ;; When asking for public visibility, export both REAL and + ;; VARIABLE. Exporting REAL is useful when defining deprecated + ;; packages: there must be a public variable bound to a package + ;; so that the (guix discover) machinery finds it. + #,(if (free-identifier=? #'visibility #'public) + #'(export real variable) + #'(begin))))) ((_ variable alias) (identifier? #'alias) #'(define-deprecated variable alias alias))))) +(define-syntax-rule (define-deprecated/public body ...) + "Like 'define/deprecated', but export all the newly introduced bindings." + (define-deprecated public body ...)) + (define-syntax-rule (define-deprecated/alias deprecated replacement) "Define as an alias a deprecated variable, procedure, or macro, along these lines: diff --git a/guix/derivations.scm b/guix/derivations.scm index 33f4dc5d9d..f77ea179f4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -1243,20 +1243,21 @@ MODULES are compiled." (hash-set! %module-cache key result) result))) -(define* (build-expression->derivation store name exp ;deprecated - #:key - (system (%current-system)) - (inputs '()) - (outputs '("out")) - hash hash-algo recursive? - (env-vars '()) - (modules '()) - guile-for-build - references-graphs - allowed-references - disallowed-references - local-build? (substitutable? #t) - (properties '())) +(define-deprecated (build-expression->derivation store name exp + #:key + (system (%current-system)) + (inputs '()) + (outputs '("out")) + hash hash-algo recursive? + (env-vars '()) + (modules '()) + guile-for-build + references-graphs + allowed-references + disallowed-references + local-build? (substitutable? #t) + (properties '())) + gexp->derivation ;unbound, but that's okay "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6a792febd4..337a73c1a2 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -54,7 +54,9 @@ condition-fix-hint guix-warning-port - program-name)) + program-name + + define-with-syntax-properties)) ;;; Commentary: ;;; @@ -331,3 +333,37 @@ number of arguments in ARGS matches the escapes in FORMAT." (define program-name ;; Name of the command-line program currently executing, or #f. (make-parameter #f)) + + +(define-syntax define-with-syntax-properties + (lambda (x) + "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and +SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties, +respectively, of each ensuing syntax object." + (syntax-case x () + ((_ (binding (value-identifier syntax-properties-identifier) + ...) + body ...) + (and (and-map identifier? #'(value-identifier ...)) + (and-map identifier? #'(syntax-properties-identifier ...))) + #'(define-syntax binding + (lambda (y) + (with-ellipsis ::: + (syntax-case y () + ((_ value-identifier ...) + (with-syntax ((syntax-properties-identifier + #`'#,(datum->syntax y + (syntax-source + #'value-identifier))) + ...) + #'(begin body ...))) + (_ + (syntax-violation #f (format #f + "Expected (~a~{ ~a~})" + 'binding + '(value-identifier ...)) + y))))))) + (_ + (syntax-violation #f "Expected a definition of the form \ +(define-with-syntax-properties (binding (value syntax-properties) \ +...) body ...)" x))))) diff --git a/guix/docker.scm b/guix/docker.scm index a6f73d423c..5e6460f43f 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -214,10 +214,11 @@ SRFI-19 time-utc object, as the creation time in metadata." (else (error "unsupported system" system))))))) - (cond* ("x86_64" "amd64") - ("i686" "386") - ("arm" "arm") - ("mips64" "mips64le"))))) + (cond* ("x86_64" "amd64") + ("i686" "386") + ("arm" "arm") + ("aarch64" "arm64") + ("mips64" "mips64le"))))) ;; Make sure we start with a fresh, empty working directory. (mkdir directory) (with-directory-excursion directory diff --git a/guix/download.scm b/guix/download.scm index 85b97a4766..4e219c9f49 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -36,6 +36,7 @@ #:use-module (srfi srfi-26) #:export (%mirrors %disarchive-mirrors + %download-fallback-test (url-fetch* . url-fetch) url-fetch/executable url-fetch/tarbomb @@ -399,14 +400,23 @@ (plain-file "content-addressed-mirrors" (object->string %content-addressed-mirrors))) +(define %no-mirrors-file + ;; File specifying an empty list of mirrors, for fallback tests. + (plain-file "no-content-addressed-mirrors" (object->string ''()))) + (define %disarchive-mirrors ;; TODO: Eventually turn into a procedure that takes a hash algorithm ;; (symbol) and hash (bytevector). - '("https://disarchive.ngyro.com/")) + '("https://disarchive.guix.gnu.org/" + "https://disarchive.ngyro.com/")) (define %disarchive-mirror-file (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors))) +(define %no-disarchive-mirrors-file + ;; File specifying an empty list of Disarchive mirrors, for fallback tests. + (plain-file "no-disarchive-mirrors" (object->string '()))) + (define built-in-builders* (store-lift built-in-builders)) @@ -455,6 +465,24 @@ download by itself using its own dependencies." ;; for that built-in is widespread. #:local-build? #t))) +(define %download-fallback-test + ;; Define whether to test one of the download fallback mechanism. Possible + ;; values are: + ;; + ;; - #f, to use the normal download methods, not trying to exercise the + ;; fallback mechanism; + ;; + ;; - 'none, to disable all the fallback mechanisms; + ;; + ;; - 'content-addressed-mirrors, to purposefully attempt to download from + ;; a content-addressed mirror; + ;; + ;; - 'disarchive-mirrors, to download from Disarchive + Software Heritage. + ;; + ;; This is meant to be used for testing purposes. + (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST") + string->symbol))) + (define* (url-fetch* url hash-algo hash #:optional name #:key (system (%current-system)) @@ -490,7 +518,10 @@ name in the store." (unless (member "download" builtins) (error "'guix-daemon' is too old, please upgrade" builtins)) - (built-in-download (or name file-name) url + (built-in-download (or name file-name) + (match (%download-fallback-test) + ((or #f 'none) url) + (_ "https://example.org/does-not-exist")) #:guile guile #:system system #:hash-algo hash-algo @@ -498,9 +529,15 @@ name in the store." #:executable? executable? #:mirrors %mirror-file #:content-addressed-mirrors - %content-addressed-mirror-file + (match (%download-fallback-test) + ((or #f 'content-addressed-mirrors) + %content-addressed-mirror-file) + (_ %no-mirrors-file)) #:disarchive-mirrors - %disarchive-mirror-file))))) + (match (%download-fallback-test) + ((or #f 'disarchive-mirrors) + %disarchive-mirror-file) + (_ %no-disarchive-mirrors-file))))))) (define* (url-fetch/executable url hash-algo hash #:optional name diff --git a/guix/extracting-download.scm b/guix/extracting-download.scm new file mode 100644 index 0000000000..4b7dcc7e83 --- /dev/null +++ b/guix/extracting-download.scm @@ -0,0 +1,179 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> +;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; +;;; 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 extracting-download) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module ((guix build download) #:prefix build:) + #:use-module ((guix build utils) #:hide (delete)) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix packages) ;; for %current-system + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (srfi srfi-26) + #:export (http-fetch/extract + download-to-store/extract)) + +;;; +;;; Produce fixed-output derivations with data extracted from n archive +;;; fetched over HTTP or FTP. +;;; +;;; This is meant to be used for package repositories where the actual source +;;; archive is packed into another archive, eventually carrying meta-data. +;;; Using this derivation saves both storing the outer archive and extracting +;;; the actual one at build time. The hash is calculated on the actual +;;; archive to ease validating the stored file. +;;; + +(define* (http-fetch/extract url filename-to-extract hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile))) + "Return a fixed-output derivation that fetches an archive at URL, and +extracts FILE_TO_EXTRACT from the archive. The FILE_TO_EXTRACT is expected to +have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the +base name of URL; optionally, NAME can specify a different file name." + (define file-name + (match url + ((head _ ...) + (basename head)) + (_ + (basename url)))) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + + (define guile-json + (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) + + (define gnutls + (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + + (define inputs + `(("tar" ,(module-ref (resolve-interface '(gnu packages base)) + 'tar)))) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%system)) + + (define %system + #$(%current-system))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build download) + (guix build utils) + (guix utils) + (web uri)))))) + + (define build + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-zlib) + #~(begin + (use-modules (guix build download) + (guix build utils) + (guix utils) + (web uri) + (ice-9 match) + (ice-9 popen)) + ;; The code below expects tar to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (call-with-temporary-directory + (lambda (directory) + ;; TODO: Support different archive types, based on content-type + ;; or archive name extention. + (let* ((file-to-extract (getenv "extract filename")) + (port (http-fetch (string->uri (getenv "download url")) + #:verify-certificate? #f)) + (tar (open-pipe* OPEN_WRITE "tar" "-C" directory + "-xf" "-" file-to-extract))) + (dump-port port tar) + (close-port port) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + (copy-file (string-append directory "/" + (getenv "extract filename")) + #$output)))))))) + + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name file-name) build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "extract-download" + #:env-vars + `(("download url" . ,url) + ("extract filename" . ,filename-to-extract)) + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") + #:system system + #:local-build? #t ; don't offload download + #:hash-algo hash-algo + #:hash hash + #:guile-for-build guile))) + + +(define* (download-to-store/extract store url filename-to-extract + #:optional (name (basename url)) + #:key (log (current-error-port)) + (verify-certificate? #t)) + "Download an archive from URL, and extracts FILE_TO_EXTRACT from the archive +to STORE, either under NAME or URL's basename if omitted. Write progress +reports to LOG. VERIFY-CERTIFICATE? determines whether or not to validate +HTTPS server certificates." + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port log)) + (build:url-fetch url temp + ;;#:mirrors %mirrors + #:verify-certificate? + verify-certificate?)))) + (close port) + (and result + (call-with-temporary-output-file + (lambda (contents port) + (let ((tar (open-pipe* OPEN_READ + "tar" ;"--auto-compress" + "-xf" temp "--to-stdout" filename-to-extract))) + (dump-port tar port) + (close-port port) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + (add-to-store store name #f "sha256" contents))))))))) diff --git a/guix/gexp.scm b/guix/gexp.scm index f3d278b3e6..01dca902f7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -40,6 +40,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + sexp->gexp with-imported-modules with-extensions let-system @@ -106,6 +107,10 @@ lowered-gexp-load-path lowered-gexp-load-compiled-path + with-build-variables + input-tuples->gexp + outputs->gexp + gexp->derivation gexp->file gexp->script @@ -113,6 +118,7 @@ mixed-text-file file-union directory-union + imported-files imported-modules compiled-modules @@ -197,6 +203,18 @@ As a result, the S-expression will be approximate if GEXP has references." (set-record-type-printer! <gexp> write-gexp) +(define (gexp-with-hidden-inputs gexp inputs) + "Add INPUTS, a list of <gexp-input>, to the references of GEXP. These are +\"hidden inputs\" because they do not actually appear in the expansion of GEXP +returned by 'gexp->sexp'." + (make-gexp (append inputs (gexp-references gexp)) + (gexp-self-modules gexp) + (gexp-self-extensions gexp) + (let ((extra (length inputs))) + (lambda args + (apply (gexp-proc gexp) (drop args extra)))) + (gexp-location gexp))) + ;;; ;;; Methods. @@ -271,14 +289,17 @@ OBJ must be an object that has an associated gexp compiler, such as a (#f (raise (condition (&gexp-input-error (input obj))))) (lower - ;; Cache in STORE the result of lowering OBJ. - (mcached (mlet %store-monad ((lowered (lower obj system target))) - (if (and (struct? lowered) - (not (derivation? lowered))) - (loop lowered) - (return lowered))) - obj - system target graft?)))))) + ;; Cache in STORE the result of lowering OBJ. If OBJ is a + ;; derivation, bypass the cache. + (if (derivation? obj) + (return obj) + (mcached (mlet %store-monad ((lowered (lower obj system target))) + (if (and (struct? lowered) + (not (derivation? lowered))) + (loop lowered) + (return lowered))) + obj + system target graft?))))))) (define* (lower+expand-object obj #:optional (system (%current-system)) @@ -293,9 +314,11 @@ expand to file names, but it's possible to expand to a plain data type." (raise (condition (&gexp-input-error (input obj))))) (lower (mlet* %store-monad ((graft? (grafting?)) - (lowered (mcached (lower obj system target) - obj - system target graft?))) + (lowered (if (derivation? obj) + (return obj) + (mcached (lower obj system target) + obj + system target graft?)))) ;; LOWER might return something that needs to be further ;; lowered. (if (struct? lowered) @@ -662,7 +685,8 @@ SUFFIX." expander => (lambda (obj lowered output) (match obj (($ <file-append> base suffix) - (let* ((expand (lookup-expander base)) + (let* ((expand (or (lookup-expander base) + (lookup-expander lowered))) (base (expand base lowered output))) (string-append base (string-concatenate suffix))))))) @@ -1607,7 +1631,8 @@ last one is created from the given <scheme-file> object." (guile (%guile-for-build)) (module-path %load-path) (extensions '()) - (deprecation-warnings #f)) + (deprecation-warnings #f) + (optimization-level 1)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other. When TARGET is true, cross-compile MODULES for @@ -1618,127 +1643,178 @@ TARGET, a GNU triplet." #:system system #:guile guile #:module-path - module-path))) + module-path)) + (extensions (mapm %store-monad + (lambda (extension) + (lower-object extension system + #:target #f)) + extensions))) (define build - (gexp - (begin - (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' + (gexp-with-hidden-inputs + (gexp + (begin + (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' + + (use-modules (ice-9 ftw) + (ice-9 format) + (srfi srfi-1) + (srfi srfi-26) + (system base target) + (system base compile)) - (use-modules (ice-9 ftw) - (ice-9 format) - (srfi srfi-1) - (srfi srfi-26) - (system base target) - (system base compile)) + (define modules + (getenv "modules")) - (define (regular? file) - (not (member file '("." "..")))) + (define total + (string->number (getenv "module count"))) - (define (process-entry entry output processed) - (if (file-is-directory? entry) - (let ((output (string-append output "/" (basename entry)))) - (mkdir-p output) - (process-directory entry output processed)) - (let* ((base (basename entry ".scm")) - (output (string-append output "/" base ".go"))) - (format #t "[~2@a/~2@a] Compiling '~a'...~%" - (+ 1 processed (ungexp total)) - (ungexp (* total 2)) - entry) + (define extensions + (string-split (getenv "extensions") #\space)) - (ungexp-splicing - (if target - (gexp ((with-target (ungexp target) + (define target + (getenv "target")) + + (define optimization-level + (string->number (getenv "optimization level"))) + + (define optimizations-for-level + (or (and=> (false-if-exception + (resolve-interface '(system base optimize))) + (lambda (iface) + (module-ref iface 'optimizations-for-level))) ;Guile 3.0 + (const '()))) + + (define (regular? file) + (not (member file '("." "..")))) + + (define (process-entry entry output processed) + (if (file-is-directory? entry) + (let ((output (string-append output "/" (basename entry)))) + (mkdir-p output) + (process-directory entry output processed)) + (let* ((base (basename entry ".scm")) + (output (string-append output "/" base ".go"))) + (format #t "[~2@a/~2@a] Compiling '~a'...~%" + (+ 1 processed total) + (* total 2) + entry) + + (with-target (or target %host-type) (lambda () (compile-file entry #:output-file output #:opts - %auto-compilation-options))))) - (gexp ((compile-file entry - #:output-file output - #:opts %auto-compilation-options))))) + `(,@%auto-compilation-options + ,@(optimizations-for-level + optimization-level))))) + + (+ 1 processed)))) - (+ 1 processed)))) + (define (process-directory directory output processed) + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (cut process-entry <> output <>) + processed + entries))) - (define (process-directory directory output processed) - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (cut process-entry <> output <>) - processed - entries))) + (define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around <https://bugs.gnu.org/15602>. + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (lambda (file loaded) + (if (file-is-directory? file) + (load-from-directory file loaded) + (begin + (format #t "[~2@a/~2@a] Loading '~a'...~%" + (+ 1 loaded) (* 2 total) + file) + (save-module-excursion + (lambda () + (primitive-load file))) + (+ 1 loaded)))) + loaded + entries))) - (define* (load-from-directory directory - #:optional (loaded 0)) - "Load all the source files found in DIRECTORY." - ;; XXX: This works around <https://bugs.gnu.org/15602>. - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (lambda (file loaded) - (if (file-is-directory? file) - (load-from-directory file loaded) - (begin - (format #t "[~2@a/~2@a] Loading '~a'...~%" - (+ 1 loaded) (ungexp (* 2 total)) - file) - (save-module-excursion - (lambda () - (primitive-load file))) - (+ 1 loaded)))) - loaded - entries))) + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) (else _IOLBF))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) (else _IOLBF))) + (define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)) - (define mkdir-p - ;; Capture 'mkdir-p'. - (@ (guix build utils) mkdir-p)) + ;; Remove environment variables for internal consumption. + (unsetenv "modules") + (unsetenv "module count") + (unsetenv "extensions") + (unsetenv "target") + (unsetenv "optimization level") - ;; Add EXTENSIONS to the search path. - (set! %load-path - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path)) - (set! %load-compiled-path - (append (map (lambda (extension) - (string-append extension "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path)) + ;; Add EXTENSIONS to the search path. + (set! %load-path + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + extensions) + %load-path)) + (set! %load-compiled-path + (append (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + extensions) + %load-compiled-path)) - (set! %load-path (cons (ungexp modules) %load-path)) + (set! %load-path (cons modules %load-path)) - ;; Above we loaded our own (guix build utils) but now we may need to - ;; load a compile a different one. Thus, force a reload. - (let ((utils (string-append (ungexp modules) - "/guix/build/utils.scm"))) - (when (file-exists? utils) - (load utils))) + ;; Above we loaded our own (guix build utils) but now we may need to + ;; load a compile a different one. Thus, force a reload. + (let ((utils (string-append modules + "/guix/build/utils.scm"))) + (when (file-exists? utils) + (load utils))) - (mkdir (ungexp output)) - (chdir (ungexp modules)) + (mkdir (ungexp output)) + (chdir modules) - (load-from-directory ".") - (process-directory "." (ungexp output) 0)))) + (load-from-directory ".") + (process-directory "." (ungexp output) 0))) + (append (map gexp-input extensions) + (list (gexp-input modules))))) - ;; TODO: Pass MODULES as an environment variable. (gexp->derivation name build + #:script-name "compile-modules" #:system system #:target target #:guile-for-build guile #:local-build? #t #:env-vars - (case deprecation-warnings - ((#f) - '(("GUILE_WARN_DEPRECATED" . "no"))) - ((detailed) - '(("GUILE_WARN_DEPRECATED" . "detailed"))) - (else - '()))))) + `(("modules" + . ,(if (derivation? modules) + (derivation->output-path modules) + modules)) + ("module count" . ,(number->string total)) + ("extensions" + . ,(string-join + (map (match-lambda + ((? derivation? drv) + (derivation->output-path drv)) + ((? string? str) str)) + extensions))) + ("optimization level" + . ,(number->string optimization-level)) + ,@(if target + `(("target" . ,target)) + '()) + ,@(case deprecation-warnings + ((#f) + '(("GUILE_WARN_DEPRECATED" . "no"))) + ((detailed) + '(("GUILE_WARN_DEPRECATED" . "detailed"))) + (else + '())))))) ;;; @@ -1806,6 +1882,72 @@ Assume MODULES are compiled with GUILE." extensions)) %load-compiled-path))))))))) +(define* (input-tuples->gexp inputs #:key native?) + "Given INPUTS, a list of label/gexp-input tuples, return a gexp that expands +to an input alist." + (define references + (map (match-lambda + ((label input) input)) + inputs)) + + (define labels + (match inputs + (((labels . _) ...) + labels))) + + (define (proc . args) + (cons 'quote (list (map cons labels args)))) + + ;; This gexp is more efficient than an equivalent hand-written gexp: fewer + ;; allocations, no need to scan long list-valued <gexp-input> records in + ;; search of file-like objects, etc. + (make-gexp references '() '() proc + (source-properties inputs))) + +(define (outputs->gexp outputs) + "Given OUTPUTS, a list of output names, return a gexp that expands to an +output alist." + (define references + (map gexp-output outputs)) + + (define (proc . args) + `(list ,@(map (lambda (name) + `(cons ,name ((@ (guile) getenv) ,name))) + outputs))) + + ;; This gexp is more efficient than an equivalent hand-written gexp. + (make-gexp references '() '() proc + (source-properties outputs))) + +(define (with-build-variables inputs outputs body) + "Return a gexp that surrounds BODY with a definition of the legacy +'%build-inputs', '%outputs', and '%output' variables based on INPUTS, a list +of name/gexp-input tuples, and OUTPUTS, a list of strings." + + ;; These two variables are defined for backward compatibility. They are + ;; used by package expressions. These must be top-level defines so that + ;; 'use-modules' form in BODY that are required for macro expansion work as + ;; expected. + (gexp (begin + (define %build-inputs + (ungexp (input-tuples->gexp inputs))) + (define %outputs + (ungexp (outputs->gexp outputs))) + (define %output + (assoc-ref %outputs "out")) + + (ungexp body)))) + +(define (sexp->gexp sexp) + "Turn SEXP into a gexp without any references. + +Using this is a way for the caller to tell that SEXP doesn't need to be +scanned for file-like objects, thereby reducing processing costs. This is +particularly useful if SEXP is a long list or a deep tree." + (make-gexp '() '() '() + (lambda () sexp) + (source-properties sexp))) + (define* (gexp->script name exp #:key (guile (default-guile)) (module-path %load-path) diff --git a/guix/git.scm b/guix/git.scm index dc2ca1be84..43e85a5026 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,8 @@ #:use-module (guix utils) #:use-module (guix records) #:use-module (guix gexp) + #:autoload (guix git-download) + (git-reference-url git-reference-commit git-reference-recursive?) #:use-module (guix sets) #:use-module ((guix diagnostics) #:select (leave warning)) #:use-module (guix progress) @@ -65,7 +68,9 @@ git-checkout-url git-checkout-branch git-checkout-commit - git-checkout-recursive?)) + git-checkout-recursive? + + git-reference->git-checkout)) (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) @@ -672,6 +677,13 @@ is true, limit to only refs/tags." (commit git-checkout-commit (default #f)) ;#f | tag | commit (recursive? git-checkout-recursive? (default #f))) +(define (git-reference->git-checkout reference) + "Convert the <git-reference> REFERENCE to an equivalent <git-checkout>." + (git-checkout + (url (git-reference-url reference)) + (commit (git-reference-commit reference)) + (recursive? (git-reference-recursive? reference)))) + (define* (latest-repository-commit* url #:key ref recursive? log-port) ;; Monadic variant of 'latest-repository-commit'. (lambda (store) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 5fae24b325..088bebc0de 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,9 +57,9 @@ "/gpg/trustedkeys.kbx"))) (define %openpgp-key-server - ;; The default key server. Note that keys.gnupg.net appears to be - ;; unreliable. - (make-parameter "pool.sks-keyservers.net")) + ;; The default key server. It defaults to #f, which causes GnuPG to use the + ;; one it is configured with. + (make-parameter #f)) ;; Regexps for status lines. See file `doc/DETAILS' in GnuPG. @@ -182,22 +183,26 @@ missing key or its key id if the fingerprint is unavailable." (_ #f))) status)) -(define* (gnupg-receive-keys fingerprint/key-id server - #:optional (keyring (current-keyring))) - "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to -KEYRING." +(define* (gnupg-receive-keys fingerprint/key-id + #:key server (keyring (current-keyring))) + "Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from +GnuPG's default/configured one. The key is added to KEYRING." (unless (file-exists? keyring) (mkdir-p (dirname keyring)) - (call-with-output-file keyring (const #t))) ;create an empty keybox + (call-with-output-file keyring (const #t))) ;create an empty keybox - (zero? (system* (%gpg-command) "--keyserver" server - "--no-default-keyring" "--keyring" keyring - "--recv-keys" fingerprint/key-id))) + (zero? (apply system* + `(,(%gpg-command) + ,@(if server + (list "--keyserver" server) + '()) + "--no-default-keyring" "--keyring" ,keyring + "--recv-keys" ,fingerprint/key-id)))) (define* (gnupg-verify* sig file #:key (key-download 'interactive) - (server (%openpgp-key-server)) + server (keyring (current-keyring))) "Like `gnupg-verify', but try downloading the public key if it's missing. Return two values: 'valid-signature and a fingerprint/name pair upon success, @@ -215,7 +220,7 @@ fingerprint/user name pair on success and #f otherwise." (let ((missing (gnupg-status-missing-key? status))) (define (download-and-try-again) ;; Download the missing key and try again. - (if (gnupg-receive-keys missing server keyring) + (if (gnupg-receive-keys missing #:server server #:keyring keyring) (match (gnupg-status-good-signature? (gnupg-verify sig file keyring)) (#f diff --git a/guix/grafts.scm b/guix/grafts.scm index 4c69eb35a2..0ffda8f9aa 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -42,6 +42,7 @@ graft-derivation/shallow %graft? + without-grafting set-grafting grafting?)) @@ -341,6 +342,17 @@ DRV, and graft DRV itself to refer to those grafted dependencies." ;; Whether to honor package grafts by default. (make-parameter #t)) +(define (call-without-grafting thunk) + (lambda (store) + (values (parameterize ((%graft? #f)) + (run-with-store store (thunk))) + store))) + +(define-syntax-rule (without-grafting mexp ...) + "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is +false." + (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) + (define-inlinable (set-grafting enable?) ;; This monadic procedure enables grafting when ENABLE? is true, and ;; disables it otherwise. It returns the previous setting. diff --git a/guix/hash.scm b/guix/hash.scm new file mode 100644 index 0000000000..3cb68e5c44 --- /dev/null +++ b/guix/hash.scm @@ -0,0 +1,73 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; +;;; 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 hash) + #:use-module (gcrypt hash) + #:use-module (guix serialization) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (vcs-file? + file-hash*)) + +(define (vcs-file? file stat) + "Returns true if FILE is a version control system file." + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) + (else + #f))) + +(define* (file-hash* file #:key + (algorithm (hash-algorithm sha256)) + (recursive? 'auto) + (select? (negate vcs-file?))) + "Compute the hash of FILE with ALGORITHM. + +Symbolic links are only dereferenced if RECURSIVE? is false. +Directories are only supported if RECURSIVE? is #true or 'auto'. +The executable bit is only recorded if RECURSIVE? is #true. +If FILE is a symbolic link, it is only followed if RECURSIVE? is false. + +For regular files, there are two different hashes when the executable +hash isn't recorded: the regular hash and the nar hash. In most situations, +the regular hash is desired and setting RECURSIVE? to 'auto' does the right +thing for both regular files and directories. + +This procedure must only be used under controlled circumstances; +the detection of symbolic links in FILE is racy. + +When FILE is a directory, the procedure SELECT? called as (SELECT? FILE STAT) +decides which files to include. By default, version control files are +excluded. To include everything, SELECT? can be set to (const #true)." + (if (or (eq? recursive? #true) + (and (eq? recursive? 'auto) + ;; Don't change this to (eq? 'directory ...), because otherwise + ;; if 'file' denotes a symbolic link, the 'file-hash' below + ;; would dereference it -- dereferencing symbolic links would + ;; open an avoidable can of potential worms. + (not (eq? 'regular (stat:type (lstat file)))))) + (let-values (((port get-hash) + (open-hash-port algorithm))) + (write-file file port #:select? select?) + (force-output port) + (get-hash)) + (file-hash algorithm file))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index f649928c5a..7a73c11382 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,9 +35,10 @@ #:use-module (web uri) #:use-module (guix memoization) #:use-module (guix http-client) - #:use-module (gcrypt hash) + #:use-module (guix diagnostics) + #:use-module (guix hash) + #:use-module (guix i18n) #:use-module (guix store) - #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) @@ -135,9 +137,9 @@ (map (lambda (name) (case (%input-style) ((specification) - (list name (list 'unquote (list 'specification->package name)))) + `(specification->package ,name)) (else - (list name (list 'unquote (string->symbol name)))))) + (string->symbol name)))) (sort names string-ci<?))) (define* (maybe-inputs package-inputs #:optional (type 'inputs)) @@ -147,15 +149,15 @@ package definition." (() '()) ((package-inputs ...) - `((,type (,'quasiquote ,(format-inputs package-inputs))))))) + `((,type (list ,@(format-inputs package-inputs))))))) (define %cran-url "https://cran.r-project.org/web/packages/") (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.13. Bioconductor packages should be +;; The latest Bioconductor release is 3.14. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.13") +(define %bioconductor-version "3.14") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -171,11 +173,11 @@ package definition." release." (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve list of packages from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) + (warning (G_ "failed to retrieve list of packages \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) #f)) ;; Split the big list on empty lines, then turn each chunk into an ;; alist of attributes. @@ -194,17 +196,6 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) -;; XXX taken from (guix scripts hash) -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - ;; Little helper to download URLs only once. (define download (memoize @@ -227,27 +218,61 @@ bioconductor package NAME, or #F if the package is unknown." (let ((store-directory (add-to-store store (basename url) #t "sha256" dir))) (values store-directory changeset))))))) - (else (download-to-store store url))))))) + (else + (match url + ((? string?) + (download-to-store store url)) + ((urls ...) + ;; Try all the URLs. A use case where this is useful is when one + ;; of the URLs is the /Archive CRAN URL. + (any (cut download-to-store store <>) urls))))))))) + +(define (fetch-description-from-tarball url) + "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and +return the resulting alist." + (match (download url) + (#f #f) + (tarball + (call-with-temporary-directory + (lambda (dir) + (parameterize ((current-error-port (%make-void-port "rw+")) + (current-output-port (%make-void-port "rw+"))) + (and (zero? (system* "tar" "--wildcards" "-x" + "--strip-components=1" + "-C" dir + "-f" tarball "*/DESCRIPTION")) + (description->alist + (call-with-input-file (string-append dir "/DESCRIPTION") + read-string))))))))) -(define (fetch-description repository name) +(define* (fetch-description repository name #:optional version) "Return an alist of the contents of the DESCRIPTION file for the R package -NAME in the given REPOSITORY, or #f in case of failure. NAME is +NAME at VERSION in the given REPOSITORY, or #f in case of failure. NAME is case-sensitive." (case repository ((cran) - (let ((url (string-append %cran-url name "/DESCRIPTION"))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (let* ((port (http-fetch url)) - (result (description->alist (read-string port)))) - (close-port port) - result)))) + (guard (c ((http-get-error? c) + (warning (G_ "failed to retrieve package information \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + ;; When VERSION is true, we have to download the tarball to get at its + ;; 'DESCRIPTION' file; only the latest one is directly accessible over + ;; HTTP. + (if version + (let ((urls (list (string-append "mirror://cran/src/contrib/" + name "_" version ".tar.gz") + (string-append "mirror://cran/src/contrib/Archive/" + name "/" + name "_" version ".tar.gz")))) + (fetch-description-from-tarball urls)) + (let* ((url (string-append %cran-url name "/DESCRIPTION")) + (port (http-fetch url)) + (result (description->alist (read-string port)))) + (close-port port) + result)))) ((bioconductor) ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, @@ -256,22 +281,13 @@ from ~s: ~a (~s)~%" (and (latest-bioconductor-package-version name) #t) (and (latest-bioconductor-package-version name 'annotation) 'annotation) (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + ;; TODO: Honor VERSION. (version (latest-bioconductor-package-version name type)) (url (car (bioconductor-uri name version type))) - (tarball (download url))) - (call-with-temporary-directory - (lambda (dir) - (parameterize ((current-error-port (%make-void-port "rw+")) - (current-output-port (%make-void-port "rw+"))) - (and (zero? (system* "tar" "--wildcards" "-x" - "--strip-components=1" - "-C" dir - "-f" tarball "*/DESCRIPTION")) - (and=> (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)) - (lambda (meta) - (if (boolean? type) meta - (cons `(bioconductor-type . ,type) meta)))))))))) + (meta (fetch-description-from-tarball url))) + (if (boolean? type) + meta + (cons `(bioconductor-type . ,type) meta)))) ((git) (and (string-prefix? "http" name) ;; Download the git repository at "NAME" @@ -437,16 +453,6 @@ reference the pkg-config tool." (define (needs-knitr? meta) (member "knitr" (listify meta "VignetteBuilder"))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file select? recursive?) - ;; Compute the hash of FILE. - (if recursive? - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (call-with-input-file file port-sha256))) - (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." @@ -484,11 +490,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((bioconductor) (list (assoc-ref meta 'bioconductor-type))) (else '()))) - ((url rest ...) url) + ((urls ...) urls) ((? string? url) url) (_ #f))))) - (git? (assoc-ref meta 'git)) - (hg? (assoc-ref meta 'hg)) + (git? (if (assoc-ref meta 'git) #true #false)) + (hg? (if (assoc-ref meta 'hg) #true #false)) (source (download source-url #:method (cond (git? 'git) (hg? 'hg) @@ -544,12 +550,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (sha256 (base32 ,(bytevector->nix-base32-string - (case repository - ((git) - (file-hash source (negate vcs-file?) #t)) - ((hg) - (file-hash source (negate vcs-file?) #t)) - (else (file-sha256 source)))))))) + (file-hash* source #:recursive? (or git? hg?))))))) ,@(if (not (and git? hg? (equal? (string-append "r-" name) (cran-guix-name name)))) @@ -591,7 +592,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:key (repo 'cran) version) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((description (fetch-description repo package-name))) + (let ((description (fetch-description repo package-name version))) (if description (description->package repo description) (case repo @@ -609,8 +610,9 @@ s-expression corresponding to that package, or #f on failure." (&message (message "couldn't find meta-data for R package"))))))))))) -(define* (cran-recursive-import package-name #:key (repo 'cran)) +(define* (cran-recursive-import package-name #:key (repo 'cran) version) (recursive-import package-name + #:version version #:repo repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 287ffd2536..c76d7e9c1a 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; @@ -79,7 +79,10 @@ (number crate-version-number "num") ;string (download-path crate-version-download-path "dl_path") ;string (readme-path crate-version-readme-path "readme_path") ;string - (license crate-version-license "license") ;string + (license crate-version-license "license" ;string | #f + (match-lambda + ('null #f) + ((? string? str) str))) (links crate-version-links)) ;alist ;; Crate dependency. Each dependency (each edge in the graph) is annotated as @@ -198,6 +201,7 @@ and LICENSE." (description ,(beautify-description description)) (license ,(match license (() #f) + (#f #f) ((license) license) (_ `(list ,@license))))))) (close-port port) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 89e7a9160d..0b88020554 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,10 +52,10 @@ ;;; ;;; The following happens under the hood: ;;; -;;; * <git://code.call-cc.org/eggs-5-latest> is a Git repository that contains -;;; the latest version of all CHICKEN eggs. We look clone this repository -;;; and retrieve the latest version number, and the PACKAGE.egg file, which -;;; contains a list of lists containing metadata about the egg. +;;; * <git://code.call-cc.org/eggs-5-all> is a Git repository that contains +;;; all versions of all CHICKEN eggs. We look clone this repository and, by +;;; default, retrieve the latest version number, and the PACKAGE.egg file, +;;; which contains a list of lists containing metadata about the egg. ;;; ;;; * All the eggs are stored as tarballs at ;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for @@ -96,7 +97,7 @@ NAME." (define (eggs-repository) "Update or fetch the latest version of the eggs repository and return the path to the repository." - (let* ((url "git://code.call-cc.org/eggs-5-latest") + (let* ((url "git://code.call-cc.org/eggs-5-all") (directory commit _ (update-cached-checkout url))) directory)) @@ -112,12 +113,13 @@ to the repository." (last directory) #f))) -(define* (egg-metadata name #:optional file) - "Return the package metadata file for the egg NAME, or if FILE is specified, -return the package metadata in FILE." +(define* (egg-metadata name #:key (version #f) (file #f)) + "Return the package metadata file for the egg NAME at version VERSION, or if +FILE is specified, return the package metadata in FILE." (call-with-input-file (or file (string-append (egg-directory name) "/" - (find-latest-version name) + (or version + (find-latest-version name)) "/" name ".egg")) read)) @@ -173,10 +175,11 @@ return the package metadata in FILE." ;;; Egg importer. ;;; -(define* (egg->guix-package name #:key (file #f) (source #f)) - "Import a CHICKEN egg called NAME from either the given .egg FILE, or from -the latest NAME metadata downloaded from the official repository if FILE is #f. -Return a <package> record or #f on failure. +(define* (egg->guix-package name version #:key (file #f) (source #f)) + "Import a CHICKEN egg called NAME from either the given .egg FILE, or from the +latest NAME metadata downloaded from the official repository if FILE is #f. +Return a <package> record or #f on failure. If VERSION is specified, import +the particular version from the egg repository. SOURCE is a ``file-like'' object containing the source code corresponding to the egg. If SOURCE is not specified, the latest tarball for egg NAME will be @@ -186,8 +189,8 @@ Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg locally. Note that if FILE and SOURCE are specified, recursive import will not work." (define egg-content (if file - (egg-metadata name file) - (egg-metadata name))) + (egg-metadata name #:file file) + (egg-metadata name #:version version))) (if (not egg-content) (values #f '()) ; egg doesn't exist (let* ((version* (or (assoc-ref egg-content 'version) @@ -247,12 +250,9 @@ not work." (let ((name (prettify-name (extract-name name)))) ;; Dependencies are sometimes specified as symbols and sometimes ;; as strings - (list (string-append (if system? "" package-name-prefix) - name) - (list 'unquote - (string->symbol (string-append - (if system? "" package-name-prefix) - name)))))) + (string->symbol (string-append + (if system? "" package-name-prefix) + name)))) (define egg-propagated-inputs (let ((dependencies (assoc-ref egg-content 'dependencies))) @@ -291,7 +291,7 @@ not work." '()) ((inputs ...) (list (list input-type - (list 'quasiquote inputs)))))) + `(list ,@inputs)))))) (values `(package @@ -319,17 +319,18 @@ not work." (license ,egg-licenses)) (filter (lambda (name) (not (member name '("srfi-4")))) - (map (compose guix-name->egg-name first) + (map (compose guix-name->egg-name symbol->string) (append egg-propagated-inputs egg-native-inputs))))))) (define egg->guix-package/m ;memoized variant (memoize egg->guix-package)) -(define (egg-recursive-import package-name) +(define* (egg-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package (lambda* (name #:key version repo) - (egg->guix-package/m name)) + (egg->guix-package/m name version)) #:guix-name egg-name->guix-name)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 96ebc17af1..ea77a7c244 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,15 +38,17 @@ #:use-module (guix import utils) #:use-module (guix http-client) #:use-module (guix git) + #:use-module (guix hash) #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix store) #:use-module (guix ui) - #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (guix memoization) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package + guix-package->elpa-name %elpa-updater elpa-recursive-import)) @@ -228,27 +231,6 @@ keywords to values." (close-port port) (data->recipe (cons ':name data)))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file select? recursive?) - ;; Compute the hash of FILE. - (if recursive? - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (call-with-input-file file port-sha256))) - -;; XXX taken from (guix scripts hash) -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - (define (git-repository->origin recipe url) "Fetch origin details from the Git repository at URL for the provided MELPA RECIPE." @@ -270,7 +252,7 @@ RECIPE." (sha256 (base32 ,(bytevector->nix-base32-string - (file-hash directory (negate vcs-file?) #t))))))) + (file-hash* directory #:recursive? #true))))))) (define* (melpa-recipe->origin recipe) "Fetch origin details from the MELPA recipe and associated repository for @@ -337,9 +319,10 @@ the package named PACKAGE-NAME." type '<elpa-package>'." (define melpa-recipe - (if (eq? repo 'melpa) - (package-name->melpa-recipe (elpa-package-name pkg)) - #f)) + ;; XXX: Call 'identity' to work around a Guile 3.0.[5-7] compiler bug: + ;; <https://bugs.gnu.org/48368>. + (and (eq? (identity repo) 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)))) (define name (elpa-package-name pkg)) @@ -352,9 +335,7 @@ type '<elpa-package>'." (elpa-package-inputs pkg)))) (define dependencies - (map (lambda (n) - (let ((new-n (elpa-name->package-name n))) - (list new-n (list 'unquote (string->symbol new-n))))) + (map (compose string->symbol elpa-name->package-name) dependencies-names)) (define (maybe-inputs input-type inputs) @@ -362,8 +343,7 @@ type '<elpa-package>'." (() '()) ((inputs ...) - (list (list input-type - (list 'quasiquote inputs)))))) + (list (list input-type `(list ,@inputs)))))) (define melpa-source (melpa-recipe->origin melpa-recipe)) @@ -381,7 +361,8 @@ type '<elpa-package>'." (sha256 (base32 ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) + (bytevector->nix-base32-string + (file-hash* tarball #:recursive? #false)) "failed to download package"))))))) (build-system emacs-build-system) ,@(maybe-inputs 'propagated-inputs dependencies) @@ -390,7 +371,7 @@ type '<elpa-package>'." '()) (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) + (description ,(beautify-description (elpa-package-description pkg))) (license ,license)) dependencies-names)) @@ -414,14 +395,18 @@ type '<elpa-package>'." ;;; Updates. ;;; +(define (guix-package->elpa-name package) + "Given a Guix package, PACKAGE, return the upstream name on ELPA." + (or (and=> (package-properties package) + (cut assq-ref <> 'upstream-name)) + (if (string-prefix? "emacs-" (package-name package)) + (string-drop (package-name package) 6) + (package-name package)))) + (define (latest-release package) "Return an <upstream-release> for the latest release of PACKAGE." - (define name - (if (string-prefix? "emacs-" (package-name package)) - (string-drop (package-name package) 6) - (package-name package))) - - (define repo 'gnu) + (define name (guix-package->elpa-name package)) + (define repo (elpa-repository package)) (match (elpa-package-info name repo) (#f @@ -440,11 +425,20 @@ type '<elpa-package>'." (urls (list url)) (signature-urls (list (string-append url ".sig")))))))) -(define package-from-gnu.org? - (url-predicate (lambda (url) - (let ((uri (string->uri url))) - (and uri - (string=? (uri-host uri) "elpa.gnu.org")))))) +(define elpa-repository + (memoize + (url-predicate (lambda (url) + (let ((uri (string->uri url))) + (and uri + (cond + ((string=? (uri-host uri) "elpa.gnu.org") + 'gnu) + ((string=? (uri-host uri) "elpa.nongnu.org") + 'nongnu) + (else #f)))))))) + +(define (package-from-elpa-repository? package) + (member (elpa-repository package) '(gnu nongnu))) (define %elpa-updater ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org @@ -452,7 +446,7 @@ type '<elpa-package>'." (upstream-updater (name 'elpa) (description "Updater for ELPA packages") - (pred package-from-gnu.org?) + (pred package-from-elpa-repository?) (latest latest-release))) (define elpa-guix-name (cut guix-name "emacs-" <>)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 418d716be6..0e5bb7e635 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -110,12 +111,7 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." ,@(if (null? dependencies) '() `((propagated-inputs - (,'quasiquote - ,(map (lambda (name) - `(,name - (,'unquote - ,(string->symbol name)))) - dependencies))))) + (list ,@(map string->symbol dependencies))))) (synopsis ,synopsis) (description ,description) (home-page ,home-page) diff --git a/guix/import/git.scm b/guix/import/git.scm index 1eb219f3fe..4cf404677c 100644 --- a/guix/import/git.scm +++ b/guix/import/git.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:export (%generic-git-updater ;; For tests. @@ -172,21 +174,21 @@ repository at URL." (values version tag))))))) (define (latest-git-tag-version package) - "Given a PACKAGE, return the latest version of it, or #f if the latest version -could not be determined." + "Given a PACKAGE, return the latest version of it and the corresponding git +tag, or #false and #false if the latest version could not be determined." (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) (warning (or (package-field-location package 'source) (package-location package)) (G_ "~a for ~a~%") (condition-message c) (package-name package)) - #f) + (values #f #f)) ((eq? (exception-kind c) 'git-error) (warning (or (package-field-location package 'source) (package-location package)) (G_ "failed to fetch Git repository for ~a~%") (package-name package)) - #f)) + (values #f #f))) (let* ((source (package-source package)) (url (git-reference-url (origin-uri source))) (property (cute assq-ref (package-properties package) <>))) @@ -208,14 +210,16 @@ could not be determined." "Return an <upstream-source> for the latest release of PACKAGE." (let* ((name (package-name package)) (old-version (package-version package)) - (url (git-reference-url (origin-uri (package-source package)))) - (new-version (latest-git-tag-version package))) - - (and new-version + (old-reference (origin-uri (package-source package))) + (new-version new-version-tag (latest-git-tag-version package))) + (and new-version new-version-tag (upstream-source (package name) (version new-version) - (urls (list url)))))) + (urls (git-reference + (url (git-reference-url old-reference)) + (commit new-version-tag) + (recursive? (git-reference-recursive? old-reference)))))))) (define %generic-git-updater (upstream-updater diff --git a/guix/import/github.scm b/guix/import/github.scm index 888b148ffb..8c1898c0c5 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-71) #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix diagnostics) @@ -37,7 +39,10 @@ #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) - #:export (%github-updater)) + #:export (%github-api %github-updater)) + +;; For tests. +(define %github-api (make-parameter "https://api.github.com")) (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or @@ -148,11 +153,11 @@ tags show up in the \"Releases\" tab of the web UI. For instance, 'https://api.github.com/repos/aconchillo/guile-json/releases' returns the empty list." (define release-url - (string-append "https://api.github.com/repos/" + (string-append (%github-api) "/repos/" (github-user-slash-repository url) "/releases")) (define tag-url - (string-append "https://api.github.com/repos/" + (string-append (%github-api) "/repos/" (github-user-slash-repository url) "/tags")) @@ -181,12 +186,15 @@ empty list." (x x))))) (define (latest-released-version url package-name) - "Return a string of the newest released version name given a string URL like + "Return the newest released version and its tag given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of -the package e.g. 'bedtools2'. Return #f if there is no releases" +the package e.g. 'bedtools2'. Return #f (two values) if there are no +releases." (define (pre-release? x) (assoc-ref x "prerelease")) + ;; This procedure returns (version . tag) pair, or #f + ;; if RELEASE doesn't seyem to correspond to a version. (define (release->version release) (let ((tag (or (assoc-ref release "tag_name") ;a "release" (assoc-ref release "name"))) ;a tag @@ -197,22 +205,22 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" ((and (< name-length (string-length tag)) (string=? (string-append package-name "-") (substring tag 0 (+ name-length 1)))) - (substring tag (+ name-length 1))) + (cons (substring tag (+ name-length 1)) tag)) ;; some tags start with a "v" e.g. "v0.25.0" ;; or with the word "version" e.g. "version.2.1" ;; where some are just the version number ((string-prefix? "version" tag) - (if (char-set-contains? char-set:digit (string-ref tag 7)) - (substring tag 7) - (substring tag 8))) + (cons (if (char-set-contains? char-set:digit (string-ref tag 7)) + (substring tag 7) + (substring tag 8)) tag)) ((string-prefix? "v" tag) - (substring tag 1)) + (cons (substring tag 1) tag)) ;; Finally, reject tags that don't start with a digit: ;; they may not represent a release. ((and (not (string-null? tag)) (char-set-contains? char-set:digit (string-ref tag 0))) - tag) + (cons tag tag)) (else #f)))) (let* ((json (and=> (fetch-releases-or-tags url) @@ -229,14 +237,14 @@ https://github.com/settings/tokens")) (match (remove pre-release? json) (() json) ; keep everything (releases releases))) - version>?) - ((latest-release . _) latest-release) - (() #f))))) + (lambda (x y) (version>? (car x) (car y)))) + (((latest-version . tag) . _) (values latest-version tag)) + (() (values #f #f)))))) (define (latest-release pkg) "Return an <upstream-source> for the latest release of PKG." - (define (origin-github-uri origin) - (match (origin-uri origin) + (define (github-uri uri) + (match uri ((? string? url) url) ;surely a github.com URL ((? download:git-reference? ref) @@ -244,14 +252,20 @@ https://github.com/settings/tokens")) ((urls ...) (find (cut string-contains <> "github.com") urls)))) - (let* ((source-uri (origin-github-uri (package-source pkg))) + (let* ((original-uri (origin-uri (package-source pkg))) + (source-uri (github-uri original-uri)) (name (package-name pkg)) - (newest-version (latest-released-version source-uri name))) + (newest-version version-tag + (latest-released-version source-uri name))) (if newest-version (upstream-source (package name) (version newest-version) - (urls (list (updated-github-url pkg newest-version)))) + (urls (if (download:git-reference? original-uri) + (download:git-reference + (inherit original-uri) + (commit version-tag)) + (list (updated-github-url pkg newest-version))))) #f))) ; On GitHub but no proper releases (define %github-updater diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 51d5b77d34..2b9b71feb0 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -100,7 +100,8 @@ download policy (see 'download-tarball' for details.)" (file-sha256 tarball)))))) (build-system gnu-build-system) (synopsis ,(gnu-package-doc-summary package)) - (description ,(gnu-package-doc-description package)) + (description ,(beautify-description + (gnu-package-doc-description package))) (home-page ,(match (gnu-package-doc-urls package) ((head . tail) (qualified-url head)))) (license find-by-yourself!))) diff --git a/guix/import/go.scm b/guix/import/go.scm index 9769b557ae..d00c13475a 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> @@ -26,6 +26,7 @@ (define-module (guix import go) #:use-module (guix build-system go) #:use-module (guix git) + #:use-module (guix hash) #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module (guix import utils) @@ -36,11 +37,11 @@ #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) #:autoload (htmlprag) (html->sxml) ;from Guile-Lib - #:autoload (guix git) (update-cached-checkout) - #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) #:autoload (guix serialization) (write-file) #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) + #:autoload (gcrypt hash) (hash-algorithm sha256) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 peg) #:use-module (ice-9 rdelim) @@ -54,6 +55,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (sxml match) #:use-module ((sxml xpath) #:renamer (lambda (s) (if (eq? 'filter s) @@ -474,7 +476,7 @@ Optionally include a VERSION string to append to the name." because goproxy servers don't currently provide all the information needed to build a package." (define (go-import->module-meta content-text) - (match (string-split content-text #\space) + (match (string-tokenize content-text char-set:graphic) ((root-path vcs repo-url) (make-module-meta root-path (string->symbol vcs) (strip-.git-suffix/maybe repo-url))))) @@ -499,25 +501,6 @@ source." goproxy (module-meta-repo-root meta-data))) -;; XXX: Copied from (guix scripts hash). -(define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - -;; XXX: Adapted from 'file-hash' in (guix scripts hash). -(define* (file-hash file #:optional (algorithm (hash-algorithm sha256))) - ;; Compute the hash of FILE. - (let-values (((port get-hash) (open-hash-port algorithm))) - (write-file file port #:select? (negate vcs-file?)) - (force-output port) - (get-hash))) - (define* (git-checkout-hash url reference algorithm) "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or tag." @@ -536,7 +519,7 @@ tag." (update-cached-checkout url #:ref `(tag-or-commit . ,reference))))) - (file-hash checkout algorithm))) + (file-hash* checkout #:algorithm algorithm #:recursive? #true))) (define (vcs->origin vcs-type vcs-repo-url version) "Generate the `origin' block of a package depending on what type of source @@ -588,6 +571,34 @@ control system is being used." (formatted-message (G_ "unsupported vcs type '~a' for package '~a'") vcs-type vcs-repo-url))))) +(define (strip-v-prefix version) + "Strip from VERSION the \"v\" prefix that Go uses." + (string-trim version #\v)) + +(define (ensure-v-prefix version) + "Add a \"v\" prefix to VERSION if it does not already have one." + (if (string-prefix? "v" version) + version + (string-append "v" version))) + +(define (validate-version version available-versions module-path) + "Raise an error if VERSION is not among AVAILABLE-VERSIONS, unless VERSION +is a pseudo-version. Return VERSION." + ;; Pseudo-versions do not appear in the versions list; skip the + ;; following check. + (if (or (go-pseudo-version? version) + (member version available-versions)) + version + (raise + (make-compound-condition + (formatted-message (G_ "version ~a of ~a is not available~%") + version module-path available-versions) + (condition (&fix-hint + (hint (format #f (G_ "Pick one of the following \ +available versions:~{ ~a~}.") + (map strip-v-prefix + available-versions))))))))) + (define* (go-module->guix-package module-path #:key (goproxy "https://proxy.golang.org") version @@ -596,22 +607,18 @@ control system is being used." The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. When VERSION is unspecified, the latest version available is used." (let* ((available-versions (go-module-available-versions goproxy module-path)) - (version* (or version - (go-module-version-string goproxy module-path))) ;latest - ;; Elide the "v" prefix Go uses. - (strip-v-prefix (cut string-trim <> #\v)) - ;; Pseudo-versions do not appear in the versions list; skip the - ;; following check. - (_ (unless (or (go-pseudo-version? version*) - (member version* available-versions)) - (error (format #f "error: version ~s is not available -hint: use one of the following available versions ~a\n" - version* available-versions)))) + (version* (validate-version + (or (and version (ensure-v-prefix version)) + (go-module-version-string goproxy module-path)) ;latest + available-versions + module-path)) (content (fetch-go.mod goproxy module-path version*)) (dependencies+versions (go.mod-requirements (parse-go.mod content))) (dependencies (if pin-versions? dependencies+versions (map car dependencies+versions))) + (module-path-sans-suffix + (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -631,7 +638,7 @@ hint: use one of the following available versions ~a\n" (build-system go-build-system) (arguments '(#:import-path ,module-path - ,@(if (string=? module-path root-module-path) + ,@(if (string=? module-path-sans-suffix root-module-path) '() `(#:unpack-path ,root-module-path)))) ,@(maybe-propagated-inputs @@ -645,10 +652,10 @@ hint: use one of the following available versions ~a\n" (synopsis ,synopsis) (description ,(and=> description beautify-description)) (license ,(match (list->licenses licenses) - (() #f) ;unknown license - ((license) ;a single license + (() #f) ;unknown license + ((license) ;a single license license) - ((license ...) ;a list of licenses + ((license ...) ;a list of licenses `(list ,@license))))) (if pin-versions? dependencies+versions @@ -668,12 +675,6 @@ This package and its dependencies won't be imported.~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (values #f '())) - (else - (warning (G_ "Failed to import package ~s. -reason: ~s.~%") - package-name - (exception-args c)) (values #f '()))) (apply go-module->guix-package args))))) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index f94a1e7087..b94f4169d4 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +33,7 @@ #:use-module ((guix utils) #:select (package-name->name+version canonical-newline-port)) #:use-module (guix http-client) - #:use-module ((guix import utils) #:select (factorize-uri recursive-import)) + #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) #:use-module (gcrypt hash) @@ -40,6 +41,7 @@ #:use-module (guix memoization) #:use-module (guix upstream) #:use-module (guix packages) + #:autoload (guix build-system haskell) (hackage-uri) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (%hackage-url hackage->guix-package @@ -54,8 +56,8 @@ hackage-package?)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (8.6.5). - ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5. + ;; List of libraries distributed with ghc (as of 8.10.7). + ;; Contents of …-ghc-8.10.7/lib/ghc-8.10.7 '("ghc" "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but ;; hackage-name->package-name takes this into account. @@ -67,6 +69,7 @@ "containers" "deepseq" "directory" + "exceptions" "filepath" "ghc" "ghc-boot" @@ -120,12 +123,12 @@ version is returned." (string-append package-name-prefix (string-downcase name)))) (define guix-package->hackage-name - (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*")) + (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*")) (name-rx (make-regexp "(.*)-[0-9\\.]+"))) (lambda (package) "Given a Guix package name, return the corresponding Hackage name." (let* ((source-url (and=> (package-source package) origin-uri)) - (name (match:substring (regexp-exec uri-rx source-url) 1))) + (name (match:substring (regexp-exec uri-rx source-url) 2))) (match (regexp-exec name-rx name) (#f name) (m (match:substring m 1))))))) @@ -265,14 +268,12 @@ the hash of the Cabal file." hackage-dependencies)) (define dependencies - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (map string->symbol (map hackage-name->package-name hackage-dependencies))) (define native-dependencies - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (map string->symbol (map hackage-name->package-name hackage-native-dependencies))) @@ -282,8 +283,8 @@ the hash of the Cabal file." '()) ((inputs ...) (list (list input-type - (list 'quasiquote inputs)))))) - + `(list ,@inputs)))))) + (define (maybe-arguments) (match (append (if (not include-test-dependencies?) '(#:tests? #f) @@ -302,7 +303,7 @@ the hash of the Cabal file." (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (hackage-uri ,name version)) (sha256 (base32 ,(if tarball @@ -314,7 +315,7 @@ the hash of the Cabal file." ,@(maybe-arguments) (home-page ,(cabal-package-home-page cabal)) (synopsis ,(cabal-package-synopsis cabal)) - (description ,(cabal-package-description cabal)) + (description ,(beautify-description (cabal-package-description cabal))) (license ,(string->license (cabal-package-license cabal)))) (append hackage-dependencies hackage-native-dependencies)))) @@ -352,7 +353,7 @@ respectively." #:guix-name hackage-name->package-name)) (define hackage-package? - (let ((hackage-rx (make-regexp "https?://hackage.haskell.org"))) + (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) (define (latest-release package) @@ -366,7 +367,7 @@ respectively." (hackage-cabal-url hackage-name)) #f) ((_ *** ("version" (version))) - (let ((url (hackage-source-url hackage-name version))) + (let ((url (hackage-uri hackage-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index ba86c60bfd..3b2cdcdcac 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +25,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module ((guix packages) #:prefix package:) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix ui) #:use-module (guix i18n) @@ -36,15 +38,20 @@ #:use-module (json) #:use-module (guix base32) #:use-module (guix git) + #:use-module ((guix git-download) #:prefix download:) + #:use-module (guix hash) #:use-module (guix store) #:export (%default-sort-key %contentdb-api json->package contentdb-fetch elaborate-contentdb-name + minetest-package? + latest-minetest-release minetest->guix-package minetest-recursive-import - sort-packages)) + sort-packages + %minetest-updater)) ;; The ContentDB API is documented at ;; <https://content.minetest.net>. @@ -280,14 +287,6 @@ results. The return value is a list of <package-keys> records." (with-store store (latest-repository-commit store url #:ref ref))) -;; XXX adapted from (guix scripts hash) -(define (file-hash file) - "Compute the hash of FILE." - (let-values (((port get-hash) (open-sha256-port))) - (write-file file port) - (force-output port) - (get-hash))) - (define (make-minetest-sexp author/name version repository commit inputs home-page synopsis description media-license license) @@ -308,15 +307,19 @@ MEDIA-LICENSE and LICENSE." ;; The git commit is not always available. ,(and commit (bytevector->nix-base32-string - (file-hash + (file-hash* (download-git-repository repository - `(commit . ,commit))))))) + `(commit . ,commit)) + ;; 'download-git-repository' already filtered out the '.git' + ;; directory. + #:select? (const #true) + #:recursive? #true))))) (file-name (git-file-name name version)))) (build-system minetest-mod-build-system) ,@(maybe-propagated-inputs (map contentdb->package-name inputs)) (home-page ,home-page) (synopsis ,(delete-cr synopsis)) - (description ,(delete-cr description)) + (description ,(beautify-description (delete-cr description))) (license ,(if (eq? media-license license) license `(list ,media-license ,license))) @@ -345,6 +348,17 @@ official Minetest forum and the Git repository (if any)." (substring title 1) title)) +(define (version-style version) + "Determine the kind of version number VERSION is -- a date, or a conventional +conventional version number." + (define dots? (->bool (string-index version #\.))) + (define hyphens? (->bool (string-index version #\-))) + (match (cons dots? hyphens?) + ((#true . #false) 'regular) ; something like "0.1" + ((#false . #false) 'regular) ; single component version number + ((#true . #true) 'regular) ; result of 'git-version' + ((#false . #true) 'date))) ; something like "2021-01-25" + ;; If the default sort key is changed, make sure to modify 'show-help' ;; in (guix scripts import minetest) appropriately as well. (define %default-sort-key "score") @@ -466,3 +480,37 @@ list of AUTHOR/NAME strings." (recursive-import author/name #:repo->guix-package minetest->guix-package* #:guix-name contentdb->package-name)) + +(define (minetest-package? pkg) + "Is PKG a Minetest mod on ContentDB?" + (and (string-prefix? "minetest-" (package:package-name pkg)) + (assq-ref (package:package-properties pkg) 'upstream-name))) + +(define (latest-minetest-release pkg) + "Return an <upstream-source> for the latest release of the package PKG, +or #false if the latest release couldn't be determined." + (define author/name + (assq-ref (package:package-properties pkg) 'upstream-name)) + (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f? + (define release (latest-release author/name)) + (define source (package:package-source pkg)) + (and contentdb-package release + (release-commit release) ; not always set + ;; Only continue if both the old and new version number are both + ;; dates or regular version numbers, as two different styles confuses + ;; the logic for determining which version is newer. + (eq? (version-style (release-version release)) + (version-style (package:package-version pkg))) + (upstream-source + (package (package:package-name pkg)) + (version (release-version release)) + (urls (download:git-reference + (url (package-repository contentdb-package)) + (commit (release-commit release))))))) + +(define %minetest-updater + (upstream-updater + (name 'minetest) + (description "Updater for Minetest packages on ContentDB") + (pred minetest-package?) + (latest latest-minetest-release))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index fe13d29f03..a6f6fe8c9f 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; ;;; This file is part of GNU Guix. @@ -230,7 +231,8 @@ path to the repository." (('list-pat . stuff) stuff) (('string-pat stuff) stuff) (('multiline-string stuff) stuff) - (('dict records ...) records)) + (('dict records ...) records) + (_ #f)) acc)))) #f file)) @@ -305,10 +307,8 @@ path to the repository." (map dependency->native-input depends))) (define (dependency-list->inputs lst) - (map - (lambda (dependency) - (list dependency (list 'unquote (string->symbol dependency)))) - (ocaml-names->guix-names lst))) + (map string->symbol + (ocaml-names->guix-names lst))) (define* (opam-fetch name #:optional (repositories-specs '("opam"))) (or (fold (lambda (repository others) @@ -318,11 +318,11 @@ path to the repository." (_ others))) #f (filter-map get-opam-repository repositories-specs)) - (leave (G_ "package '~a' not found~%") name))) + (warning (G_ "opam: package '~a' not found~%") name))) -(define* (opam->guix-package name #:key (repo '()) version) - "Import OPAM package NAME from REPOSITORIES (a list of names, URLs or local -paths, always including OPAM's official repository). Return a 'package' sexp +(define* (opam->guix-package name #:key (repo 'opam) version) + "Import OPAM package NAME from REPOSITORY (a directory name) or, if +REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." (and-let* ((with-opam (if (member "opam" repo) repo (cons "opam" repo))) (opam-file (opam-fetch name with-opam)) @@ -361,17 +361,18 @@ or #f on failure." 'ocaml-build-system)) ,@(if (null? inputs) '() - `((propagated-inputs ,(list 'quasiquote inputs)))) + `((propagated-inputs (list ,@inputs)))) ,@(if (null? native-inputs) '() - `((native-inputs ,(list 'quasiquote native-inputs)))) + `((native-inputs (list ,@native-inputs)))) ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) '() `((properties ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) + (description ,(beautify-description + (metadata-ref opam-content "description"))) (license ,(spdx-string->license (metadata-ref opam-content "license")))) (filter diff --git a/guix/import/print.scm b/guix/import/print.scm index 0310739b3a..66016145cb 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,14 +26,20 @@ #:use-module (guix build-system) #:use-module (gnu packages) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (guix import utils) #:use-module (ice-9 control) #:use-module (ice-9 match) #:export (package->code)) -;; FIXME: the quasiquoted arguments field may contain embedded package -;; objects, e.g. in #:disallowed-references; they will just be printed with -;; their usual #<package ...> representation, not as variable names. +(define (redundant-input-labels? inputs) + "Return #t if input labels in the INPUTS list are redundant." + (every (match-lambda + ((label (? package? package) . _) + (string=? label (package-name package))) + (_ #f)) + inputs)) + (define (package->code package) "Return an S-expression representing the source code that produces PACKAGE when evaluated." @@ -72,6 +79,11 @@ when evaluated." (file-type (quote ,(search-path-specification-file-type spec))) (file-pattern ,(search-path-specification-file-pattern spec)))) + (define (factorized-uri-code uri version) + (match (factorize-uri uri version) + ((? string? uri) uri) + ((factorized ...) `(string-append ,@factorized)))) + (define (source->code source version) (let ((uri (origin-uri source)) (method (origin-method source)) @@ -89,9 +101,14 @@ when evaluated." (guix hg-download) (guix svn-download))) (procedure-name method))) - (uri (string-append ,@(match (factorize-uri uri version) - ((? string? uri) (list uri)) - (factorized factorized)))) + (uri ,(if version + (match uri + ((? string? uri) + (factorized-uri-code uri version)) + ((lst ...) + `(list + ,@(map (cut factorized-uri-code <> version) uri)))) + uri)) ,(if (equal? (content-hash-algorithm hash) 'sha256) `(sha256 (base32 ,(bytevector->nix-base32-string (content-hash-value hash)))) @@ -101,24 +118,62 @@ when evaluated." ;; FIXME: in order to be able to throw away the directory prefix, ;; we just assume that the patch files can be found with ;; "search-patches". - ,@(if (null? patches) '() - `((patches (search-patches ,@(map basename patches)))))))) + ,@(cond ((null? patches) + '()) + ((every string? patches) + `((patches (search-patches ,@(map basename patches))))) + (else + `((patches (list ,@(map (match-lambda + ((? string? file) + `(search-patch ,file)) + ((? origin? origin) + (source->code origin #f))) + patches))))))))) + + (define (variable-reference module name) + ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import + ;; the individual package modules. + (list '@ module name)) + + (define (object->code obj quoted?) + (match obj + ((? package? package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (if quoted? + (list 'unquote (variable-reference module name)) + (variable-reference module name)))) + ((? origin? origin) + (let ((code (source->code origin #f))) + (if quoted? + (list 'unquote code) + code))) + ((lst ...) + (let ((lst (map (cut object->code <> #t) lst))) + (if quoted? + lst + (list 'quasiquote lst)))) + (obj + obj))) - (define (package-lists->code lsts) - (list 'quasiquote - (map (match-lambda - ((? symbol? s) - (list (symbol->string s) (list 'unquote s))) - ((label pkg . out) - (let ((mod (package-module-name pkg))) - (cons* label - ;; FIXME: using '@ certainly isn't pretty, but it - ;; avoids having to import the individual package - ;; modules. - (list 'unquote - (list '@ mod (variable-name pkg mod))) - out)))) - lsts))) + (define (inputs->code inputs) + (if (redundant-input-labels? inputs) + `(list ,@(map (match-lambda ;no need for input labels ("new style") + ((_ package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (variable-reference module name))) + ((_ package output) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (list 'quasiquote + (list + (list 'unquote + (variable-reference module name)) + output))))) + inputs)) + (list 'quasiquote ;preserve input labels (deprecated) + (object->code inputs #t)))) (let ((name (package-name package)) (version (package-version package)) @@ -154,19 +209,20 @@ when evaluated." '-build-system))) ,@(match arguments (() '()) - (args `((arguments ,(list 'quasiquote args))))) + (_ `((arguments + ,(list 'quasiquote (object->code arguments #t)))))) ,@(match outputs (("out") '()) (outs `((outputs (list ,@outs))))) ,@(match native-inputs (() '()) - (pkgs `((native-inputs ,(package-lists->code pkgs))))) + (pkgs `((native-inputs ,(inputs->code pkgs))))) ,@(match inputs (() '()) - (pkgs `((inputs ,(package-lists->code pkgs))))) + (pkgs `((inputs ,(inputs->code pkgs))))) ,@(match propagated-inputs (() '()) - (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + (pkgs `((propagated-inputs ,(inputs->code pkgs))))) ,@(if (lset= string=? supported-systems %supported-systems) '() `((supported-systems (list ,@supported-systems)))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index b7859c8341..b4284f5c33 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -10,6 +10,7 @@ ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -113,7 +114,7 @@ (url distribution-url) ;string (digests distribution-digests) ;list of string pairs (file-name distribution-file-name "filename") ;string - (has-signature? distribution-has-signature? "hash_sig") ;Boolean + (has-signature? distribution-has-signature? "has_sig") ;Boolean (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ... (python-version distribution-package-python-version "python_version")) @@ -128,27 +129,30 @@ missing-source-error? (package missing-source-error-package)) -(define (latest-source-release pypi-package) - "Return the latest source release for PYPI-PACKAGE." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) +(define (latest-version project) + "Return the latest version of PROJECT, a <pypi-project> record." + (project-info-version (pypi-project-info project))) + +(define* (source-release pypi-package + #:optional (version (latest-version pypi-package))) + "Return the source release of VERSION for PYPI-PACKAGE, a <pypi-project> +record, by default the latest version." + (let ((releases (or (assoc-ref (pypi-project-releases pypi-package) version) + '()))) (or (find (lambda (release) (string=? "sdist" (distribution-package-type release))) releases) (raise (condition (&missing-source-error (package pypi-package))))))) -(define (latest-wheel-release pypi-package) +(define* (wheel-release pypi-package + #:optional (version (latest-version pypi-package))) "Return the url of the wheel for the latest release of pypi-package, or #f if there isn't any." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) - (or (find (lambda (release) - (string=? "bdist_wheel" (distribution-package-type release))) - releases) - #f))) + (let ((releases (assoc-ref (pypi-project-releases pypi-package) version))) + (find (lambda (release) + (string=? "bdist_wheel" (distribution-package-type release))) + releases))) (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the @@ -185,7 +189,7 @@ the input field." (() '()) ((package-inputs ...) - `((,input-type (,'quasiquote ,package-inputs)))))) + `((,input-type (list ,@package-inputs)))))) (define %requirement-name-regexp ;; Regexp to match the requirement name in a requirement specification. @@ -404,15 +408,8 @@ return the unaltered list of upstream dependency names." (remove (cut string=? "argparse" <>) deps)) (define (requirement->package-name/sort deps) - (sort - (map (lambda (input) - (let ((guix-name (python->package-name input))) - (list guix-name (list 'unquote (string->symbol guix-name))))) - deps) - (lambda args - (match args - (((a _ ...) (b _ ...)) - (string-ci<? a b)))))) + (map string->symbol + (sort (map python->package-name deps) string-ci<?))) (define process-requirements (compose requirement->package-name/sort strip-argparse)) @@ -426,7 +423,7 @@ return the unaltered list of upstream dependency names." "Return the `package' s-expression for a python package with the given NAME, VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (maybe-upstream-name name) - (if (string-match ".*\\-[0-9]+" (pk name)) + (if (string-match ".*\\-[0-9]+" name) `((properties ,`'(("upstream-name" . ,name)))) '())) @@ -474,7 +471,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." ,@(maybe-inputs native-inputs 'native-inputs) (home-page ,home-page) (synopsis ,synopsis) - (description ,description) + (description ,(beautify-description description)) (license ,(license->symbol license))) upstream-dependencies)))))))) @@ -484,18 +481,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let* ((project (pypi-fetch package-name)) - (info (and project (pypi-project-info project)))) + (info (and=> project pypi-project-info)) + (version (or version (and=> project latest-version)))) (and project (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) (leave (G_ "no source release for pypi package ~a ~a~%") - (project-info-name info) - (project-info-version info))))) - (make-pypi-sexp (project-info-name info) - (project-info-version info) - (and=> (latest-source-release project) + (project-info-name info) version)))) + (make-pypi-sexp (project-info-name info) version + (and=> (source-release project version) distribution-url) - (and=> (latest-wheel-release project) + (and=> (wheel-release project version) distribution-url) (project-info-home-page info) (project-info-summary info) @@ -503,8 +499,9 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (string->license (project-info-license info))))))))) -(define (pypi-recursive-import package-name) +(define* (pypi-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package pypi->guix-package #:guix-name python->package-name)) @@ -537,12 +534,19 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (guard (c ((missing-source-error? c) #f)) (let* ((info (pypi-project-info pypi-package)) (version (project-info-version info)) - (url (distribution-url - (latest-source-release pypi-package)))) + (dist (source-release pypi-package)) + (url (distribution-url dist))) (upstream-source + (urls (list url)) + (signature-urls + (if (distribution-has-signature? dist) + (list (string-append url ".asc")) + #f)) + (input-changes + (changed-inputs package + (pypi->guix-package pypi-name))) (package (package-name package)) - (version version) - (urls (list url)))))))) + (version version))))))) (define %pypi-updater (upstream-updater diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 731e69651e..49be982a7f 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,19 +22,18 @@ (define-module (guix import stackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 control) + #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (srfi srfi-43) #:use-module (guix import json) #:use-module (guix import hackage) #:use-module (guix import utils) #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:export (%stackage-url stackage->guix-package stackage-recursive-import @@ -47,15 +47,31 @@ (define %stackage-url (make-parameter "https://www.stackage.org")) -;; Latest LTS version compatible with GHC 8.6.5. -(define %default-lts-version "14.27") +;; Latest LTS version compatible with current GHC. +(define %default-lts-version "18.14") -(define (lts-info-packages lts-info) - "Returns the alist of packages contained in LTS-INFO." - (or (assoc-ref lts-info "packages") '())) +(define-json-mapping <stackage-lts> make-stackage-lts + stackage-lts? + json->stackage-lts + (snapshot stackage-lts-snapshot "snapshot" json->snapshot) + (packages stackage-lts-packages "packages" + (lambda (vector) + (map json->stackage-package (vector->list vector))))) -(define (leave-with-message fmt . args) - (raise (condition (&message (message (apply format #f fmt args)))))) +(define-json-mapping <snapshot> make-snapshot + stackage-snapshot? + json->snapshot + (name snapshot-name) + (ghc-version snapshot-ghc-version) + (compiler snapshot-compiler)) + +(define-json-mapping <stackage-package> make-stackage-package + stackage-package? + json->stackage-package + (origin stackage-package-origin) + (name stackage-package-name) + (version stackage-package-version) + (synopsis stackage-package-synopsis)) (define stackage-lts-info-fetch ;; "Retrieve the information about the LTS Stackage release VERSION." @@ -65,21 +81,15 @@ "/lts-" (if (string-null? version) %default-lts-version version))) - (lts-info (json-fetch url))) - (if lts-info - (reverse lts-info) - (leave-with-message "LTS release version not found: ~a" version)))))) - -(define (stackage-package-name pkg-info) - (assoc-ref pkg-info "name")) - -(define (stackage-package-version pkg-info) - (assoc-ref pkg-info "version")) + (lts-info (and=> (json-fetch url) json->stackage-lts))) + (or lts-info + (raise (formatted-message (G_ "LTS release version not found: ~a") + version))))))) -(define (lts-package-version pkgs-info name) - "Return the version of the package with upstream NAME included in PKGS-INFO." +(define (lts-package-version packages name) + "Return the version of the package with upstream NAME included in PACKAGES." (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) - (vector->list pkgs-info)))) + packages))) (stackage-package-version pkg))) @@ -96,21 +106,22 @@ #:key (include-test-dependencies? #t) (lts-version %default-lts-version) - (packages-info - (lts-info-packages + (packages + (stackage-lts-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." - (let* ((version (lts-package-version packages-info package-name)) + (let* ((version (lts-package-version packages package-name)) (name-version (hackage-name-version package-name version))) (if name-version (hackage->guix-package name-version #:include-test-dependencies? include-test-dependencies?) - (leave-with-message "~a: Stackage package not found" package-name)))))) + (raise (formatted-message (G_ "~a: Stackage package not found") + package-name))))))) (define (stackage-recursive-import package-name . args) (recursive-import package-name @@ -124,43 +135,46 @@ included in the Stackage LTS release." ;;; (define latest-lts-release - (let ((pkgs-info - (mlambda () (lts-info-packages - (stackage-lts-info-fetch %default-lts-version))))) - (lambda* (package) + (let ((packages + (mlambda () + (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))))) + (lambda* (pkg) "Return an <upstream-source> for the latest Stackage LTS release of 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)) + (let* ((hackage-name (guix-package->hackage-name pkg)) + (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) (match (and=> name-version hackage-fetch) - (#f (format (current-error-port) - "warning: failed to parse ~a~%" - (hackage-cabal-url hackage-name)) - #f) + (#f + (warning (G_ "failed to parse ~a~%") + (hackage-cabal-url hackage-name)) + #f) (_ (let ((url (hackage-source-url hackage-name version))) (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (list url)))))))))) + (urls (list url)) + (input-changes + (changed-inputs + pkg + (stackage->guix-package hackage-name #:packages (packages)))))))))))) -(define (stackage-package? package) - "Whether PACKAGE is available on the default Stackage LTS release." +(define (stackage-lts-package? package) + "Return whether PACKAGE is available on the default Stackage LTS release." (and (hackage-package? package) - (let ((packages (lts-info-packages + (let ((packages (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))) (hackage-name (guix-package->hackage-name package))) - (vector-any identity - (vector-map - (lambda (_ metadata) - (string=? (cdr (list-ref metadata 2)) hackage-name)) - packages))))) + (find (lambda (package) + (string=? (stackage-package-name package) hackage-name)) + packages)))) (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") - (pred stackage-package?) + (pred stackage-lts-package?) (latest latest-lts-release))) ;;; stackage.scm ends here diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 18d8b95ee0..c741555928 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -18,19 +18,18 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import texlive) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (sxml xpath) - #:use-module (srfi srfi-11) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (web uri) - #:use-module (guix diagnostics) - #:use-module (guix i18n) - #:use-module (guix http-client) #:use-module (gcrypt hash) + #:use-module (guix derivations) #:use-module (guix memoization) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix serialization) @@ -39,24 +38,16 @@ #:use-module (guix utils) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (guix build-system texlive) - #:export (texlive->guix-package - - fetch-sxml - sxml->package)) + #:export (files-differ? + texlive->guix-package + texlive-recursive-import)) ;;; Commentary: ;;; -;;; Generate a package declaration template for the latest version of a -;;; package on CTAN, using the XML output produced by the XML API to the CTAN -;;; database at http://www.ctan.org/xml/1.2/ -;;; -;;; Instead of taking the packages from CTAN, however, we fetch the sources -;;; from the SVN repository of the Texlive project. We do this because CTAN -;;; only keeps a single version of each package whereas we can access any -;;; version via SVN. Unfortunately, this means that the importer is really -;;; just a Texlive importer, not a generic CTAN importer. +;;; Generate a package declaration template for corresponding package in the +;;; Tex Live Package Database (tlpdb). We fetch all sources from different +;;; locations in the SVN repository of the Texlive project. ;;; ;;; Code: @@ -79,6 +70,8 @@ ("bsd4" 'bsd-4) ("opl" 'opl1.0+) ("ofl" 'silofl1.1) + + ("lpplgpl" `(list lppl gpl1+)) ("lppl" 'lppl) ("lppl1" 'lppl1.0+) ; usually means "or later" ("lppl1.2" 'lppl1.2+) ; usually means "or later" @@ -107,91 +100,211 @@ ("cc-by-nc-nd-4" 'non-free) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) - (_ #f))) - -(define (fetch-sxml name) - "Return an sxml representation of the package information contained in the -XML description of the CTAN package or #f in case of failure." - ;; This API always returns the latest release of the module. - (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (xml->sxml (http-fetch url) - #:trim-whitespace? #t)))) + (x `(error unknown-license ,x)))) -(define (guix-name component name) +(define (guix-name name) "Return a Guix package name for a given Texlive package NAME." - (string-append "texlive-" component "-" + (string-append "texlive-" (string-map (match-lambda (#\_ #\-) (#\. #\-) (chr (char-downcase chr))) name))) -(define* (sxml->package sxml #:optional (component "latex")) - "Return the `package' s-expression for a Texlive package from the SXML -expression describing it." - (define (sxml-value path) - (match ((sxpath path) sxml) - (() #f) - ((val) val))) +(define (tlpdb-file) + (define texlive-bin + ;; Resolve this variable lazily so that (gnu packages ...) does not end up + ;; in the closure of this module. + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-bin)) + (with-store store - (let* ((id (sxml-value '(entry @ id *text*))) - (synopsis (sxml-value '(entry caption *text*))) - (version (or (sxml-value '(entry version @ number *text*)) - (sxml-value '(entry version @ date *text*)))) - (license (match ((sxpath '(entry license @ type *text*)) sxml) - ((license) (string->license license)) - ((lst ...) (map string->license lst)))) - (home-page (string-append "http://www.ctan.org/pkg/" id)) - (ref (texlive-ref component id)) - (checkout (download-svn-to-store store ref))) - (unless checkout - (warning (G_ "Could not determine source location. \ -Please manually specify the source field.~%"))) - `(package - (name ,(guix-name component id)) - (version ,version) - (source ,(if checkout - `(origin - (method svn-fetch) - (uri (texlive-ref ,component ,id)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file checkout port) - (force-output port) - (get-hash)))))) - #f)) - (build-system texlive-build-system) - (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,(string-trim-both - (string-join - (map string-trim-both - (string-split - (beautify-description - (sxml->string (or (sxml-value '(entry description)) - '()))) - #\newline))))) - (license ,(match license - ((lst ...) `(list ,@lst)) - (license license))))))) + (run-with-store store + (mlet* %store-monad + ((drv (lower-object texlive-bin)) + (built (built-derivations (list drv)))) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (string-append (first items) + "/share/tlpkg/texlive.tlpdb")))))))) + +(define tlpdb + (memoize + (lambda () + (let ((file (tlpdb-file)) + (fields + '((name . string) + (shortdesc . string) + (longdesc . string) + (catalogue-license . string) + (catalogue-ctan . string) + (srcfiles . list) + (runfiles . list) + (docfiles . list) + (depend . simple-list))) + (record + (lambda* (key value alist #:optional (type 'string)) + (let ((new + (or (and=> (assoc-ref alist key) + (lambda (existing) + (cond + ((eq? type 'string) + (string-append existing " " value)) + ((or (eq? type 'list) (eq? type 'simple-list)) + (cons value existing))))) + (cond + ((eq? type 'string) + value) + ((or (eq? type 'list) (eq? type 'simple-list)) + (list value)))))) + (acons key new (alist-delete key alist)))))) + (call-with-input-file file + (lambda (port) + (let loop ((all (list)) + (current (list)) + (last-property #false)) + (let ((line (read-line port))) + (cond + ((eof-object? line) all) + + ;; End of record. + ((string-null? line) + (loop (cons (cons (assoc-ref current 'name) current) + all) + (list) #false)) + + ;; Continuation of a list + ((and (zero? (string-index line #\space)) last-property) + ;; Erase optional second part of list values like + ;; "details=Readme" for files + (let ((plain-value (first + (string-split + (string-trim-both line) #\space)))) + (loop all (record last-property + plain-value + current + 'list) + last-property))) + (else + (or (and-let* ((space (string-index line #\space)) + (key (string->symbol (string-take line space))) + (value (string-drop line (1+ space))) + (field-type (assoc-ref fields key))) + ;; Erase second part of list keys like "size=29" + (cond + ((eq? field-type 'list) + (loop all current key)) + (else + (loop all (record key value current field-type) key)))) + (loop all current #false)))))))))))) + +(define* (files-differ? directory package-name + #:key + (package-database tlpdb) + (type #false) + (direction 'missing)) + "Return a list of files in DIRECTORY that differ from the expected installed +files for PACKAGE-NAME according to the PACKAGE-DATABASE. By default all +files considered, but this can be restricted by setting TYPE to 'runfiles, +'docfiles, or 'srcfiles. The names of files that are missing from DIRECTORY +are returned; by setting DIRECTION to anything other than 'missing, the names +of those files are returned that are unexpectedly installed." + (define (strip-directory-prefix file-name) + (string-drop file-name (1+ (string-length directory)))) + (let* ((data (or (assoc-ref (package-database) package-name) + (error (format #false + "~a is not a valid package name in the TeX Live package database." + package-name)))) + (files (if type + (or (assoc-ref data type) (list)) + (append (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'srcfiles) (list))))) + (existing (file-system-fold + (const #true) ;enter? + (lambda (path stat result) (cons path result)) ;leaf + (lambda (path stat result) result) ;down + (lambda (path stat result) result) ;up + (lambda (path stat result) result) ;skip + (lambda (path stat errno result) result) ;error + (list) + directory))) + (if (eq? direction 'missing) + (lset-difference string=? + files (map strip-directory-prefix existing)) + ;; List files that are installed but should not be. + (lset-difference string=? + (map strip-directory-prefix existing) files)))) + +(define (files->directories files) + (define name->parts (cut string-split <> #\/)) + (map (cut string-join <> "/" 'suffix) + (delete-duplicates (map (lambda (file) + (drop-right (name->parts file) 1)) + (sort files string<)) + ;; Remove sub-directories, i.e. more specific + ;; entries with the same prefix. + (lambda (x y) (every equal? x y))))) + +(define (tlpdb->package name package-database) + (and-let* ((data (assoc-ref package-database name)) + (dirs (files->directories + (map (lambda (dir) + (string-drop dir (string-length "texmf-dist/"))) + (append (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'srcfiles) (list)))))) + (name (guix-name name)) + (version (number->string %texlive-revision)) + (ref (svn-multi-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist")) + (locations dirs) + (revision %texlive-revision))) + (source (with-store store + (download-multi-svn-to-store + store ref (string-append name "-svn-multi-checkout"))))) + (values + `(package + (inherit (simple-texlive-package + ,name + (list ,@dirs) + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file source port) + (force-output port) + (get-hash)))) + ,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true)))) + ,@(or (and=> (assoc-ref data 'depend) + (lambda (inputs) + `((propagated-inputs + (list ,@(map (lambda (tex-name) + (let ((name (guix-name tex-name))) + (string->symbol name))) + inputs)))))) + '()) + ,@(or (and=> (assoc-ref data 'catalogue-ctan) + (lambda (url) + `((home-page ,(string-append "https://ctan.org" url))))) + '((home-page "https://www.tug.org/texlive/"))) + (synopsis ,(assoc-ref data 'shortdesc)) + (description ,(beautify-description + (assoc-ref data 'longdesc))) + (license ,(string->license + (assoc-ref data 'catalogue-license)))) + (or (assoc-ref data 'depend) (list))))) (define texlive->guix-package (memoize - (lambda* (package-name #:optional (component "latex")) - "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' + (lambda* (name #:key repo version (package-database tlpdb)) + "Find the metadata for NAME in the tlpdb and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-sxml package-name) - (cut sxml->package <> component))))) + (tlpdb->package name (package-database))))) + +(define (texlive-recursive-import name) + (recursive-import name + #:repo->guix-package texlive->guix-package + #:guix-name guix-name)) -;;; ctan.scm ends here +;;; texlive.scm ends here diff --git a/guix/import/utils.scm b/guix/import/utils.scm index a180742ca3..1c3cfa3e0b 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,7 @@ #:use-module (guix store) #:use-module (guix download) #:use-module (guix sets) + #:use-module (guix ui) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -152,6 +154,7 @@ of the string VERSION is replaced by the symbol 'version." ("CC0-1.0" 'license:cc0) ("CC-BY-2.0" 'license:cc-by2.0) ("CC-BY-3.0" 'license:cc-by3.0) + ("CC-BY-4.0" 'license:cc-by4.0) ("CC-BY-SA-2.0" 'license:cc-by-sa2.0) ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) @@ -163,6 +166,7 @@ of the string VERSION is replaced by the symbol 'version." ("EPL-1.0" 'license:epl1.0) ("MIT" 'license:expat) ("FTL" 'license:freetype) + ("Freetype" 'license:freetype) ("GFDL-1.1" 'license:fdl1.1+) ("GFDL-1.2" 'license:fdl1.2+) ("GFDL-1.3" 'license:fdl1.3+) @@ -179,6 +183,7 @@ of the string VERSION is replaced by the symbol 'version." ("GPL-3.0-only" 'license:gpl3) ("GPL-3.0+" 'license:gpl3+) ("GPL-3.0-or-later" 'license:gpl3+) + ("HPND" 'license:hpnd) ("ISC" 'license:isc) ("IJG" 'license:ijg) ("Imlib2" 'license:imlib2) @@ -231,9 +236,10 @@ to in the (guix licenses) module, or #f if there is no such known license." with dashes." (string-join (string-split (string-downcase str) #\_) "-")) -(define (beautify-description description) - "Improve the package DESCRIPTION by turning a beginning sentence fragment -into a proper sentence and by using two spaces between sentences." +(define* (beautify-description description #:optional (length 80)) + "Improve the package DESCRIPTION by turning a beginning sentence fragment into +a proper sentence and by using two spaces between sentences, and wrap lines at +LENGTH characters." (let ((cleaned (cond ((string-prefix? "A " description) (string-append "This package provides a" @@ -248,8 +254,9 @@ into a proper sentence and by using two spaces between sentences." (string-length "Functions")))) (else description)))) ;; Use double spacing between sentences - (regexp-substitute/global #f "\\. \\b" - cleaned 'pre ". " 'post))) + (fill-paragraph (regexp-substitute/global #f "\\. \\b" + cleaned 'pre ". " 'post) + length))) (define* (package-names->package-inputs names #:optional (output #f)) "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an diff --git a/guix/inferior.scm b/guix/inferior.scm index 81958baaa5..572114f626 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -785,6 +785,9 @@ determines whether CHANNELS are authenticated." (define add-indirect-root* (store-lift add-indirect-root)) + (define add-temp-root* + (store-lift add-temp-root)) + (mkdir-p cache-directory) (maybe-remove-expired-cache-entries cache-directory cache-entries @@ -805,11 +808,15 @@ determines whether CHANNELS are authenticated." ;; what's going to be built. (built-derivations (list profile)) - ;; Note: Caching is fine even when AUTHENTICATE? is false because - ;; we always call 'latest-channel-instances?'. - (symlink* (derivation->output-path profile) cached) - (add-indirect-root* cached) - (return cached)))))) + ;; Cache if and only if AUTHENTICATE? is true. + (if authenticate? + (mbegin %store-monad + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return cached)) + (mbegin %store-monad + (add-temp-root* (derivation->output-path profile)) + (return (derivation->output-path profile))))))))) (define* (inferior-for-channels channels #:key diff --git a/guix/licenses.scm b/guix/licenses.scm index c071aae4a9..82ca44f42e 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -308,6 +308,8 @@ at URI, which may be a file:// URI pointing the package's tree." "https://directory.fsf.org/wiki/License:EUPL-1.2" "https://www.gnu.org/licenses/license-list#EUPL-1.2")) +;; Some people call it the MIT license. For clarification see: +;; https://www.gnu.org/licenses/license-list.html#Expat (define expat (license "Expat" "http://directory.fsf.org/wiki/License:Expat" diff --git a/guix/lint.scm b/guix/lint.scm index 527fda165a..3ca7a0b608 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -82,6 +82,7 @@ #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-input-labels check-wrapper-inputs check-patch-file-names check-patch-headers @@ -321,6 +322,21 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f." (G_ "Texinfo markup in description is invalid") #:field 'description)))) + (define (check-description-typo description typo-corrections) + "Check that DESCRIPTION does not contain typo, with optional correction" + (append-map + (match-lambda + ((typo . correction) + (if (string-contains description typo) + (list + (make-warning package + (G_ + (format #false + "description contains typo '~a'~@[, should be '~a'~]" + typo correction)))) + '()))) + typo-corrections)) + (define (check-trademarks description) "Check that DESCRIPTION does not contain '™' or '®' characters. See http://www.gnu.org/prep/standards/html_node/Trademarks.html." @@ -401,6 +417,10 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-not-empty description) (check-quotes description) (check-trademarks description) + (check-description-typo description '(("This packages" . "This package") + ("This modules" . "This module") + ("allows to" . #f) + ("permits to" . #f))) ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) @@ -458,6 +478,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "help2man" "intltool" "itstool" + "kdoctools" "libtool" "m4" "qttools" @@ -503,6 +524,37 @@ of a package, and INPUT-NAMES, a list of package specifications such as (package-input-intersection (package-direct-inputs package) input-names)))) +(define (check-input-labels package) + "Emit a warning for labels that differ from the corresponding package name." + (define (check input-kind package-inputs) + (define (warning label name) + (make-warning package + (G_ "label '~a' does not match package name '~a'") + (list label name) + #:field input-kind)) + + (append-map (match-lambda + (((? string? label) (? package? dependency)) + (if (string=? label (package-name dependency)) + '() + (list (warning label (package-name dependency))))) + (((? string? label) (? package? dependency) output) + (let ((expected (string-append (package-name dependency) + ":" output))) + (if (string=? label expected) + '() + (list (warning label expected))))) + (_ + '())) + (package-inputs package))) + + (append-map (match-lambda + ((kind proc) + (check kind proc))) + `((native-inputs ,package-native-inputs) + (inputs ,package-inputs) + (propagated-inputs ,package-propagated-inputs)))) + (define (report-wrap-program-error package wrapper-name) "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME requires it." @@ -519,9 +571,7 @@ or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported." input-names))) (define (check-procedure-body body) (match body - ;; Explicitely setting an interpreter is acceptable, - ;; #:sh support is added on 'core-updates'. - ;; TODO(core-updates): remove mention of core-updates. + ;; Explicitely setting an interpreter is acceptable. (('wrap-program _ '#:sh . _) '()) (('wrap-program _ . _) (list (report-wrap-program-error package 'wrap-program))) @@ -938,8 +988,12 @@ patch could not be found." ;; Check whether we're reaching tar's maximum file name length. (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-2.0.0rc3-10000-1234567890/")) - (max 99)) + ;; Margin approximating the largest path that "make dist" might + ;; create, with a release candidate version, 123456 commits, and + ;; git commit hash abcde0. + (margin (string-length "guix-92.0.0rc3-123456-abcde0/")) + ;; Tested maximum patch file length for ustar format. + (max 151)) (filter-map (match-lambda ((? string? patch) (if (> (+ margin (if (string-prefix? (%distro-directory) @@ -949,7 +1003,7 @@ patch could not be found." max) (make-warning package - (G_ "~a: file name is too long") + (G_ "~a: file name is too long, which may break 'make dist'") (list (basename patch)) #:field 'patch-file-names) #f)) @@ -1556,7 +1610,7 @@ Heritage and missing from the Disarchive database") (#f '()) (id (list (make-warning package - (G_ " + (G_ "\ Disarchive entry refers to non-existent SWH directory '~a'") (list id) #:field 'source))))))) @@ -1756,6 +1810,10 @@ them for PACKAGE." (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (lint-checker + (name 'input-labels) + (description "Identify input labels that do not match package names") + (check check-input-labels)) + (lint-checker (name 'wrapper-inputs) (description "Make sure 'wrap-program' can finds its interpreter.") (check check-wrapper-inputs)) diff --git a/guix/narinfo.scm b/guix/narinfo.scm index 72e0f75fda..4fc550aa6c 100644 --- a/guix/narinfo.scm +++ b/guix/narinfo.scm @@ -144,7 +144,9 @@ must contain the original contents of a narinfo file." (map (lambda (url) (or (string->uri url) (string->uri - (string-append cache-url "/" url)))) + (if (string-suffix? "/" cache-url) + (string-append cache-url url) + (string-append cache-url "/" url))))) urls) compressions (match file-sizes diff --git a/guix/packages.scm b/guix/packages.scm index 8c3a0b0b7b..9d5b23eb8a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -23,6 +24,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix packages) + #:use-module ((guix build utils) #:select (compressor tarball? + strip-store-file-name)) #:use-module (guix utils) #:use-module (guix records) #:use-module (guix store) @@ -49,6 +52,7 @@ #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (web uri) + #:autoload (texinfo) (texi-fragment->stexi) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience @@ -107,6 +111,18 @@ deprecated-package package-field-location + this-package-input + this-package-native-input + + lookup-package-input + lookup-package-native-input + lookup-package-propagated-input + lookup-package-direct-input + + prepend ;syntactic keyword + replace ;syntactic keyword + modify-inputs + package-direct-sources package-transitive-sources package-direct-inputs @@ -153,6 +169,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-development-inputs package-closure default-guile @@ -163,6 +180,11 @@ package->cross-derivation origin->derivation)) +;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize +;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>. +;; Work around it. +(module-re-export! (current-module) '(delete) #:replace? #t) + ;;; Commentary: ;;; ;;; This module provides a high-level mechanism to define packages in a @@ -275,8 +297,8 @@ as base32. Otherwise, it must be a bytevector." (default '()) (delayed)) (snippet origin-snippet (default #f)) ; sexp or #f - (patch-flags origin-patch-flags ; list of strings - (default '("-p1"))) + (patch-flags origin-patch-flags ; string-list gexp + (default %default-patch-flags)) ;; Patching requires Guile, GNU Patch, and a few more. These two fields are ;; used to specify these dependencies when needed. @@ -324,6 +346,9 @@ specifications to 'hash'." (set-record-type-printer! <origin> print-origin) +(define %default-patch-flags + #~("-p1")) + (define (origin-actual-file-name origin) "Return the file name of ORIGIN, either its 'file-name' field or the file name of its URI." @@ -370,7 +395,7 @@ from forcing GEXP-PROMISE." ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu" - "powerpc64le-linux")) + "powerpc64le-linux" "powerpc-linux" "riscv64-linux")) (define %hurd-systems ;; The GNU/Hurd systems for which support is being developed. @@ -381,7 +406,16 @@ from forcing GEXP-PROMISE." ;; ;; XXX: MIPS is unavailable in CI: ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. - (fold delete %supported-systems '("mips64el-linux"))) + (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux"))) + +(define-inlinable (sanitize-inputs inputs) + "Sanitize INPUTS by turning it into a list of name/package tuples if it's +not already the case." + (cond ((null? inputs) inputs) + ((and (pair? (car inputs)) + (string? (caar inputs))) + inputs) + (else (map add-input-label inputs)))) (define-syntax current-location-vector (lambda (s) @@ -437,6 +471,49 @@ lexical scope of its body." (lambda (s) #,location))) body ...)))))) +(define-syntax validate-texinfo + (let ((validate? (getenv "GUIX_UNINSTALLED"))) + (define ensure-thread-safe-texinfo-parser! + ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7. + (let ((patched? (or (> (string->number (major-version)) 3) + (> (string->number (minor-version)) 0) + (> (string->number (micro-version)) 7))) + (next-token-of/thread-safe + (lambda (pred port) + (let loop ((chars '())) + (match (read-char port) + ((? eof-object?) + (list->string (reverse! chars))) + (chr + (let ((chr* (pred chr))) + (if chr* + (loop (cons chr* chars)) + (begin + (unread-char chr port) + (list->string (reverse! chars))))))))))) + (lambda () + (unless patched? + (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe) + (set! patched? #t))))) + + (lambda (s) + "Raise a syntax error when passed a literal string that is not valid +Texinfo. Otherwise, return the string." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + (if validate? + (catch 'parser-error + (lambda () + (ensure-thread-safe-texinfo-parser!) + (texi-fragment->stexi (syntax->datum #'str)) + #'str) + (lambda _ + (syntax-violation 'package "invalid Texinfo markup" #'str))) + #'str)) + ((_ obj) + #'obj))))) + ;; A package. (define-record-type* <package> package make-package @@ -450,11 +527,14 @@ lexical scope of its body." (default '()) (thunked)) (inputs package-inputs ; input packages or derivations - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (propagated-inputs package-propagated-inputs ; same, but propagated - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (native-inputs package-native-inputs ; native input packages/derivations - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (outputs package-outputs ; list of strings (default '("out"))) @@ -471,9 +551,11 @@ lexical scope of its body." (replacement package-replacement ; package | #f (default #f) (thunked) (innate)) - (synopsis package-synopsis) ; one-line description - (description package-description) ; one or two paragraphs - (license package-license) + (synopsis package-synopsis + (sanitize validate-texinfo)) ; one-line description + (description package-description + (sanitize validate-texinfo)) ; one or two paragraphs + (license package-license) ; (list of) <license> (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems)) @@ -487,6 +569,24 @@ lexical scope of its body." (default (current-definition-location)) (innate))) +(define (add-input-label input) + "Add an input label to INPUT." + (match input + ((? package? package) + (list (package-name package) package)) + (((? package? package) output) ;XXX: ugly? + (list (package-name package) package output)) + ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored? + (let ((obj (gexp-input-thing input)) + (output (gexp-input-output input))) + `(,(if (package? obj) + (package-name obj) + "_") + ,obj + ,@(if (string=? output "out") '() (list output))))) + (x + `("_" ,x)))) + (set-record-type-printer! <package> (lambda (package port) (let ((loc (package-location package)) @@ -543,6 +643,7 @@ it has in Guix." user interfaces, ignores." (package (inherit p) + (location (package-location p)) (properties `((hidden? . #t) ,@(package-properties p))))) @@ -566,12 +667,6 @@ object." (define (package-field-location package field) "Return the source code location of the definition of FIELD for PACKAGE, or #f if it could not be determined." - (define (goto port line column) - (unless (and (= (port-column port) (- column 1)) - (= (port-line port) (- line 1))) - (unless (eof-object? (read-char port)) - (goto port line column)))) - (match (package-location package) (($ <location> file line column) (match (search-path %load-path file) @@ -581,7 +676,7 @@ object." ;; In general we want to keep relative file names for modules. (call-with-input-file file-found (lambda (port) - (goto port line column) + (go-to-location port line column) (match (read port) (('package inits ...) (let ((field (assoc field inits))) @@ -604,6 +699,18 @@ object." #f))) (_ #f))) +(define-syntax-rule (this-package-input name) + "Return the input NAME of the package being defined--i.e., an input +from the ‘inputs’ or ‘propagated-inputs’ field. Native inputs are not +considered. If this input does not exist, return #f instead." + (or (lookup-package-input this-package name) + (lookup-package-propagated-input this-package name))) + +(define-syntax-rule (this-package-native-input name) + "Return the native package input NAME of the package being defined--i.e., +an input from the ‘native-inputs’ field. If this native input does not +exist, return #f instead." + (lookup-package-native-input this-package name)) ;; Error conditions. @@ -654,8 +761,12 @@ identifiers. The result is inferred from the file names of patches." (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) 'canonical-package)) (ref (lambda (module var) - (canonical - (module-ref (resolve-interface module) var))))) + ;; Make sure 'canonical-package' is not influenced by + ;; '%current-target-system' since we're going to use the + ;; native package anyway. + (parameterize ((%current-target-system #f)) + (canonical + (module-ref (resolve-interface module) var)))))) `(("tar" ,(ref '(gnu packages base) 'tar)) ("xz" ,(ref '(gnu packages compression) 'xz)) ("bzip2" ,(ref '(gnu packages compression) 'bzip2)) @@ -688,7 +799,7 @@ the build code of derivation." #:key inputs (snippet #f) - (flags '("-p1")) + (flags %default-patch-flags) (modules '()) (guile-for-build (%guile-for-build)) (system (%current-system))) @@ -712,20 +823,7 @@ specifies modules in scope when evaluating SNIPPET." ((package) package) (#f #f))))) - (define decompression-type - (cond ((string-suffix? "gz" source-file-name) "gzip") - ((string-suffix? "Z" source-file-name) "gzip") - ((string-suffix? "bz2" source-file-name) "bzip2") - ((string-suffix? "lz" source-file-name) "lzip") - ((string-suffix? "zip" source-file-name) "unzip") - (else "xz"))) - - (define original-file-name - ;; Remove the store prefix plus the slash, hash, and hyphen. - (let* ((sans (string-drop source-file-name - (+ (string-length (%store-prefix)) 1))) - (dash (string-index sans #\-))) - (string-drop sans (+ 1 dash)))) + (define original-file-name (strip-store-file-name source-file-name)) (define (numeric-extension? file-name) ;; Return true if FILE-NAME ends with digits. @@ -738,11 +836,9 @@ specifies modules in scope when evaluating SNIPPET." (define (tarxz-name file-name) ;; Return a '.tar.xz' file name based on FILE-NAME. - (let ((base (cond ((numeric-extension? file-name) - original-file-name) - ((checkout? file-name) - (string-drop-right file-name 9)) - (else (file-sans-extension file-name))))) + (let ((base (if (numeric-extension? file-name) + original-file-name + (file-sans-extension file-name)))) (string-append base (if (equal? (file-extension base) "tar") ".xz" @@ -751,22 +847,27 @@ specifies modules in scope when evaluating SNIPPET." (define instantiate-patch (match-lambda ((? string? patch) ;deprecated - (interned-file patch #:recursive? #t)) + (local-file patch #:recursive? #t)) ((? struct? patch) ;origin, local-file, etc. - (lower-object patch system)))) + patch))) - (mlet %store-monad ((tar -> (lookup-input "tar")) - (xz -> (lookup-input "xz")) - (patch -> (lookup-input "patch")) - (locales -> (lookup-input "locales")) - (decomp -> (lookup-input decompression-type)) - (patches (sequence %store-monad - (map instantiate-patch patches)))) + (let ((tar (lookup-input "tar")) + (gzip (lookup-input "gzip")) + (bzip2 (lookup-input "bzip2")) + (lzip (lookup-input "lzip")) + (xz (lookup-input "xz")) + (patch (lookup-input "patch")) + (locales (lookup-input "locales")) + (comp (and=> (compressor source-file-name) lookup-input)) + (patches (map instantiate-patch patches))) (define build (with-imported-modules '((guix build utils)) #~(begin (use-modules (ice-9 ftw) + (ice-9 match) + (ice-9 regex) (srfi srfi-1) + (srfi srfi-26) (guix build utils)) ;; The --sort option was added to GNU tar in version 1.28, released @@ -792,6 +893,29 @@ specifies modules in scope when evaluating SNIPPET." (lambda (name) (not (member name '("." ".."))))))) + (define (repack directory output) + ;; Write to OUTPUT a compressed tarball containing DIRECTORY. + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + + (apply invoke #+(file-append tar "/bin/tar") + "cvfa" output + ;; Avoid non-determinism in the archive. Set the mtime + ;; to 1 as is the case in the store (software like gzip + ;; behaves differently when it stumbles upon mtime = 0). + "--mtime=@1" + "--owner=root:0" "--group=root:0" + (if tar-supports-sort? + `("--sort=name" ,directory) + '("--no-recursion" + "--files-from=.file_list")))) + ;; Encoding/decoding errors shouldn't be silent. (fluid-set! %default-port-conversion-strategy 'error) @@ -805,77 +929,71 @@ specifies modules in scope when evaluating SNIPPET." (package-version locales))))) (setlocale LC_ALL "en_US.utf8")) - (setenv "PATH" (string-append #+xz "/bin" ":" - #+decomp "/bin")) + (setenv "PATH" + (string-append #+xz "/bin" + (if #+comp + (string-append ":" #+comp "/bin") + ""))) - ;; SOURCE may be either a directory or a tarball. - (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory)) - #+(if (string=? decompression-type "unzip") - #~(invoke "unzip" #+source) - #~(invoke (string-append #+tar "/bin/tar") - "xvf" #+source))) + (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) + ;; SOURCE may be either a directory, a tarball or a simple file. + (let ((name (strip-store-file-name #+source)) + (command (and=> #+comp (cut string-append <> "/bin/" + (compressor #+source))))) + (if (file-is-directory? #+source) + (copy-recursively #+source name) + (cond + ((tarball? #+source) + (invoke (string-append #+tar "/bin/tar") "xvf" #+source)) + ((and=> (compressor #+source) (cut string= "unzip" <>)) + ;; Note: Referring to the store unzip here (#+unzip) + ;; would introduce a cycle. + (invoke "unzip" #+source)) + (else + (copy-file #+source name) + (when command + (invoke command "--decompress" name)))))) - (for-each apply-patch '#+patches) + (let* ((file (first-file ".")) + (directory (if (file-is-directory? file) + file + "."))) + (format (current-error-port) "source is at '~a'~%" file) - (let ((result #+(if snippet - #~(let ((module (make-fresh-user-module))) - (module-use-interfaces! - module - (map resolve-interface '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module)) - #~#t))) - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ -## WARNING: the snippet returned `~s'. Return values other than #t -## are deprecated. Please migrate this package so that its snippet -## reports errors by raising an exception, and otherwise returns #t.~%" - result)) - (unless result - (error "snippet returned false"))) + (with-directory-excursion directory - (chdir "..") + (for-each apply-patch '#+patches) - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) - (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (apply invoke - (string-append #+tar "/bin/tar") - "cvfa" #$output - ;; Avoid non-determinism in the archive. Set the mtime - ;; to 1 as is the case in the store (software like gzip - ;; behaves differently when it stumbles upon mtime = 0). - "--mtime=@1" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list"))))))) + #+(if snippet + #~(let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+(if (pair? snippet) + (sexp->gexp snippet) + snippet) + #:to 'value + #:opts %auto-compilation-options + #:env module)) + #~#t)) + + ;; If SOURCE is a directory (such as a checkout), return a + ;; directory. Otherwise create a tarball. + (cond + ((file-is-directory? #+source) + (copy-recursively directory #$output + #:log (%make-void-port "w"))) + ((or #+comp (tarball? #+source)) + (repack directory #$output)) + (else ;single uncompressed file + (copy-file file #$output))))))) - (let ((name (tarxz-name original-file-name))) + (let ((name (if (or (checkout? original-file-name) + (not (compressor original-file-name))) + original-file-name + (tarxz-name original-file-name)))) (gexp->derivation name build #:graft? #f #:system system @@ -940,6 +1058,94 @@ preserved, and only duplicate propagated inputs are removed." ((input rest ...) (loop rest (cons input result) propagated first? seen))))) +(define (lookup-input inputs name) + "Lookup NAME among INPUTS, an input list." + ;; Note: Currently INPUTS is assumed to be an input list that contains input + ;; labels. In the future, input labels will be gone and this procedure will + ;; check package names. + (match (assoc-ref inputs name) + ((obj) obj) + ((obj _) obj) + (#f #f))) + +(define (lookup-package-input package name) + "Look up NAME among PACKAGE's inputs. Return it if found, #f otherwise." + (lookup-input (package-inputs package) name)) + +(define (lookup-package-native-input package name) + "Look up NAME among PACKAGE's native inputs. Return it if found, #f +otherwise." + (lookup-input (package-native-inputs package) name)) + +(define (lookup-package-propagated-input package name) + "Look up NAME among PACKAGE's propagated inputs. Return it if found, #f +otherwise." + (lookup-input (package-propagated-inputs package) name)) + +(define (lookup-package-direct-input package name) + "Look up NAME among PACKAGE's direct inputs. Return it if found, #f +otherwise." + (lookup-input (package-direct-inputs package) name)) + +(define (replace-input name replacement inputs) + "Replace input NAME by REPLACEMENT within INPUTS." + (map (lambda (input) + (match input + (((? string? label) . _) + (if (string=? label name) + (match replacement ;does REPLACEMENT specify an output? + ((_ _) (cons label replacement)) + (_ (list label replacement))) + input)))) + inputs)) + +(define-syntax prepend + (lambda (s) + (syntax-violation 'prepend + "'prepend' may only be used within 'modify-inputs'" + s))) + +(define-syntax replace + (lambda (s) + (syntax-violation 'replace + "'replace' may only be used within 'modify-inputs'" + s))) + +(define-syntax modify-inputs + (syntax-rules (delete prepend append replace) + "Modify the given package inputs, as returned by 'package-inputs' & co., +according to the given clauses. The example below removes the GMP and ACL +inputs of Coreutils and adds libcap: + + (modify-inputs (package-inputs coreutils) + (delete \"gmp\" \"acl\") + (append libcap)) + +Other types of clauses include 'prepend' and 'replace'. + +The first argument must be a labeled input list; the result is also a labeled +input list." + ;; Note: This macro hides the fact that INPUTS, as returned by + ;; 'package-inputs' & co., is actually an alist with labels. Eventually, + ;; it will operate on list of inputs without labels. + ((_ inputs (delete name) clauses ...) + (modify-inputs (alist-delete name inputs) + clauses ...)) + ((_ inputs (delete names ...) clauses ...) + (modify-inputs (fold alist-delete inputs (list names ...)) + clauses ...)) + ((_ inputs (prepend lst ...) clauses ...) + (modify-inputs (append (map add-input-label (list lst ...)) inputs) + clauses ...)) + ((_ inputs (append lst ...) clauses ...) + (modify-inputs (append inputs (map add-input-label (list lst ...))) + clauses ...)) + ((_ inputs (replace name replacement) clauses ...) + (modify-inputs (replace-input name replacement inputs) + clauses ...)) + ((_ inputs) + inputs))) + (define (package-direct-sources package) "Return all source origins associated with PACKAGE; including origins in PACKAGE's inputs." @@ -1017,23 +1223,36 @@ in INPUTS and their transitive propagated inputs." (define package-transitive-supported-systems (let () - (define supported-systems - (mlambda (package system) - (parameterize ((%current-system system)) - (fold (lambda (input systems) - (match input - ((label (? package? package) . _) - (lset-intersection string=? systems - (supported-systems package system))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package)))))) + (define (supported-systems-procedure system) + (define supported-systems + (mlambdaq (package) + (parameterize ((%current-system system)) + (fold (lambda (input systems) + (match input + ((label (? package? package) . _) + (lset-intersection string=? systems + (supported-systems package))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package)))))) + + supported-systems) + + (define procs + ;; Map system strings to one-argument procedures. This allows these + ;; procedures to have fast 'eq?' memoization on their argument. + (make-hash-table)) (lambda* (package #:optional (system (%current-system))) "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (supported-systems package system)))) + (match (hash-ref procs system) + (#f + (hash-set! procs system (supported-systems-procedure system)) + (package-transitive-supported-systems package system)) + (proc + (proc package)))))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its @@ -1070,6 +1289,15 @@ dependencies are known to build on SYSTEM." (%current-system (bag-system bag))) (transitive-inputs (bag-target-inputs bag)))) +(define* (package-development-inputs package + #:optional (system (%current-system)) + #:key target) + "Return the list of inputs required by PACKAGE for development purposes on +SYSTEM. When TARGET is true, return the inputs needed to cross-compile +PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as +\"aarch64-linux-gnu\"." + (bag-transitive-inputs (package->bag package system target))) + (define* (package-closure packages #:key (system (%current-system))) "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of packages they depend on, recursively." @@ -1262,10 +1490,6 @@ matching package and returns a replacement for that package." ;;; Package derivations. ;;; -(define %derivation-cache - ;; Package to derivation-path mapping. - (make-weak-key-hash-table 100)) - (define (cache! cache package system thunk) "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on SYSTEM." @@ -1293,56 +1517,51 @@ Return the cached result when available." (#f (cache! cache package key thunk)) (value value))) (#f - (cache! cache package key thunk))))) - ((_ package system body ...) - (cached (=> %derivation-cache) package system body ...)))) + (cache! cache package key thunk))))))) -(define* (expand-input store package input system #:optional cross-system) - "Expand INPUT, an input tuple, such that it contains only references to -derivation paths or store paths. PACKAGE is only used to provide contextual -information in exceptions." - (define (intern file) - ;; Add FILE to the store. Set the `recursive?' bit to #t, so that - ;; file permissions are preserved. - (add-to-store store (basename file) #t "sha256" file)) +(define* (expand-input package input system #:key target) + "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is +only used to provide contextual information in exceptions." + (with-monad %store-monad + (match input + ;; INPUT doesn't need to be lowered here because it'll be lowered down + ;; the road in the gexp that refers to it. However, packages need to be + ;; special-cased to pass #:graft? #f (only the "tip" of the package + ;; graph needs to have #:graft? #t). Lowering them here also allows + ;; 'bag->derivation' to delete non-eq? packages that lead to the same + ;; derivation. + (((? string? name) (? package? package)) + (mlet %store-monad ((drv (if target + (package->cross-derivation package + target system + #:graft? #f) + (package->derivation package system + #:graft? #f)))) + (return (list name (gexp-input drv #:native? (not target)))))) + (((? string? name) (? package? package) (? string? output)) + (mlet %store-monad ((drv (if target + (package->cross-derivation package + target system + #:graft? #f) + (package->derivation package system + #:graft? #f)))) + (return (list name (gexp-input drv output #:native? (not target)))))) - (define derivation - (if cross-system - (cut package-cross-derivation store <> cross-system system - #:graft? #f) - (cut package-derivation store <> system #:graft? #f))) - - (match input - (((? string? name) (? package? package)) - (list name (derivation package))) - (((? string? name) (? package? package) - (? string? sub-drv)) - (list name (derivation package) - sub-drv)) - (((? string? name) - (and (? string?) (? derivation-path?) drv)) - (list name drv)) - (((? string? name) - (and (? string?) (? file-exists? file))) - ;; Add FILE to the store. When FILE is in the sub-directory of a - ;; store path, it needs to be added anyway, so it can be used as a - ;; source. - (list name (intern file))) - (((? string? name) (? struct? source)) - ;; 'package-source-derivation' calls 'lower-object', which can throw - ;; '&gexp-input-error'. However '&gexp-input-error' lacks source - ;; location info, so we catch and rethrow here (XXX: not optimal - ;; performance-wise). - (guard (c ((gexp-input-error? c) - (raise (condition - (&package-input-error - (package package) - (input (gexp-error-invalid-input c))))))) - (list name (package-source-derivation store source system)))) - (x - (raise (condition (&package-input-error - (package package) - (input x))))))) + (((? string? name) (? file-like? thing)) + (return (list name (gexp-input thing #:native? (not target))))) + (((? string? name) (? file-like? thing) (? string? output)) + (return (list name (gexp-input thing output #:native? (not target))))) + (((? string? name) + (and (? string?) (? file-exists? file))) + ;; Add FILE to the store. When FILE is in the sub-directory of a + ;; store path, it needs to be added anyway, so it can be used as a + ;; source. + (return (list name (gexp-input (local-file file #:recursive? #t) + #:native? (not target))))) + (x + (raise (condition (&package-input-error + (package package) + (input x)))))))) (define %bag-cache ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags. @@ -1390,45 +1609,51 @@ and return it." (&package-error (package package)))))))))))) -(define %graft-cache - ;; 'eq?' cache mapping package objects to a graft corresponding to their - ;; replacement package. - (make-weak-key-hash-table 200)) - -(define (input-graft store system) - "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 (cons output system) - (let ((orig (package-derivation store package system - #:graft? #f)) - (new (package-derivation store replacement system - #:graft? #t))) - (graft - (origin orig) - (origin-output output) - (replacement new) - (replacement-output output))))))))) +(define (input-graft system) + "Return a monadic procedure that, given a package with a graft, returns a +graft, and #f otherwise." + (with-monad %store-monad + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (if replacement + ;; XXX: We should use a separate cache instead of abusing the + ;; object cache. + (mcached (mlet %store-monad ((orig (package->derivation package system + #:graft? #f)) + (new (package->derivation replacement system + #:graft? #t))) + (return (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))) + package 'graft output system) + (return #f)))) + (_ + (return #f))))) -(define (input-cross-graft store target system) +(define (input-cross-graft target system) "Same as 'input-graft', but for cross-compilation inputs." - (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)))))))) + (with-monad %store-monad + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (if replacement + (mlet %store-monad ((orig (package->cross-derivation package + target system + #:graft? #f)) + (new (package->cross-derivation replacement + target system + #:graft? #t))) + (return (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))) + (return #f)))) + (_ + (return #f))))) (define* (fold-bag-dependencies proc seed bag #:key (native? #t)) @@ -1463,7 +1688,7 @@ dependencies; otherwise, restrict to target dependencies." ((head . tail) (loop tail result visited))))) -(define* (bag-grafts store bag) +(define* (bag-grafts bag) "Return the list of grafts potentially applicable to BAG. Potentially applicable grafts are collected by looking at direct or indirect dependencies of BAG that have a 'replacement'. Whether a graft is actually applicable @@ -1472,158 +1697,199 @@ to (see 'graft-derivation'.)" (define system (bag-system bag)) (define target (bag-target bag)) - (define native-grafts - (let ((->graft (input-graft store system))) - (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))) + (mlet %store-monad + ((native-grafts + (let ((->graft (input-graft system))) (parameterize ((%current-system system) - (%current-target-system target)) + (%current-target-system #f)) (fold-bag-dependencies (lambda (package output grafts) - (match (->graft package output) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag - #:native? #f))) - '())) + (mlet %store-monad ((grafts grafts)) + (>>= (->graft package output) + (match-lambda + (#f (return grafts)) + (graft (return (cons graft grafts))))))) + (return '()) + bag)))) - ;; We can end up with several identical grafts if we stumble upon packages - ;; that are not 'eq?' but map to the same derivation (this can happen when - ;; using things like 'package-with-explicit-inputs'.) Hence the - ;; 'delete-duplicates' call. - (delete-duplicates - (append native-grafts target-grafts))) + (target-grafts + (if target + (let ((->graft (input-cross-graft target system))) + (parameterize ((%current-system system) + (%current-target-system target)) + (fold-bag-dependencies + (lambda (package output grafts) + (mlet %store-monad ((grafts grafts)) + (>>= (->graft package output) + (match-lambda + (#f (return grafts)) + (graft (return (cons graft grafts))))))) + (return '()) + bag + #:native? #f))) + (return '())))) -(define* (package-grafts store package - #:optional (system (%current-system)) - #:key target) + ;; We can end up with several identical grafts if we stumble upon packages + ;; that are not 'eq?' but map to the same derivation (this can happen when + ;; using things like 'package-with-explicit-inputs'.) Hence the + ;; 'delete-duplicates' call. + (return (delete-duplicates + (append native-grafts target-grafts))))) + +(define* (package-grafts* package + #:optional (system (%current-system)) + #:key target) "Return the list of grafts applicable to PACKAGE as built for SYSTEM and TARGET." (let* ((package (or (package-replacement package) package)) (bag (package->bag package system target))) - (bag-grafts store bag))) + (bag-grafts bag))) + +(define package-grafts + (store-lower package-grafts*)) -(define* (bag->derivation store bag - #:optional context) +(define-inlinable (derivation=? drv1 drv2) + "Return true if DRV1 and DRV2 are equal." + (or (eq? drv1 drv2) + (string=? (derivation-file-name drv1) + (derivation-file-name drv2)))) + +(define (input=? input1 input2) + "Return true if INPUT1 and INPUT2 are equivalent." + (match input1 + ((label1 obj1 . outputs1) + (match input2 + ((label2 obj2 . outputs2) + (and (string=? label1 label2) + (equal? outputs1 outputs2) + (or (and (derivation? obj1) (derivation? obj2) + (derivation=? obj1 obj2)) + (equal? obj1 obj2)))))))) + +(define* (bag->derivation bag #:optional context) "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be a package object describing the context in which the call occurs, for improved error reporting." (if (bag-target bag) - (bag->cross-derivation store bag) - (let* ((system (bag-system bag)) - (inputs (bag-transitive-inputs bag)) - (input-drvs (map (cut expand-input store context <> system) - inputs)) - (paths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-native-search-paths - p)) - (_ '())) - inputs)))) - - (apply (bag-build bag) - store (bag-name bag) input-drvs + (bag->cross-derivation bag) + (mlet* %store-monad ((system -> (bag-system bag)) + (inputs -> (bag-transitive-inputs bag)) + (input-drvs (mapm %store-monad + (cut expand-input context <> system) + inputs)) + (paths -> (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + inputs)))) + ;; It's possible that INPUTS contains packages that are not 'eq?' but + ;; that lead to the same derivation. Delete those duplicates to avoid + ;; issues down the road, such as duplicate entries in '%build-inputs'. + (apply (bag-build bag) (bag-name bag) + (delete-duplicates input-drvs input=?) #:search-paths paths #:outputs (bag-outputs bag) #:system system (bag-arguments bag))))) -(define* (bag->cross-derivation store bag - #:optional context) +(define* (bag->cross-derivation bag #:optional context) "Return the derivation to build BAG, which is actually a cross build. Optionally, CONTEXT can be a package object denoting the context of the call. This is an internal procedure." - (let* ((system (bag-system bag)) - (target (bag-target bag)) - (host (bag-transitive-host-inputs bag)) - (host-drvs (map (cut expand-input store context <> system target) - host)) - (target* (bag-transitive-target-inputs bag)) - (target-drvs (map (cut expand-input store context <> system) - target*)) - (build (bag-transitive-build-inputs bag)) - (build-drvs (map (cut expand-input store context <> system) - build)) - (all (append build target* host)) - (paths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-search-paths p)) - (_ '())) - all))) - (npaths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-native-search-paths - p)) - (_ '())) - all)))) + (mlet* %store-monad ((system -> (bag-system bag)) + (target -> (bag-target bag)) + (host -> (bag-transitive-host-inputs bag)) + (host-drvs (mapm %store-monad + (cut expand-input context <> + system #:target target) + host)) + (target* -> (bag-transitive-target-inputs bag)) + (target-drvs (mapm %store-monad + (cut expand-input context <> system) + target*)) + (build -> (bag-transitive-build-inputs bag)) + (build-drvs (mapm %store-monad + (cut expand-input context <> system) + build)) + (all -> (append build target* host)) + (paths -> (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-search-paths p)) + (_ '())) + all))) + (npaths -> (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + all)))) - (apply (bag-build bag) - store (bag-name bag) - #:native-drvs build-drvs - #:target-drvs (append host-drvs target-drvs) + (apply (bag-build bag) (bag-name bag) + #:build-inputs (delete-duplicates build-drvs input=?) + #:host-inputs (delete-duplicates host-drvs input=?) + #:target-inputs (delete-duplicates target-drvs input=?) #:search-paths paths #:native-search-paths npaths #:outputs (bag-outputs bag) #:system system #:target target (bag-arguments bag)))) -(define* (package-derivation store package - #:optional (system (%current-system)) - #:key (graft? (%graft?))) +(define bag->derivation* + (store-lower bag->derivation)) + +(define graft-derivation* + (store-lift graft-derivation)) + +(define* (package->derivation package + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Return the <derivation> object of PACKAGE for SYSTEM." ;; Compute the derivation and cache the result. Caching is important ;; because some derivations, such as the implicit inputs of the GNU build ;; system, will be queried many, many times in a row. - (cached package (cons system graft?) - (let* ((bag (package->bag package system #f #:graft? graft?)) - (drv (bag->derivation store bag package))) - (if graft? - (match (bag-grafts store bag) - (() - drv) - (grafts - (let ((guile (package-derivation store (guile-for-grafts) - system #:graft? #f))) - ;; TODO: As an optimization, we can simply graft the tip - ;; of the derivation graph since 'graft-derivation' - ;; recurses anyway. - (graft-derivation store drv grafts - #:system system - #:guile guile)))) - drv)))) + (mcached (mlet* %store-monad ((bag -> (package->bag package system #f + #:graft? graft?)) + (drv (bag->derivation bag package))) + (if graft? + (>>= (bag-grafts bag) + (match-lambda + (() + (return drv)) + (grafts + (mlet %store-monad ((guile (package->derivation + (guile-for-grafts) + system #:graft? #f))) + (graft-derivation* drv grafts + #:system system + #:guile guile))))) + (return drv))) + package system #f graft?)) -(define* (package-cross-derivation store package target - #:optional (system (%current-system)) - #:key (graft? (%graft?))) +(define* (package->cross-derivation package target + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix system identifying string)." - (cached package (list system target graft?) - (let* ((bag (package->bag package system target #:graft? graft?)) - (drv (bag->derivation store bag package))) - (if graft? - (match (bag-grafts store bag) - (() - drv) - (grafts - (graft-derivation store drv grafts - #:system system - #:guile - (package-derivation store (guile-for-grafts) - system #:graft? #f)))) - drv)))) + (mcached (mlet* %store-monad ((bag -> (package->bag package system target + #:graft? graft?)) + (drv (bag->derivation bag package))) + (if graft? + (>>= (bag-grafts bag) + (match-lambda + (() + (return drv)) + (grafts + (mlet %store-monad ((guile (package->derivation + (guile-for-grafts) + system #:graft? #f))) + (graft-derivation* drv grafts + #:system system + #:guile guile))))) + (return drv))) + package system target graft?)) (define* (package-output store package #:optional (output "out") (system (%current-system))) @@ -1671,11 +1937,11 @@ unless you know what you are doing." out) store)))) -(define package->derivation - (store-lift package-derivation)) +(define package-derivation + (store-lower package->derivation)) -(define package->cross-derivation - (store-lift package-cross-derivation)) +(define package-cross-derivation + (store-lower package->cross-derivation)) (define-gexp-compiler (package-compiler (package <package>) system target) ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for @@ -1695,7 +1961,7 @@ unless you know what you are doing." (content-hash-value hash) name #:system system)) (($ <origin> uri method hash name (= force (patches ...)) snippet - (flags ...) inputs (modules ...) guile-for-build) + flags inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. (mlet %store-monad ((source (method uri (content-hash-algorithm hash) diff --git a/guix/profiles.scm b/guix/profiles.scm index 2486f91d09..1d354ecb78 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016, 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> -;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> @@ -124,6 +124,7 @@ profile-manifest package->manifest-entry + package->development-manifest packages->manifest ca-certificate-bundle %default-profile-hooks @@ -400,6 +401,24 @@ file name." (properties properties)))) entry)) +(define* (package->development-manifest package + #:optional + (system (%current-system)) + #:key target) + "Return a manifest for the \"development inputs\" of PACKAGE for SYSTEM, +optionally when cross-compiling to TARGET. Development inputs include both +explicit and implicit inputs of PACKAGE." + (manifest + (filter-map (match-lambda + ((label (? package? package)) + (package->manifest-entry package)) + ((label (? package? package) output) + (package->manifest-entry package output)) + ;; TODO: Support <inferior-package>. + (_ + #f)) + (package-development-inputs package system #:target target)))) + (define (packages->manifest packages) "Return a list of manifest entries, one for each item listed in PACKAGES. Elements of PACKAGES can be either package objects or package/string tuples @@ -1161,6 +1180,52 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." `((type . profile-hook) (hook . emacs-subdirs)))) +(define (gdk-pixbuf-loaders-cache-file manifest) + "Return a derivation that produces a loaders cache file for every gdk-pixbuf +loaders discovered in MANIFEST." + (define gdk-pixbuf ;lazy reference + (module-ref (resolve-interface '(gnu packages gtk)) 'gdk-pixbuf)) + + (mlet* %store-monad + ((gdk-pixbuf (manifest-lookup-package manifest "gdk-pixbuf")) + (librsvg (manifest-lookup-package manifest "librsvg")) + (gdk-pixbuf-bin -> (if (string? gdk-pixbuf) + (string-append gdk-pixbuf "/bin") + (file-append gdk-pixbuf "/bin")))) + + (define build + (with-imported-modules (source-module-closure + '((guix build glib-or-gtk-build-system))) + #~(begin + (use-modules (guix build glib-or-gtk-build-system)) + (setenv "PATH" (string-append #$gdk-pixbuf-bin ":" (getenv "PATH"))) + + (generate-gdk-pixbuf-loaders-cache + ;; XXX: MANIFEST-LOOKUP-PACKAGE transitively searches through + ;; every input referenced by the manifest, while MANIFEST-INPUTS + ;; only retrieves the immediate inputs as well as their + ;; propagated inputs; to avoid causing an empty output derivation + ;; we must ensure that the inputs contain at least one + ;; loaders.cache file. This is why we include gdk-pixbuf or + ;; librsvg when they are transitively found. + (list #$@(if gdk-pixbuf + (list gdk-pixbuf) + '()) + #$@(if librsvg + (list librsvg) + '()) + #$@(manifest-inputs manifest)) + (list #$output))))) + + (if gdk-pixbuf + (gexp->derivation "gdk-pixbuf-loaders-cache-file" build + #:local-build? #t + #:substitutable? #f + #:properties + '((type . profile-hook) + (hook . gdk-pixbuf-loaders-cache-file))) + (return #f)))) + (define (glib-schemas manifest) "Return a derivation that unions all schemas from manifest entries and creates the Glib 'gschemas.compiled' file." @@ -1663,6 +1728,16 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (manual-database/optional manifest) + "Return a derivation to build the manual database of MANIFEST, but only if +MANIFEST contains the \"man-db\" package. Otherwise, return #f." + ;; Building the man database (for "man -k") is expensive and rarely used. + ;; Build it only if the profile also contains "man-db". + (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) + (if man-db + (manual-database manifest) + (return #f)))) + (define (texlive-configuration manifest) "Return a derivation that builds a TeXlive configuration for the entries in MANIFEST." @@ -1765,15 +1840,15 @@ MANIFEST." ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file - manual-database + manual-database/optional fonts-dir-file ghc-package-cache-file ca-certificate-bundle emacs-subdirs + gdk-pixbuf-loaders-cache-file glib-schemas gtk-icon-themes gtk-im-modules - texlive-configuration xdg-desktop-database xdg-mime-database)) diff --git a/guix/progress.scm b/guix/progress.scm index 0cbc804ec1..4f8e98edc0 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -270,19 +270,25 @@ ABBREVIATION used to shorten FILE for display." tasks is performed. Write PREFIX at the beginning of the line." (define done 0) + (define (draw-bar) + (let* ((ratio (* 100. (/ done total)))) + (erase-current-line port) + (if (string-null? prefix) + (display (progress-bar ratio (current-terminal-columns)) port) + (let ((width (- (current-terminal-columns) + (string-length prefix) 3))) + (display prefix port) + (display " " port) + (display (progress-bar ratio width) port))) + (force-output port))) + + (define draw-bar/rate-limited + (rate-limited draw-bar %progress-interval)) + (define (report-progress) (set! done (+ 1 done)) (unless (> done total) - (let* ((ratio (* 100. (/ done total)))) - (erase-current-line port) - (if (string-null? prefix) - (display (progress-bar ratio (current-terminal-columns)) port) - (let ((width (- (current-terminal-columns) - (string-length prefix) 3))) - (display prefix port) - (display " " port) - (display (progress-bar ratio width) port))) - (force-output port)))) + (draw-bar/rate-limited))) (progress-reporter (start (lambda () diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 69c2781abb..c29d5105ae 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -35,10 +35,10 @@ #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -196,65 +196,68 @@ taken since we do not import the archives." (define (port-sha256* port size) ;; Like 'port-sha256', but limited to SIZE bytes. - (let-values (((out get) (open-sha256-port))) + (let ((out get (open-sha256-port))) (dump-port* port out size) (close-port out) (get))) (define (archive-contents port) - "Return a list representing the files contained in the nar read from PORT." - (fold-archive (lambda (file type contents result) - (match type - ((or 'regular 'executable) - (match contents - ((port . size) - (cons `(,file ,type ,(port-sha256* port size)) - result)))) - ('directory result) - ('directory-complete result) - ('symlink - (cons `(,file ,type ,contents) result)))) - '() - port - "")) + "Return a list representing the files contained in the nar read from PORT. +The list is sorted in canonical order--i.e., the order in which entries appear +in the nar." + (reverse + (fold-archive (lambda (file type contents result) + (match type + ((or 'regular 'executable) + (match contents + ((port . size) + (cons `(,file ,type ,(port-sha256* port size)) + result)))) + ('directory result) + ('directory-complete result) + ('symlink + (cons `(,file ,type ,contents) result)))) + '() + port + ""))) (define (store-item-contents item) "Return a list of files and contents for ITEM in the same format as 'archive-contents'." - (file-system-fold (const #t) ;enter? - (lambda (file stat result) ;leaf - (define short - (string-drop file (string-length item))) + (let loop ((file item)) + (define stat + (lstat file)) - (match (stat:type stat) - ('regular - (let ((size (stat:size stat)) - (type (if (zero? (logand (stat:mode stat) - #o100)) - 'regular - 'executable))) - (cons `(,short ,type - ,(call-with-input-file file - (cut port-sha256* <> size))) - result))) - ('symlink - (cons `(,short symlink ,(readlink file)) - result)))) - (lambda (directory stat result) result) ;down - (lambda (directory stat result) result) ;up - (lambda (file stat result) result) ;skip - (lambda (file stat errno result) result) ;error - '() - item - lstat)) + (define short + (string-drop file (string-length item))) + + (match (stat:type stat) + ('regular + (let ((size (stat:size stat)) + (type (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable))) + `((,short ,type + ,(call-with-input-file file + (cut port-sha256* <> size)))))) + ('symlink + `((,short symlink ,(readlink file)))) + ('directory + (append-map (match-lambda + ((or "." "..") + '()) + (entry + (loop (string-append file "/" entry)))) + ;; Traverse entries in canonical order, the same as the + ;; order of entries in nars. + (scandir file (const #t) string<?)))))) (define (call-with-nar narinfo proc) "Call PROC with an input port from which it can read the nar pointed to by NARINFO." - (let*-values (((uri compression size) - (narinfo-best-uri narinfo)) - ((port actual-size) - (http-fetch uri))) + (let* ((uri compression size (narinfo-best-uri narinfo)) + (port actual-size (http-fetch uri))) (define reporter (progress-reporter/file (narinfo-path narinfo) (and size diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6958bd6238..ec071402f4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -34,23 +34,33 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) - #:use-module (gnu build linux-container) - #:use-module (gnu build accounts) - #:use-module ((guix build syscalls) #:select (set-network-interface-up)) - #:use-module (gnu system linux-container) + #:autoload (ice-9 ftw) (scandir) + #:autoload (gnu build linux-container) (call-with-container %namespaces + user-namespace-supported? + unprivileged-user-namespace-supported? + setgroups-supported?) + #:autoload (gnu build accounts) (password-entry group-entry + password-entry-name password-entry-directory + write-passwd write-group) + #:autoload (guix build syscalls) (set-network-interface-up openpty login-tty) #:use-module (gnu system file-systems) - #:use-module (gnu packages) - #:use-module (gnu packages bash) - #:use-module ((gnu packages bootstrap) - #:select (bootstrap-executable %bootstrap-guile)) + #:autoload (gnu packages) (specification->package+output) + #:autoload (gnu packages bash) (bash) + #:autoload (gnu packages bootstrap) (bootstrap-executable %bootstrap-guile) #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-98) #:export (assert-container-features - guix-environment)) + guix-environment + guix-environment* + show-environment-options-help + (%options . %environment-options) + (%default-options . %environment-default-options))) (define %default-shell (or (getenv "SHELL") "/bin/sh")) @@ -66,41 +76,18 @@ do not augment existing environment variables with additional search paths." (newline))) (profile-search-paths profile manifest))) -(define (input->manifest-entry input) - "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a -package." - (match input - ((_ (? package? package)) - (package->manifest-entry package)) - ((_ (? package? package) output) - (package->manifest-entry package output)) - (_ - #f))) - -(define (package-environment-inputs package) - "Return a list of manifest entries corresponding to the transitive input -packages for PACKAGE." - ;; Remove non-package inputs such as origin records. - (filter-map input->manifest-entry - (bag-transitive-inputs (package->bag package)))) - -(define (show-help) - (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] -Build an environment that includes the dependencies of PACKAGE and execute -COMMAND or an interactive shell in that environment.\n")) +(define (show-environment-options-help) + "Print help about options shared between 'guix environment' and 'guix +shell'." (display (G_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) (display (G_ " - -l, --load=FILE create environment for the package that the code within - FILE evaluates to")) - (display (G_ " -m, --manifest=FILE create environment with the manifest from FILE")) (display (G_ " -p, --profile=PATH create environment from profile at PATH")) (display (G_ " - --ad-hoc include all specified packages in the environment instead - of only their inputs")) + --check check if the shell clobbers environment variables")) (display (G_ " --pure unset existing environment variables")) (display (G_ " @@ -136,7 +123,24 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " - --bootstrap use bootstrap binaries to build the environment")) + --bootstrap use bootstrap binaries to build the environment"))) + +(define (show-help) + (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] +Build an environment that includes the dependencies of PACKAGE and execute +COMMAND or an interactive shell in that environment.\n")) + (warning (G_ "This command is deprecated in favor of 'guix shell'.\n")) + (newline) + + ;; These two options are left out in 'guix shell'. + (display (G_ " + -l, --load=FILE create environment for the package that the code within + FILE evaluates to")) + (display (G_ " + --ad-hoc include all specified packages in the environment instead + of only their inputs")) + + (show-environment-options-help) (newline) (show-build-options-help) (newline) @@ -179,6 +183,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix environment"))) + (option '("check") #f #f + (lambda (opt name arg result) + (alist-cons 'check? #t result))) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) @@ -297,11 +304,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -313,8 +320,9 @@ for the corresponding packages." (specification->package+output spec))) (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) - (package-environment-inputs - (transform (specification->package+output spec)))) + (manifest-entries + (package->development-manifest + (transform (specification->package+output spec))))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) @@ -394,7 +402,193 @@ regexps in WHITE-LIST." (match command ((program . args) - (apply execlp program program args)))) + (catch 'system-error + (lambda () + (apply execlp program program args)) + (lambda _ + ;; Following established convention, exit with 127 upon ENOENT. + (primitive-_exit 127)))))) + +(define (child-shell-environment shell profile manifest) + "Create a child process, load PROFILE and MANIFEST, and then run SHELL in +interactive mode in it. Return a name/value vhash for all the variables shown +by running 'set' in the shell." + (define-values (controller inferior) + (openpty)) + + (define script + ;; Script to obtain the list of environment variable values. On a POSIX + ;; shell we can rely on 'set', but on fish we have to use 'env' (fish's + ;; 'set' truncates values and prints them in a different format.) + "env || /usr/bin/env || set; echo GUIX-CHECK-DONE; read x; exit\n") + + (define lines + (match (primitive-fork) + (0 + (catch #t + (lambda () + (load-profile profile manifest #:pure? #t) + (setenv "GUIX_ENVIRONMENT" profile) + (close-fdes controller) + (login-tty inferior) + (execl shell shell)) + (lambda _ + (primitive-exit 127)))) + (pid + (close-fdes inferior) + (let* ((port (fdopen controller "r+l")) + (result (begin + (display script port) + (let loop ((lines '())) + (match (read-line port) + ((? eof-object?) (reverse lines)) + ("GUIX-CHECK-DONE\r" + (display "done\n" port) + (reverse lines)) + (line + ;; Drop the '\r' from LINE. + (loop (cons (string-drop-right line 1) + lines)))))))) + (close-port port) + (waitpid pid) + result)))) + + (fold (lambda (line table) + ;; Note: 'set' in fish outputs "NAME VALUE" instead of "NAME=VALUE" + ;; but it also truncates values anyway, so don't try to support it. + (let ((index (string-index line #\=))) + (if index + (vhash-cons (string-take line index) + (string-drop line (+ 1 index)) + table) + table))) + vlist-null + lines)) + +(define* (validate-child-shell-environment profile manifest + #:optional (shell %default-shell)) + "Run SHELL in interactive mode in an environment for PROFILE and MANIFEST +and report clobbered environment variables." + (define warned? #f) + (define-syntax-rule (warn exp ...) + (begin + (set! warned? #t) + (warning exp ...))) + + (info (G_ "checking the environment variables visible from shell '~a'...~%") + shell) + (let ((actual (child-shell-environment shell profile manifest))) + (when (vlist-null? actual) + (leave (G_ "failed to determine environment of shell '~a'~%") + shell)) + (for-each (match-lambda + ((spec . expected) + (let ((name (search-path-specification-variable spec))) + (match (vhash-assoc name actual) + (#f + (warn (G_ "variable '~a' is missing from shell \ +environment~%") + name)) + ((_ . actual) + (cond ((string=? expected actual) + #t) + ((string-prefix? expected actual) + (warn (G_ "variable '~a' has unexpected \ +suffix '~a'~%") + name + (string-drop actual + (string-length expected)))) + (else + (warn (G_ "variable '~a' is clobbered: '~a'~%") + name actual)))))))) + (profile-search-paths profile manifest)) + + ;; Special case. + (match (vhash-assoc "GUIX_ENVIRONMENT" actual) + (#f + (warn (G_ "'GUIX_ENVIRONMENT' is missing from the shell \ +environment~%"))) + ((_ . value) + (unless (string=? value profile) + (warn (G_ "'GUIX_ENVIRONMENT' is set to '~a' instead of '~a'~%") + value profile)))) + + ;; Check the prompt unless we have more important warnings. + (unless warned? + (match (vhash-assoc "PS1" actual) + (#f #f) + ((_ . str) + (when (and (getenv "PS1") (string=? str (getenv "PS1"))) + (warning (G_ "'PS1' is the same in sub-shell~%")) + (display-hint (G_ "Consider setting a different prompt for +environment shells to make them distinguishable. + +If you are using Bash, you can do that by adding these lines to +@file{~/.bashrc}: + +@example +if [ -n \"$GUIX_ENVIRONMENT\" ] +then + export PS1=\"\\u@@\\h \\w [env]\\$ \" +fi +@end example +")))))) + + (if warned? + (begin + (display-hint (G_ "One or more environment variables have a +different value in the shell than the one we set. This means that you may +find yourself running code in an environment different from the one you asked +Guix to prepare. + +This usually indicates that your shell startup files are unexpectedly +modifying those environment variables. For example, if you are using Bash, +make sure that environment variables are set or modified in +@file{~/.bash_profile} and @emph{not} in @file{~/.bashrc}. For more +information on Bash startup files, run: + +@example +info \"(bash) Bash Startup Files\" +@end example + +Alternatively, you can avoid the problem by passing the @option{--container} +or @option{-C} option. That will give you a fully isolated environment +running in a \"container\", immune to the issue described above.")) + (exit 1)) + (info (G_ "All is good! The shell gets correct environment \ +variables.~%"))))) + +(define (suggest-command-name profile command) + "COMMAND was not found in PROFILE so display a hint suggesting the closest +command name." + (define not-dot? + (match-lambda + ((or "." "..") #f) + (_ #t))) + + (match (scandir (string-append profile "/bin") not-dot?) + ((or #f ()) #f) + (available + (match command + ((executable _ ...) + ;; Look for a suggestion with a high threshold: a suggestion is + ;; usually better than no suggestion. + (let ((closest (string-closest executable available + #:threshold 12))) + (unless (or (not closest) (string=? closest executable)) + (display-hint (format #f (G_ "Did you mean '~a'?~%") + closest))))))))) + +(define (validate-exit-status profile command status) + "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command +not found\" error. Otherwise return STATUS." + ;; Most likely, exit value 127 means ENOENT. + (when (eqv? (status:exit-val status) 127) + (report-error (G_ "~a: command not found~%") + (first command)) + (suggest-command-name profile command) + (exit 1)) + status) (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) @@ -407,7 +601,8 @@ regexps in WHITE-LIST." #:pure? pure? #:white-list white-list)) (pid (match (waitpid pid) - ((_ . status) status))))) + ((_ . status) + (validate-exit-status profile command status)))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -428,6 +623,9 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + (define (exit/status* status) + (exit/status (validate-exit-status profile command status))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -484,7 +682,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status + (exit/status* (call-with-container file-systems (lambda () ;; Setup global shell. @@ -666,11 +864,15 @@ message if any test fails." (define-command (guix-environment . args) (category development) - (synopsis "spawn one-off software environments") + (synopsis "spawn one-off software environments (deprecated)") + (guix-environment* (parse-args args))) + +(define (guix-environment* opts) + "Run the 'guix environment' command on OPTS, an alist resulting for +command-line option processing with 'parse-command-line'." (with-error-handling - (let* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) + (let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) @@ -690,6 +892,26 @@ message if any test fails." (mappings (pick-all opts 'file-system-mapping)) (white-list (pick-all opts 'inherit-regexp))) + (define store-needed? + ;; Whether connecting to the daemon is needed. + (or container? (not profile))) + + (define-syntax-rule (with-store/maybe store exp ...) + ;; Evaluate EXP... with STORE bound to a connection, unless + ;; STORE-NEEDED? is false, in which case STORE is bound to #f. + (let ((proc (lambda (store) exp ...))) + (if store-needed? + (with-store s + (set-build-options-from-command-line s opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (proc s))) + (proc #f)))) + (when container? (assert-container-features)) (when (and (not container?) link-prof?) @@ -700,85 +922,92 @@ message if any test fails." (leave (G_ "--no-cwd cannot be used without --container~%"))) - (with-store store - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest-from-opts - (options/resolve-packages store opts)) + (with-store/maybe store + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest-from-opts + (options/resolve-packages store opts)) - (define manifest - (if profile - (profile-manifest profile) - manifest-from-opts)) + (define manifest + (if profile + (profile-manifest profile) + manifest-from-opts)) - (when (and profile - (> (length (manifest-entries manifest-from-opts)) 0)) - (leave (G_ "'--profile' cannot be used with package options~%"))) + (when (and profile + (> (length (manifest-entries manifest-from-opts)) 0)) + (leave (G_ "'--profile' cannot be used with package options~%"))) - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; creating an empty environment~%"))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (default-guile))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (if profile + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (and store-needed? + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (default-guile)))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (if profile + (return #f) + (manifest->derivation + manifest system bootstrap?))) + (profile -> (if profile (readlink* profile) (derivation->output-path prof-drv))) - (gc-root -> (assoc-ref opts 'gc-root))) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (mwhen store-needed? + (built-derivations (append + (if prof-drv (list prof-drv) '()) + (if (derivation? bash) (list bash) '())))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (mwhen (assoc-ref opts 'check?) + (return + (if container? + (warning (G_ "'--check' is unnecessary \ +when using '--container'; doing nothing~%")) + (validate-child-shell-environment profile manifest)))) - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (built-derivations (if (derivation? bash) - (list prof-drv bash) - (list prof-drv))) - (mwhen gc-root - (register-gc-root profile gc-root)) + (cond + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + (derivation->output-path bash) + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:white-list white-list + #:link-profile? link-prof? + #:network? network? + #:map-cwd? (not no-cwd?)))) - (cond - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - (derivation->output-path bash) - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:white-list white-list - #:link-profile? link-prof? - #:network? network? - #:map-cwd? (not no-cwd?)))) + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?)))))))))))))) - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:white-list white-list - #:pure? pure?))))))))))))))) +;;; Local Variables: +;;; eval: (put 'with-store/maybe 'scheme-indent-function 1) +;;; End: diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 439fae0b52..8943e87099 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -542,7 +542,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " --list-types list the available graph types")) (display (G_ " - --max-depth=DEPTH limit to nodes within distance DEPTH")) + -M, --max-depth=DEPTH limit to nodes within distance DEPTH")) (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index b8622373cc..4e792c6a03 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,8 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2014, 2016-2017, 2020-2022 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> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +25,7 @@ #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (guix ui) + #:use-module (guix hash) #:use-module (guix scripts) #:use-module (guix base16) #:use-module (guix base32) @@ -34,17 +37,47 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:autoload (disarchive git-hash) (git-hash-file git-hash-directory) #:export (guix-hash)) ;;; +;;; Serializers +;;; + +(define* (nar-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (file-hash* file #:algorithm algorithm #:select? select? #:recursive? #true)) + +(define* (default-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (match file + ("-" (port-hash algorithm (current-input-port))) + (_ (file-hash* file #:algorithm algorithm #:recursive? #false)))) + +(define* (git-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (define directory? + (case (stat:type (stat file)) + ((directory) #t) + (else #f))) + (if directory? + (git-hash-directory file algorithm #:select? select?) + (git-hash-file file algorithm))) + + +;;; ;;; Command-line options. ;;; (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) - (hash-algorithm . ,(hash-algorithm sha256)))) + (hash-algorithm . ,(hash-algorithm sha256)) + (serializer . ,default-hash))) (define (show-help) (display (G_ "Usage: guix hash [OPTION] FILE @@ -60,7 +93,7 @@ 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_ " - -r, --recursive compute the hash on FILE recursively")) + -S, --serializer=TYPE compute the hash on FILE according to TYPE serialization")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -101,7 +134,27 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-delete 'format result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) - (alist-cons 'recursive? #t result))) + (unless (eqv? name #\r) + (warning (G_ "'--recursive' is deprecated, \ +use '--serializer=nar' instead~%"))) + (alist-cons 'serializer nar-hash + (alist-delete 'serializer result)))) + (option '(#\S "serializer") #t #f + (lambda (opt name arg result) + (define serializer-proc + (match arg + ("none" + default-hash) + ("nar" + nar-hash) + ("git" + git-hash) + (x + (leave (G_ "unsupported serializer type: ~a~%") + arg)))) + + (alist-cons 'serializer serializer-proc + (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -125,16 +178,6 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (parse-command-line args %options (list %default-options) #:build-options? #f)) - (define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -144,32 +187,29 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (fmt (assq-ref opts 'format)) (select? (if (assq-ref opts 'exclude-vcs?) (negate vcs-file?) - (const #t)))) + (const #t))) + (algorithm (assoc-ref opts 'hash-algorithm)) + (serializer (assoc-ref opts 'serializer))) (define (file-hash file) ;; Compute the hash of FILE. - ;; Catch and gracefully report possible '&nar-error' conditions. - (with-error-handling - (if (assoc-ref opts 'recursive?) - (let-values (((port get-hash) - (open-hash-port (assoc-ref opts 'hash-algorithm)))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (match file - ("-" (port-hash (assoc-ref opts 'hash-algorithm) - (current-input-port))) - (_ (call-with-input-file file - (cute port-hash (assoc-ref opts 'hash-algorithm) - <>))))))) + ;; Catch and gracefully report possible error + (catch 'system-error + (lambda _ + (with-error-handling + (serializer file algorithm select?))) + (lambda args + (leave (G_ "~a ~a~%") + file + (strerror (system-error-errno args)))))) + + (define (formatted-hash thing) + (fmt (file-hash thing))) (match args - ((file) - (catch 'system-error - (lambda () - (format #t "~a~%" (fmt (file-hash file)))) - (lambda args - (leave (G_ "~a~%") - (strerror (system-error-errno args)))))) - (x - (leave (G_ "wrong number of arguments~%")))))) + (() + (leave (G_ "no arguments specified~%"))) + (_ + (for-each + (compose (cute format #t "~a~%" <>) formatted-hash) + args))))) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 75df6d707d..2312e4d313 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +24,7 @@ #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu packages) #:use-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) @@ -38,6 +40,7 @@ #:autoload (guix scripts pull) (channel-commit-hyperlink) #:use-module (guix scripts home import) #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) @@ -86,6 +89,9 @@ Some ACTIONS support additional ARGS.\n")) (show-build-options-help) (display (G_ " + -e, --expression=EXPR consider the home-environment EXPR evaluates to + instead of reading FILE, when applicable")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " @@ -99,7 +105,7 @@ Some ACTIONS support additional ARGS.\n")) "Return the verbosity level based on OPTS, the alist of parsed options." (or (assoc-ref opts 'verbosity) (if (eq? (assoc-ref opts 'action) 'build) - 2 1))) + 3 1))) (define %options ;; Specification of the command-line options. @@ -107,6 +113,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda args (show-help) (exit 0))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix show"))) @@ -115,6 +124,9 @@ Some ACTIONS support additional ARGS.\n")) (let ((level (string->number* arg))) (alist-cons 'verbosity level (alist-delete 'verbosity result))))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) %standard-build-options)) (define %default-options @@ -125,7 +137,7 @@ Some ACTIONS support additional ARGS.\n")) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 3) + (verbosity . #f) ;default (debug . 0))) @@ -179,6 +191,7 @@ ACTION must be one of the sub-commands that takes a home environment declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." (define (ensure-home-environment file-or-exp obj) + (ensure-profile-directory) (unless (home-environment? obj) (leave (G_ "'~a' does not return a home environment ~%") file-or-exp)) @@ -248,19 +261,32 @@ argument list and OPTS is the option alist." (apply search args)) ((import) (let* ((profiles (delete-duplicates - (match (filter-map (match-lambda - (('profile . p) p) - (_ #f)) - opts) - (() (list %current-profile)) - (lst (reverse lst))))) - (manifest (concatenate-manifests - (map profile-manifest profiles)))) - (import-manifest manifest (current-output-port)))) + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) + (manifest (concatenate-manifests + (map profile-manifest profiles))) + (destination (match args + ((destination) destination) + (_ (leave (G_ "wrong number of arguments~%")))))) + (unless (file-exists? destination) + (mkdir-p destination)) + (call-with-output-file + (string-append destination "/home-configuration.scm") + (cut import-manifest manifest destination <>)) + (info (G_ "'~a' populated with all the Home configuration files~%") + destination) + (display-hint (format #f (G_ "\ +Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively +deploy the home environment described by these files.\n") + destination)))) ((describe) (match (generation-number %guix-home) (0 - (error (G_ "no home environment generation, nothing to describe~%"))) + (leave (G_ "no home environment generation, nothing to describe~%"))) (generation (display-home-environment-generation generation)))) ((list-generations) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 79fb23a2fd..15bd3140ed 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,12 +24,19 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix packages) + #:autoload (guix scripts package) (manifest-entry-version-prefix) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (import-manifest)) + #:export (import-manifest + + ;; For tests. + manifest+configuration-files->code)) ;;; Commentary: ;;; @@ -36,202 +45,136 @@ ;;; ;;; Code: +(define (basename+remove-dots file-name) + "Remove the dot from the dotfile FILE-NAME; replace the other dots in +FILE-NAME with \"-\", and return the basename of it." + (string-map (match-lambda + (#\. #\-) + (c c)) + (let ((base (basename file-name))) + (if (string-prefix? "." base) + (string-drop base 1) + base)))) -(define (generate-bash-module+configuration) - (let ((rc (string-append (getenv "HOME") "/.bashrc")) - (profile (string-append (getenv "HOME") "/.bash_profile")) - (logout (string-append (getenv "HOME") "/.bash_logout"))) - `((gnu home-services bash) - (service home-bash-service-type - (home-bash-configuration - ,@(if (file-exists? rc) - `((bashrc - (list (slurp-file-gexp (local-file ,rc))))) - '()) - ,@(if (file-exists? profile) - `((bash-profile - (list (slurp-file-gexp - (local-file ,profile))))) - '()) - ,@(if (file-exists? logout) - `((bash-logout - (list (slurp-file-gexp - (local-file ,logout))))) - '())))))) - - -(define %files-configurations-alist - `((".bashrc" . ,generate-bash-module+configuration) - (".bash_profile" . ,generate-bash-module+configuration) - (".bash_logout" . ,generate-bash-module+configuration))) - -(define (modules+configurations) - (let ((configurations (delete-duplicates - (filter-map (match-lambda - ((file . proc) - (if (file-exists? - (string-append (getenv "HOME") "/" file)) - proc - #f))) - %files-configurations-alist) - (lambda (x y) - (equal? (procedure-name x) (procedure-name y)))))) - (map (lambda (proc) (proc)) configurations))) - -;; Based on `manifest->code' from (guix profiles) -;; MAYBE: Upstream it? -(define* (manifest->code manifest - #:key - (entry-package-version (const "")) - (home-environment? #f)) - "Return an sexp representing code to build an approximate version of -MANIFEST; the code is wrapped in a top-level 'begin' form. If -HOME-ENVIRONMENT? is #t, return an <home-environment> definition. -Call ENTRY-PACKAGE-VERSION to determine the version number to use in -the spec for a given entry; it can be set to 'manifest-entry-version' -for fully-specified version numbers, or to some other procedure to -disambiguate versions for packages for which several versions are -available." - (define (entry-transformations entry) - ;; Return the transformations that apply to ENTRY. - (assoc-ref (manifest-entry-properties entry) 'transformations)) +(define (generate-bash-configuration+modules destination-directory) + (define (destination-append path) + (string-append destination-directory "/" path)) - (define transformation-procedures - ;; List of transformation options/procedure name pairs. - (let loop ((entries (manifest-entries manifest)) - (counter 1) - (result '())) - (match entries - (() result) - ((entry . tail) - (match (entry-transformations entry) - (#f - (loop tail counter result)) - (options - (if (assoc-ref result options) - (loop tail counter result) - (loop tail (+ 1 counter) - (alist-cons options - (string->symbol - (format #f "transform~a" counter)) - result))))))))) + (define (bash-alias->pair line) + (if (string-prefix? "alias" line) + (let ((matched (string-match "alias (.+)=\"?'?([^\"']+)\"?'?" line))) + `(,(match:substring matched 1) . ,(match:substring matched 2))) + '())) + + (define (parse-aliases input) + (let loop ((line (read-line input)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line input) + (cons (bash-alias->pair line) result))))) - (define (qualified-name entry) - ;; Return the name of ENTRY possibly with "@" followed by a version. - (match (entry-package-version entry) - ("" (manifest-entry-name entry)) - (version (string-append (manifest-entry-name entry) - "@" version)))) + (let ((rc (destination-append ".bashrc")) + (profile (destination-append ".bash_profile")) + (logout (destination-append ".bash_logout"))) + `((service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((aliases + ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias")) + (alist (parse-aliases port))) + (close-port port) + (filter (negate null?) alist)))) + '()) + ,@(if (file-exists? rc) + `((bashrc + (list (local-file ,rc + ,(basename+remove-dots rc))))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (local-file ,profile + ,(basename+remove-dots profile))))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (local-file ,logout + ,(basename+remove-dots logout))))) + '()))) + (guix gexp) + (gnu home services shells)))) - (if (null? transformation-procedures) - (let ((specs (map (lambda (entry) - (match (manifest-entry-output entry) - ("out" (qualified-name entry)) - (output (string-append (qualified-name entry) - ":" output)))) - (manifest-entries manifest)))) - (if home-environment? - (let ((modules+configurations (modules+configurations))) - `(begin - (use-modules (gnu home) - (gnu packages) - ,@(map first modules+configurations)) - ,(home-environment-template - #:specs specs - #:services (map second modules+configurations)))) - `(begin - (use-modules (gnu packages)) +(define %files+configurations-alist + `((".bashrc" . ,generate-bash-configuration+modules) + (".bash_profile" . ,generate-bash-configuration+modules) + (".bash_logout" . ,generate-bash-configuration+modules))) - (specifications->manifest - (list ,@specs))))) - (let* ((transform (lambda (options exp) - (if (not options) - exp - (let ((proc (assoc-ref transformation-procedures - options))) - `(,proc ,exp))))) - (packages (map (lambda (entry) - (define options - (entry-transformations entry)) +(define (configurations+modules configuration-directory) + "Return a list of procedures which when called, generate code for a home +service declaration. Copy configuration files to CONFIGURATION-DIRECTORY; the +generated service declarations will refer to those files that have been saved +in CONFIGURATION-DIRECTORY." + (define configurations + (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (let ((absolute-path (string-append (getenv "HOME") + "/" file))) + (and (file-exists? absolute-path) + (begin + (copy-file absolute-path + (string-append + configuration-directory "/" file)) + proc))))) + %files+configurations-alist) + eq?)) - (define name - (qualified-name entry)) + (map (lambda (proc) (proc configuration-directory)) configurations)) - (match (manifest-entry-output entry) - ("out" - (transform options - `(specification->package ,name))) - (output - `(list ,(transform - options - `(specification->package ,name)) - ,output)))) - (manifest-entries manifest))) - (transformations (map (match-lambda - ((options . name) - `(define ,name - (options->transformation ',options)))) - transformation-procedures))) - (if home-environment? - (let ((modules+configurations (modules+configurations))) - `(begin - (use-modules (guix transformations) - (gnu home) - (gnu packages) - ,@(map first modules+configurations)) - - ,@transformations - - ,(home-environment-template - #:packages packages - #:services (map second modules+configurations)))) - `(begin - (use-modules (guix transformations) - (gnu packages)) +(define (manifest+configuration-files->code manifest + configuration-directory) + "Read MANIFEST and the user's configuration files listed in +%FILES+CONFIGURATIONS-ALIST, and return a 'home-environment' sexp. Copy the +user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." + (match (manifest->code manifest + #:entry-package-version + manifest-entry-version-prefix) + (('begin ('use-modules profile-modules ...) + definitions ... ('packages->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates + (append profile-modules (concatenate modules)))) - ,@transformations + ,@definitions - (packages->manifest - (list ,@packages))))))) + (home-environment + (packages ,packages) + (services (list ,@services))))))) + (('begin ('specifications->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates (concatenate modules))) -(define* (home-environment-template #:key (packages #f) (specs #f) services) - "Return an S-exp containing a <home-environment> declaration -containing PACKAGES, or SPECS (package specifications), and SERVICES." - `(home-environment - (packages - ,@(if packages - `((list ,@packages)) - `((map specification->package - (list ,@specs))))) - (services (list ,@services)))) + (home-environment + (packages (map (compose list specification->package+output) + ,packages)) + (services (list ,@services))))))))) (define* (import-manifest - manifest + manifest destination-directory #:optional (port (current-output-port))) "Write to PORT a <home-environment> corresponding to MANIFEST." - (define (version-spec entry) - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) - - (match (manifest->code manifest - #:entry-package-version version-spec - #:home-environment? #t) + (match (manifest+configuration-files->code manifest + destination-directory) (('begin exp ...) (format port (G_ "\ ;; This \"home-environment\" file can be passed to 'guix home reconfigure' diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 3e4b038cc4..2934d4300a 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -27,8 +27,8 @@ #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -98,21 +98,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (parameterize ((%input-style (assoc-ref opts 'style))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (with-error-handling - (map package->definition - (filter identity - (cran-recursive-import package-name - #:repo (or (assoc-ref opts 'repo) 'cran))))) - ;; Single import - (let ((sexp (cran->guix-package package-name - #:repo (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (with-error-handling + (map package->definition + (filter identity + (cran-recursive-import name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran))))) + ;; Single import + (let ((sexp (cran->guix-package name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (G_ "failed to download description for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm index 829cdc2ca0..6a9657d12c 100644 --- a/guix/scripts/import/egg.scm +++ b/guix/scripts/import/egg.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-egg)) @@ -83,21 +84,24 @@ Import and convert the egg package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (egg-recursive-import package-name)) - ;; Single import - (let ((sexp (egg->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import name version)) + ;; Single import + (let ((sexp (egg->guix-package name version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + (if version + (string-append name "@" version) + name))) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index f5cfea8683..f1970d3543 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -87,37 +87,38 @@ that are not yet in Guix")) (parse-command-line args %options (list %default-options) #:build-options? #f)) - (let* ((opts (parse-options)) - (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) - (reverse opts))) - ;; Append the full version to the package symbol name when using - ;; pinned versions. - (package->definition* (if (assoc-ref opts 'pin-versions?) - (cut package->definition <> 'full) - package->definition))) - (match args - ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 - (receive (name version) - (package-name->name+version spec) - (let ((arguments (list name - #:goproxy (assoc-ref opts 'goproxy) - #:version version - #:pin-versions? - (assoc-ref opts 'pin-versions?)))) - (if (assoc-ref opts 'recursive) - ;; Recursive import. - (map package->definition* - (apply go-module-recursive-import arguments)) - ;; Single import. - (let ((sexp (apply go-module->guix-package* arguments))) - (unless sexp - (leave (G_ "failed to download meta-data for module '~a'.~%") - name)) - (package->definition* sexp)))))) - (() - (leave (G_ "too few arguments~%"))) - ((many ...) - (leave (G_ "too many arguments~%")))))) + (with-error-handling + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts))) + ;; Append the full version to the package symbol name when using + ;; pinned versions. + (package->definition* (if (assoc-ref opts 'pin-versions?) + (cut package->definition <> 'full) + package->definition))) + (match args + ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 + (receive (name version) + (package-name->name+version spec) + (let ((arguments (list name + #:goproxy (assoc-ref opts 'goproxy) + #:version version + #:pin-versions? + (assoc-ref opts 'pin-versions?)))) + (if (assoc-ref opts 'recursive) + ;; Recursive import. + (map package->definition* + (apply go-module-recursive-import arguments)) + ;; Single import. + (let ((sexp (apply go-module->guix-package* arguments))) + (unless sexp + (leave (G_ "failed to download meta-data for module '~a'.~%") + name)) + (package->definition* sexp)))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%"))))))) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 9170a0b359..a52cd95c93 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -83,21 +84,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (pypi-recursive-import package-name)) - ;; Single import - (let ((sexp (pypi->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (pypi-recursive-import name version)) + ;; Single import + (let ((sexp (pypi->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm index 6f0818e274..c5dcc07ea1 100644 --- a/guix/scripts/import/texlive.scm +++ b/guix/scripts/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -43,8 +43,6 @@ (display (G_ "Usage: guix import texlive PACKAGE-NAME Import and convert the Texlive package for PACKAGE-NAME.\n")) (display (G_ " - -a, --archive=ARCHIVE specify the archive repository")) - (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -60,10 +58,6 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import texlive"))) - (option '(#\a "archive") #t #f - (lambda (opt name arg result) - (alist-cons 'component arg - (alist-delete 'component result)))) %standard-import-options)) @@ -84,13 +78,11 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (texlive->guix-package package-name - (or (assoc-ref opts 'component) - "latex")))) + ((name) + (let ((sexp (texlive->guix-package name))) (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) + (leave (G_ "failed to import package '~a'~%") + name)) sexp)) (() (leave (G_ "too few arguments~%"))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 835078cb97..925325ef5f 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> @@ -20,21 +20,26 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts offload) - #:use-module (ssh key) - #:use-module (ssh auth) - #:use-module (ssh session) - #:use-module (ssh channel) - #:use-module (ssh popen) - #:use-module (ssh version) + #:autoload (ssh key) (private-key-from-file + public-key-from-file) + #:autoload (ssh auth) (userauth-public-key!) + #:autoload (ssh session) (make-session + connect! get-error + disconnect! session-set!) + #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) - #:use-module (guix ssh) + #:autoload (guix ssh) (authenticate-server* + connect-to-remote-daemon + send-files retrieve-files retrieve-files* + remote-inferior report-guile-error) #:use-module (guix store) - #:use-module (guix inferior) - #:use-module (guix derivations) - #:use-module ((guix serialization) - #:select (nar-error? nar-error-file)) - #:use-module (guix nar) + #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix derivations) (read-derivation-from-file + derivation-file-name + build-derivations) + #:autoload (guix serialization) (nar-error? nar-error-file) + #:autoload (guix nar) (restore-file-set) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) @@ -47,12 +52,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) - #:use-module (ice-9 binary-ports) #:export (build-machine build-machine? build-machine-name @@ -228,6 +231,9 @@ number of seconds after which the connection times out." ;; stateless instead. #:knownhosts "/dev/null" + ;; Likewise for ~/.ssh/config. + #:config "/dev/null" + ;; We need lightweight compression when ;; exchanging full archives. #:compression @@ -560,6 +566,15 @@ expired." If TIMEOUT is #f, simply evaluate EXP..." (call-with-timeout timeout drv (lambda () exp ...))) +(define (check-ssh-zlib-support) + "Warn once if libssh lacks zlib support." + ;; We rely on protocol-level compression from libssh to optimize large data + ;; transfers. Warn if it's missing. + (unless (zlib-support?) + (warning (G_ "Guile-SSH lacks zlib support")) + (warning (G_ "data transfers will *not* be compressed!"))) + (set! check-ssh-zlib-support (const #t))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -584,7 +599,9 @@ If TIMEOUT is #f, simply evaluate EXP..." (lambda () ;; Offload DRV to MACHINE. (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) + (check-ssh-zlib-support) + (let ((drv (read-derivation-from-file drv)) + (inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can ;; be issues with the connection or deadlocks that could @@ -782,12 +799,6 @@ machine." (and=> (passwd:dir (getpw (getuid))) (cut setenv "HOME" <>)) - ;; We rely on protocol-level compression from libssh to optimize large data - ;; transfers. Warn if it's missing. - (unless (zlib-support?) - (warning (G_ "Guile-SSH lacks zlib support")) - (warning (G_ "data transfers will *not* be compressed!"))) - (match args ((system max-silent-time print-build-trace? build-timeout) (let ((max-silent-time (string->number max-silent-time)) @@ -803,8 +814,7 @@ machine." (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system - (read-derivation-from-file - (match:substring match 3)) + (match:substring match 3) (string-tokenize (match:substring match 4) not-coma) #:print-build-trace? print-build-trace? diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 9e1f270dfb..38bc021665 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -27,6 +28,7 @@ #:use-module (guix scripts) #:use-module (guix ui) #:use-module (guix gexp) + #:use-module ((guix build utils) #:select (%xz-parallel-args)) #:use-module (guix utils) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -79,29 +81,34 @@ compressor? (name compressor-name) ;string (e.g., "gzip") (extension compressor-extension) ;string (e.g., ".lz") - (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) + (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip" + ; "-9n" )) (define %compressors ;; Available compression tools. (list (compressor "gzip" ".gz" - #~(#+(file-append gzip "/bin/gzip") "-9n")) + #~(list #+(file-append gzip "/bin/gzip") "-9n")) (compressor "lzip" ".lz" - #~(#+(file-append lzip "/bin/lzip") "-9")) + #~(list #+(file-append lzip "/bin/lzip") "-9")) (compressor "xz" ".xz" - #~(#+(file-append xz "/bin/xz") "-e")) + #~(append (list #+(file-append xz "/bin/xz") + "-e") + (%xz-parallel-args))) (compressor "bzip2" ".bz2" - #~(#+(file-append bzip2 "/bin/bzip2") "-9")) + #~(list #+(file-append bzip2 "/bin/bzip2") "-9")) (compressor "zstd" ".zst" ;; The default level 3 compresses better than gzip in a ;; fraction of the time, while the highest level 19 ;; (de)compresses more slowly and worse than xz. - #~(#+(file-append zstd "/bin/zstd") "-3")) + #~(list #+(file-append zstd "/bin/zstd") "-3")) (compressor "none" "" #f))) ;; This one is only for use in this module, so don't put it in %compressors. (define bootstrap-xz (compressor "bootstrap-xz" ".xz" - #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e"))) + #~(append (list #+(file-append %bootstrap-coreutils&co "/bin/xz") + "-e") + (%xz-parallel-args)))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -298,7 +305,7 @@ its source property." (apply invoke tar "-cvf" #$output "." (tar-base-options #:tar tar - #:compressor '#+(and=> compressor compressor-command))))))) + #:compressor #+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target @@ -574,11 +581,13 @@ the image." ,@(source-module-closure `((guix docker) (guix build store-copy) + (guix build utils) ;for %xz-parallel-args (guix profiles) (guix search-paths)) #:select? not-config?)) #~(begin (use-modules (guix docker) (guix build store-copy) + (guix build utils) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) (ice-9 match)) @@ -625,7 +634,7 @@ the image." #~(list (string-append #$profile "/" #$entry-point))) #:extra-files directives - #:compressor '#+(compressor-command compressor) + #:compressor #+(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" @@ -804,7 +813,7 @@ Section: misc (apply invoke tar `(,@(tar-base-options #:tar tar - #:compressor '#+(and=> compressor compressor-command)) + #:compressor #+(and=> compressor compressor-command)) "-cvf" ,control-tarball-file-name "control" ,@(if postinst-file '("postinst") '()) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a34ecdcb54..9699c70c6d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -68,6 +68,7 @@ guix-package search-path-environment-variables + manifest-entry-version-prefix transaction-upgrade-entry ;mostly for testing @@ -138,6 +139,7 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + dry-run? (hooks %default-profile-hooks) allow-collisions? bootstrap?) @@ -153,6 +155,7 @@ hooks\" run when building the profile." (prof (derivation->output-path prof-drv))) (cond + (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) (format (current-error-port) (G_ "nothing to be done~%"))) @@ -327,31 +330,35 @@ Alternately, see @command{guix package --search-paths -p ~s}.") ;;; Export a manifest. ;;; +(define (manifest-entry-version-prefix entry) + "Search among all the versions of ENTRY's package that are available, and +return the shortest unambiguous version prefix for this package. If only one +version of ENTRY's package is available, return the empty string." + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + (define* (export-manifest manifest #:optional (port (current-output-port))) "Write to PORT a manifest corresponding to MANIFEST." - (define (version-spec entry) - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) - (match (manifest->code manifest - #:entry-package-version version-spec) + #:entry-package-version + manifest-entry-version-prefix) (('begin exp ...) (format port (G_ "\ ;; This \"manifest\" file can be passed to 'guix package -m' to reproduce @@ -1064,6 +1071,7 @@ processed, #f otherwise." trans #:dry-run? dry-run?) (build-and-use-profile store profile new + #:dry-run? dry-run? #:allow-collisions? allow-collisions? #:bootstrap? bootstrap?))))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 25846b7dc2..6e2b4368da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module ((system repl server) #:prefix repl:) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) + #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 poll) #:use-module (ice-9 regex) @@ -400,15 +401,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) (not-found request #:phrase "" #:ttl negative-ttl) - (values `((content-type . (application/x-nix-narinfo)) + (values `((content-type . (application/x-nix-narinfo + (charset . "UTF-8"))) + (x-nar-path . ,nar-path) + (x-narinfo-compressions . ,compressions) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - (cut display - (narinfo-string store store-path - #:nar-path nar-path - #:compressions compressions) - <>))))) + ;; Do not call narinfo-string directly here as it is an + ;; expensive call that could potentially block the main + ;; thread. Instead, create the narinfo string in the + ;; http-write procedure. + store-path)))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -663,19 +667,38 @@ requested using POOL." (link narinfo other))) others)))))) +(define (compression->sexp compression) + "Return the SEXP representation of COMPRESSION." + (match compression + (($ <compression> type level) + `(compression ,type ,level)))) + +(define (sexp->compression sexp) + "Turn the given SEXP into a <compression> record and return it." + (match sexp + (('compression type level) + (compression type level)))) + ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. (declare-header! "X-Nar-Compression" (lambda (str) - (match (call-with-input-string str read) - (('compression type level) - (compression type level)))) + (sexp->compression + (call-with-input-string str read))) compression? (lambda (compression port) - (match compression - (($ <compression> type level) - (write `(compression ,type ,level) port))))) + (write (compression->sexp compression) port))) + +;; This header is used to pass the supported compressions to http-write in +;; order to format on-the-fly narinfo responses. +(declare-header! "X-Narinfo-Compressions" + (lambda (str) + (map sexp->compression + (call-with-input-string str read))) + (cut every compression? <>) + (lambda (compressions port) + (write (map compression->sexp compressions) port))) (define* (render-nar store request store-item #:key (compression %no-compression)) @@ -830,7 +853,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression))) + '(content-length x-raw-file x-nar-compression + x-narinfo-compressions x-nar-path))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -964,6 +988,38 @@ blocking." (unless keep-alive? (close-port client))) (values)))))) + (('application/x-nix-narinfo . _) + (let ((compressions (assoc-ref (response-headers response) + 'x-narinfo-compressions)) + (nar-path (assoc-ref (response-headers response) + 'x-nar-path))) + (if nar-path + (begin + (when (keep-alive? response) + (keep-alive client)) + (call-with-new-thread + (lambda () + (set-thread-name "publish narinfo") + (let* ((narinfo + (with-store store + (narinfo-string store (utf8->string body) + #:nar-path nar-path + #:compressions compressions))) + (narinfo-bv (string->bytevector narinfo "UTF-8")) + (narinfo-length + (bytevector-length narinfo-bv)) + (response (write-response + (with-content-length response + narinfo-length) + client)) + (output (response-port response))) + (configure-socket client) + (put-bytevector output narinfo-bv) + (force-output output) + (unless (keep-alive? response) + (close-port output)) + (values))))) + (%http-write server client response body)))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index fb6c52a567..68bb9040d8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -8,6 +8,7 @@ ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +27,6 @@ (define-module (guix scripts refresh) #:use-module (guix ui) - #:use-module (gcrypt hash) #:use-module (guix scripts) #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (guix store) @@ -38,6 +38,7 @@ #:use-module (guix scripts graph) #:use-module (guix monads) #:use-module (guix gnupg) + #:use-module (guix hash) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) #:use-module (ice-9 match) @@ -314,14 +315,14 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball source) + (let-values (((version output source) (package-update store package updaters #:key-download key-download)) ((loc) (or (package-field-location package 'version) (package-location package)))) (when version - (if (and=> tarball file-exists?) + (if (and=> output file-exists?) (begin (info loc (G_ "~a: updating from version ~a to version ~a...~%") @@ -329,26 +330,41 @@ warn about packages that have no matching updater." (package-version package) version) (for-each (lambda (change) - (format (current-error-port) - (match (list (upstream-input-change-action change) - (upstream-input-change-type change)) - (('add 'regular) - (G_ "~a: consider adding this input: ~a~%")) - (('add 'native) - (G_ "~a: consider adding this native input: ~a~%")) - (('add 'propagated) - (G_ "~a: consider adding this propagated input: ~a~%")) - (('remove 'regular) - (G_ "~a: consider removing this input: ~a~%")) - (('remove 'native) - (G_ "~a: consider removing this native input: ~a~%")) - (('remove 'propagated) - (G_ "~a: consider removing this propagated input: ~a~%"))) - (package-name package) - (upstream-input-change-name change))) + (define field + (match (upstream-input-change-type change) + ('native 'native-inputs) + ('propagated 'propagated-inputs) + (_ 'inputs))) + + (define name + (package-name package)) + (define loc + (package-field-location package field)) + (define change-name + (upstream-input-change-name change)) + + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (info loc (G_ "~a: consider adding this input: ~a~%") + name change-name)) + (('add 'native) + (info loc (G_ "~a: consider adding this native input: ~a~%") + name change-name)) + (('add 'propagated) + (info loc (G_ "~a: consider adding this propagated input: ~a~%") + name change-name)) + (('remove 'regular) + (info loc (G_ "~a: consider removing this input: ~a~%") + name change-name)) + (('remove 'native) + (info loc (G_ "~a: consider removing this native input: ~a~%") + name change-name)) + (('remove 'propagated) + (info loc (G_ "~a: consider removing this propagated input: ~a~%") + name change-name)))) (upstream-source-input-changes source)) - (let ((hash (call-with-input-file tarball - port-sha256))) + (let ((hash (file-hash* output))) (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm new file mode 100644 index 0000000000..a92932cbc9 --- /dev/null +++ b/guix/scripts/shell.scm @@ -0,0 +1,444 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 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 scripts shell) + #:use-module (guix ui) + #:use-module ((guix diagnostics) #:select (location)) + #:use-module (guix scripts environment) + #:autoload (guix scripts build) (show-build-options-help) + #:autoload (guix transformations) (transformation-option-key? + show-transformation-options-help) + #:use-module (guix scripts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:autoload (guix base32) (bytevector->base32-string) + #:autoload (rnrs bytevectors) (string->utf8) + #:autoload (guix utils) (config-directory cache-directory) + #:autoload (guix describe) (current-channels) + #:autoload (guix channels) (channel-commit) + #:autoload (gcrypt hash) (sha256) + #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix cache) + #:use-module ((ice-9 ftw) #:select (scandir)) + #:autoload (gnu packages) (cache-is-authoritative?) + #:export (guix-shell)) + +(define (show-help) + (display (G_ "Usage: guix shell [OPTION] PACKAGES... [-- COMMAND...] +Build an environment that includes PACKAGES and execute COMMAND or an +interactive shell in that environment.\n")) + (newline) + + ;; These two options differ from 'guix environment'. + (display (G_ " + -D, --development include the development inputs of the next package")) + (display (G_ " + -f, --file=FILE add to the environment the package FILE evaluates to")) + (display (G_ " + -q inhibit loading of 'guix.scm' and 'manifest.scm'")) + (display (G_ " + --rebuild-cache rebuild cached environment, if any")) + + (show-environment-options-help) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + +(define (ensure-ad-hoc alist) + (if (assq-ref alist 'ad-hoc?) + alist + `((ad-hoc? . #t) ,@alist))) + +(define (wrapped-option opt) + "Wrap OPT, a SRFI-37 option, such that its processor always adds the +'ad-hoc?' flag to the resulting alist." + (option (option-names opt) + (option-required-arg? opt) + (option-optional-arg? opt) + (compose ensure-ad-hoc (option-processor opt)))) + +(define %options + ;; Specification of the command-line options. + (let ((to-remove '("ad-hoc" "inherit" "load" "help" "version"))) + (append + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix shell"))) + + (option '(#\D "development") #f #f + (lambda (opt name arg result) + ;; Temporarily remove the 'ad-hoc?' flag from result. + ;; The next option will put it back thanks to + ;; 'wrapped-option'. + (alist-delete 'ad-hoc? result))) + + ;; For consistency with 'guix package', support '-f' rather than + ;; '-l' like 'guix environment' does. + (option '(#\f "file") #t #f + (lambda (opt name arg result) + (alist-cons 'load (tag-package-arg result arg) + (ensure-ad-hoc result)))) + (option '(#\q) #f #f + (lambda (opt name arg result) + (alist-cons 'explicit-loading? #t result))) + (option '("rebuild-cache") #f #f + (lambda (opt name arg result) + (alist-cons 'rebuild-cache? #t result)))) + (filter-map (lambda (opt) + (and (not (any (lambda (name) + (member name to-remove)) + (option-names opt))) + (wrapped-option opt))) + %environment-options)))) + +(define %default-options + `((ad-hoc? . #t) ;always true + ,@%environment-default-options)) + +(define (parse-args args) + "Parse the list of command line arguments ARGS." + (define (handle-argument arg result) + (alist-cons 'package (tag-package-arg result arg) + (ensure-ad-hoc result))) + + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let ((args command (break (cut string=? "--" <>) args))) + (let ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument))) + (options-with-caching + (auto-detect-manifest + (match command + (() opts) + (("--") opts) + (("--" command ...) (alist-cons 'exec command opts)))))))) + +(define (find-file-in-parent-directories candidates) + "Find one of CANDIDATES in the current directory or one of its ancestors." + (define start (getcwd)) + (define device (stat:dev (stat start))) + + (let loop ((directory start)) + (let ((stat (stat directory))) + (and (= (stat:uid stat) (getuid)) + (= (stat:dev stat) device) + (or (any (lambda (candidate) + (let ((candidate (string-append directory "/" candidate))) + (and (file-exists? candidate) candidate))) + candidates) + (and (not (string=? directory "/")) + (loop (dirname directory)))))))) ;lexical ".." resolution + +(define (authorized-directory-file) + "Return the name of the file listing directories for which 'guix shell' may +automatically load 'guix.scm' or 'manifest.scm' files." + (string-append (config-directory) "/shell-authorized-directories")) + +(define (authorized-shell-directory? directory) + "Return true if DIRECTORY is among the authorized directories for automatic +loading. The list of authorized directories is read from +'authorized-directory-file'; each line must be either: an absolute file name, +a hash-prefixed comment, or a blank line." + (catch 'system-error + (lambda () + (call-with-input-file (authorized-directory-file) + (lambda (port) + (let loop () + (match (read-line port) + ((? eof-object?) #f) + ((= string-trim line) + (cond ((string-prefix? "#" line) ;comment + (loop)) + ((string-prefix? "/" line) ;absolute file name + (or (string=? line directory) + (loop))) + ((string-null? (string-trim-right line)) ;blank line + (loop)) + (else ;bogus line + (let ((loc (location (port-filename port) + (port-line port) + (port-column port)))) + (warning loc (G_ "ignoring invalid file name: '~a'~%") + line)))))))))) + (const #f))) + +(define (options-with-caching opts) + "If OPTS contains only options that allow us to compute a cache key, +automatically add a 'profile' key (when a profile for that file is already in +cache) or a 'gc-root' key (to add the profile to cache)." + ;; Attempt to compute a file name for use as the cached profile GC root. + (let* ((root timestamp (profile-cached-gc-root opts)) + (stat (and root (false-if-exception (lstat root))))) + (if (and (not (assoc-ref opts 'rebuild-cache?)) + stat + (<= timestamp (stat:mtime stat))) + (let ((now (current-time))) + ;; Update the atime on ROOT to reflect usage. + (utime root + now (stat:mtime stat) 0 (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW) + (alist-cons 'profile root + (remove (match-lambda + (('load . _) #t) + (('manifest . _) #t) + (('package . _) #t) + (('ad-hoc-package . _) #t) + (_ #f)) + opts))) ;load right away + (if (and root (not (assq-ref opts 'gc-root))) + (begin + (if stat + (delete-file root) + (mkdir-p (dirname root))) + (alist-cons 'gc-root root opts)) + opts)))) + +(define (auto-detect-manifest opts) + "If OPTS do not specify packages or a manifest, load a \"guix.scm\" or +\"manifest.scm\" file from the current directory or one of its ancestors. +Return the modified OPTS." + (define (options-contain-payload? opts) + (match opts + (() #f) + ((('package . _) . _) #t) + ((('load . _) . _) #t) + ((('manifest . _) . _) #t) + ((('expression . _) . _) #t) + ((_ . rest) (options-contain-payload? rest)))) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (define disallow-implicit-load? + (assoc-ref opts 'explicit-loading?)) + + (if (or (not interactive?) + disallow-implicit-load? + (options-contain-payload? opts)) + opts + (match (find-file-in-parent-directories '("manifest.scm" "guix.scm")) + (#f + (warning (G_ "no packages specified; creating an empty environment~%")) + opts) + (file + (if (authorized-shell-directory? (dirname file)) + (begin + (info (G_ "loading environment from '~a'...~%") file) + (match (basename file) + ("guix.scm" (alist-cons 'load `(package ,file) opts)) + ("manifest.scm" (alist-cons 'manifest file opts)))) + (begin + (report-error + (G_ "not loading '~a' because not authorized to do so~%") + file) + (display-hint (format #f (G_ "To allow automatic loading of +@file{~a} when running @command{guix shell}, you must explicitly authorize its +directory, like so: + +@example +echo ~a >> ~a +@end example\n") + file + (dirname file) + (authorized-directory-file))) + (exit 1))))))) + + +;;; +;;; Profile cache. +;;; + +(define %profile-cache-directory + ;; Directory where profiles created by 'guix shell' alone (without extra + ;; options) are cached. + (make-parameter (string-append (cache-directory #:ensure? #f) + "/profiles"))) + +(define (profile-cache-primary-key) + "Return the \"primary key\" used when computing keys for the profile cache. +Return #f if no such key can be obtained and caching cannot be +performed--e.g., because the package cache is not authoritative." + (and (cache-is-authoritative?) + (match (current-channels) + (() + #f) + (((= channel-commit commits) ...) + (string-join commits))))) + +(define (profile-file-cache-key file system) + "Return the cache key for the profile corresponding to FILE, a 'guix.scm' or +'manifest.scm' file, or #f if we lack channel information." + (match (profile-cache-primary-key) + (#f #f) + (primary-key + (let ((stat (stat file))) + (bytevector->base32-string + ;; Since FILE is not canonicalized, only include the device/inode + ;; numbers. XXX: In some rare cases involving Btrfs and NFS, this can + ;; be insufficient: <https://lwn.net/Articles/866582/>. + (sha256 (string->utf8 + (string-append primary-key ":" system ":" + (number->string (stat:dev stat)) ":" + (number->string (stat:ino stat)))))))))) + +(define (profile-spec-cache-key specs system) + "Return the cache key corresponding to SPECS built for SYSTEM, where SPECS +is a list of package specs. Return #f if caching is not possible." + (match (profile-cache-primary-key) + (#f #f) + (primary-key + (bytevector->base32-string + (sha256 (string->utf8 + (string-append primary-key ":" system ":" + (object->string specs)))))))) + +(define (profile-cached-gc-root opts) + "Return two values: the file name of a GC root for use as a profile cache +for the options in OPTS, and a timestamp which, if greater than the GC root's +mtime, indicates that the GC root is stale. If OPTS do not permit caching, +return #f and #f." + (define (key->file key) + (string-append (%profile-cache-directory) "/" key)) + + (let loop ((opts opts) + (system (%current-system)) + (file #f) + (specs '())) + (match opts + (() + (if file + (values (and=> (profile-file-cache-key file system) key->file) + (stat:mtime (stat file))) + (values (and=> (profile-spec-cache-key specs system) key->file) + 0))) + (((and spec ('package . _)) . rest) + (if (not file) + (loop rest system file (cons spec specs)) + (values #f #f))) + ((('load . ('package candidate)) . rest) + (if (and (not file) (null? specs)) + (loop rest system candidate specs) + (values #f #f))) + ((('manifest . candidate) . rest) + (if (and (not file) (null? specs)) + (loop rest system candidate specs) + (values #f #f))) + ((('expression . _) . _) + ;; Arbitrary expressions might be non-deterministic or otherwise depend + ;; on external state so do not cache when they're used. + (values #f #f)) + ((((? transformation-option-key?) . _) . _) + ;; Transformation options are potentially "non-deterministic", or at + ;; least depending on external state (with-source, with-commit, etc.), + ;; so do not cache anything when they're used. + (values #f #f)) + ((('system . system) . rest) + (loop rest system file specs)) + ((_ . rest) (loop rest system file specs))))) + + +;;; +;;; One-time hints. +;;; + +(define (hint-directory) + "Return the directory name where previously given hints are recorded." + (string-append (cache-directory #:ensure? #f) "/hints")) + +(define (hint-file hint) + "Return the name of the file that marks HINT as already printed." + (string-append (hint-directory) "/" (symbol->string hint))) + +(define (record-hint hint) + "Mark HINT as already given." + (let ((file (hint-file hint))) + (mkdir-p (dirname file)) + (close-fdes (open-fdes file (logior O_CREAT O_WRONLY))))) + +(define (hint-given? hint) + "Return true if HINT was already given." + (file-exists? (hint-file hint))) + + +(define-command (guix-shell . args) + (category development) + (synopsis "spawn one-off software environments") + + (define (cache-entries directory) + (filter-map (match-lambda + ((or "." "..") #f) + (file (string-append directory "/" file))) + (or (scandir directory) '()))) + + (define* (entry-expiration file) + ;; Return the time at which FILE, a cached profile, is considered expired. + (match (false-if-exception (lstat file)) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) (* 60 60 24 7))))) + + (define opts + (parse-args args)) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (if (assoc-ref opts 'check?) + (record-hint 'shell-check) + (when (and interactive? + (not (hint-given? 'shell-check)) + (not (assoc-ref opts 'container?)) + (not (assoc-ref opts 'search-paths))) + (display-hint (G_ "Consider passing the @option{--check} option once +to make sure your shell does not clobber environment variables."))) ) + + ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use + ;; of cached profiles, and (2) cleanup actually happens, even when + ;; 'guix-environment*' calls 'exit'. + (add-hook! exit-hook + (lambda _ + (maybe-remove-expired-cache-entries + (%profile-cache-directory) + cache-entries + #:entry-expiration entry-expiration))) + + (guix-environment* opts)) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm new file mode 100644 index 0000000000..fb31c694f2 --- /dev/null +++ b/guix/scripts/style.scm @@ -0,0 +1,854 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 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/>. + +;;; Commentary: +;;; +;;; This script updates package definitions so they use the "simplified" style +;;; for input lists, as in: +;;; +;;; (package +;;; ;; ... +;;; (inputs (list foo bar baz))) +;;; +;;; Code: + +(define-module (guix scripts style) + #:autoload (gnu packages) (specification->package fold-packages) + #:use-module (guix scripts) + #:use-module ((guix scripts build) #:select (%standard-build-options)) + #:use-module (guix combinators) + #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (pretty-print-with-comments + read-with-comments + canonicalize-comment + + guix-style)) + + +;;; +;;; Comment-preserving reader. +;;; + +;; A comment. +(define-record-type <comment> + (comment str margin?) + comment? + (str comment->string) + (margin? comment-margin?)) + +(define (read-with-comments port) + "Like 'read', but include <comment> objects when they're encountered." + ;; Note: Instead of implementing this functionality in 'read' proper, which + ;; is the best approach long-term, this code is a later on top of 'read', + ;; such that we don't have to rely on a specific Guile version. + (let loop ((blank-line? #t) + (return (const 'unbalanced))) + (match (read-char port) + ((? eof-object? eof) + eof) ;oops! + (chr + (cond ((eqv? chr #\newline) + (loop #t return)) + ((char-set-contains? char-set:whitespace chr) + (loop blank-line? return)) + ((memv chr '(#\( #\[)) + (let/ec return + (let liip ((lst '())) + (liip (cons (loop (match lst + (((? comment?) . _) #t) + (_ #f)) + (lambda () + (return (reverse lst)))) + lst))))) + ((memv chr '(#\) #\])) + (return)) + ((eq? chr #\') + (list 'quote (loop #f return))) + ((eq? chr #\`) + (list 'quasiquote (loop #f return))) + ((eq? chr #\,) + (list (match (peek-char port) + (#\@ + (read-char port) + 'unquote-splicing) + (_ + 'unquote)) + (loop #f return))) + ((eqv? chr #\;) + (unread-char chr port) + (comment (read-line port 'concat) + (not blank-line?))) + (else + (unread-char chr port) + (read port))))))) + + +;;; +;;; Comment-preserving pretty-printer. +;;; + +(define-syntax vhashq + (syntax-rules (quote) + ((_) vlist-null) + ((_ (key (quote (lst ...))) rest ...) + (vhash-consq key '(lst ...) (vhashq rest ...))) + ((_ (key value) rest ...) + (vhash-consq key '((() . value)) (vhashq rest ...))))) + +(define %special-forms + ;; Forms that are indented specially. The number is meant to be understood + ;; like Emacs' 'scheme-indent-function' symbol property. When given an + ;; alist instead of a number, the alist gives "context" in which the symbol + ;; is a special form; for instance, context (modify-phases) means that the + ;; symbol must appear within a (modify-phases ...) expression. + (vhashq + ('begin 1) + ('lambda 2) + ('lambda* 2) + ('match-lambda 1) + ('match-lambda* 2) + ('define 2) + ('define* 2) + ('define-public 2) + ('define*-public 2) + ('define-syntax 2) + ('define-syntax-rule 2) + ('define-module 2) + ('define-gexp-compiler 2) + ('let 2) + ('let* 2) + ('letrec 2) + ('letrec* 2) + ('match 2) + ('when 2) + ('unless 2) + ('package 1) + ('origin 1) + ('operating-system 1) + ('modify-inputs 2) + ('modify-phases 2) + ('add-after '(((modify-phases) . 3))) + ('add-before '(((modify-phases) . 3))) + ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' + ('substitute* 2) + ('substitute-keyword-arguments 2) + ('call-with-input-file 2) + ('call-with-output-file 2) + ('with-output-to-file 2) + ('with-input-from-file 2))) + +(define %newline-forms + ;; List heads that must be followed by a newline. The second argument is + ;; the context in which they must appear. This is similar to a special form + ;; of 1, except that indent is 1 instead of 2 columns. + (vhashq + ('arguments '(package)) + ('sha256 '(origin source package)) + ('base32 '(sha256 origin)) + ('git-reference '(uri origin source)) + ('search-paths '(package)) + ('native-search-paths '(package)) + ('search-path-specification '()))) + +(define (prefix? candidate lst) + "Return true if CANDIDATE is a prefix of LST." + (let loop ((candidate candidate) + (lst lst)) + (match candidate + (() #t) + ((head1 . rest1) + (match lst + (() #f) + ((head2 . rest2) + (and (equal? head1 head2) + (loop rest1 rest2)))))))) + +(define (special-form-lead symbol context) + "If SYMBOL is a special form in the given CONTEXT, return its number of +arguments; otherwise return #f. CONTEXT is a stack of symbols lexically +surrounding SYMBOL." + (match (vhash-assq symbol %special-forms) + (#f #f) + ((_ . alist) + (any (match-lambda + ((prefix . level) + (and (prefix? prefix context) (- level 1)))) + alist)))) + +(define (newline-form? symbol context) + "Return true if parenthesized expressions starting with SYMBOL must be +followed by a newline." + (match (vhash-assq symbol %newline-forms) + (#f #f) + ((_ . prefix) + (prefix? prefix context)))) + +(define (escaped-string str) + "Return STR with backslashes and double quotes escaped. Everything else, in +particular newlines, is left as is." + (list->string + `(#\" + ,@(string-fold-right (lambda (chr lst) + (match chr + (#\" (cons* #\\ #\" lst)) + (#\\ (cons* #\\ #\\ lst)) + (_ (cons chr lst)))) + '() + str) + #\"))) + +(define (string-width str) + "Return the \"width\" of STR--i.e., the width of the longest line of STR." + (apply max (map string-length (string-split str #\newline)))) + +(define (canonicalize-comment c) + "Canonicalize comment C, ensuring it has the \"right\" number of leading +semicolons." + (let ((line (string-trim-both + (string-trim (comment->string c) (char-set #\;))))) + (comment (string-append + (if (comment-margin? c) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? c)))) + +(define* (pretty-print-with-comments port obj + #:key + (format-comment identity) + (indent 0) + (max-width 78) + (long-list 5)) + "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns +and assuming the current column is INDENT. Comments present in OBJ are +included in the output. + +Lists longer than LONG-LIST are written as one element per line. Comments are +passed through FORMAT-COMMENT before being emitted; a useful value for +FORMAT-COMMENT is 'canonicalize-comment'." + (let loop ((indent indent) + (column indent) + (delimited? #t) ;true if comes after a delimiter + (context '()) ;list of "parent" symbols + (obj obj)) + (define (print-sequence context indent column lst delimited?) + (define long? + (> (length lst) long-list)) + + (let print ((lst lst) + (first? #t) + (delimited? delimited?) + (column column)) + (match lst + (() + column) + ((item . tail) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is long, + ;; but only if ITEM is not the first item. Also insert a newline + ;; before a keyword. + (and (or (pair? item) long? + (and (keyword? item) + (not (eq? item #:allow-other-keys)))) + (not first?) (not delimited?) + (not (comment? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail #f + (comment? item) + (loop indent column + (or newline? delimited?) + context + item))))))) + + (define (sequence-would-protrude? indent lst) + ;; Return true if elements of LST written at INDENT would protrude + ;; beyond MAX-WIDTH. This is implemented as a cheap test with false + ;; negatives to avoid actually rendering all of LST. + (find (match-lambda + ((? string? str) + (>= (+ (string-width str) 2 indent) max-width)) + ((? symbol? symbol) + (>= (+ (string-width (symbol->string symbol)) indent) + max-width)) + ((? boolean?) + (>= (+ 2 indent) max-width)) + (() + (>= (+ 2 indent) max-width)) + (_ ;don't know + #f)) + lst)) + + (define (special-form? head) + (special-form-lead head context)) + + (match obj + ((? comment? comment) + (if (comment-margin? comment) + (begin + (display " " port) + (display (comment->string (format-comment comment)) + port)) + (begin + ;; When already at the beginning of a line, for example because + ;; COMMENT follows a margin comment, no need to emit a newline. + (unless (= column indent) + (newline port) + (display (make-string indent #\space) port)) + (display (comment->string (format-comment comment)) + port))) + (display (make-string indent #\space) port) + indent) + (('quote lst) + (unless delimited? (display " " port)) + (display "'" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('quasiquote lst) + (unless delimited? (display " " port)) + (display "`" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote lst) + (unless delimited? (display " " port)) + (display "," port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote-splicing lst) + (unless delimited? (display " " port)) + (display ",@" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('gexp lst) + (unless delimited? (display " " port)) + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('ungexp obj) + (unless delimited? (display " " port)) + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-native obj) + (unless delimited? (display " " port)) + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-splicing lst) + (unless delimited? (display " " port)) + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (('ungexp-native-splicing lst) + (unless delimited? (display " " port)) + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (((? special-form? head) arguments ...) + ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second + ;; and following arguments are less indented. + (let* ((lead (special-form-lead head context)) + (context (cons head context)) + (head (symbol->string head)) + (total (length arguments))) + (unless delimited? (display " " port)) + (display "(" port) + (display head port) + (unless (zero? lead) + (display " " port)) + + ;; Print the first LEAD arguments. + (let* ((indent (+ column 2 + (if delimited? 0 1))) + (column (+ column 1 + (if (zero? lead) 0 1) + (if delimited? 0 1) + (string-length head))) + (initial-indent column)) + (define new-column + (let inner ((n lead) + (arguments (take arguments (min lead total))) + (column column)) + (if (zero? n) + (begin + (newline port) + (display (make-string indent #\space) port) + indent) + (match arguments + (() column) + ((head . tail) + (inner (- n 1) tail + (loop initial-indent column + (= n lead) + context + head))))))) + + ;; Print the remaining arguments. + (let ((column (print-sequence + context indent new-column + (drop arguments (min lead total)) + #t))) + (display ")" port) + (+ column 1))))) + ((head tail ...) + (let* ((overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2)))) + (newline? (newline-form? head context)) + (context (cons head context))) + (if overflow? + (begin + (newline port) + (display (make-string indent #\space) port)) + (unless delimited? (display " " port))) + (display "(" port) + + (let* ((new-column (loop column column #t context head)) + (indent (if (or (>= new-column max-width) + (not (symbol? head)) + (sequence-would-protrude? + (+ new-column 1) tail) + newline?) + column + (+ new-column 1)))) + (when newline? + ;; Insert a newline right after HEAD. + (newline port) + (display (make-string indent #\space) port)) + + (let ((column + (print-sequence context indent + (if newline? indent new-column) + tail newline?))) + (display ")" port) + (+ column 1))))) + (_ + (let* ((str (if (string? obj) + (escaped-string obj) + (object->string obj))) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 0 1) len)))))))) + +(define (object->string* obj indent . args) + (call-with-output-string + (lambda (port) + (apply pretty-print-with-comments port obj + #:indent indent + args)))) + + +;;; +;;; Simplifying input expressions. +;;; + +(define (label-matches? label name) + "Return true if LABEL matches NAME, a package name." + (or (string=? label name) + (and (string-prefix? "python-" label) + (string-prefix? "python2-" name) + (string=? (string-drop label (string-length "python-")) + (string-drop name (string-length "python2-")))))) + +(define* (simplify-inputs location package str inputs + #:key (label-matches? label-matches?)) + "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current +value is INPUTS the corresponding source code is STR. Return a string to +replace STR." + (define (simplify-input-expression return) + (match-lambda + ((label ('unquote symbol)) symbol) + ((label ('unquote symbol) output) + (list 'quasiquote + (list (list 'unquote symbol) output))) + (_ + ;; Expression doesn't look like a simple input. + (warning location (G_ "~a: complex expression, \ +bailing out~%") + package) + (return str)))) + + (define (simplify-input exp input return) + (define package* package) + + (match input + ((or ((? string? label) (? package? package)) + ((? string? label) (? package? package) + (? string?))) + ;; If LABEL doesn't match PACKAGE's name, then simplifying would incur + ;; a rebuild, and perhaps it would break build-side code relying on + ;; this specific label. + (if (label-matches? label (package-name package)) + ((simplify-input-expression return) exp) + (begin + (warning location (G_ "~a: input label \ +'~a' does not match package name, bailing out~%") + package* label) + (return str)))) + (_ + (warning location (G_ "~a: non-trivial input, \ +bailing out~%") + package*) + (return str)))) + + (define (simplify-expressions exp inputs return) + ;; Simplify the expressions in EXP, which correspond to INPUTS, and return + ;; a list of expressions. Call RETURN with a string when bailing out. + (let loop ((result '()) + (exp exp) + (inputs inputs)) + (match exp + (((? comment? head) . rest) + (loop (cons head result) rest inputs)) + ((head . rest) + (match inputs + ((input . inputs) + ;; HEAD (an sexp) and INPUT (an input tuple) are correlated. + (loop (cons (simplify-input head input return) result) + rest inputs)) + (() + ;; If EXP and INPUTS have a different length, that + ;; means EXP is a non-trivial input list, for example + ;; with input-splicing, conditionals, etc. + (warning location (G_ "~a: input expression is too short~%") + package) + (return str)))) + (() + ;; It's possible for EXP to contain fewer elements than INPUTS, for + ;; example in the case of input splicing. No bailout here. (XXX) + (reverse result))))) + + (define inputs-exp + (call-with-input-string str read-with-comments)) + + (match inputs-exp + (('list _ ...) ;already done + str) + (('modify-inputs _ ...) ;already done + str) + (('quasiquote ;prepending inputs + (exp ... + ('unquote-splicing + ((and symbol (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg)))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (prepend ,@things))) + (location-column location)))) + (('quasiquote ;replacing an input + ((and exp ((? string? to-delete) ('unquote replacement))) + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions (list exp) + (list (car inputs)) + return))) + `(modify-inputs (,symbol ,arg) + (replace ,to-delete ,replacement))) + (location-column location)))) + + (('quasiquote ;removing an input + (exp ... + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,to-delete) + (prepend ,@things))) + (location-column location)))) + (('fold 'alist-delete ;removing several inputs + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...))) + (object->string* + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete)) + (location-column location))) + (('quasiquote ;removing several inputs and adding others + (exp ... + ('unquote-splicing + ('fold 'alist-delete + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...)))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete) + (prepend ,@things))) + (location-column location)))) + (('quasiquote (exp ...)) + (let/ec return + (object->string* + `(list ,@(simplify-expressions exp inputs return)) + (location-column location)))) + (_ + (warning location (G_ "~a: unsupported input style, \ +bailing out~%") + package) + str))) + +(define (edit-expression/dry-run properties rewrite-string) + "Like 'edit-expression' but display what would be edited without actually +doing it." + (edit-expression properties + (lambda (str) + (unless (string=? (rewrite-string str) str) + (info (source-properties->location properties) + (G_ "would be edited~%"))) + str))) + +(define (absolute-location loc) + "Replace the file name in LOC by an absolute location." + (location (if (string-prefix? "/" (location-file loc)) + (location-file loc) + (search-path %load-path (location-file loc))) + (location-line loc) + (location-column loc))) + +(define* (simplify-package-inputs package + #:key (policy 'silent) + (edit-expression edit-expression)) + "Edit the source code of PACKAGE to simplify its inputs field if needed. +POLICY is a symbol that defines whether to simplify inputs; it can one of +'silent (change only if the resulting derivation is the same), 'safe (change +only if semantics are known to be unaffected), and 'always (fearlessly +simplify inputs!). Call EDIT-EXPRESSION to actually edit the source of +PACKAGE." + (for-each (lambda (field-name field) + (match (field package) + (() + #f) + (inputs + (match (package-field-location package field-name) + (#f + ;; If the location of FIELD-NAME is not found, it may be + ;; that PACKAGE inherits from another package. + #f) + (location + (edit-expression + (location->source-properties (absolute-location location)) + (lambda (str) + (define matches? + (match policy + ('silent + ;; Simplify inputs only when the label matches + ;; perfectly, such that the resulting derivation + ;; is unchanged. + label-matches?) + ('safe + ;; If PACKAGE has no arguments, labels are known + ;; to have no effect: this is a "safe" change, but + ;; it may change the derivation. + (if (null? (package-arguments package)) + (const #t) + label-matches?)) + ('always + ;; Assume it's gonna be alright. + (const #t)))) + + (simplify-inputs location + (package-name package) + str inputs + #:label-matches? matches?)))))))) + '(inputs native-inputs propagated-inputs) + (list package-inputs package-native-inputs + package-propagated-inputs))) + + +;;; +;;; Formatting package definitions. +;;; + +(define* (format-package-definition package + #:key policy + (edit-expression edit-expression)) + "Reformat the definition of PACKAGE." + (unless (package-definition-location package) + (leave (package-location package) + (G_ "no definition location for package ~a~%") + (package-full-name package))) + + (edit-expression + (location->source-properties + (absolute-location (package-definition-location package))) + (lambda (str) + (let ((exp (call-with-input-string str + read-with-comments))) + (object->string* exp + (location-column + (package-definition-location package)) + #:format-comment canonicalize-comment))))) + +(define (package-location<? p1 p2) + "Return true if P1's location is \"before\" P2's." + (let ((loc1 (package-location p1)) + (loc2 (package-location p2))) + (and loc1 loc2 + (if (string=? (location-file loc1) (location-file loc2)) + (< (location-line loc1) (location-line loc2)) + (string<? (location-file loc1) (location-file loc2)))))) + + +;;; +;;; Options. +;;; + +(define %options + ;; Specification of the command-line options. + (list (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) + + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\S "styling") #t #f + (lambda (opt name arg result) + (alist-cons 'styling-procedure + (match arg + ("inputs" simplify-package-inputs) + ("format" format-package-definition) + (_ (leave (G_ "~a: unknown styling~%") + arg))) + result))) + (option '("input-simplification") #t #f + (lambda (opt name arg result) + (let ((symbol (string->symbol arg))) + (unless (memq symbol '(silent safe always)) + (leave (G_ "~a: invalid input simplification policy~%") + arg)) + (alist-cons 'input-simplification-policy symbol + result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix style"))))) + +(define (show-help) + (display (G_ "Usage: guix style [OPTION]... [PACKAGE]... +Update package definitions to the latest style.\n")) + (display (G_ " + -S, --styling=RULE apply RULE, a styling rule")) + (newline) + (display (G_ " + -n, --dry-run display files that would be edited but do nothing")) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (display (G_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (G_ " + --input-simplification=POLICY + follow POLICY for package input simplification, one + of 'silent', 'safe', or 'always'")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %default-options + ;; Alist of default option values. + `((input-simplification-policy . silent) + (styling-procedure . ,format-package-definition))) + + +;;; +;;; Entry point. +;;; + +(define-command (guix-style . args) + (category packaging) + (synopsis "update the style of package definitions") + + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (packages (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (('expression . str) + (read/eval str)) + (_ #f)) + opts)) + (edit (if (assoc-ref opts 'dry-run?) + edit-expression/dry-run + edit-expression)) + (style (assoc-ref opts 'styling-procedure)) + (policy (assoc-ref opts 'input-simplification-policy))) + (with-error-handling + (for-each (lambda (package) + (style package #:policy policy + #:edit-expression edit)) + ;; Sort package by source code location so that we start editing + ;; files from the bottom and going upward. That way, the + ;; 'location' field of <package> records is not invalidated as + ;; we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location<?)))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index c044e1d47a..908a8334a8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -237,7 +237,7 @@ was found." ;;; (define (show-help) - (display (G_ "Usage: guix substitute [OPTION]... + (display (G_ "Usage: guix substitute OPTION [ARGUMENT]... Internal tool to substitute a pre-built binary to a local build.\n")) (display (G_ " --query report on the availability of substitutes for the diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65eb98e4b2..414e931c8a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -57,6 +57,7 @@ #:use-module (guix build utils) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:use-module (gnu build image) #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) @@ -64,6 +65,7 @@ (device-module-aliases matching-modules) #:use-module (gnu system linux-initrd) #:use-module (gnu image) + #:use-module (gnu platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -253,7 +255,7 @@ the ownership of '~a' may be incorrect!~%") (install-bootloader local-eval bootloader bootcfg #:target target) (return - (info (G_ "bootloader successfully installed on '~a'~%") + (info (G_ "bootloader successfully installed on~{ ~a~}~%") (bootloader-configuration-targets bootloader)))))))) @@ -688,6 +690,8 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action image action #:key full-boot? + volatile? + (graphic? #t) container-shared-network? mappings) "Return as a monadic value the derivation for IMAGE according to ACTION." @@ -705,21 +709,18 @@ checking this by themselves in their 'check' procedure." ((vm) (system-qemu-image/shared-store-script os #:full-boot? full-boot? - #:disk-image-size - (if full-boot? - image-size - (* 70 (expt 2 20))) + #:volatile? volatile? + #:graphic? graphic? + #:disk-image-size image-size #:mappings mappings)) - ((image disk-image vm-image) + ((image disk-image vm-image docker-image) (when (eq? action 'disk-image) (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) (when (eq? action 'vm-image) (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) - (lower-object (system-image image))) - ((docker-image) - (system-docker-image os - #:memory-size 1024 - #:shared-network? container-shared-network?))))) + (when (eq? action 'docker-image) + (warning (G_ "'docker-image' is deprecated: use 'image' instead~%"))) + (lower-object (system-image image)))))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -771,6 +772,8 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? target full-boot? + volatile-vm-root? + (graphic? #t) container-shared-network? (mappings '()) (gc-root #f)) @@ -824,6 +827,9 @@ static checks." (mlet* %store-monad ((sys (system-derivation-for-action image action #:full-boot? full-boot? + #:volatile? + volatile-vm-root? + #:graphic? graphic? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -994,6 +1000,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --volatile for 'image', make the root file system volatile")) (display (G_ " + --persistent for 'vm', make the root file system persistent")) + (display (G_ " --label=LABEL for 'image', label disk image with LABEL")) (display (G_ " --save-provenance save provenance information")) @@ -1012,6 +1020,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --full-boot for 'vm', make a full boot sequence")) (display (G_ " + --no-graphic for 'vm', use the tty that we are started in for IO")) + (display (G_ " --skip-checks skip file system and initrd module safety checks")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -1073,13 +1083,19 @@ Some ACTIONS support additional ARGS.\n")) (alist-cons 'install-bootloader? #f result))) (option '("volatile") #f #f (lambda (opt name arg result) - (alist-cons 'volatile-root? #t result))) + (alist-cons 'volatile-image-root? #t result))) + (option '("persistent") #f #f + (lambda (opt name arg result) + (alist-cons 'volatile-vm-root? #f result))) (option '("label") #t #f (lambda (opt name arg result) (alist-cons 'label arg result))) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) + (option '("no-graphic") #f #f + (lambda (opt name arg result) + (alist-cons 'no-graphic? #t result))) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) @@ -1139,7 +1155,8 @@ Some ACTIONS support additional ARGS.\n")) (image-size . guess) (install-bootloader? . #t) (label . #f) - (volatile-root? . #f) + (volatile-image-root? . #f) + (volatile-vm-root? . #t) (graph-backend . "graphviz"))) (define (verbosity-level opts) @@ -1204,23 +1221,26 @@ resulting from command-line parsing." (label (assoc-ref opts 'label)) (image-type (lookup-image-type-by-name (assoc-ref opts 'image-type))) - (image (let* ((image-type (if (eq? action 'vm-image) - qcow2-image-type - image-type)) + (image (let* ((image-type (case action + ((vm-image) qcow2-image-type) + ((docker-image) docker-image-type) + (else image-type))) (image-size (assoc-ref opts 'image-size)) - (volatile? (assoc-ref opts 'volatile-root?)) + (volatile? + (assoc-ref opts 'volatile-image-root?)) + (shared-network? + (assoc-ref opts 'container-shared-network?)) (base-image (if (operating-system? obj) (os->image obj #:type image-type) - obj)) - (base-target (image-target base-image))) + obj))) (image (inherit (if label (image-with-label base-image label) base-image)) - (target (or base-target target)) (size image-size) - (volatile-root? volatile?)))) + (volatile-root? volatile?) + (shared-network? shared-network?)))) (os (image-operating-system image)) (target-file (match args ((first second) second) @@ -1267,6 +1287,9 @@ resulting from command-line parsing." #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) #:full-boot? (assoc-ref opts 'full-boot?) + #:volatile-vm-root? + (assoc-ref opts 'volatile-vm-root?) + #:graphic? (not (assoc-ref opts 'no-graphic?)) #:container-shared-network? (assoc-ref opts 'container-shared-network?) #:mappings (filter-map (match-lambda @@ -1307,7 +1330,7 @@ argument list and OPTS is the option alist." ((describe) (match (generation-number %system-profile) (0 - (error (G_ "no system generation, nothing to describe~%"))) + (leave (G_ "no system generation, nothing to describe~%"))) (generation (display-system-generation generation)))) ((search) diff --git a/guix/self.scm b/guix/self.scm index 5922ea6aa1..943bb0b498 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -64,6 +64,7 @@ ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'gnutls)) ("disarchive" (ref '(gnu packages backup) 'disarchive)) + ("guile-lzma" (ref '(gnu packages guile) 'guile-lzma)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) @@ -316,81 +317,23 @@ the result to OUTPUT." chr)) str)) - (define xref-regexp - ;; Texinfo cross-reference regexp. - (make-regexp "@(px|x)?ref\\{([^,}]+)")) - - (define (translate-cross-references texi translations) - ;; Translate the cross-references that appear in TEXI, a Texinfo - ;; file, using the msgid/msgstr pairs from TRANSLATIONS. - (define content - (call-with-input-file texi get-string-all)) - - (define matches - (list-matches xref-regexp content)) - - (define translation-map - (fold (match-lambda* - (((msgid . str) result) - (vhash-cons msgid str result))) - vlist-null - translations)) - - (define translated - ;; Iterate over MATCHES and replace cross-references with their - ;; translation found in TRANSLATION-MAP. (We can't use - ;; 'substitute*' because matches can span multiple lines.) - (let loop ((matches matches) - (offset 0) - (result '())) - (match matches - (() - (string-concatenate-reverse - (cons (string-drop content offset) result))) - ((head . tail) - (let ((prefix (match:substring head 1)) - (ref (canonicalize-whitespace (match:substring head 2)))) - (define translated - (string-append "@" (or prefix "") - "ref{" - (match (vhash-assoc ref translation-map) - (#f ref) - ((_ . str) str)))) - - (loop tail - (match:end head) - (append (list translated - (string-take - (string-drop content offset) - (- (match:start head) offset))) - result))))))) - - (format (current-error-port) - "translated ~a cross-references in '~a'~%" - (length matches) texi) - (call-with-output-file texi - (lambda (port) - (display translated port)))) - (define* (translate-texi prefix po lang #:key (extras '())) "Translate the manual for one language LANG using the PO file. PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'. EXTRAS is a list of extra files, such as '(\"contributing\")." - (let ((translations (call-with-input-file po read-po-file))) - (for-each (lambda (file) - (translate-tmp-texi po (string-append file ".texi") - (string-append file "." lang - ".texi.tmp"))) - (cons prefix extras)) + (for-each (lambda (file) + (translate-tmp-texi po (string-append file ".texi") + (string-append file "." lang + ".texi.tmp"))) + (cons prefix extras)) - (for-each (lambda (file) - (let* ((texi (string-append file "." lang ".texi")) - (tmp (string-append texi ".tmp"))) - (copy-file tmp texi) - (translate-cross-references texi - translations))) - (cons prefix extras)))) + (for-each (lambda (file) + (let* ((texi (string-append file "." lang ".texi")) + (tmp (string-append texi ".tmp"))) + (copy-file tmp texi) + (translate-cross-references texi po))) + (cons prefix extras))) (define (available-translations directory domain) ;; Return the list of available translations under DIRECTORY for @@ -847,6 +790,9 @@ itself." (define disarchive (specification->package "disarchive")) + (define guile-lzma + (specification->package "guile-lzma")) + (define dependencies (append-map transitive-package-dependencies (list guile-gcrypt gnutls guile-git guile-avahi @@ -961,20 +907,39 @@ itself." (define *home-modules* (scheme-node "guix-home" `((gnu home) - (gnu home-services) - ,@(scheme-modules* source "gnu/home-services")) + (gnu home services) + ,@(scheme-modules* source "gnu/home/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules* *system-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) + (define *core-cli-modules* + ;; Core command-line interface modules that do not depend on (gnu system + ;; …) or (gnu home …), and not even on *PACKAGE-MODULES*. + (scheme-node "guix-cli-core" + (remove (match-lambda + (('guix 'scripts 'system . _) #t) + (('guix 'scripts 'environment) #t) + (('guix 'scripts 'container . _) #t) + (('guix 'scripts 'deploy) #t) + (('guix 'scripts 'home . _) #t) + (('guix 'scripts 'import . _) #t) + (('guix 'pack) #t) + (_ #f)) + (scheme-modules* source "guix/scripts")) + (list *core-modules* *extra-modules* + *core-package-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *cli-modules* (scheme-node "guix-cli" (append (scheme-modules* source "/guix/scripts") `((gnu ci))) (list *core-modules* *extra-modules* *core-package-modules* *package-modules* - *system-modules* *home-modules*) + *core-cli-modules* *system-modules* *home-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) @@ -1020,6 +985,7 @@ itself." ;; comes with *CORE-MODULES*. (list *config* *cli-modules* + *core-cli-modules* *system-test-modules* *system-modules* *home-modules* @@ -1047,7 +1013,9 @@ itself." (command (guix-command modules #:source source #:dependencies - (cons disarchive dependencies) + (cons* disarchive + guile-lzma + dependencies) #:guile guile-for-build #:guile-version guile-version))) (whole-package name modules dependencies diff --git a/guix/status.scm b/guix/status.scm index f351a56d92..eefe18365f 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -381,6 +381,8 @@ the current build phase." (G_ "building CA certificate bundle...")) ('emacs-subdirs (G_ "listing Emacs sub-directories...")) + ('gdk-pixbuf-loaders-cache-file + (G_ "generating GdkPixbuf loaders cache...")) ('glib-schemas (G_ "generating GLib schema cache...")) ('gtk-icon-themes diff --git a/guix/store.scm b/guix/store.scm index 89a719bcfc..a93e9596d9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1349,11 +1349,18 @@ on the build output of a previous derivation." (things unresolved-things) (continuation unresolved-continuation)) -(define (build-accumulator continue store things mode) - "This build handler accumulates THINGS and returns an <unresolved> object." - (if (= mode (build-mode normal)) - (unresolved things continue) - (continue #t))) +(define (build-accumulator expected-store) + "Return a build handler that accumulates THINGS and returns an <unresolved> +object, only for build requests on EXPECTED-STORE." + (lambda (continue store things mode) + ;; Note: Do not compare STORE and EXPECTED-STORE with 'eq?' because + ;; 'cache-object-mapping' and similar functional "setters" change the + ;; store's object identity. + (if (and (eq? (store-connection-socket store) + (store-connection-socket expected-store)) + (= mode (build-mode normal))) + (unresolved things continue) + (continue #t)))) (define* (map/accumulate-builds store proc lst #:key (cutoff 30)) @@ -1366,13 +1373,16 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes." ;; stumbling upon the same .drv build requests with many incoming edges. ;; See <https://bugs.gnu.org/49439>. + (define accumulator + (build-accumulator store)) + (define-values (result rest) (let loop ((lst lst) (result '()) (unresolved 0)) (match lst ((head . tail) - (match (with-build-handler build-accumulator + (match (with-build-handler accumulator (proc head)) ((? unresolved? obj) (if (>= unresolved cutoff) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index cd9660174c..370df4a74c 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,12 +22,13 @@ (define-module (guix store deduplication) #:use-module (gcrypt hash) - #:use-module (guix build utils) + #:use-module ((guix build utils) #:hide (dump-port)) #:use-module (guix build syscalls) #:use-module (guix base32) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -37,6 +38,31 @@ dump-file/deduplicate copy-file/deduplicate)) +;; TODO: Remove once 'dump-port' in (guix build utils) has an optional 'len' +;; parameter. +(define* (dump-port in out + #:optional len + #:key (buffer-size 16384)) + "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it +to OUT, using chunks of BUFFER-SIZE bytes." + (define buffer + (make-bytevector buffer-size)) + + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))) + (or (eof-object? bytes) + (and len (= total len)) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (loop total + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size))))))) + (define (nar-sha256 file) "Gives the sha256 hash of a file and the size of the file in nar form." (let-values (((port get-hash) (open-sha256-port))) @@ -127,11 +153,27 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." (unless (= EMLINK (system-error-errno args)) (apply throw args))))))) +(define %deduplication-minimum-size + ;; Size below which files are not deduplicated. This avoids adding too many + ;; entries to '.links', which would slow down 'removeUnusedLinks' while + ;; saving little space. Keep in sync with optimize-store.cc. + 8192) + (define* (deduplicate path hash #:key (store (%store-directory))) "Check if a store item with sha256 hash HASH already exists. If so, replace PATH with a hardlink to the already-existing one. If not, register PATH so that future duplicates can hardlink to it. PATH is assumed to be under STORE." + ;; Lightweight promises. + (define-syntax-rule (delay exp) + (let ((value #f)) + (lambda () + (unless value + (set! value exp)) + value))) + (define-syntax-rule (force promise) + (promise)) + (define links-directory (string-append store "/.links")) @@ -144,13 +186,18 @@ under STORE." ((file . properties) (unless (member file '("." "..")) (let* ((file (string-append path "/" file)) + (st (delay (lstat file))) (type (match (assoc-ref properties 'type) ((or 'unknown #f) - (stat:type (lstat file))) + (stat:type (force st))) (type type)))) - (loop file type - (and (not (eq? 'directory type)) - (nar-sha256 file))))))) + (when (or (eq? 'directory type) + (and (eq? 'regular type) + (>= (stat:size (force st)) + %deduplication-minimum-size))) + (loop file type + (and (not (eq? 'directory type)) + (nar-sha256 file)))))))) (scandir* path)) (let ((link-file (string-append links-directory "/" (bytevector->nix-base32-string hash)))) @@ -222,9 +269,9 @@ OUTPUT as it goes." This procedure is suitable as a #:dump-file argument to 'restore-file'. When used that way, it deduplicates files on the fly as they are restored, thereby -removing the need to a deduplication pass that would re-read all the files +removing the need for a deduplication pass that would re-read all the files down the road." - (define hash + (define (dump-and-compute-hash) (call-with-output-file file (lambda (output) (let-values (((hash-port get-hash) @@ -236,7 +283,11 @@ down the road." (close-port hash-port) (get-hash))))) - (deduplicate file hash #:store store)) + (if (>= size %deduplication-minimum-size) + (deduplicate file (dump-and-compute-hash) #:store store) + (call-with-output-file file + (lambda (output) + (dump-port input output size))))) (define* (copy-file/deduplicate source target #:key (store (%store-directory))) diff --git a/guix/store/roots.scm b/guix/store/roots.scm index 58653507f8..222f69c5c0 100644 --- a/guix/store/roots.scm +++ b/guix/store/roots.scm @@ -50,7 +50,7 @@ (define (gc-roots) "Return the list of garbage collector roots (\"GC roots\"). This includes -\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that +\"regular\" roots found in %GC-ROOTS-DIRECTORY as well as indirect roots that are user-controlled symlinks stored anywhere on the file system." (define (regular? file) (match file diff --git a/guix/substitutes.scm b/guix/substitutes.scm index a5c554acff..9014cf61ec 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -156,7 +156,11 @@ indicates that PATH is unavailable at CACHE-URL." (define (narinfo-request cache-url path) "Return an HTTP request for the narinfo of PATH at CACHE-URL." - (let* ((base (string->uri cache-url)) + ;; Ensure BASE has a trailing slash so that REF is correct regardless of + ;; whether the user-provided CACHE-URL has a trailing slash. + (let* ((base (string->uri (if (string-suffix? "/" cache-url) + cache-url + (string-append cache-url "/")))) (ref (build-relative-ref #:path (string-append (store-path-hash-part path) ".narinfo"))) (url (resolve-uri-reference ref base)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index b96151234c..55ce0d7351 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> -;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +26,9 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module ((guix build svn) #:prefix build:) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (svn-reference svn-reference? svn-reference-url @@ -41,7 +43,8 @@ svn-multi-reference-revision svn-multi-reference-locations svn-multi-reference-recursive? - svn-multi-fetch)) + svn-multi-fetch + download-multi-svn-to-store)) ;;; Commentary: ;;; @@ -134,7 +137,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #$(svn-multi-reference-recursive? ref) #:user-name #$(svn-multi-reference-user-name ref) #:password #$(svn-multi-reference-password ref))) - '#$(svn-multi-reference-locations ref))))) + '#$(sexp->gexp (svn-multi-reference-locations ref)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build @@ -166,4 +169,28 @@ reports to LOG." (add-to-store store name #t "sha256" (string-append temp "/svn"))))))) +(define* (download-multi-svn-to-store store ref + #:optional (name (basename (svn-multi-reference-url ref))) + #:key (log (current-error-port))) + "Download from REF, a <svn-multi-reference> object to STORE. Write progress +reports to LOG." + (call-with-temporary-directory + (lambda (temp) + (and (every (lambda (location) + (let ((dir (string-append temp "/" (dirname location)))) + (mkdir-p dir)) + (parameterize ((current-output-port log)) + (build:svn-fetch (string-append (svn-multi-reference-url ref) + "/" location) + (svn-multi-reference-revision ref) + (if (string-suffix? "/" location) + (string-append temp "/" location) + (string-append temp "/" (dirname location))) + #:recursive? + (svn-multi-reference-recursive? ref) + #:user-name (svn-multi-reference-user-name ref) + #:password (svn-multi-reference-password ref)))) + (svn-multi-reference-locations ref)) + (add-to-store store name #t "sha256" temp))))) + ;;; svn-download.scm ends here diff --git a/guix/swh.scm b/guix/swh.scm index 5c41685a24..c7c1c873a2 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -136,6 +137,12 @@ ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL. (make-parameter #t)) +;; Token from an account to the Software Heritage Authentication service +;; <https://archive.softwareheritage.org/api/> +(define %swh-token + (make-parameter (and=> (getenv "GUIX_SWH_TOKEN") + string->symbol))) + (define (swh-url path . rest) ;; URLs returned by the API may be relative or absolute. This has changed ;; without notice before. Handle both cases by detecting whether the path @@ -246,6 +253,10 @@ FALSE-IF-404? is true, return #f upon 404 responses." (and ((%allow-request?) url method) (let*-values (((response port) (method url #:streaming? #t + #:headers + (if (%swh-token) + `((authorization . (Bearer ,(%swh-token)))) + '()) #:verify-certificate? (%verify-swh-certificate?)))) ;; See <https://archive.softwareheritage.org/api/#rate-limiting>. diff --git a/guix/tests.scm b/guix/tests.scm index fc3d521163..4cd1ad6cf9 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,12 +20,13 @@ #:use-module ((guix config) #:select (%storedir %localstatedir)) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) #:use-module (guix monads) #:use-module ((guix utils) #:select (substitute-keyword-arguments)) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) #:select (mkdir-p compressor)) #:use-module ((gcrypt hash) #:hide (sha256)) #:use-module (guix build-system gnu) #:use-module (gnu packages base) @@ -60,7 +61,9 @@ dummy-package dummy-origin - gnu-make-for-tests)) + gnu-make-for-tests + + test-file)) ;;; Commentary: ;;; @@ -135,17 +138,21 @@ no external store to talk to." (open-connection)) (const #f))) - (dynamic-wind - (const #t) - (lambda () - ;; Since we're using a different store we must clear the - ;; package-derivation cache. - (hash-clear! (@@ (guix packages) %derivation-cache)) - - (proc store)) - (lambda () - (when store - (close-connection store)))))) + (let ((store-variable (getenv "NIX_STORE_DIR"))) + (dynamic-wind + (lambda () + ;; This environment variable is set by 'pre-inst-env' but it + ;; influences '%store-directory' in (guix build utils), which is + ;; itself used in (guix packages). Thus, unset it before going any + ;; further. + (unsetenv "NIX_STORE_DIR")) + (lambda () + (proc store)) + (lambda () + (when store-variable + (setenv "NIX_STORE_DIR" store-variable)) + (when store + (close-connection store))))))) (define-syntax-rule (with-external-store store exp ...) "Evaluate EXP with STORE bound to the external store rather than the @@ -182,18 +189,22 @@ too expensive to build entirely in the test store." (loop (1+ i))) bv)))) -(define (file=? a b) - "Return true if files A and B have the same type and same content." - (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) - (case (stat:type (lstat a)) - ((regular) - (equal? - (call-with-input-file a get-bytevector-all) - (call-with-input-file b get-bytevector-all))) - ((symlink) - (string=? (readlink a) (readlink b))) - (else - (error "what?" (lstat a)))))) +(define* (file=? a b #:optional (stat lstat)) + "Return true if files A and B have the same type and same content. Call +STAT to obtain file metadata." + (let ((sta (stat a)) (stb (stat b))) + (and (eq? (stat:type sta) (stat:type stb)) + (case (stat:type sta) + ((regular) + (or (and (= (stat:ino sta) (stat:ino stb)) + (= (stat:dev sta) (stat:dev stb))) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all)))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (stat a))))))) (define (canonical-file? file) "Return #t if FILE is in the store, is read-only, and its mtime is 1." @@ -435,6 +446,42 @@ default values, and with EXTRA-FIELDS set as specified." (native-inputs '()) ;no need for 'pkg-config' (inputs %bootstrap-inputs-for-tests)))) + +;;; +;;; Test utility procedures. + +(define (test-file store name content) + "Create a simple file in STORE with CONTENT (a string), compressed according +to its file name extension. Return both its file name and its hash." + (let* ((ext (string-index-right name #\.)) + (name-sans-ext (if ext + (string-take name (string-index-right name #\.)) + name)) + (comp (compressor name)) + (command #~(if #+comp + (string-append #+%bootstrap-coreutils&co + "/bin/" #+comp) + #f)) + (f (with-imported-modules '((guix build utils)) + (computed-file name + #~(begin + (use-modules (guix build utils) + (rnrs io simple)) + (with-output-to-file #+name-sans-ext + (lambda _ + (format #t #+content))) + (when #+command + (invoke #+command #+name-sans-ext)) + (copy-file #+name #$output))))) + (file-drv (run-with-store store (lower-object f))) + (file (derivation->output-path file-drv)) + (file-drv-outputs (derivation-outputs file-drv)) + (_ (build-derivations store (list file-drv))) + (file-hash (derivation-output-hash + (assoc-ref file-drv-outputs "out")))) + (values file file-hash))) + +;;; ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 69960284d9..94f1021c79 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -23,9 +23,10 @@ #:use-module (guix utils) #:use-module (guix build utils) #:use-module (ice-9 match) - #:use-module (ice-9 control) + #:use-module ((ice-9 control) #:select (let/ec)) #:export (git-command with-temporary-git-repository + with-git-repository find-commit)) (define git-command @@ -59,8 +60,9 @@ Return DIRECTORY on success." (apply invoke (git-command) "-C" directory command args))))) - (mkdir-p directory) - (git "init") + (unless (directory-exists? (string-append directory "/.git")) + (mkdir-p directory) + (git "init")) (let loop ((directives directives)) (match directives @@ -78,6 +80,9 @@ Return DIRECTORY on success." port))) (git "add" file) (loop rest))) + ((('add file-name-and-content) rest ...) + (loop (cons `(add ,file-name-and-content ,file-name-and-content) + rest))) ((('remove file) rest ...) (git "rm" "-f" file) (loop rest)) @@ -99,12 +104,18 @@ Return DIRECTORY on success." ((('checkout branch) rest ...) (git "checkout" branch) (loop rest)) + ((('checkout branch 'orphan) rest ...) + (git "checkout" "--orphan" branch) + (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)) + ((('reset to) rest ...) + (git "reset" "--hard" to) (loop rest))))) (define (call-with-temporary-git-repository directives proc) @@ -121,6 +132,14 @@ per DIRECTIVES." (lambda (directory) exp ...))) +(define-syntax-rule (with-git-repository directory + directives exp ...) + "Evaluate EXP in a context where DIRECTORY is (further) populated as +per DIRECTIVES." + (begin + (populate-git-repository directory directives) + exp ...)) + (define (find-commit repository message) "Return the commit in REPOSITORY whose message includes MESSAGE, a string." (let/ec return diff --git a/guix/tests/gnupg.scm b/guix/tests/gnupg.scm index eb8ff63a43..09f02a2b67 100644 --- a/guix/tests/gnupg.scm +++ b/guix/tests/gnupg.scm @@ -28,11 +28,14 @@ %ed25519-public-key-file %ed25519-secret-key-file - %ed25519bis-public-key-file - %ed25519bis-secret-key-file + %ed25519-2-public-key-file + %ed25519-2-secret-key-file + %ed25519-3-public-key-file + %ed25519-3-secret-key-file read-openpgp-packet key-fingerprint + key-fingerprint-vector key-id)) (define gpg-command @@ -63,20 +66,27 @@ process is terminated afterwards." (call-with-fresh-gnupg-setup imported (lambda () exp ...))) (define %ed25519-public-key-file - (search-path %load-path "tests/ed25519.key")) + (search-path %load-path "tests/keys/ed25519.pub")) (define %ed25519-secret-key-file - (search-path %load-path "tests/ed25519.sec")) -(define %ed25519bis-public-key-file - (search-path %load-path "tests/ed25519bis.key")) -(define %ed25519bis-secret-key-file - (search-path %load-path "tests/ed25519bis.sec")) + (search-path %load-path "tests/keys/ed25519.sec")) +(define %ed25519-2-public-key-file + (search-path %load-path "tests/keys/ed25519-2.pub")) +(define %ed25519-2-secret-key-file + (search-path %load-path "tests/keys/ed25519-2.sec")) +(define %ed25519-3-public-key-file + (search-path %load-path "tests/keys/ed25519-3.pub")) +(define %ed25519-3-secret-key-file + (search-path %load-path "tests/keys/ed25519-3.sec")) (define (read-openpgp-packet file) (get-openpgp-packet (open-bytevector-input-port (call-with-input-file file read-radix-64)))) +(define key-fingerprint-vector + (compose openpgp-public-key-fingerprint + read-openpgp-packet)) + (define key-fingerprint (compose openpgp-format-fingerprint - openpgp-public-key-fingerprint - read-openpgp-packet)) + key-fingerprint-vector)) diff --git a/guix/transformations.scm b/guix/transformations.scm index 5ae1977cb2..0976f0d824 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -18,9 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix transformations) + #:use-module ((guix config) #:select (%system)) #:use-module (guix i18n) #:use-module (guix store) #:use-module (guix packages) + #:use-module (guix build-system) #:use-module (guix profiles) #:use-module (guix diagnostics) #:autoload (guix download) (download-to-store) @@ -29,6 +31,7 @@ #:autoload (guix upstream) (package-latest-release upstream-source-version upstream-source-signature-urls) + #:autoload (guix cpu) (current-cpu cpu->gcc-architecture) #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix gexp) @@ -49,7 +52,11 @@ #:export (options->transformation manifest-entry-with-transformations + tunable-package? + tuned-package + show-transformation-options-help + transformation-option-key? %transformation-options)) ;;; Commentary: @@ -419,6 +426,181 @@ the equal sign." obj) obj))) +(define tuning-compiler + (mlambda (micro-architecture) + "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the +actual compiler." + (define wrapper + #~(begin + (use-modules (ice-9 match)) + + (define* (search-next command + #:optional + (path (string-split (getenv "PATH") + #\:))) + ;; Search the next COMMAND on PATH, a list of + ;; directories representing the executable search path. + (define this + (stat (car (command-line)))) + + (let loop ((path path)) + (match path + (() + (match command + ("cc" (search-next "gcc")) + (_ #f))) + ((directory rest ...) + (let* ((file (string-append + directory "/" command)) + (st (stat file #f))) + (if (and st (not (equal? this st))) + file + (loop rest))))))) + + (match (command-line) + ((command arguments ...) + (match (search-next (basename command)) + (#f (exit 127)) + (next + (apply execl next + (append (cons next arguments) + (list (string-append "-march=" + #$micro-architecture)))))))))) + + (define program + (program-file (string-append "tuning-compiler-wrapper-" micro-architecture) + wrapper)) + + (computed-file (string-append "tuning-compiler-" micro-architecture) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define bin (string-append #$output "/bin")) + (mkdir-p bin) + + (for-each (lambda (program) + (symlink #$program + (string-append bin "/" program))) + '("cc" "gcc" "clang" "g++" "c++" "clang++"))))))) + +(define (build-system-with-tuning-compiler bs micro-architecture) + "Return a variant of BS, a build system, that ensures that the compiler that +BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE, +which names a specific CPU of the target architecture--e.g., when targeting +86_64 MICRO-ARCHITECTURE might be \"skylake\". If it does, return a build +system that builds code for MICRO-ARCHITECTURE; otherwise raise an error." + (define %not-hyphen + (char-set-complement (char-set #\-))) + + (define lower + (build-system-lower bs)) + + (define (lower* . args) + ;; The list of CPU names supported by the '-march' option of C/C++ + ;; compilers is specific to each compiler and version thereof. Rather + ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly + ;; leading to an obscure build error, check whether the compiler is known + ;; to support MICRO-ARCHITECTURE. If not, bail out. + (let* ((lowered (apply lower args)) + (architecture (match (string-tokenize (bag-system lowered) + %not-hyphen) + ((arch _ ...) arch))) + (compiler (any (match-lambda + ((label (? package? p) . _) + (and (assoc-ref (package-properties p) + 'compiler-cpu-architectures) + p)) + (_ #f)) + (bag-build-inputs lowered)))) + (unless compiler + (raise (formatted-message + (G_ "failed to determine which compiler is used")))) + + (let ((lst (assoc-ref (package-properties compiler) + 'compiler-cpu-architectures))) + (unless lst + (raise (formatted-message + (G_ "failed to determine whether ~a supports ~a") + (package-full-name compiler) + micro-architecture))) + (unless (member micro-architecture + (or (assoc-ref lst architecture) '())) + (raise (formatted-message + (G_ "compiler ~a does not support micro-architecture ~a") + (package-full-name compiler) + micro-architecture)))) + + (bag + (inherit lowered) + (build-inputs + ;; Arrange so that the compiler wrapper comes first in $PATH. + `(("tuning-compiler" ,(tuning-compiler micro-architecture)) + ,@(bag-build-inputs lowered)))))) + + (build-system + (inherit bs) + (lower lower*))) + +(define (tuned-package p micro-architecture) + "Return package P tuned for MICRO-ARCHITECTURE." + (package + (inherit p) + (build-system + (build-system-with-tuning-compiler (package-build-system p) + micro-architecture)) + (arguments + ;; The machine building this package may or may not be able to run code + ;; for MICRO-ARCHITECTURE. Because of that, skip tests; they are run for + ;; the "baseline" variant anyway. + (substitute-keyword-arguments (package-arguments p) + ((#:tests? _ #f) #f))) + + (properties + `((cpu-tuning . ,micro-architecture) + + ;; Remove the 'tunable?' property so that 'package-tuning' does not + ;; call 'tuned-package' again on this one. + ,@(alist-delete 'tunable? (package-properties p)))))) + +(define (tunable-package? package) + "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the +host CPU is worthwhile." + (assq 'tunable? (package-properties package))) + +(define package-tuning + (mlambda (micro-architecture) + "Return a procedure that maps the given package to its counterpart tuned +for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'." + (define rewriting-property + (gensym " package-tuning")) + + (package-mapping (lambda (p) + (cond ((assq rewriting-property (package-properties p)) + p) + ((assq 'tunable? (package-properties p)) + (info (G_ "tuning ~a for CPU ~a~%") + (package-full-name p) micro-architecture) + (package/inherit p + (replacement (tuned-package p micro-architecture)) + (properties `((,rewriting-property . #t) + ,@(package-properties p))))) + (else + p))) + (lambda (p) + (assq rewriting-property (package-properties p))) + #:deep? #t))) + +(define (transform-package-tuning micro-architectures) + "Return a procedure that, when " + (match micro-architectures + ((micro-architecture _ ...) + (let ((rewrite (package-tuning micro-architecture))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))))) + (define (transform-package-with-debug-info specs) "Return a procedure that, when passed a package, set its 'replacement' field to the same package but with #:strip-binaries? #f in its 'arguments' field." @@ -601,6 +783,7 @@ are replaced by their latest upstream version." (with-commit . ,transform-package-source-commit) (with-git-url . ,transform-package-source-git-url) (with-c-toolchain . ,transform-package-toolchain) + (tune . ,transform-package-tuning) (with-debug-info . ,transform-package-with-debug-info) (without-tests . ,transform-package-tests) (with-patch . ,transform-package-patches) @@ -614,6 +797,12 @@ are replaced by their latest upstream version." (and (eq? k key) proc))) %transformations)) +(define (transformation-option-key? key) + "Return true if KEY is an option key (as returned while parsing options with +%TRANSFORMATION-OPTIONS) corresponding to a package transformation option. +For example, (transformation-option-key? 'with-input) => #t." + (->bool (transformation-procedure key))) + ;;; ;;; Command-line handling. @@ -640,6 +829,28 @@ are replaced by their latest upstream version." (parser 'with-git-url)) (option '("with-c-toolchain") #t #f (parser 'with-c-toolchain)) + (option '("tune") #f #t + (lambda (opt name arg result . rest) + (define micro-architecture + (match arg + ((or #f "native") + (unless (string=? (or (assoc-ref result 'system) + (%current-system)) + %system) + (leave (G_ "\ +building for ~a instead of ~a, so tuning cannot be guessed~%") + (assoc-ref result 'system) %system)) + + (cpu->gcc-architecture (current-cpu))) + ("generic" #f) + (_ arg))) + + (apply values + (if micro-architecture + (alist-cons 'tune micro-architecture + result) + (alist-delete 'tune result)) + rest))) (option '("with-debug-info") #t #f (parser 'with-debug-info)) (option '("without-tests") #t #f diff --git a/guix/ui.scm b/guix/ui.scm index 1428c254b3..093de1b4ab 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> @@ -377,7 +377,8 @@ ARGS is the list of arguments received by the 'throw' handler." (+ 2 (string-contains message ": "))))) (format (current-error-port) (G_ "~amissing closing parenthesis~%") location)) - (apply throw args))) + (report-error (G_ "read error while loading '~a': ~a~%") + file (apply format #f message args)))) (('syntax-error proc message properties form subform . rest) (let ((loc (source-properties->location properties))) (report-error loc (G_ "~s: ~a~%") @@ -520,7 +521,7 @@ See the \"Application Setup\" section in the manual, for more info.\n")) "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (format #t "Copyright ~a 2021 ~a" + (format #t "Copyright ~a 2022 ~a" ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ @@ -939,7 +940,7 @@ warning." (define (colorize-store-file-name file) "Colorize FILE, a store file name, such that the hash part is less prominent -that the rest." +than the rest." (let ((len (string-length file)) (prefix (+ (string-length (%store-prefix)) 32 2))) (if (< len prefix) @@ -1431,10 +1432,22 @@ converted to a space; sequences of more than one line break are preserved." (with-fluids ((%default-port-encoding "UTF-8")) (stexi->plain-text (texi-fragment->stexi str)))) +(define (texi->plain-text* package str) + "Same as 'texi->plain-text', but gracefully handle Texinfo errors." + (catch 'parser-error + (lambda () + (texi->plain-text str)) + (lambda args + (warning (package-location package) + (G_ "~a: invalid Texinfo markup~%") + (package-full-name package)) + str))) + (define (package-field-string package field-accessor) "Return a plain-text representation of PACKAGE field." (and=> (field-accessor package) - (compose texi->plain-text P_))) + (lambda (str) + (texi->plain-text* package (P_ str))))) (define (package-description-string package) "Return a plain-text representation of PACKAGE description field." @@ -1501,13 +1514,15 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." ;; the initial "+ " prefix. (if (> width 2) (- width 2) width)) + (define (split-lines str indent) + (string->recutils + (fill-paragraph str width* indent))) + (define (dependencies->recutils packages) (let ((list (string-join (delete-duplicates (map package-full-name (sort packages package<?))) " "))) - (string->recutils - (fill-paragraph list width* - (string-length "dependencies: "))))) + (split-lines list (string-length "dependencies: ")))) (define (package<? p1 p2) (string<? (package-full-name p1) (package-full-name p2))) @@ -1517,7 +1532,8 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (format port "version: ~a~%" (package-version p)) (format port "outputs: ~a~%" (string-join (package-outputs p))) (format port "systems: ~a~%" - (string-join (package-transitive-supported-systems p))) + (split-lines (string-join (package-transitive-supported-systems p)) + (string-length "systems: "))) (format port "dependencies: ~a~%" (match (package-direct-inputs p) (((labels inputs . _) ...) @@ -1555,7 +1571,8 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (parameterize ((%text-width width*)) ;; Call 'texi->plain-text' on the concatenated string to account ;; for the width of "description:" in paragraph filling. - (texi->plain-text + (texi->plain-text* + p (string-append "description: " (or (and=> (package-description p) P_) "")))) @@ -2085,10 +2102,17 @@ contain a 'define-command' form." (lambda (command) (eq? category (command-category command)))) - (format #t (G_ "Usage: guix COMMAND ARGS... -Run COMMAND with ARGS.\n")) + (display (G_ "Usage: guix OPTION | COMMAND ARGS... +Run COMMAND with ARGS, if given.\n")) + + (display (G_ " + -h, --help display this helpful text again and exit")) + (display (G_ " + -V, --version display version and copyright information and exit")) + (newline) + (newline) - (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) + (display (G_ "COMMAND must be one of the sub-commands listed below:\n")) (let ((commands (commands)) (categories (module-ref (resolve-interface '(guix scripts)) diff --git a/guix/upstream.scm b/guix/upstream.scm index 632e9ebc4f..6666803a92 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,7 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> -;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,12 +26,15 @@ #:use-module (guix discovery) #:use-module ((guix download) #:select (download-to-store url-fetch)) + #:use-module (guix git-download) #:use-module (guix gnupg) #:use-module (guix packages) #:use-module (guix diagnostics) #:use-module (guix ui) #:use-module (guix base32) #:use-module (guix gexp) + #:autoload (guix git) (latest-repository-commit git-reference->git-checkout) + #:use-module (guix hash) #:use-module (guix store) #:use-module ((guix derivations) #:select (built-derivations derivation->output-path)) #:autoload (gcrypt hash) (port-sha256) @@ -93,7 +98,7 @@ upstream-source? (package upstream-source-package) ;string (version upstream-source-version) ;string - (urls upstream-source-urls) ;list of strings + (urls upstream-source-urls) ;list of strings|git-reference (signature-urls upstream-source-signature-urls ;#f | list of strings (default #f)) (input-changes upstream-source-input-changes @@ -117,16 +122,22 @@ S-expression PACKAGE-SEXP." (match expr ((path *** ('inputs ('quasiquote ((label ('unquote sym)) ...)))) label) + ((path *** ('inputs + ('list sym ...))) (map symbol->string sym)) (_ '()))) (new-native (match expr ((path *** ('native-inputs ('quasiquote ((label ('unquote sym)) ...)))) label) + ((path *** ('native-inputs + ('list sym ...))) (map symbol->string sym)) (_ '()))) (new-propagated (match expr ((path *** ('propagated-inputs ('quasiquote ((label ('unquote sym)) ...)))) label) + ((path *** ('propagated-inputs + ('list sym ...))) (map symbol->string sym)) (_ '()))) (current-regular (map input->name (package-inputs package))) @@ -357,10 +368,9 @@ values: 'interactive' (default), 'always', and 'never'." data url) #f))))))) -(define-gexp-compiler (upstream-source-compiler (source <upstream-source>) - system target) - "Download SOURCE from its first URL and lower it as a fixed-output -derivation that would fetch it." +(define (upstream-source-compiler/url-fetch source system) + "Lower SOURCE, an <upstream-source> pointing to a tarball, as a +fixed-output derivation that would fetch it, and verify its authenticity." (mlet* %store-monad ((url -> (first (upstream-source-urls source))) (signature -> (and=> (upstream-source-signature-urls source) @@ -378,6 +388,30 @@ derivation that would fetch it." (url-fetch url 'sha256 hash (store-path-package-name tarball) #:system system)))) +(define (upstream-source-compiler/git-fetch source system) + "Lower SOURCE, an <upstream-source> using git, as a fixed-output +derivation that would fetch it." + (mlet* %store-monad ((reference -> (upstream-source-urls source)) + (checkout + (lower-object + (git-reference->git-checkout reference) + system))) + ;; Like in 'upstream-source-compiler/url-fetch', return a fixed-output + ;; derivation instead of CHECKOUT. + (git-fetch reference 'sha256 + (file-hash* checkout #:recursive? #true #:select? (const #true)) + (git-file-name (upstream-source-package source) + (upstream-source-version source)) + #:system system))) + +(define-gexp-compiler (upstream-source-compiler (source <upstream-source>) + system target) + "Download SOURCE, lower it as a fixed-output derivation that would fetch it, +and verify its authenticity if possible." + (if (git-reference? (upstream-source-urls source)) + (upstream-source-compiler/git-fetch source system) + (upstream-source-compiler/url-fetch source system))) + (define (find2 pred lst1 lst2) "Like 'find', but operate on items from both LST1 and LST2. Return two values: the item from LST1 and the item from LST2 that match PRED." @@ -430,9 +464,24 @@ SOURCE, an <upstream-source>." #:key-download key-download))) (values version tarball source)))))) +(define* (package-update/git-fetch store package source #:key key-download) + "Return the version, checkout, and SOURCE, to update PACKAGE to +SOURCE, an <upstream-source>." + ;; TODO: it would be nice to authenticate commits, e.g. with + ;; "guix git authenticate" or a list of permitted signing keys. + (define ref (upstream-source-urls source)) ; a <git-reference> + (values (upstream-source-version source) + (latest-repository-commit + store + (git-reference-url ref) + #:ref `(tag-or-commit . ,(git-reference-commit ref)) + #:recursive? (git-reference-recursive? ref)) + source)) + (define %method-updates ;; Mapping of origin methods to source update procedures. - `((,url-fetch . ,package-update/url-fetch))) + `((,url-fetch . ,package-update/url-fetch) + (,git-fetch . ,package-update/git-fetch))) (define* (package-update store package #:optional (updaters (force %updaters)) @@ -492,9 +541,22 @@ new version string if an update was made, and #f otherwise." (origin-hash (package-source package)))) (old-url (match (origin-uri (package-source package)) ((? string? url) url) + ((? git-reference? ref) + (git-reference-url ref)) (_ #f))) (new-url (match (upstream-source-urls source) - ((first _ ...) first))) + ((first _ ...) first) + ((? git-reference? ref) + (git-reference-url ref)) + (_ #f))) + (old-commit (match (origin-uri (package-source package)) + ((? git-reference? ref) + (git-reference-commit ref)) + (_ #f))) + (new-commit (match (upstream-source-urls source) + ((? git-reference? ref) + (git-reference-commit ref)) + (_ #f))) (file (and=> (location-file loc) (cut search-path %load-path <>)))) (if file @@ -508,6 +570,9 @@ new version string if an update was made, and #f otherwise." 'filename file)) (replacements `((,old-version . ,version) (,old-hash . ,hash) + ,@(if (and old-commit new-commit) + `((,old-commit . ,new-commit)) + '()) ,@(if (and old-url new-url) `((,(dirname old-url) . ,(dirname new-url))) diff --git a/guix/utils.scm b/guix/utils.scm index 2920fa7684..cba6464523 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,9 +7,11 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> -;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -35,11 +37,14 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) + #:use-module (srfi srfi-71) #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) - #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) + #:use-module ((guix build utils) + #:select (dump-port mkdir-p delete-file-recursively + call-with-temporary-output-file %xz-parallel-args)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;<location>, &error-location, etc. @@ -48,6 +53,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) + #:use-module (ice-9 vlist) #:autoload (zlib) (make-zlib-input-port make-zlib-output-port) #:use-module (system foreign) #:re-export (<location> ;for backwards compatibility @@ -65,7 +71,9 @@ &fix-hint fix-hint? - condition-fix-hint) + condition-fix-hint + + call-with-temporary-output-file) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -78,11 +86,18 @@ %current-system %current-target-system package-name->name+version + target-linux? + target-hurd? target-mingw? + target-x86-32? + target-x86-64? target-arm32? target-aarch64? target-arm? + target-ppc32? + target-ppc64le? target-powerpc? + target-riscv64? target-64bit? cc-for-target cxx-for-target @@ -104,7 +119,6 @@ tarball-sans-extension compressed-file? switch-symlinks - call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output @@ -115,6 +129,7 @@ cache-directory readlink* + go-to-location edit-expression filtered-port @@ -246,6 +261,18 @@ a symbol such as 'xz." '())) (_ (error "unsupported compression scheme" compression)))) +(define (compressed-port compression input) + "Return an input port where INPUT is compressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('xz (filtered-port `(,%xz "-c" ,@(%xz-parallel-args)) input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + '())) + (_ (error "unsupported compression scheme" compression)))) + (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data read from PORT according to COMPRESSION, a symbol such as 'xz." @@ -325,43 +352,129 @@ a list of command-line arguments passed to the compression program." (unless (every (compose zero? cdr waitpid) pids) (error "compressed-output-port failure" pids)))))) +(define %source-location-map + ;; Maps inode/device tuples to "source location maps" used by + ;; 'go-to-location'. + (make-hash-table)) + +(define (source-location-key/stamp stat) + "Return two values: the key for STAT in %SOURCE-LOCATION-MAP, and a stamp +used to invalidate corresponding entries." + (let ((key (list (stat:ino stat) (stat:dev stat))) + (stamp (list (stat:mtime stat) (stat:mtimensec stat) + (stat:size stat)))) + (values key stamp))) + +(define* (go-to-location port line column) + "Jump to LINE and COLUMN (both one-indexed) in PORT. Maintain a source +location map such that this can boil down to seek(2) and a few read(2) calls, +which can drastically speed up repetitive operations on large files." + (let* ((stat (stat port)) + (key stamp (source-location-key/stamp stat)) + + ;; Look for an up-to-date source map for KEY. The map is a vlist + ;; where each entry gives the byte offset of the beginning of a line: + ;; element 0 is the offset of the first line, element 1 the offset of + ;; the second line, etc. The map is filled lazily. + (source-map (match (hash-ref %source-location-map key) + (#f + (vlist-cons 0 vlist-null)) + ((cache-stamp ... map) + (if (equal? cache-stamp stamp) ;invalidate? + map + (vlist-cons 0 vlist-null))))) + (last (vlist-length source-map))) + ;; Jump to LINE, ideally via SOURCE-MAP. + (if (<= line last) + (seek port (vlist-ref source-map (- line 1)) SEEK_SET) + (let ((target line) + (offset (vlist-ref source-map (- last 1)))) + (seek port offset SEEK_SET) + (let loop ((source-map (vlist-reverse source-map)) + (line last)) + (if (< line target) + (match (read-char port) + (#\newline + (loop (vlist-cons (ftell port) source-map) + (+ 1 line))) + ((? eof-object?) + (error "unexpected end of file" port line)) + (chr (loop source-map line))) + (hash-set! %source-location-map key + `(,@stamp + ,(vlist-reverse source-map))))))) + + ;; Read up to COLUMN. + (let ((target column)) + (let loop ((column 1)) + (when (< column target) + (match (read-char port) + (#\newline (error "unexpected end of line" port)) + (#\tab (loop (+ 8 column))) + (chr (loop (+ 1 column))))))) + + ;; Update PORT's position info. + (set-port-line! port (- line 1)) + (set-port-column! port (- column 1)))) + +(define (move-source-location-map! source target line) + "Move the source location map from SOURCE up to LINE to TARGET. SOURCE and +TARGET must be stat buffers as returned by 'stat'." + (let* ((source-key (source-location-key/stamp source)) + (target-key target-stamp (source-location-key/stamp target))) + (match (hash-ref %source-location-map source-key) + (#f #t) + ((_ ... source-map) + ;; Strip the source map and update the associated stamp. + (let ((source-map (vlist-take source-map (max line 1)))) + (hash-remove! %source-location-map source-key) + (hash-set! %source-location-map target-key + `(,@target-stamp ,source-map))))))) + (define* (edit-expression source-properties proc #:key (encoding "UTF-8")) "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should be a procedure that takes the original expression in string and returns a new one. ENCODING will be used to interpret all port I/O, it default to UTF-8. This procedure returns #t on success." + (define file (assq-ref source-properties 'filename)) + (define line (assq-ref source-properties 'line)) + (define column (assq-ref source-properties 'column)) + (with-fluids ((%default-port-encoding encoding)) - (let* ((file (assq-ref source-properties 'filename)) - (line (assq-ref source-properties 'line)) - (column (assq-ref source-properties 'column)) - (in (open-input-file file)) - ;; The start byte position of the expression. - (start (begin (while (not (and (= line (port-line in)) - (= column (port-column in)))) - (when (eof-object? (read-char in)) - (error (format #f "~a: end of file~%" in)))) - (ftell in))) - ;; The end byte position of the expression. - (end (begin (read in) (ftell in)))) - (seek in 0 SEEK_SET) ; read from the beginning of the file. - (let* ((pre-bv (get-bytevector-n in start)) - ;; The expression in string form. - (str (iconv:bytevector->string - (get-bytevector-n in (- end start)) - (port-encoding in))) - (post-bv (get-bytevector-all in)) - (str* (proc str))) - ;; Verify the edited expression is still a scheme expression. - (call-with-input-string str* read) - ;; Update the file with edited expression. - (with-atomic-file-output file - (lambda (out) - (put-bytevector out pre-bv) - (display str* out) - ;; post-bv maybe the end-of-file object. - (when (not (eof-object? post-bv)) - (put-bytevector out post-bv)) - #t)))))) + (call-with-input-file file + (lambda (in) + (let* ( ;; The start byte position of the expression. + (start (begin (go-to-location in (+ 1 line) (+ 1 column)) + (ftell in))) + ;; The end byte position of the expression. + (end (begin (read in) (ftell in)))) + (seek in 0 SEEK_SET) ; read from the beginning of the file. + (let* ((pre-bv (get-bytevector-n in start)) + ;; The expression in string form. + (str (iconv:bytevector->string + (get-bytevector-n in (- end start)) + (port-encoding in))) + (post-bv (get-bytevector-all in)) + (str* (proc str))) + ;; Modify FILE only if there are changes. + (unless (string=? str* str) + ;; Verify the edited expression is still a scheme expression. + (call-with-input-string str* read) + ;; Update the file with edited expression. + (with-atomic-file-output file + (lambda (out) + (put-bytevector out pre-bv) + (display str* out) + ;; post-bv maybe the end-of-file object. + (when (not (eof-object? post-bv)) + (put-bytevector out post-bv)) + #t)) + + ;; Due to 'with-atomic-file-output', IN and FILE no longer share + ;; the same inode, but we can reassign the source map up to LINE + ;; to the new file. + (move-source-location-map! (stat in) (stat file) + (+ 1 line))))))))) ;;; @@ -531,10 +644,43 @@ a character other than '@'." (idx (values (substring spec 0 idx) (substring spec (1+ idx)))))) +(define* (target-linux? #:optional (target (or (%current-target-system) + (%current-system)))) + "Does the operating system of TARGET use the Linux kernel?" + (->bool (string-contains target "linux"))) + +(define* (target-hurd? #:optional (target (or (%current-target-system) + (%current-system)))) + "Does TARGET represent the GNU(/Hurd) system?" + (and (string-suffix? "-gnu" target) + (not (string-contains target "linux")))) + (define* (target-mingw? #:optional (target (%current-target-system))) + "Is the operating system of TARGET Windows?" (and target + ;; The "-32" doesn't mean TARGET is 32-bit, as "x86_64-w64-mingw32" + ;; is a valid triplet (see the (gnu ci) module) and 'w64' and 'x86_64' + ;; are 64-bit. (string-suffix? "-mingw32" target))) +(define* (target-x86-32? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a variant of Intel's 32-bit architecture +(IA32)?" + ;; Intel also has a 16-bit architecture in the iN86 series, i286 + ;; (see, e.g., https://en.wikipedia.org/wiki/Intel_80286) so this + ;; procedure is not named target-x86?. + (or (string-prefix? "i386-" target) + (string-prefix? "i486-" target) + (string-prefix? "i586-" target) + (string-prefix? "i686-" target))) + +(define* (target-x86-64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a variant of Intel/AMD's 64-bit +architecture (x86_64)?" + (string-prefix? "x86_64-" target)) + (define* (target-arm32? #:optional (target (or (%current-target-system) (%current-system)))) (string-prefix? "arm" target)) @@ -547,13 +693,27 @@ a character other than '@'." (%current-system)))) (or (target-arm32? target) (target-aarch64? target))) +(define* (target-ppc32? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "powerpc-" target)) + +(define* (target-ppc64le? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "powerpc64le-" target)) + (define* (target-powerpc? #:optional (target (or (%current-target-system) (%current-system)))) (string-prefix? "powerpc" target)) +(define* (target-riscv64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a 'riscv64' machine?" + (string-prefix? "riscv64" target)) + (define* (target-64bit? #:optional (system (or (%current-target-system) (%current-system)))) - (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64"))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" + "powerpc64" "riscv64"))) (define* (cc-for-target #:optional (target (%current-target-system))) (if target @@ -738,22 +898,6 @@ REPLACEMENT." (substring str start index) pieces)))))))) -(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 -call." - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory "/guix-file.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (close out)) - (false-if-exception (delete-file template)))))) - (define (call-with-temporary-directory proc) "Call PROC with a name of a temporary directory; close the directory and delete it when leaving the dynamic extent of this call." |