diff options
Diffstat (limited to 'guix')
38 files changed, 966 insertions, 576 deletions
diff --git a/guix/build-system.scm b/guix/build-system.scm index 4174972b98..76d670995c 100644 --- a/guix/build-system.scm +++ b/guix/build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix build-system) #:use-module (guix records) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (build-system build-system? @@ -37,7 +38,9 @@ bag-arguments bag-build - make-bag)) + make-bag + + build-system-with-c-toolchain)) (define-record-type* <build-system> build-system make-build-system build-system? @@ -98,3 +101,31 @@ intermediate representation just above derivations." #:outputs outputs #:target target arguments)))) + +(define (build-system-with-c-toolchain bs toolchain) + "Return a variant of BS, a build system, that uses TOOLCHAIN instead of the +default GNU C/C++ toolchain. TOOLCHAIN must be a list of +inputs (label/package tuples) providing equivalent functionality, such as the +'gcc-toolchain' package." + (define lower + (build-system-lower bs)) + + (define toolchain-packages + ;; These are the GNU toolchain packages pulled in by GNU-BUILD-SYSTEM and + ;; all the build systems that inherit from it. Keep the list in sync with + ;; 'standard-packages' in (guix build-system gnu). + '("gcc" "binutils" "libc" "libc:static" "ld-wrapper")) + + (define (lower* . args) + (let ((lowered (apply lower args))) + (bag + (inherit lowered) + (build-inputs + (append (fold alist-delete + (bag-build-inputs lowered) + toolchain-packages) + toolchain))))) + + (build-system + (inherit bs) + (lower lower*))) diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 630b99e2bf..28403a1960 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> -;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2019, 2020 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,12 +54,14 @@ ;; Imported build-side modules `((guix build asdf-build-system) (guix build lisp-utils) + (guix build union) ,@%gnu-build-system-modules)) (define %asdf-build-modules ;; Used (visible) build-side modules '((guix build asdf-build-system) (guix build utils) + (guix build union) (guix build lisp-utils))) (define (default-lisp implementation) @@ -210,7 +212,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) + '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file) (package-arguments pkg)) (package-arguments pkg))) @@ -278,8 +280,8 @@ set up using CL source package conventions." (lambda* (store name inputs #:key source outputs (tests? #t) - (asd-file #f) - (asd-system-name #f) + (asd-files ''()) + (asd-systems ''()) (test-asd-file #f) (phases '(@ (guix build asdf-build-system) %standard-phases)) @@ -289,12 +291,17 @@ set up using CL source package conventions." (imported-modules %asdf-build-system-modules) (modules %asdf-build-modules)) - (define system-name - (or asd-system-name - (string-drop - ;; NAME is the value returned from `package-full-name'. - (hyphen-separated-name->name+version name) - (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix. + ;; FIXME: The definition of 'systems' is pretty hacky. + ;; Is there a more elegant way to do it? + (define systems + (if (null? (cadr asd-systems)) + `(quote + ,(list + (string-drop + ;; NAME is the value returned from `package-full-name'. + (hyphen-separated-name->name+version name) + (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix. + asd-systems)) (define builder `(begin @@ -309,8 +316,8 @@ set up using CL source package conventions." (derivation->output-path source)) ((source) source) (source source)) - #:asd-file ,(or asd-file (string-append system-name ".asd")) - #:asd-system-name ,system-name + #:asd-files ,asd-files + #:asd-systems ,systems #:test-asd-file ,test-asd-file #:system ,system #:tests? ,tests? diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 8304e3b222..18a584f782 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -121,7 +122,9 @@ version REVISION." (haddock-flags ''()) (tests? #t) (test-target "test") - (parallel-build? #t) + ;; FIXME: Parallel builds lead to indeterministic + ;; results, see <http://issues.guix.gnu.org/43843#3>. + (parallel-build? #f) (configure-flags ''()) (extra-directories ''()) (phases '(@ (guix build haskell-build-system) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 25dd031962..6ad855cab2 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +20,7 @@ (define-module (guix build asdf-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (guix build union) #:use-module (guix build lisp-utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -41,14 +43,22 @@ ;; ;; Code: -(define %object-prefix "/lib") +(define %object-prefix "/lib/common-lisp") (define (%lisp-source-install-prefix) - (string-append %source-install-prefix "/" (%lisp-type) "-source")) + (string-append %source-install-prefix "/" (%lisp-type))) (define %system-install-prefix (string-append %source-install-prefix "/systems")) +(define (main-system-name output) + (let ((package-name (package-name->name+version + (strip-store-file-name output))) + (lisp-prefix (string-append (%lisp-type) "-"))) + (if (string-prefix? lisp-prefix package-name) + (string-drop package-name (string-length lisp-prefix)) + package-name))) + (define (lisp-source-directory output name) (string-append output (%lisp-source-install-prefix) "/" name)) @@ -71,6 +81,13 @@ to it's binary output." (define (source-asd-file output name asd-file) (string-append (lisp-source-directory output name) "/" asd-file)) +(define (find-asd-files output name asd-files) + (if (null? asd-files) + (find-files (lisp-source-directory output name) "\\.asd$") + (map (lambda (asd-file) + (source-asd-file output name asd-file)) + asd-files))) + (define (copy-files-to-output out name) "Copy all files from the current directory to OUT. Create an extra link to any system-defining files in the source to a convenient location. This is @@ -107,9 +124,10 @@ if it's present in the native-inputs." (package-name->name+version (strip-store-file-name output))) (define (no-prefix pkgname) - (if (string-index pkgname #\-) - (string-drop pkgname (1+ (string-index pkgname #\-))) - pkgname)) + (let ((index (string-index pkgname #\-))) + (if index + (string-drop pkgname (1+ index)) + pkgname))) (define parent (match (assoc package-name inputs (lambda (key alist-car) @@ -125,9 +143,10 @@ if it's present in the native-inputs." (define parent-source (and parent (string-append parent "/share/common-lisp/" - (string-take parent-name - (string-index parent-name #\-)) - "-source"))) + (let ((index (string-index parent-name #\-))) + (if index + (string-take parent-name index) + parent-name))))) (define (first-subdirectory directory) ; From gnu-build-system. "Return the file name of the first sub-directory of DIRECTORY." @@ -146,122 +165,83 @@ if it's present in the native-inputs." (with-directory-excursion source-directory (copy-files-to-output output package-name))) -(define* (copy-source #:key outputs asd-system-name #:allow-other-keys) +(define* (copy-source #:key outputs asd-systems #:allow-other-keys) "Copy the source to the library output." (let* ((out (library-output outputs)) - (install-path (string-append out %source-install-prefix))) - (copy-files-to-output out asd-system-name) + (install-path (string-append out %source-install-prefix)) + (system-name (main-system-name out))) + (copy-files-to-output out system-name) ;; Hide the files from asdf (with-directory-excursion install-path - (rename-file "source" (string-append (%lisp-type) "-source")) + (rename-file "source" (%lisp-type)) (delete-file-recursively "systems"))) #t) -(define* (build #:key outputs inputs asd-file asd-system-name +(define* (configure #:key inputs #:allow-other-keys) + ;; Create a directory having the configuration files for + ;; all the dependencies in 'etc/common-lisp/'. + (let ((out (string-append (getcwd) "/.cl-union"))) + (match inputs + (((name . directories) ...) + (union-build out (filter directory-exists? directories) + #:create-all-directories? #t + #:log-port (%make-void-port "w")))) + (setenv "CL_UNION" out) + (setenv "XDG_CONFIG_DIRS" (string-append out "/etc"))) + #t) + +(define* (build #:key outputs inputs asd-files asd-systems #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) - (source-path (lisp-source-directory out asd-system-name)) + (system-name (main-system-name out)) + (source-path (string-append out (%lisp-source-install-prefix))) (translations (wrap-output-translations `(,(output-translation source-path out)))) - (asd-file (source-asd-file out asd-system-name asd-file))) - + (asd-files (find-asd-files out system-name asd-files))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) - (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - - (compile-system asd-system-name asd-file) - - ;; As above, ecl will sometimes create this even though it doesn't use it - - (let ((cache-directory (string-append out "/.cache"))) - (when (directory-exists? cache-directory) - (delete-file-recursively cache-directory)))) + (compile-systems asd-systems asd-files)) #t) -(define* (check #:key tests? outputs inputs asd-file asd-system-name +(define* (check #:key tests? outputs inputs asd-files asd-systems test-asd-file #:allow-other-keys) "Test the system." (let* ((out (library-output outputs)) - (asd-file (source-asd-file out asd-system-name asd-file)) + (system-name (main-system-name out)) + (asd-files (find-asd-files out system-name asd-files)) (test-asd-file (and=> test-asd-file - (cut source-asd-file out asd-system-name <>)))) + (cut source-asd-file out system-name <>)))) (if tests? - (test-system asd-system-name asd-file test-asd-file) + (test-system (first asd-systems) asd-files test-asd-file) (format #t "test suite not run~%"))) #t) -(define* (create-asd-file #:key outputs - inputs - asd-file - asd-system-name - #:allow-other-keys) - "Create a system definition file for the built system." - (let*-values (((out) (library-output outputs)) - ((_ version) (package-name->name+version - (strip-store-file-name out))) - ((new-asd-file) (string-append - (library-directory out) - "/" (normalize-string asd-system-name) - ".asd"))) - - (make-asd-file new-asd-file - #:system asd-system-name - #:version version - #:inputs inputs - #:system-asd-file asd-file)) - #t) - -(define* (symlink-asd-files #:key outputs #:allow-other-keys) - "Create an extra reference to the system in a convenient location." - (let* ((out (library-output outputs))) - (for-each - (lambda (asd-file) - (receive (new-asd-file asd-file-directory) - (bundle-asd-file out asd-file) - (mkdir-p asd-file-directory) - (symlink asd-file new-asd-file) - ;; Update the source registry for future phases which might want to - ;; use the newly compiled system. - (prepend-to-source-registry - (string-append asd-file-directory "/")))) - - (find-files (string-append out %object-prefix) "\\.asd$"))) - #t) +(define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys) + "Create the ASDF configuration files for the built systems." + (let* ((system-name (main-system-name (assoc-ref outputs "out"))) + (out (library-output outputs)) + (conf-dir (string-append out "/etc/common-lisp")) + (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp")) + (source-dir (lisp-source-directory out system-name)) + (lib-dir (string-append (library-directory out) "/" system-name))) + (make-asdf-configuration system-name conf-dir deps-conf-dir + source-dir lib-dir) + #t)) (define* (cleanup-files #:key outputs #:allow-other-keys) "Remove any compiled files which are not a part of the final bundle." - (let ((out (library-output outputs))) - (match (%lisp-type) - ("sbcl" - (for-each - (lambda (file) - (unless (string-suffix? "--system.fasl" file) - (delete-file file))) - (find-files out "\\.fasl$"))) - ("ecl" - (for-each delete-file - (append (find-files out "\\.fas$") - (find-files out "\\.o$"))))) - - (with-directory-excursion (library-directory out) - (for-each - (lambda (file) - (rename-file file - (string-append "./" (basename file)))) - (find-files ".")) - (for-each delete-file-recursively - (scandir "." - (lambda (file) - (and - (directory-exists? file) - (string<> "." file) - (string<> ".." file))))))) + (let* ((out (library-output outputs)) + (cache-directory (string-append out "/.cache"))) + ;; Remove the cache directory in case the lisp implementation wrote + ;; something in there when compiling or testing a system. + (when (directory-exists? cache-directory) + (delete-file-recursively cache-directory))) #t) (define* (strip #:rest args) @@ -280,15 +260,14 @@ if it's present in the native-inputs." (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) - (delete 'configure) - (delete 'install) + (replace 'configure configure) + (add-before 'configure 'copy-source copy-source) (replace 'build build) - (add-before 'build 'copy-source copy-source) (replace 'check check) - (replace 'strip strip) - (add-after 'check 'create-asd-file create-asd-file) - (add-after 'create-asd-file 'cleanup cleanup-files) - (add-after 'cleanup 'create-symlinks symlink-asd-files))) + (add-after 'check 'create-asdf-configuration create-asdf-configuration) + (add-after 'create-asdf-configuration 'cleanup cleanup-files) + (delete 'install) + (replace 'strip strip))) (define* (asdf-build #:key inputs (phases %standard-phases) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 95e8dd772a..117c8da66c 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -173,7 +173,13 @@ directory = '" port) (or skip-build? (not (has-executable-target?)) (invoke "cargo" "install" "--path" "." "--root" out - "--features" (string-join features))))) + "--features" (string-join features))) + + ;; This is a file which we definitely don't need installed. + (when (file-exists? (string-append out "/.crates.toml")) + (delete-file (string-append out "/.crates.toml"))) + + #t)) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/cargo-utils.scm b/guix/build/cargo-utils.scm index 5ac429a62a..7a3bb4b843 100644 --- a/guix/build/cargo-utils.scm +++ b/guix/build/cargo-utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> -;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module (guix build utils) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) #:export (generate-checksums generate-all-checksums)) @@ -70,7 +71,7 @@ the same directory." (display "}" port))))) (define (generate-all-checksums dir-name) - (for-each + (n-par-for-each (parallel-job-count) (lambda (filename) (let* ((dir (dirname filename)) (checksum-file (string-append dir "/.cargo-checksum.json"))) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index b9cb2bfd7b..227df820db 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -254,6 +255,17 @@ XXX We can't make use of compiled libraries (Go \"packages\")." (copy-recursively source dest #:keep-mtime? #t))) #t) +(define* (install-license-files #:key unpack-path + import-path + #:allow-other-keys + #:rest args) + "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'. Adjust +the standard install-license-files phase to first enter the correct directory." + (with-directory-excursion (string-append "src/" (if (string-null? unpack-path) + import-path + unpack-path)) + (apply (assoc-ref gnu:%standard-phases 'install-license-files) args))) + (define* (remove-store-reference file file-name #:optional (store (%store-directory))) "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME @@ -317,6 +329,7 @@ files in OUTPUTS." (replace 'build build) (replace 'check check) (replace 'install install) + (replace 'install-license-files install-license-files) (add-after 'install 'remove-go-references remove-go-references))) (define* (go-build #:key inputs (phases %standard-phases) diff --git a/guix/build/hg.scm b/guix/build/hg.scm index b3e3ff7ac3..0ffad7fa2d 100644 --- a/guix/build/hg.scm +++ b/guix/build/hg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,8 @@ (define-module (guix build hg) #:use-module (guix build utils) + #:use-module (srfi srfi-34) + #:use-module (ice-9 format) #:export (hg-fetch)) ;;; Commentary: @@ -35,22 +38,29 @@ "Fetch CHANGESET from URL into DIRECTORY. CHANGESET must be a valid Mercurial changeset identifier. Return #t on success, #f otherwise." - (invoke hg-command - "clone" url - "--rev" changeset - ;; Disable TLS certificate verification. The hash of - ;; the checkout is known in advance anyway. - "--insecure" - directory) - - ;; The contents of '.hg' vary as a function of the current - ;; status of the Mercurial repo. Since we want a fixed - ;; output, this directory needs to be taken out. - ;; Since the '.hg' file is also in sub-modules, we have to - ;; search for it in all sub-directories. - (for-each delete-file-recursively - (find-files directory "^\\.hg$" #:directories? #t)) - - #t) + (mkdir-p directory) + + (guard (c ((invoke-error? c) + (report-invoke-error c) + (delete-file-recursively directory) + #f)) + (with-directory-excursion directory + (invoke hg-command + "clone" url + "--rev" changeset + ;; Disable TLS certificate verification. The hash of + ;; the checkout is known in advance anyway. + "--insecure" + directory) + + ;; The contents of '.hg' vary as a function of the current + ;; status of the Mercurial repo. Since we want a fixed + ;; output, this directory needs to be taken out. + ;; Since the '.hg' file is also in sub-modules, we have to + ;; search for it in all sub-directories. + (for-each delete-file-recursively + (find-files directory "^\\.hg$" #:directories? #t)) + + #t))) ;;; hg.scm ends here diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 88605bd255..17d2637f87 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,19 +29,17 @@ %lisp-type %source-install-prefix lisp-eval-program - compile-system + compile-systems test-system replace-escaped-macros generate-executable-wrapper-system generate-executable-entry-point generate-executable-for-system - %bundle-install-prefix - bundle-asd-file wrap-output-translations prepend-to-source-registry build-program build-image - make-asd-file + make-asdf-configuration valid-char-set normalize-string library-output)) @@ -65,9 +64,6 @@ ;; link farm for system definition (.asd) files. (define %source-install-prefix "/share/common-lisp") -(define (%bundle-install-prefix) - (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems")) - (define (library-output outputs) "If a `lib' output exists, build things there. Otherwise use `out'." (or (assoc-ref outputs "lib") (assoc-ref outputs "out"))) @@ -81,38 +77,6 @@ "Replace invalid characters in STR with a hyphen." (string-join (string-tokenize str valid-char-set) "-")) -(define (normalize-dependency dependency) - "Normalize the name of DEPENDENCY. Handles dependency definitions of the -dependency-def form described by -<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>. -Assume that any symbols in DEPENDENCY will be in upper-case." - (match dependency - ((':VERSION name rest ...) - `(:version ,(normalize-string name) ,@rest)) - ((':FEATURE feature-specification dependency-specification) - `(:feature - ,feature-specification - ,(normalize-dependency dependency-specification))) - ((? string? name) (normalize-string name)) - (require-specification require-specification))) - -(define (inputs->asd-file-map inputs) - "Produce a hash table of the form (system . asd-file), where system is the -name of an ASD system, and asd-file is the full path to its definition." - (alist->hash-table - (filter-map - (match-lambda - ((_ . path) - (let ((prefix (string-append path (%bundle-install-prefix)))) - (and (directory-exists? prefix) - (match (find-files prefix "\\.asd$") - ((asd-file) - (cons - (string-drop-right (basename asd-file) 4) ; drop ".asd" - asd-file)) - (_ #f)))))) - inputs))) - (define (wrap-output-translations translations) `(:output-translations ,@translations @@ -143,70 +107,26 @@ with PROGRAM." "--eval" "(quit)")) (_ (error "The LISP provided is not supported at this time.")))) -(define (asdf-load-all systems) - (map (lambda (system) - `(asdf:load-system ,system)) - systems)) - -(define (compile-system system asd-file) - "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE -first." +(define (compile-systems systems asd-files) + "Use a lisp implementation to compile the SYSTEMS using asdf. +Load ASD-FILES first." (lisp-eval-program `((require :asdf) - (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) - (asdf:operate 'asdf:compile-bundle-op ,system)))) - -(define (system-dependencies system asd-file) - "Return the dependencies of SYSTEM, as reported by -asdf:system-depends-on. First load the system's ASD-FILE." - (define deps-file ".deps.sexp") - (define program - `((require :asdf) - (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) - (with-open-file - (stream ,deps-file :direction :output) - (format stream - "~s~%" - (asdf:system-depends-on - (asdf:find-system ,system)))))) - - (dynamic-wind - (lambda _ - (lisp-eval-program program)) - (lambda _ - (call-with-input-file deps-file read)) - (lambda _ - (when (file-exists? deps-file) - (delete-file deps-file))))) - -(define (compiled-system system) - (let ((system (basename system))) ; this is how asdf handles slashes - (match (%lisp-type) - ("sbcl" (string-append system "--system")) - (_ system)))) - -(define* (generate-system-definition system - #:key version dependencies component?) - `(asdf:defsystem - ,(normalize-string system) - ,@(if component? - '(:class asdf/bundle:prebuilt-system) - '()) - :version ,version - :depends-on ,dependencies - ,@(if component? - `(:components ((:compiled-file ,(compiled-system system)))) - '()) - ,@(if (string=? "ecl" (%lisp-type)) - `(:lib ,(string-append system ".a")) - '()))) - -(define (test-system system asd-file test-asd-file) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first. + ,@(map (lambda (asd-file) + `(asdf:load-asd (truename ,asd-file))) + asd-files) + ,@(map (lambda (system) + `(asdf:compile-system ,system)) + systems)))) + +(define (test-system system asd-files test-asd-file) + "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILES first. Also load TEST-ASD-FILE if necessary." (lisp-eval-program `((require :asdf) - (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) + ,@(map (lambda (asd-file) + `(asdf:load-asd (truename ,asd-file))) + asd-files) ,@(if test-asd-file `((asdf:load-asd (truename ,test-asd-file))) ;; Try some likely files. @@ -237,6 +157,7 @@ created a \"SYSTEM-exec\" system which contains the entry program." :executable t :compression t)) '()) + (asdf:load-asd (truename ,(string-append system "-exec.asd"))) (asdf:operate ',type ,(string-append system "-exec"))))) (define (generate-executable-wrapper-system system dependencies) @@ -271,79 +192,30 @@ ENTRY-PROGRAM for SYSTEM within the current directory." (declare (ignorable arguments)) ,@entry-program)))))))) -(define (generate-dependency-links registry system) - "Creates a program which populates asdf's source registry from REGISTRY, an -alist of dependency names to corresponding asd files. This allows the system -to locate its dependent systems." - `(progn - (asdf/source-registry:ensure-source-registry) - ,@(map (match-lambda - ((name . asd-file) - `(setf - (gethash ,name - asdf/source-registry:*source-registry*) - ,(string->symbol "#p") - ,asd-file))) - registry))) - -(define* (make-asd-file asd-file - #:key system version inputs - (system-asd-file #f)) - "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the -system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." - (define dependencies - (let ((deps - (system-dependencies system system-asd-file))) - (if (eq? 'NIL deps) - '() - (map normalize-dependency deps)))) - - (define lisp-input-map - (inputs->asd-file-map inputs)) - - (define dependency-name - (match-lambda - ((':version name _ ...) name) - ((':feature _ dependency-specification) - (dependency-name dependency-specification)) - ((? string? name) name) - (_ #f))) - - (define registry - (filter-map hash-get-handle - (make-list (length dependencies) - lisp-input-map) - (map dependency-name dependencies))) - - ;; Ensure directory exists, which might not be the case for an .asd without components. - (mkdir-p (dirname asd-file)) - (call-with-output-file asd-file - (lambda (port) - (display - (replace-escaped-macros - (format #f "~y~%~y~%" - (generate-system-definition - system - #:version version - #:dependencies dependencies - ;; Some .asd don't have components, and thus they don't generate any .fasl. - #:component? (match (%lisp-type) - ("sbcl" (pair? (find-files (dirname asd-file) - "--system\\.fasl$"))) - ("ecl" (pair? (find-files (dirname asd-file) - "\\.fasb$"))) - (_ (error "The LISP provided is not supported at this time.")))) - (generate-dependency-links registry system))) - port)))) - -(define (bundle-asd-file output-path original-asd-file) - "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in -OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two -values: the asd file itself and the directory in which it resides." - (let ((bundle-asd-path (string-append output-path - (%bundle-install-prefix)))) - (values (string-append bundle-asd-path "/" (basename original-asd-file)) - bundle-asd-path))) +(define (make-asdf-configuration name conf-dir deps-conf-dir source-dir lib-dir) + (let ((registry-dir (string-append + conf-dir "/source-registry.conf.d")) + (translations-dir (string-append + conf-dir "/asdf-output-translations.conf.d")) + (deps-registry-dir (string-append + deps-conf-dir "/source-registry.conf.d")) + (deps-translations-dir (string-append + deps-conf-dir + "/asdf-output-translations.conf.d"))) + (mkdir-p registry-dir) + (when (directory-exists? deps-registry-dir) + (copy-recursively deps-registry-dir registry-dir)) + (with-output-to-file (string-append registry-dir "/50-" name ".conf") + (lambda _ + (format #t "~y~%" `(:tree ,source-dir)))) + + (mkdir-p translations-dir) + (when (directory-exists? deps-translations-dir) + (copy-recursively deps-translations-dir translations-dir)) + (with-output-to-file (string-append translations-dir "/50-" name ".conf") + (lambda _ + (format #t "~y~%" `((,source-dir :**/ :*.*.*) + (,lib-dir :**/ :*.*.*))))))) (define (replace-escaped-macros string) "Replace simple lisp forms that the guile writer escapes, for example by @@ -368,6 +240,7 @@ will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments' has been bound to the command-line arguments which were passed. Link in any asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are retained." + (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc")) (generate-executable program #:dependencies dependencies #:dependency-prefixes dependency-prefixes @@ -388,6 +261,7 @@ retained." "Generate an image, possibly standalone, which contains all DEPENDENCIES, placing the result in IMAGE.image. Link in any asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are retained." + (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc")) (generate-executable image #:dependencies dependencies #:dependency-prefixes dependency-prefixes @@ -416,20 +290,15 @@ references to those libraries are retained." (mkdir-p bin-directory) (with-directory-excursion bin-directory (generate-executable-wrapper-system name dependencies) - (generate-executable-entry-point name entry-program)) - - (prepend-to-source-registry - (string-append bin-directory "/")) - - (setenv "ASDF_OUTPUT_TRANSLATIONS" - (replace-escaped-macros - (format - #f "~S" - (wrap-output-translations - `(((,bin-directory :**/ :*.*.*) - (,bin-directory :**/ :*.*.*))))))) - - (generate-executable-for-system type name #:compress? compress?) + (generate-executable-entry-point name entry-program) + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros + (format + #f "~S" + (wrap-output-translations + `(((,bin-directory :**/ :*.*.*) + (,bin-directory :**/ :*.*.*))))))) + (generate-executable-for-system type name #:compress? compress?)) (let* ((after-store-prefix-index (string-index out-file #\/ @@ -445,9 +314,11 @@ references to those libraries are retained." (symlink asd-file (string-append hidden-asd-links "/" (basename asd-file)))) - (find-files (string-append path (%bundle-install-prefix)) + (find-files (string-append path %source-install-prefix "/" + (%lisp-type)) "\\.asd$"))) dependency-prefixes)) (delete-file (string-append bin-directory "/" name "-exec.asd")) - (delete-file (string-append bin-directory "/" name "-exec.lisp")))) + (delete-file (string-append bin-directory "/" name "-exec.lisp")) + (delete-file (string-append bin-directory "/" name "-exec.fasl")))) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 33783f3056..44d77a968f 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,8 @@ (define-module (guix build svn) #:use-module (guix build utils) + #:use-module (srfi srfi-34) + #:use-module (ice-9 format) #:export (svn-fetch)) ;;; Commentary: @@ -36,20 +39,23 @@ (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a valid Subversion revision. Return #t on success, #f otherwise." - (apply invoke svn-command - "export" "--non-interactive" - ;; Trust the server certificate. This is OK as we - ;; verify the checksum later. This can be removed when - ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) - `(,@(if (and user-name password) - (list (string-append "--username=" user-name) - (string-append "--password=" password)) - '()) - ,@(if recursive? - '() - (list "--ignore-externals")) - ,url ,directory)) - #t) + (guard (c ((invoke-error? c) + (report-invoke-error c) + #f)) + (apply invoke svn-command + "export" "--non-interactive" + ;; Trust the server certificate. This is OK as we + ;; verify the checksum later. This can be removed when + ;; ca-certificates package is added. + "--trust-server-cert" "-r" (number->string revision) + `(,@(if (and user-name password) + (list (string-append "--username=" user-name) + (string-append "--password=" password)) + '()) + ,@(if recursive? + '() + (list "--ignore-externals")) + ,url ,directory)) + #t)) ;;; svn.scm ends here diff --git a/guix/channels.scm b/guix/channels.scm index ad2442f50e..916d663e9f 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -783,7 +783,8 @@ modules in the old ~/.config/guix/latest style." ;; derivation that builds modules. We have to infer what the ;; dependencies of these modules were. (list guile-json-3 guile-git guile-bytestructures - (ssh -> guile-ssh) (tls -> gnutls))))) + (ssh -> guile-ssh) (tls -> gnutls)) + #:guile (default-guile)))) (define (old-style-guix? drv) "Return true if DRV corresponds to a ~/.config/guix/latest style of diff --git a/guix/cve.scm b/guix/cve.scm index 57b8459d01..b3a8b13a06 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -336,7 +336,7 @@ sexp to CACHE." ,(map vulnerability->sexp vulns)) cache)))) -(define (fetch-vulnerabilities year ttl) +(define* (fetch-vulnerabilities year ttl #:key (timeout 10)) "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has the given TTL (fetch from the NIST web site when TTL has expired)." (define (cache-miss uri) @@ -361,16 +361,18 @@ the given TTL (fetch from the NIST web site when TTL has expired)." (let* ((port (http-fetch/cached (yearly-feed-uri year) #:ttl ttl #:write-cache write-cache - #:cache-miss cache-miss)) + #:cache-miss cache-miss + #:timeout timeout)) (sexp (read* port))) (close-port port) (match sexp (('vulnerabilities 1 vulns) (map sexp->vulnerability vulns))))) -(define (current-vulnerabilities) +(define* (current-vulnerabilities #:key (timeout 10)) "Return the current list of Common Vulnerabilities and Exposures (CVE) as -published by the US NIST." +published by the US NIST. TIMEOUT specifies the timeout in seconds for +connection establishment." (let ((past-years (unfold (cut > <> 3) (lambda (n) (- %current-year n)) @@ -381,7 +383,7 @@ published by the US NIST." (* n %past-year-ttl)) 1+ 1))) - (append-map fetch-vulnerabilities + (append-map (cut fetch-vulnerabilities <> <> #:timeout timeout) (cons %current-year past-years) (cons %current-year-ttl past-ttls)))) diff --git a/guix/describe.scm b/guix/describe.scm index 6b9b219113..05bf99eb58 100644 --- a/guix/describe.scm +++ b/guix/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,11 +43,17 @@ ;;; ;;; Code: +(define initial-program-arguments + ;; Save the initial program arguments. This allows us to see the "real" + ;; 'guix' program, even if 'guix repl -s' calls 'set-program-arguments' + ;; later on. + (program-arguments)) + (define current-profile (mlambda () "Return the profile (created by 'guix pull') the calling process lives in, or #f if this is not applicable." - (match (command-line) + (match initial-program-arguments ((program . _) (and (string-suffix? "/bin/guix" program) ;; Note: We want to do _lexical dot-dot resolution_. Using ".." diff --git a/guix/gexp.scm b/guix/gexp.scm index a8d890ccd2..b8c831ccc3 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -26,6 +26,8 @@ #:use-module (guix derivations) #:use-module (guix grafts) #:use-module (guix utils) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -46,6 +48,7 @@ gexp-input-output gexp-input-native? + assume-valid-file-name local-file local-file? local-file-file @@ -401,9 +404,15 @@ Here TARGET is bound to the cross-compilation triplet or #f." (define (true file stat) #t) (define* (%local-file file promise #:optional (name (basename file)) - #:key recursive? (select? true)) + #:key + (literal? #t) location + recursive? (select? true)) ;; This intermediate procedure is part of our ABI, but the underlying ;; %%LOCAL-FILE is not. + (when (and (not literal?) (not (string-prefix? "/" file))) + (warning (and=> location source-properties->location) + (G_ "resolving '~a' relative to current directory~%") + file)) (%%local-file file promise name recursive? select?)) (define (absolute-file-name file directory) @@ -416,6 +425,12 @@ vicinity of DIRECTORY." (string-append directory "/" file)) (else file)))) +(define-syntax-rule (assume-valid-file-name file) + "This is a syntactic keyword to tell 'local-file' that it can assume that +the given file name is valid, even if it's not a string literal, and thus not +warn about it." + file) + (define-syntax local-file (lambda (s) "Return an object representing local file FILE to add to the store; this @@ -434,18 +449,28 @@ where FILE is the entry's absolute file name and STAT is the result of This is the declarative counterpart of the 'interned-file' monadic procedure. It is implemented as a macro to capture the current source directory where it appears." - (syntax-case s () + (syntax-case s (assume-valid-file-name) ((_ file rest ...) (string? (syntax->datum #'file)) ;; FILE is a literal, so resolve it relative to the source directory. #'(%local-file file (delay (absolute-file-name file (current-source-directory))) rest ...)) - ((_ file rest ...) - ;; Resolve FILE relative to the current directory. + ((_ (assume-valid-file-name file) rest ...) + ;; FILE is not a literal, so resolve it relative to the current + ;; directory. Since the user declared FILE is valid, do not pass + ;; #:literal? #f so that we do not warn about it later on. #'(%local-file file (delay (absolute-file-name file (getcwd))) rest ...)) + ((_ file rest ...) + ;; Resolve FILE relative to the current directory. + (with-syntax ((location (datum->syntax s (syntax-source s)))) + #`(%local-file file + (delay (absolute-file-name file (getcwd))) + rest ... + #:location 'location + #:literal? #f))) ;warn if FILE is relative ((_) #'(syntax-error "missing file name")) (id diff --git a/guix/http-client.scm b/guix/http-client.scm index 5a5a33b4c0..a767175d67 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -71,7 +71,8 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t) (verify-certificate? #t) - (headers '((user-agent . "GNU Guile")))) + (headers '((user-agent . "GNU Guile"))) + timeout) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an @@ -80,13 +81,17 @@ extra HTTP headers. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. +TIMEOUT specifies the timeout in seconds for connection establishment; when +TIMEOUT is #f, connection establishment never times out. + Raise an '&http-get-error' condition if downloading fails." (let loop ((uri (if (string? uri) (string->uri uri) uri))) (let ((port (or port (guix:open-connection-for-uri uri #:verify-certificate? - verify-certificate?))) + verify-certificate? + #:timeout timeout))) (headers (match (uri-userinfo uri) ((? string? str) (cons (cons 'Authorization @@ -155,13 +160,16 @@ Raise an '&http-get-error' condition if downloading fails." (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? (write-cache dump-port) - (cache-miss (const #t))) + (cache-miss (const #t)) + (timeout 10)) "Like 'http-fetch', return an input port, but cache its contents in ~/.cache/guix. The cache remains valid for TTL seconds. Call WRITE-CACHE with the HTTP input port and the cache output port to write the data to cache. Call CACHE-MISS with URI just before fetching data from -URI." +URI. + +TIMEOUT specifies the timeout in seconds for connection establishment." (let ((file (cache-file-for-uri uri))) (define (update-cache cache-port) (define cache-time @@ -183,7 +191,7 @@ URI." cache-port) (raise c)))) (let ((port (http-fetch uri #:text? text? - #:headers headers))) + #:headers headers #:timeout timeout))) (cache-miss uri) (mkdir-p (dirname file)) (when cache-port diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 7dfe771e41..da00019297 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -718,7 +718,7 @@ If #f use the function 'port-filename' to obtain it." (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency> (define (cabal-flags->alist flag-list) - "Retrun an alist associating the flag name to its default value from a + "Return an alist associating the flag name to its default value from a list of <cabal-flag> objects." (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag))) flag-list)) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index fd940415a2..514417f781 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -49,7 +49,7 @@ cpan-release-license cpan-release-author cpan-release-version - cpan-release-modle + cpan-release-module cpan-release-distribution cpan-release-download-url cpan-release-abstract diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 9cda3da006..6d9eb0a092 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -49,16 +49,19 @@ condition)) ;; Define a PEG parser for the opam format -(define-peg-pattern comment none (and "#" (* STRCHR) "\n")) +(define-peg-pattern comment none (and "#" (* COMMCHR) "\n")) (define-peg-pattern SP none (or " " "\n" comment)) (define-peg-pattern SP2 body (or " " "\n")) (define-peg-pattern QUOTE none "\"") (define-peg-pattern QUOTE2 body "\"") (define-peg-pattern COLON none ":") ;; A string character is any character that is not a quote, or a quote preceded by a backslash. +(define-peg-pattern COMMCHR none + (or " " "!" "\\" "\"" (range #\# #\頋))) (define-peg-pattern STRCHR body (or " " "!" "\n" (and (ignore "\\") "\"") - (and (ignore "\\") "\\") (range #\# #\頋))) + (ignore "\\\n") (and (ignore "\\") "\\") + (range #\# #\頋))) (define-peg-pattern operator all (or "=" "!" "<" ">")) (define-peg-pattern records body (* (and (or record weird-record) (* SP)))) @@ -69,8 +72,12 @@ (define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")"))) (define-peg-pattern choice body (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice) + group-pat conditional-value ground-value)) +(define-peg-pattern group-pat all + (and (or conditional-value ground-value) (* SP) (ignore "&") (* SP) + (or group-pat conditional-value ground-value))) (define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP))) (define-peg-pattern conditional-value all (and ground-value (* SP) condition)) (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE)) @@ -189,6 +196,7 @@ path to the repository." (('string-pat str) str) ;; Arbitrary select the first dependency (('choice-pat choice ...) (dependency->input (car choice))) + (('group-pat val ...) (map dependency->input val)) (('conditional-value val condition) (if (native? condition) "" (dependency->input val))))) @@ -196,7 +204,8 @@ path to the repository." (match dependency (('string-pat str) "") ;; Arbitrary select the first dependency - (('choice-pat choice ...) (dependency->input (car choice))) + (('choice-pat choice ...) (dependency->native-input (car choice))) + (('group-pat val ...) (map dependency->native-input val)) (('conditional-value val condition) (if (native? condition) (dependency->input val) "")))) @@ -204,7 +213,8 @@ path to the repository." (match dependency (('string-pat str) str) ;; Arbitrary select the first dependency - (('choice-pat choice ...) (dependency->input (car choice))) + (('choice-pat choice ...) (dependency->name (car choice))) + (('group-pat val ...) (map dependency->name val)) (('conditional-value val condition) (dependency->name val)))) @@ -256,9 +266,10 @@ REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." (and-let* ((opam-file (opam-fetch name repository)) (version (assoc-ref opam-file "version")) - (opam-content (assoc-ref opam-file "metadata")) + (opam-content (pk (assoc-ref opam-file "metadata"))) (url-dict (metadata-ref opam-content "url")) - (source-url (metadata-ref url-dict "src")) + (source-url (or (metadata-ref url-dict "src") + (metadata-ref url-dict "archive"))) (requirements (metadata-ref opam-content "depends")) (dependencies (dependency-list->names requirements)) (native-dependencies (depends->native-inputs requirements)) @@ -308,7 +319,7 @@ or #f on failure." (filter (lambda (name) (not (member name '("dune" "jbuilder")))) - dependencies)))))))) + dependencies)))))))) (define (opam-recursive-import package-name) (recursive-import package-name #f diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index e04073d193..ee12108815 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -42,12 +42,12 @@ (define %stackage-url "http://www.stackage.org") (define (lts-info-ghc-version lts-info) - "Retruns the version of the GHC compiler contained in LTS-INFO." + "Returns the version of the GHC compiler contained in LTS-INFO." (and=> (assoc-ref lts-info "snapshot") (cut assoc-ref <> "ghc"))) (define (lts-info-packages lts-info) - "Retruns the alist of packages contained in LTS-INFO." + "Returns the alist of packages contained in LTS-INFO." (or (assoc-ref lts-info "packages") '())) (define (leave-with-message fmt . args) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 0cfa1f8321..145515c489 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2017, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> +;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -124,9 +125,12 @@ of the string VERSION is replaced by the symbol 'version." ;; https://spdx.org/licenses/ ;; The psfl, gfl1.0, nmap, repoze ;; licenses doesn't have SPDX identifiers + ;; + ;; Please update guix/licenses.scm when modifying + ;; this list to avoid mismatches. (match str - ("AGPL-1.0" 'license:agpl-1.0) - ("AGPL-3.0" 'license:agpl-3.0) + ("AGPL-1.0" 'license:agpl1) + ("AGPL-3.0" 'license:agpl3) ("Apache-1.1" 'license:asl1.1) ("Apache-2.0" 'license:asl2.0) ("BSL-1.0" 'license:boost1.0) @@ -166,8 +170,8 @@ of the string VERSION is replaced by the symbol 'version." ("LGPL-2.0+" 'license:lgpl2.0+) ("LGPL-2.1" 'license:lgpl2.1) ("LGPL-2.1+" 'license:lgpl2.1+) - ("LGPL-3.0" 'license:lgpl3.0) - ("LGPL-3.0+" 'license:lgpl3.0+) + ("LGPL-3.0" 'license:lgpl3) + ("LGPL-3.0+" 'license:lgpl3+) ("MPL-1.0" 'license:mpl1.0) ("MPL-1.1" 'license:mpl1.1) ("MPL-2.0" 'license:mpl2.0) @@ -175,7 +179,7 @@ of the string VERSION is replaced by the symbol 'version." ("NCSA" 'license:ncsa) ("OpenSSL" 'license:openssl) ("OLDAP-2.8" 'license:openldap2.8) - ("CUA-OPL-1.0" 'license:opl1.0) + ("CUA-OPL-1.0" 'license:cua-opl1.0) ("QPL-1.0" 'license:qpl) ("Ruby" 'license:ruby) ("SGI-B-2.0" 'license:sgifreeb2.0) diff --git a/guix/licenses.scm b/guix/licenses.scm index bf72a33c92..255b755e6c 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -14,6 +14,8 @@ ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2017 Rutger Helling <rhelling@mykolab.com> +;;; Copyright © 2020 André Batista <nandre@riseup.net> +;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +36,7 @@ #:use-module (srfi srfi-9) #:export (license? license-name license-uri license-comment agpl1 agpl3 agpl3+ + apsl2 asl1.1 asl2.0 boost1.0 bsd-2 bsd-3 bsd-4 @@ -47,6 +50,7 @@ artistic2.0 clarified-artistic copyleft-next cpl1.0 + cua-opl1.0 edl1.0 epl1.0 epl2.0 @@ -74,7 +78,7 @@ mpl1.0 mpl1.1 mpl2.0 ms-pl ncsa - nmap + npsl ogl-psi1.0 openldap2.8 openssl perl-license @@ -115,6 +119,9 @@ ;;; https://github.com/NixOS/nixpkgs/blob/master/lib/licenses.nix ;;; https://www.gnu.org/licenses/license-list ;;; +;;; Please update spdx-string->license from guix/import/utils.scm +;;; when modifying this list to avoid mismatches. +;;; ;;; Code: (define agpl1 @@ -132,6 +139,11 @@ "https://gnu.org/licenses/agpl.html" "https://gnu.org/licenses/why-affero-gpl.html")) +(define apsl2 + (license "APSL 2.0" + "https://directory.fsf.org/wiki/License:APSL-2.0" + "https://www.gnu.org/licenses/license-list.html#apsl2")) + (define asl1.1 (license "ASL 1.1" "http://directory.fsf.org/wiki/License:Apache1.1" @@ -262,6 +274,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CPLv1.0" "https://www.gnu.org/licenses/license-list#CommonPublicLicense10")) +(define cua-opl1.0 + (license "CUA Office Public License v1.0" + "https://spdx.org/licenses/CUA-OPL-1.0.html" + "https://opensource.org/licenses/CUA-OPL-1.0")) + (define edl1.0 (license "EDL 1.0" "http://directory.fsf.org/wiki/License:EDLv1.0" @@ -514,10 +531,10 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:IllinoisNCSA" "https://www.gnu.org/licenses/license-list#NCSA")) -(define nmap - (license "Nmap license" - "https://svn.nmap.org/nmap/COPYING" - "https://fedoraproject.org/wiki/Licensing/Nmap")) +(define npsl + (license "Nmap Public Source License" + "https://svn.nmap.org/nmap/LICENSE" + "https://nmap.org/npsl/")) (define ogl-psi1.0 (license "Open Government Licence for Public Sector Information" diff --git a/guix/lint.scm b/guix/lint.scm index ec43a4dcad..e1a77e8ac7 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1084,7 +1084,7 @@ or HTTP errors. This allows network-less operation and makes problems with the NIST server non-fatal." (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") '() - (current-vulnerabilities))) + (current-vulnerabilities #:timeout 4))) (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 33c851255b..648c359621 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -34,6 +34,7 @@ openpgp-error? openpgp-unrecognized-packet-error? openpgp-unrecognized-packet-error-port + openpgp-unrecognized-packet-error-type openpgp-invalid-signature-error? openpgp-invalid-signature-error-port @@ -110,7 +111,7 @@ (define-alias fx/ /) (define-alias fxdiv quotient) (define-alias fxand logand) -(define-alias fxbit-set? bit-set?) +(define-inlinable (fxbit-set? n index) (bit-set? index n)) (define-alias fxbit-field bit-field) (define-alias bitwise-bit-field bit-field) (define-alias fxarithmetic-shift-left ash) @@ -132,6 +133,7 @@ ;; Error raised when reading an unsupported or unrecognized packet tag. (define-condition-type &openpgp-unrecognized-packet-error &openpgp-error openpgp-unrecognized-packet-error? + (type openpgp-unrecognized-packet-error-type) (port openpgp-unrecognized-packet-error-port)) ;; Error raised when reading an invalid signature packet. @@ -477,7 +479,8 @@ hexadecimal format for fingerprints." ((= tag PACKET-ONE-PASS-SIGNATURE) 'one-pass-signature) ;TODO: implement (else - (raise (condition (&openpgp-unrecognized-packet-error (port p)))))))) + (raise (condition (&openpgp-unrecognized-packet-error (type tag) + (port p)))))))) (define-record-type <openpgp-public-key> (make-openpgp-public-key version subkey? time value fingerprint) @@ -817,6 +820,7 @@ FINGERPRINT, a bytevector." (if critical? (raise (condition (&openpgp-unrecognized-packet-error + (type type) (port signature-port)))) (list 'unsupported-subpacket type data)))))) diff --git a/guix/packages.scm b/guix/packages.scm index 5ad27fa8fc..bdd03a6d91 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -125,6 +125,7 @@ package-patched-vulnerabilities package-with-patches package-with-extra-patches + package-with-c-toolchain package/inherit transitive-input-references @@ -423,6 +424,16 @@ name of its URI." package) 16))))) +(define-syntax-rule (package/inherit p overrides ...) + "Like (package (inherit P) OVERRIDES ...), except that the same +transformation is done to the package replacement, if any. P must be a bare +identifier, and will be bound to either P or its replacement when evaluating +OVERRIDES." + (let loop ((p p)) + (package (inherit p) + overrides ... + (replacement (and=> (package-replacement p) loop))))) + (define (package-upstream-name package) "Return the upstream name of PACKAGE, which could be different from the name it has in Guix." @@ -783,6 +794,14 @@ specifies modules in scope when evaluating SNIPPET." (append (origin-patches (package-source original)) patches))) +(define (package-with-c-toolchain package toolchain) + "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU +C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples) +providing equivalent functionality, such as the 'gcc-toolchain' package." + (let ((bs (package-build-system package))) + (package/inherit package + (build-system (build-system-with-c-toolchain bs toolchain))))) + (define (transitive-inputs inputs) "Return the closure of INPUTS when considering the 'propagated-inputs' edges. Omit duplicate inputs, except for those already present in INPUTS @@ -971,10 +990,31 @@ packages they depend on, recursively." (vhash-consq package #t visited) (fold set-insert closure dependencies)))))))) -(define* (package-mapping proc #:optional (cut? (const #f))) +(define (build-system-with-package-mapping bs rewrite) + "Return a variant of BS, a build system, that rewrites a bag's inputs by +passing them through REWRITE, a procedure that takes an input tuplet and +returns a \"rewritten\" input tuplet." + (define lower + (build-system-lower bs)) + + (define (lower* . args) + (let ((lowered (apply lower args))) + (bag + (inherit lowered) + (build-inputs (map rewrite (bag-build-inputs lowered))) + (host-inputs (map rewrite (bag-host-inputs lowered))) + (target-inputs (map rewrite (bag-target-inputs lowered)))))) + + (build-system + (inherit bs) + (lower lower*))) + +(define* (package-mapping proc #:optional (cut? (const #f)) + #:key deep?) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion -when CUT? returns true for a given package." +when CUT? returns true for a given package. When DEEP? is true, PROC is +applied to implicit inputs as well." (define (rewrite input) (match input ((label (? package? package) outputs ...) @@ -983,48 +1023,77 @@ when CUT? returns true for a given package." (_ input))) + (define mapping-property + ;; Property indicating whether the package has already been processed. + (gensym " package-mapping-done")) + (define replace (mlambdaq (p) - ;; Return a variant of P with PROC applied to P and its explicit - ;; dependencies, recursively. Memoize the transformations. Failing to - ;; do that, we would build a huge object graph with lots of duplicates, - ;; which in turns prevents us from benefiting from memoization in - ;; 'package-derivation'. - (let ((p (proc p))) - (package - (inherit p) - (location (package-location p)) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))) - (replacement (and=> (package-replacement p) proc)))))) + ;; If P is the result of a previous call, return it. + (if (assq-ref (package-properties p) mapping-property) + p + + ;; Return a variant of P with PROC applied to P and its explicit + ;; dependencies, recursively. Memoize the transformations. Failing + ;; to do that, we would build a huge object graph with lots of + ;; duplicates, which in turns prevents us from benefiting from + ;; memoization in 'package-derivation'. + (let ((p (proc p))) + (package + (inherit p) + (location (package-location p)) + (build-system (if deep? + (build-system-with-package-mapping + (package-build-system p) rewrite) + (package-build-system p))) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p))) + (replacement (and=> (package-replacement p) replace)) + (properties `((,mapping-property . #t) + ,@(package-properties p)))))))) replace) (define* (package-input-rewriting replacements - #:optional (rewrite-name identity)) + #:optional (rewrite-name identity) + #:key (deep? #t)) "Return a procedure that, when passed a package, replaces its direct and -indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. +indirect dependencies, including implicit inputs when DEEP? is true, according +to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element +of each pair is the package to replace, and the second one is the replacement. Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a package and returns its new name after rewrite." - (define (rewrite p) - (match (assq-ref replacements p) - (#f (package - (inherit p) - (name (rewrite-name (package-name p))))) - (new new))) + (define replacement-property + ;; Property to tag right-hand sides in REPLACEMENTS. + (gensym " package-replacement")) - (package-mapping rewrite (cut assq <> replacements))) - -(define (package-input-rewriting/spec replacements) + (define (rewrite p) + (if (assq-ref (package-properties p) replacement-property) + p + (match (assq-ref replacements p) + (#f (package/inherit p + (name (rewrite-name (package-name p))))) + (new (if deep? + (package/inherit new + (properties `((,replacement-property . #t) + ,@(package-properties new)))) + new))))) + + (define (cut? p) + (or (assq-ref (package-properties p) replacement-property) + (assq-ref replacements p))) + + (package-mapping rewrite cut? + #:deep? deep?)) + +(define* (package-input-rewriting/spec replacements #:key (deep? #t)) "Return a procedure that, given a package, applies the given REPLACEMENTS to -all the package graph (excluding implicit inputs). REPLACEMENTS is a list of -spec/procedures pair; each spec is a package specification such as \"gcc\" or -\"guile@2\", and each procedure takes a matching package and returns a -replacement for that package." +all the package graph, including implicit inputs unless DEEP? is false. +REPLACEMENTS is a list of spec/procedures pair; each spec is a package +specification such as \"gcc\" or \"guile@2\", and each procedure takes a +matching package and returns a replacement for that package." (define table (fold (lambda (replacement table) (match replacement @@ -1049,22 +1118,27 @@ replacement for that package." (package-name package) table)) - (define (rewrite package) - (match (find-replacement package) - (#f package) - (proc (proc package)))) + (define replacement-property + (gensym " package-replacement")) - (package-mapping rewrite find-replacement)) - -(define-syntax-rule (package/inherit p overrides ...) - "Like (package (inherit P) OVERRIDES ...), except that the same -transformation is done to the package replacement, if any. P must be a bare -identifier, and will be bound to either P or its replacement when evaluating -OVERRIDES." - (let loop ((p p)) - (package (inherit p) - overrides ... - (replacement (and=> (package-replacement p) loop))))) + (define (rewrite p) + (if (assq-ref (package-properties p) replacement-property) + p + (match (find-replacement p) + (#f p) + (proc + (let ((new (proc p))) + ;; Mark NEW as already processed. + (package/inherit new + (properties `((,replacement-property . #t) + ,@(package-properties new))))))))) + + (define (cut? p) + (or (assq-ref (package-properties p) replacement-property) + (find-replacement p))) + + (package-mapping rewrite cut? + #:deep? deep?)) ;;; diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 0bac13edee..45f62f6ebc 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -31,6 +31,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 iconv) #:export (guix-authenticate)) ;;; Commentary: @@ -122,8 +123,9 @@ by colon, followed by the given number of characters." (reverse result)) (else (let* ((len (string->number (read-delimited ":" port))) - (str (utf8->string - (get-bytevector-n port len)))) + (str (bytevector->string + (get-bytevector-n port len) + "ISO-8859-1" 'error))) (loop (cons str result)))))))))) (define-syntax define-enumerate-type ;TODO: factorize @@ -150,7 +152,7 @@ by colon, followed by the given number of characters." (define (send-reply code str) ;; Send CODE and STR as a reply to our client. - (let ((bv (string->utf8 str))) + (let ((bv (string->bytevector str "ISO-8859-1" 'error))) (format #t "~a ~a:" code (bytevector-length bv)) (put-bytevector (current-output-port) bv) (force-output (current-output-port)))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 25418661b9..e59e0ee67f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -26,6 +26,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix memoization) #:use-module (guix grafts) #:use-module (guix utils) @@ -38,6 +39,7 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) + #:use-module (guix diagnostics) #:autoload (guix http-client) (http-fetch http-get-error?) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -46,6 +48,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) #:autoload (guix download) (download-to-store) @@ -61,6 +64,7 @@ %transformation-options options->transformation + manifest-entry-with-transformations show-transformation-options-help guix-build @@ -393,6 +397,102 @@ a checkout of the Git repository at the given URL." (rewrite obj) obj))) +(define (package-dependents/spec top bottom) + "Return the list of dependents of BOTTOM, a spec string, that are also +dependencies of TOP, a package." + (define-values (name version) + (package-name->name+version bottom)) + + (define dependent? + (mlambda (p) + (and (package? p) + (or (and (string=? name (package-name p)) + (or (not version) + (version-prefix? version (package-version p)))) + (match (bag-direct-inputs (package->bag p)) + (((labels dependencies . _) ...) + (any dependent? dependencies))))))) + + (filter dependent? (package-closure (list top)))) + +(define (package-toolchain-rewriting p bottom toolchain) + "Return a procedure that, when passed a package that's either BOTTOM or one +of its dependents up to P so, changes it so it is built with TOOLCHAIN. +TOOLCHAIN must be an input list." + (define rewriting-property + (gensym " package-toolchain-rewriting")) + + (match (package-dependents/spec p bottom) + (() ;P does not depend on BOTTOM + identity) + (set + ;; SET is the list of packages "between" P and BOTTOM (included) whose + ;; toolchain needs to be changed. + (package-mapping (lambda (p) + (if (or (assq rewriting-property + (package-properties p)) + (not (memq p set))) + p + (let ((p (package-with-c-toolchain p toolchain))) + (package/inherit p + (properties `((,rewriting-property . #t) + ,@(package-properties p))))))) + (lambda (p) + (or (assq rewriting-property (package-properties p)) + (not (memq p set)))) + #:deep? #t)))) + +(define (transform-package-toolchain replacement-specs) + "Return a procedure that, when passed a package, changes its toolchain or +that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is +a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to +the left of the equal sign must be built with the toolchain to the right of +the equal sign." + (define split-on-commas + (cute string-tokenize <> (char-set-complement (char-set #\,)))) + + (define (specification->input spec) + (let ((package (specification->package spec))) + (list (package-name package) package))) + + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec (= split-on-commas toolchain)) + (cons spec (map specification->input toolchain))) + (_ + (leave (G_ "~a: invalid toolchain replacement specification~%") + spec)))) + replacement-specs)) + + (lambda (store obj) + (if (package? obj) + (or (any (match-lambda + ((bottom . toolchain) + ((package-toolchain-rewriting obj bottom toolchain) obj))) + replacements) + obj) + obj))) + +(define (transform-package-tests specs) + "Return a procedure that, when passed a package, sets #:tests? #f in its +'arguments' field." + (define (package-without-tests p) + (package/inherit p + (arguments + (substitute-keyword-arguments (package-arguments p) + ((#:tests? _ #f) #f))))) + + (define rewrite + (package-input-rewriting/spec (map (lambda (spec) + (cons spec package-without-tests)) + specs))) + + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -403,7 +503,17 @@ a checkout of the Git repository at the given URL." (with-graft . ,transform-package-inputs/graft) (with-branch . ,transform-package-source-branch) (with-commit . ,transform-package-source-commit) - (with-git-url . ,transform-package-source-git-url))) + (with-git-url . ,transform-package-source-git-url) + (with-c-toolchain . ,transform-package-toolchain) + (without-tests . ,transform-package-tests))) + +(define (transformation-procedure key) + "Return the transformation procedure associated with KEY, a symbol such as +'with-source', or #f if there is none." + (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations)) (define %transformation-options ;; The command-line interface to the above transformations. @@ -423,11 +533,15 @@ a checkout of the Git repository at the given URL." (option '("with-commit") #t #f (parser 'with-commit)) (option '("with-git-url") #t #f - (parser 'with-git-url))))) + (parser 'with-git-url)) + (option '("with-c-toolchain") #t #f + (parser 'with-c-toolchain)) + (option '("without-tests") #t #f + (parser 'without-tests))))) (define (show-transformation-options-help) (display (G_ " - --with-source=SOURCE + --with-source=[PACKAGE=]SOURCE use SOURCE when building the corresponding package")) (display (G_ " --with-input=PACKAGE=REPLACEMENT @@ -443,7 +557,13 @@ a checkout of the Git repository at the given URL." build PACKAGE from COMMIT")) (display (G_ " --with-git-url=PACKAGE=URL - build PACKAGE from the repository at URL"))) + build PACKAGE from the repository at URL")) + (display (G_ " + --with-c-toolchain=PACKAGE=TOOLCHAIN + build PACKAGE and its dependents with TOOLCHAIN")) + (display (G_ " + --without-tests=PACKAGE + build PACKAGE without running its tests"))) (define (options->transformation opts) @@ -454,32 +574,69 @@ derivation, etc.), applies the transformations specified by OPTS." ;; order in which they appear on the command line. (filter-map (match-lambda ((key . value) - (match (any (match-lambda - ((k . proc) - (and (eq? k key) proc))) - %transformations) + (match (transformation-procedure key) (#f #f) (transform ;; XXX: We used to pass TRANSFORM a list of several ;; arguments, but we now pass only one, assuming that ;; transform composes well. - (cons key (transform (list value))))))) + (list key value (transform (list value))))))) (reverse opts))) + (define (package-with-transformation-properties p) + (package/inherit p + (properties `((transformations + . ,(map (match-lambda + ((key value _) + (cons key value))) + applicable)) + ,@(package-properties p))))) + (lambda (store obj) - (fold (match-lambda* - (((name . transform) obj) - (let ((new (transform store obj))) - (when (eq? new obj) - (warning (G_ "transformation '~a' had no effect on ~a~%") - name - (if (package? obj) - (package-full-name obj) - obj))) - new))) - obj - applicable))) + (define (tagged-object new) + (if (and (not (eq? obj new)) + (package? new) (not (null? applicable))) + (package-with-transformation-properties new) + new)) + + (tagged-object + (fold (match-lambda* + (((name value transform) obj) + (let ((new (transform store obj))) + (when (eq? new obj) + (warning (G_ "transformation '~a' had no effect on ~a~%") + name + (if (package? obj) + (package-full-name obj) + obj))) + new))) + obj + applicable)))) + +(define (package-transformations package) + "Return the transformations applied to PACKAGE according to its properties." + (match (assq-ref (package-properties package) 'transformations) + (#f '()) + (transformations transformations))) + +(define (manifest-entry-with-transformations entry) + "Return ENTRY with an additional 'transformations' property if it's not +already there." + (let ((properties (manifest-entry-properties entry))) + (if (assq 'transformations properties) + entry + (let ((item (manifest-entry-item entry))) + (manifest-entry + (inherit entry) + (properties + (match (and (package? item) + (package-transformations item)) + ((or #f '()) + properties) + (transformations + `((transformations . ,transformations) + ,@properties))))))))) ;;; @@ -805,7 +962,28 @@ must be one of 'package', 'all', or 'transitive'~%") build---packages, gexps, derivations, and so on." (define (validate-type x) (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x)) - (leave (G_ "~s: not something we can build~%") x))) + (raise (make-compound-condition + (formatted-message (G_ "~s: not something we can build~%") x) + (condition + (&fix-hint + (hint + (if (unspecified? x) + (G_ "If you build from a file, make sure the last Scheme +expression returns a package value. @code{define-public} defines a variable, +but returns @code{#<unspecified>}. To fix this, add a Scheme expression at +the end of the file that consists only of the package's variable name you +defined, as in this example: + +@example +(define-public my-package + (package + ...)) + +my-package +@end example") + (G_ "If you build from a file, make sure the last +Scheme expression returns a package, gexp, derivation or a list of such +values."))))))))) (define (ensure-list x) (let ((lst (match x diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index ad50281eb2..085f11a9d4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -34,6 +34,7 @@ #:use-module (guix scripts build) #: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) #:use-module (gnu system file-systems) #:use-module (gnu packages) @@ -549,6 +550,16 @@ WHILE-LIST." (write-passwd (list passwd)) (write-group groups) + (unless network? + ;; When isolated from the network, provide a minimal /etc/hosts + ;; to resolve "localhost". + (call-with-output-file "/etc/hosts" + (lambda (port) + (display "127.0.0.1 localhost\n" port))) + + ;; Allow local AF_INET communications. + (set-network-interface-up "lo")) + ;; For convenience, start in the user's current working ;; directory or, if unmapped, the home directory. (chdir (if map-cwd? @@ -564,7 +575,11 @@ WHILE-LIST." (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. - (launch-environment command profile manifest #:pure? #f))) + (launch-environment command + (if link-profile? + (string-append home-dir "/.guix-profile") + profile) + manifest #:pure? #f))) #:guest-uid uid #:guest-gid gid #:namespaces (if network? diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 710e786a79..906dca24b1 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -49,7 +49,7 @@ Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the -package will be generated. If no version suffix is pecified, then the +package will be generated. If no version suffix is specified, then the generated package definition will correspond to the latest available version.\n")) (display (G_ " diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 3dc8ccefcb..a5fe98b675 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -88,6 +88,10 @@ (default 3)) (daemon-socket build-machine-daemon-socket ; string (default "/var/guix/daemon-socket/socket")) + ;; A #f value tells the offload scheduler to disregard the load of the build + ;; machine when selecting the best offload machine. + (overload-threshold build-machine-overload-threshold ; inexact real between + (default 0.6)) ; 0.0 and 1.0 | #f (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -391,30 +395,34 @@ of free disk space on '~a'~%") (* 100 (expt 2 20))) ;100 MiB (define (node-load node) - "Return the load on NODE. Return +∞ if NODE is misbehaving." + "Return the load on NODE, a normalized value between 0.0 and 1.0. The value +is derived from /proc/loadavg and normalized according to the number of +logical cores available, to give a rough estimation of CPU usage. Return +1.0 (fully loaded) if NODE is misbehaving." (let ((line (inferior-eval '(begin (use-modules (ice-9 rdelim)) (call-with-input-file "/proc/loadavg" read-string)) - node))) - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + node)) + (ncores (inferior-eval '(begin + (use-modules (ice-9 threads)) + (current-processor-count)) + node))) + (if (or (eof-object? line) (eof-object? ncores)) + 1.0 ;MACHINE does not respond, so assume it is fully loaded (match (string-tokenize line) ((one five fifteen . x) - (string->number one)) + (let ((load (/ (string->number one) ncores))) + (if (> load 1.0) + 1.0 + load))) (x - +inf.0))))) - -(define (normalized-load machine load) - "Divide LOAD by the number of parallel builds of MACHINE." - (if (rational? load) - (let* ((jobs (build-machine-parallel-builds machine)) - (normalized (/ load jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ - (normalized: ~s)~%" - (build-machine-name machine) load normalized) - normalized) - load)) + 1.0))))) + +(define (report-load machine load) + (format (current-error-port) + "normalized load on machine '~a' is ~,2f~%" + (build-machine-name machine) load)) (define (random-seed) (logxor (getpid) (car (gettimeofday)))) @@ -472,11 +480,15 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (let* ((session (false-if-exception (open-ssh-session best %short-timeout))) (node (and session (remote-inferior session))) - (load (and node (normalized-load best (node-load node)))) + (load (and node (node-load node))) + (threshold (build-machine-overload-threshold best)) (space (and node (node-free-disk-space node)))) + (when load (report-load best load)) (when node (close-inferior node)) (when session (disconnect! session)) - (if (and node (< load 2.) (>= space %minimum-disk-space)) + (if (and node + (or (not threshold) (< load threshold)) + (>= space %minimum-disk-space)) (match others (((machines slots) ...) ;; Release slots from the uninteresting machines. @@ -708,13 +720,13 @@ machine." (free (node-free-disk-space inferior))) (close-inferior inferior) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%\ + host name: ~a~% normalized load: ~,2f~% free disk space: ~,2f MiB~%\ time difference: ~a s~%" (build-machine-name machine) (utsname:sysname uts) (utsname:release uts) (utsname:machine uts) (utsname:nodename uts) - (normalized-load machine load) + load (/ free (expt 2 20) 1.) (- time now)))))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a0112162e3..ea2a96d5a1 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -826,11 +826,17 @@ last resort for relocation." (string-append "-DLOADER_AUDIT_MODULE=\"" #$(audit-module) "\"") + + ;; XXX: Normally (runpath #$(audit-module)) is + ;; enough. However, to work around + ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=26634> + ;; (glibc <= 2.32), pass the whole search path of + ;; PROGRAM, which presumably is a superset of that + ;; of the audit module. (string-append "-DLOADER_AUDIT_RUNPATH={ " (string-join (map object->string - (runpath - #$(audit-module))) + (runpath program)) ", " 'suffix) "NULL }") (if gconv @@ -1143,19 +1149,24 @@ Create a bundle of PACKAGE.\n")) manifest)) identity)) + (define (with-transformations manifest) + (map-manifest-entries manifest-entry-with-transformations + manifest)) + (with-provenance - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (packages->manifest packages)))))) + (with-transformations + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages))))))) (with-error-handling (with-store store diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4eb968a49b..2f04652634 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -218,12 +218,13 @@ non-zero relevance score." (output (manifest-entry-output old))) transaction))) - (define (upgrade entry) + (define (upgrade entry transform) (match entry (($ <manifest-entry> name version output (? string? path)) (match (find-best-packages-by-name name #f) ((pkg . rest) - (let ((candidate-version (package-version pkg))) + (let* ((pkg (transform store pkg)) + (candidate-version (package-version pkg))) (match (package-superseded pkg) ((? package? new) (supersede entry new)) @@ -231,12 +232,14 @@ non-zero relevance score." (case (version-compare candidate-version version) ((>) (manifest-transaction-install-entry - (package->manifest-entry* pkg output) + (manifest-entry-with-transformations + (package->manifest-entry* pkg output)) transaction)) ((<) transaction) ((=) - (let* ((new (package->manifest-entry* pkg output))) + (let* ((new (manifest-entry-with-transformations + (package->manifest-entry* pkg output)))) ;; Here we want to determine whether the NEW actually ;; differs from ENTRY, but we need to intercept ;; 'build-things' calls because they would prevent us from @@ -255,7 +258,14 @@ non-zero relevance score." (if (manifest-transaction-removal-candidate? entry transaction) transaction - (upgrade entry))) + + ;; Upgrade ENTRY, preserving transformation options listed in its + ;; properties. + (let ((transform (options->transformation + (or (assq-ref (manifest-entry-properties entry) + 'transformations) + '())))) + (upgrade entry transform)))) ;;; @@ -585,14 +595,8 @@ upgrading, #f otherwise." (define (package->manifest-entry* package output) "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to the resulting manifest entry." - (define (provenance-properties package) - (match (package-provenance package) - (#f '()) - (sexp `((provenance ,@sexp))))) - - (package->manifest-entry package output - #:properties (provenance-properties package))) - + (manifest-entry-with-provenance + (package->manifest-entry package output))) (define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', @@ -870,12 +874,13 @@ processed, #f otherwise." (define (transform-entry entry) (let ((item (transform store (manifest-entry-item entry)))) - (manifest-entry - (inherit entry) - (item item) - (version (if (package? item) - (package-version item) - (manifest-entry-version entry)))))) + (manifest-entry-with-transformations + (manifest-entry + (inherit entry) + (item item) + (version (if (package? item) + (package-version item) + (manifest-entry-version entry))))))) (when (equal? profile %current-profile) ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 3c79e89f8d..9f20803efc 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) + #:autoload (guix describe) (current-profile) #:autoload (system repl repl) (start-repl) #:autoload (system repl server) (make-tcp-server-socket make-unix-domain-server-socket) @@ -176,9 +177,19 @@ call THUNK." ;; Run script (save-module-excursion (lambda () + ;; Invoke 'current-profile' so that it memoizes the correct value + ;; based on (program-arguments), before we call + ;; 'set-program-arguments'. This in turn ensures that + ;; (%package-module-path) will contain entries for the channels + ;; available in the current profile. + (current-profile) + (set-program-arguments script) (set-user-module) - (load-in-vicinity "." (car script))))) + + ;; When passed a relative file name, 'load-in-vicinity' searches the + ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".". + (load-in-vicinity (getcwd) (car script))))) (when (null? script) ;; Start REPL diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 26613df68f..7ec170b08a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -137,7 +137,7 @@ disabled!~%")) (define %narinfo-negative-ttl ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). - (* 3 3600)) + (* 1 3600)) (define %narinfo-transient-error-ttl ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bd5f84fc5b..9ed5c26483 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -384,6 +384,7 @@ STORE is an open connection to the store." ;; Make the specified system generation the default entry. (params (first (profile-boot-parameters %system-profile (list number)))) + (locale (boot-parameters-locale params)) (old-generations (delv number (reverse (generation-numbers %system-profile)))) (old-params (profile-boot-parameters @@ -396,6 +397,7 @@ STORE is an open connection to the store." ((bootcfg (lower-object ((bootloader-configuration-file-generator bootloader) bootloader-config entries + #:locale locale #:old-entries old-entries))) (drvs -> (list bootcfg))) (mbegin %store-monad @@ -666,38 +668,45 @@ checking this by themselves in their 'check' procedure." ;;; Action. ;;; -(define* (system-derivation-for-action os base-image action - #:key image-size file-system-type +(define* (system-derivation-for-action os action + #:key image-size image-type full-boot? container-shared-network? mappings label) "Return as a monadic value the derivation for OS according to ACTION." - (case action - ((build init reconfigure) - (operating-system-derivation os)) - ((container) - (container-script - os - #:mappings mappings - #:shared-network? container-shared-network?)) - ((vm-image) - (system-qemu-image os #:disk-image-size image-size)) - ((vm) - (system-qemu-image/shared-store-script os - #:full-boot? full-boot? - #:disk-image-size - (if full-boot? - image-size - (* 70 (expt 2 20))) - #:mappings mappings)) - ((disk-image) - (lower-object - (system-image - (image - (inherit (if label (image-with-label base-image label) base-image)) - (size image-size) - (operating-system os))))) - ((docker-image) - (system-docker-image os #:shared-network? container-shared-network?)))) + (mlet %store-monad ((target (current-target-system))) + (case action + ((build init reconfigure) + (operating-system-derivation os)) + ((container) + (container-script + os + #:mappings mappings + #:shared-network? container-shared-network?)) + ((vm-image) + (system-qemu-image os #:disk-image-size image-size)) + ((vm) + (system-qemu-image/shared-store-script os + #:full-boot? full-boot? + #:disk-image-size + (if full-boot? + image-size + (* 70 (expt 2 20))) + #:mappings mappings)) + ((disk-image) + (let* ((base-image (os->image os #:type image-type)) + (base-target (image-target base-image))) + (lower-object + (system-image + (image + (inherit (if label + (image-with-label base-image label) + base-image)) + (target (or base-target target)) + (size image-size) + (operating-system os)))))) + ((docker-image) + (system-docker-image os + #:shared-network? container-shared-network?))))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -748,18 +757,19 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size file-system-type full-boot? label - container-shared-network? + image-size image-type + full-boot? label container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'vm-image' and 'disk-image' actions. The root file system is created as a -FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it -determines whether to boot directly to the kernel or to the bootloader. -CONTAINER-SHARED-NETWORK? determines if the container will use a separate -network namespace. +the 'vm-image' and 'disk-image' actions. IMAGE-TYPE is the type of image to +be built. + +FULL-BOOT? is used for the 'vm' action; it determines whether to +boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? +determines if the container will use a separate network namespace. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -799,11 +809,9 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((target* (current-target-system)) - (image -> (find-image file-system-type target*)) - (sys (system-derivation-for-action os image action + ((sys (system-derivation-for-action os action #:label label - #:file-system-type file-system-type + #:image-type image-type #:image-size image-size #:full-boot? full-boot? #:container-shared-network? container-shared-network? @@ -888,6 +896,17 @@ Run 'herd status' to view the list of services on your system.\n")))))) ;;; +;;; Images. +;;; + +(define (list-image-types) + "Print the available image types." + (display (G_ "The available image types are:\n")) + (newline) + (format #t "~{ - ~a ~%~}" (map image-type-name (force %image-types)))) + + +;;; ;;; Options. ;;; @@ -945,9 +964,9 @@ Some ACTIONS support additional ARGS.\n")) apply STRATEGY (one of nothing-special, backtrace, or debug) when an error occurs while reading FILE")) (display (G_ " - --file-system-type=TYPE - for 'disk-image', produce a root file system of TYPE - (one of 'ext4', 'iso9660')")) + --list-image-types list available image types")) + (display (G_ " + -t, --image-type=TYPE for 'disk-image', produce an image of TYPE")) (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " @@ -1008,10 +1027,14 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) result))) - (option '(#\t "file-system-type") #t #f + (option '(#\t "image-type") #t #f (lambda (opt name arg result) - (alist-cons 'file-system-type arg + (alist-cons 'image-type (string->symbol arg) result))) + (option '("list-image-types") #f #f + (lambda (opt name arg result) + (list-image-types) + (exit 0))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -1080,7 +1103,7 @@ Some ACTIONS support additional ARGS.\n")) (debug . 0) (verbosity . #f) ;default (validate-reconfigure . ,ensure-forward-reconfigure) - (file-system-type . "ext4") + (image-type . raw) (image-size . guess) (install-bootloader? . #t) (label . #f))) @@ -1177,7 +1200,8 @@ resulting from command-line parsing." (assoc-ref opts 'skip-safety-checks?) #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) - #:file-system-type (assoc-ref opts 'file-system-type) + #:image-type (lookup-image-type-by-name + (assoc-ref opts 'image-type)) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) #:container-shared-network? diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 45bb1d5d3b..d89caf80fc 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -126,22 +126,25 @@ return the <live-service> objects that are currently running on MACHINE." (define exp (with-imported-modules '((gnu services herd)) #~(begin - (use-modules (gnu services herd)) + (use-modules (gnu services herd) + (ice-9 match)) + (let ((services (current-services))) (and services - ;; 'live-service-running' is ignored, as we can't necessarily - ;; serialize arbitrary objects. This should be fine for now, - ;; since 'machine-current-services' is not exposed publicly, - ;; and the resultant <live-service> objects are only used for - ;; resolving service dependencies. (map (lambda (service) (list (live-service-provision service) - (live-service-requirement service))) + (live-service-requirement service) + (match (live-service-running service) + (#f #f) + (#t #t) + ((? number? pid) pid) + (_ #t)))) ;not serializable services)))))) + (mlet %store-monad ((services (eval exp))) (return (map (match-lambda - ((provision requirement) - (live-service provision requirement #f))) + ((provision requirement running) + (live-service provision requirement running))) services)))) ;; XXX: Currently, this does NOT attempt to restart running services. See @@ -181,13 +184,14 @@ services as defined by OS." (mlet* %store-monad ((live-services (running-services eval))) (let*-values (((to-unload to-restart) (shepherd-service-upgrade live-services target-services))) - (let* ((to-unload (map live-service-canonical-name to-unload)) + (let* ((to-unload (map live-service-canonical-name to-unload)) (to-restart (map shepherd-service-canonical-name to-restart)) - (to-start (lset-difference eqv? - (map shepherd-service-canonical-name - target-services) - (map live-service-canonical-name - live-services))) + (running (map live-service-canonical-name + (filter live-service-running live-services))) + (to-start (lset-difference eqv? + (map shepherd-service-canonical-name + target-services) + running)) (service-files (map shepherd-service-file target-services))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(upgrade-services-program service-files diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index 8c7abd133a..5ec844328e 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -36,6 +36,8 @@ This is an alias for 'guix package -u'.\n")) -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " + --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) (newline) (show-build-options-help) (newline) diff --git a/guix/self.scm b/guix/self.scm index 02ef982c7c..bbfd2f1b95 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -27,6 +27,7 @@ #:use-module (guix packages) #:use-module (guix sets) #:use-module (guix modules) + #:use-module ((guix utils) #:select (version-major+minor)) #:use-module ((guix build utils) #:select (find-files)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -56,12 +57,13 @@ ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) - ("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls)) + ("gnutls" (ref '(gnu packages tls) 'gnutls)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) ("po4a" (ref '(gnu packages gettext) 'po4a)) ("gettext" (ref '(gnu packages gettext) 'gettext-minimal)) + ("gcc-toolchain" (ref '(gnu packages commencement) 'gcc-toolchain)) (_ #f)))) ;no such package @@ -580,6 +582,48 @@ that provide Guile modules." (computed-file name build)) +(define (quiet-guile guile) + "Return a wrapper that does the same as the 'guile' executable of GUILE, +except that it does not complain about locales and falls back to 'en_US.utf8' +instead of 'C'." + (define gcc + (specification->package "gcc-toolchain")) + + (define source + (search-path %load-path + "gnu/packages/aux-files/guile-launcher.c")) + + (define effective + (version-major+minor (package-version guile))) + + (define build + ;; XXX: Reuse <c-compiler> from (guix scripts pack) instead? + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-26)) + + (mkdir-p (string-append #$output "/bin")) + + (setenv "PATH" #$(file-append gcc "/bin")) + (setenv "C_INCLUDE_PATH" + (string-join + (map (cut string-append <> "/include") + '#$(match (bag-transitive-build-inputs + (package->bag guile)) + (((labels packages . _) ...) + (filter package? packages)))) + ":")) + (setenv "LIBRARY_PATH" #$(file-append gcc "/lib")) + + (invoke "gcc" #$(local-file source) "-Wall" "-g0" "-O2" + "-I" #$(file-append guile "/include/guile/" effective) + "-L" #$(file-append guile "/lib") + #$(string-append "-lguile-" effective) + "-o" (string-append #$output "/bin/guile"))))) + + (computed-file "guile-wrapper" build)) + (define* (guix-command modules #:key source (dependencies '()) guile (guile-version (effective-version))) @@ -634,7 +678,9 @@ load path." ;; XXX: It would be more convenient to change it to: ;; (exit (apply guix-main (command-line))) (apply guix-main (command-line)))) - #:guile guile)) + + ;; Use a 'guile' variant that doesn't complain about locales. + #:guile (quiet-guile guile))) (define (miscellaneous-files source) "Return data files taken from SOURCE." diff --git a/guix/ui.scm b/guix/ui.scm index ecaf975c1f..8d7bc238bc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -297,7 +297,8 @@ VARIABLE and return it, or #f if none was found." (hash-map->list (lambda (name module) module) (module-submodules head))))) - (match (module-local-variable head variable) + (match (and=> (module-public-interface head) + (cut module-local-variable <> variable)) (#f (loop next suggestions visited)) (_ (match (module-name head) @@ -492,7 +493,7 @@ part." lines: @example -guix package -i glibc-utf8-locales +guix install glibc-utf8-locales export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\" @end example @@ -2134,7 +2135,7 @@ and signal handling have already been set up." (G_ "guix: missing command name~%")) (show-guix-usage)) ((or ("-h") ("--help")) - (show-guix-help)) + (leave-on-EPIPE (show-guix-help))) ((or ("-V") ("--version")) (show-version-and-exit "guix")) (((? option? o) args ...) @@ -2145,7 +2146,7 @@ and signal handling have already been set up." (apply run-guix-command (string->symbol command) '("--help"))) (("help" args ...) - (show-guix-help)) + (leave-on-EPIPE (show-guix-help))) ((command args ...) (apply run-guix-command (string->symbol command) |