From fcbe4f71ca7ab7f8526bd1643044d204390ec6c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Dec 2019 23:04:57 +0100 Subject: derivations: Add 'derivation-input-fold'. * guix/derivations.scm (derivation-input-fold): New procedure. (substitution-oracle)[closure]: Rewrite in terms of 'derivation-input-fold'. * tests/derivations.scm ("derivation-input-fold"): New test. --- guix/derivations.scm | 52 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 6cdf55b1fe..480a65c78b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -86,6 +86,7 @@ fixed-output-derivation? offloadable-derivation? substitutable-derivation? + derivation-input-fold substitution-oracle derivation-hash derivation-properties @@ -303,6 +304,29 @@ result is the set of prerequisites of DRV not already in valid." (derivation-output-path (assoc-ref outputs sub-drv))) sub-drvs)))) +(define* (derivation-input-fold proc seed inputs + #:key (cut? (const #f))) + "Perform a breadth-first traversal of INPUTS, calling PROC on each input +with the current result, starting from SEED. Skip recursion on inputs that +match CUT?." + (let loop ((inputs inputs) + (result seed) + (visited (set))) + (match inputs + (() + result) + ((input rest ...) + (let ((key (derivation-input-key input))) + (cond ((set-contains? visited key) + (loop rest result visited)) + ((cut? input) + (loop rest result (set-insert key visited))) + (else + (let ((drv (derivation-input-derivation input))) + (loop (append (derivation-inputs drv) rest) + (proc input result) + (set-insert key visited)))))))))) + (define* (substitution-oracle store inputs-or-drv #:key (mode (build-mode normal))) "Return a one-argument procedure that, when passed a store file name, @@ -322,25 +346,15 @@ substituter many times." (cut valid-derivation-input? store <>)) (define (closure inputs) - (let loop ((inputs inputs) - (closure '()) - (visited (set))) - (match inputs - (() - (reverse closure)) - ((input rest ...) - (let ((key (derivation-input-key input))) - (cond ((set-contains? visited key) - (loop rest closure visited)) - ((valid-input? input) - (loop rest closure (set-insert key visited))) - (else - (let ((drv (derivation-input-derivation input))) - (loop (append (derivation-inputs drv) rest) - (if (substitutable-derivation? drv) - (cons input closure) - closure) - (set-insert key visited)))))))))) + (reverse + (derivation-input-fold (lambda (input closure) + (let ((drv (derivation-input-derivation input))) + (if (substitutable-derivation? drv) + (cons input closure) + closure))) + '() + inputs + #:cut? valid-input?))) (let* ((inputs (closure (map (match-lambda ((? derivation-input? input) -- cgit v1.2.3 From b85836d3067a0faccc945d584dfb88cf557eee97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Nov 2019 18:13:09 +0100 Subject: guix system: Use 'provenance-service-type', add "--save-provenance". * guix/scripts/system.scm (show-help, %options): Add "--save-provenance". (process-action): Define 'save-provenance?' and 'transform'; call 'transform' on the OS. * doc/guix.texi (Invoking guix system): Document it under 'reconfigure'. (Service Reference): Mention that 'provenance-service-type' is automatically added by 'reconfigure' & 'init'. --- doc/guix.texi | 61 ++++++++++++++++++++++++++++++++++++++++++------- guix/scripts/system.scm | 47 ++++++++++++++++++++++++------------- 2 files changed, 84 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 33ee81b150..bd7cb7a3da 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25900,6 +25900,15 @@ switch to it@footnote{This action (and the related actions @code{switch-generation} and @code{roll-back}) are usable only on systems already running Guix System.}. +@quotation Note +@c The paragraph below refers to the problem discussed at +@c . +It is highly recommended to run @command{guix pull} once before you run +@command{guix system reconfigure} for the first time (@pxref{Invoking +guix pull}). Failing to do that you would see an older version of Guix +once @command{reconfigure} has completed. +@end quotation + This effects all the configuration specified in @var{file}: user accounts, system services, global package list, setuid programs, etc. The command starts system services specified in @var{file} that are not @@ -25918,14 +25927,27 @@ It also adds a bootloader menu entry for the new OS configuration, entries for older configurations to a submenu, allowing you to choose an older system generation at boot time should you need it. -@quotation Note -@c The paragraph below refers to the problem discussed at -@c . -It is highly recommended to run @command{guix pull} once before you run -@command{guix system reconfigure} for the first time (@pxref{Invoking -guix pull}). Failing to do that you would see an older version of Guix -once @command{reconfigure} has completed. -@end quotation +@cindex provenance tracking, of the operating system +Upon completion, the new system is deployed under +@file{/run/current-system}. This directory contains @dfn{provenance +meta-data}: the list of channels in use (@pxref{Channels}) and +@var{file} itself, when available. This information is useful should +you later want to inspect how this particular generation was built. + +In fact, assuming @var{file} is self-contained, you can later rebuild +generation @var{n} of your operating system with: + +@example +guix time-machine \ + -C /var/guix/profiles/system-@var{n}-link/channels.scm -- \ + system reconfigure \ + /var/guix/profiles/system-@var{n}-link/configuration.scm +@end example + +You can think of it as some sort of built-in version control! Your +system is not just a binary artifact: @emph{it carries its own source}. +@xref{Service Reference, @code{provenance-service-type}}, for more +information on provenance tracking. @item switch-generation @cindex generations @@ -26187,6 +26209,25 @@ This works as per @command{guix build} (@pxref{Invoking guix build}). Return the derivation file name of the given operating system without building anything. +@cindex provenance tracking, of the operating system +@item --save-provenance +As discussed above, @command{guix system init} and @command{guix system +reconfigure} always save provenance information @i{via} a dedicated +service (@pxref{Service Reference, @code{provenance-service-type}}). +However, other commands don't do that by default. If you wish to, say, +create a virtual machine image that contains provenance information, you +can run: + +@example +guix system vm-image --save-provenance config.scm +@end example + +That way, the resulting image will effectively ``embed its own source'' +in the form of meta-data in @file{/run/current-system}. With that +information, one can rebuild the image to make sure it really contains +what it pretends to contain; or they could use that to derive a variant +of the image. + @item --file-system-type=@var{type} @itemx -t @var{type} For the @code{disk-image} action, create a file system of the given @@ -27086,6 +27127,10 @@ channels can lead to the same system, bit-for-bit; when different meta-data and thus different store file names, which makes comparison less trivial. @end quotation + +This service is automatically added to your operating system +configuration when you use @command{guix system reconfigure} or +@command{guix system init}. @end defvr @node Shepherd Services diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5f0dce2093..c9d790a731 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -722,7 +722,9 @@ and TARGET arguments." (return (primitive-eval (lowered-gexp-sexp lowered)))))) (define* (perform-action action os - #:key skip-safety-checks? + #:key + save-provenance? + skip-safety-checks? install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target @@ -917,16 +919,18 @@ Some ACTIONS support additional ARGS.\n")) --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) + (display (G_ " + --save-provenance save provenance information")) (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) + (display (G_ " + --expose=SPEC for 'vm', expose host file system according to SPEC")) (display (G_ " -N, --network for 'container', allow containers to access the network")) (display (G_ " -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) - (display (G_ " - --expose=SPEC for 'vm', expose host file system according to SPEC")) (display (G_ " --full-boot for 'vm', make a full boot sequence")) (display (G_ " @@ -979,6 +983,9 @@ Some ACTIONS support additional ARGS.\n")) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) + (option '("save-provenance") #f #f + (lambda (opt name arg result) + (alist-cons 'save-provenance? #t result))) (option '("skip-checks") #f #f (lambda (opt name arg result) (alist-cons 'skip-safety-checks? #t result))) @@ -1047,25 +1054,33 @@ resulting from command-line parsing." file-or-exp)) obj) + (define save-provenance? + (or (assoc-ref opts 'save-provenance?) + (memq action '(init reconfigure)))) + (let* ((file (match args (() #f) ((x . _) x))) (expr (assoc-ref opts 'expression)) (system (assoc-ref opts 'system)) (target (assoc-ref opts 'target)) - (os (ensure-operating-system - (or file expr) - (cond - ((and expr file) - (leave - (G_ "both file and expression cannot be specified~%"))) - (expr - (read/eval expr)) - (file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error))) - (else - (leave (G_ "no configuration specified~%")))))) + (transform (if save-provenance? + (cut operating-system-with-provenance <> file) + identity)) + (os (transform + (ensure-operating-system + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) -- cgit v1.2.3 From 60f4564a63316c5655cfd1e01ea2ebfdd9cfb9f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Nov 2019 23:07:39 +0100 Subject: guix system: "list-generations" displays provenance info. * guix/scripts/pull.scm (channel-commit-hyperlink): Export. * guix/scripts/system.scm (display-system-generation) [display-channel]: New procedure. Read the "provenance" file of GENERATION and display channel info and the configuration file name when available. --- guix/scripts/pull.scm | 1 + guix/scripts/system.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 48 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 19410ad141..04cc51829d 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -60,6 +60,7 @@ #:use-module (ice-9 format) #:export (display-profile-content channel-list + channel-commit-hyperlink with-git-error-handling guix-pull)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index c9d790a731..129c248283 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -36,9 +36,11 @@ #:use-module (guix records) #:use-module (guix profiles) #:use-module (guix scripts) + #:use-module (guix channels) #:use-module (guix scripts build) #:autoload (guix scripts package) (delete-generations delete-matching-generations) + #:autoload (guix scripts pull) (channel-commit-hyperlink) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix scripts system reconfigure) @@ -456,9 +458,30 @@ list of services." ;;; Generations. ;;; +(define (sexp->channel sexp) + "Return the channel corresponding to SEXP, an sexp as found in the +\"provenance\" file produced by 'provenance-service-type'." + (match sexp + (('channel ('name name) + ('url url) + ('branch branch) + ('commit commit)) + (channel (name name) (url url) + (branch branch) (commit commit))))) + (define* (display-system-generation number #:optional (profile %system-profile)) "Display a summary of system generation NUMBER in a human-readable format." + (define (display-channel channel) + (format #t " ~a:~%" (channel-name channel)) + (format #t (G_ " repository URL: ~a~%") (channel-url channel)) + (when (channel-branch channel) + (format #t (G_ " branch: ~a~%") (channel-branch channel))) + (format #t (G_ " commit: ~a~%") + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel) + (channel-commit channel)))) + (unless (zero? number) (let* ((generation (generation-file-name profile number)) (params (read-boot-parameters-file generation)) @@ -468,7 +491,13 @@ list of services." (root-device (if (bytevector? root) (uuid->string root) root)) - (kernel (boot-parameters-kernel params))) + (kernel (boot-parameters-kernel params)) + (provenance (catch 'system-error + (lambda () + (call-with-input-file + (string-append generation "/provenance") + read)) + (const #f)))) (display-generation profile number) (format #t (G_ " file name: ~a~%") generation) (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) @@ -495,7 +524,23 @@ list of services." (else root-device))) - (format #t (G_ " kernel: ~a~%") kernel)))) + (format #t (G_ " kernel: ~a~%") kernel) + + (match provenance + (#f #t) + (('provenance ('version 0) + ('channels channels ...) + ('configuration-file config-file)) + (unless (null? channels) + ;; TRANSLATORS: Here "channel" is the same terminology as used in + ;; "guix describe" and "guix pull --channels". + (format #t (G_ " channels:~%")) + (for-each display-channel (map sexp->channel channels))) + (when config-file + (format #t (G_ " configuration file: ~a~%") + (if (supports-hyperlinks?) + (file-hyperlink config-file) + config-file)))))))) (define* (list-generations pattern #:optional (profile %system-profile)) "Display in a human-readable format all the system generations matching -- cgit v1.2.3 From 158032bd7dcc33d17da8091b2319bf59ee9db6a1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Nov 2019 23:19:45 +0100 Subject: guix system: Add "describe" action. * guix/scripts/system.scm (show-help): Add "describe". (process-command): Handle it. (guix-system): Likewise. * doc/guix.texi (Invoking guix system): Document it. --- doc/guix.texi | 4 ++++ guix/scripts/system.scm | 11 ++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4c2ecd4b84..84548b1b7d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -26301,6 +26301,10 @@ bootloader boot menu: @table @code +@item describe +Describe the current system generation: its file name, the kernel and +bootloader used, etc., as well as provenance information when available. + @item list-generations List a summary of each generation of the operating system available on disk, in a human-readable way. This is similar to the diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 129c248283..3e9570753d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -921,6 +921,8 @@ Some ACTIONS support additional ARGS.\n")) reconfigure switch to a new operating system configuration\n")) (display (G_ "\ roll-back switch to the previous operating system configuration\n")) + (display (G_ "\ + describe describe the current system\n")) (display (G_ "\ list-generations list the system generations\n")) (display (G_ "\ @@ -1196,6 +1198,12 @@ argument list and OPTS is the option alist." ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) + ((describe) + (match (generation-number %system-profile) + (0 + (error (G_ "no system generation, nothing to describe~%"))) + (generation + (display-system-generation generation)))) ((search) (apply (resolve-subcommand "search") args)) ;; The following commands need to use the store, but they do not need an @@ -1235,7 +1243,8 @@ argument list and OPTS is the option alist." (case action ((build container vm vm-image disk-image reconfigure init extension-graph shepherd-graph - list-generations delete-generations roll-back + list-generations describe + delete-generations roll-back switch-generation search docker-image) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) -- cgit v1.2.3 From 0dc5c85638b49d5aed043420346083935ac51435 Mon Sep 17 00:00:00 2001 From: Guillaume Le Vaillant Date: Tue, 3 Dec 2019 10:31:08 +0100 Subject: file-systems: Add support for 'strict-atime' and 'lazy-time' flags. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/syscalls.scm (MS_LAZYTIME): New variable. * gnu/build/file-systems.scm (mount-flags->bit-mask): Add match rules for 'strict-atime' and 'lazy-time'. * doc/guix.texi (File Systems): Add 'strict-atime' and 'lazy-time' to the list of supported flags. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 9 ++++++--- gnu/build/file-systems.scm | 5 +++++ guix/build/syscalls.scm | 3 +++ 3 files changed, 14 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 84548b1b7d..446534c576 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11244,9 +11244,12 @@ corresponding device mapping established. This is a list of symbols denoting mount flags. Recognized flags include @code{read-only}, @code{bind-mount}, @code{no-dev} (disallow access to special files), @code{no-suid} (ignore setuid and setgid -bits), @code{no-atime} (do not update file access times), and @code{no-exec} -(disallow program execution). @xref{Mount-Unmount-Remount,,, libc, The GNU C -Library Reference Manual}, for more information on these flags. +bits), @code{no-atime} (do not update file access times), +@code{strict-atime} (update file access time), @code{lazy-time} (only +update time on the in-memory version of the file inode), and +@code{no-exec} (disallow program execution). +@xref{Mount-Unmount-Remount,,, libc, The GNU C Library Reference +Manual}, for more information on these flags. @item @code{options} (default: @code{#f}) This is either @code{#f}, or a string denoting mount options passed to the diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index cb90fa0907..13c44aa728 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017 David Craven ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019 Guillaume Le Vaillant ;;; ;;; This file is part of GNU Guix. ;;; @@ -577,6 +578,10 @@ corresponds to the symbols listed in FLAGS." (logior MS_NOEXEC (loop rest))) (('no-atime rest ...) (logior MS_NOATIME (loop rest))) + (('strict-atime rest ...) + (logior MS_STRICTATIME (loop rest))) + (('lazy-time rest ...) + (logior MS_LAZYTIME (loop rest))) (() 0)))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ce7999b433..248d6761fc 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019 Guillaume Le Vaillant ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +44,7 @@ MS_BIND MS_MOVE MS_STRICTATIME + MS_LAZYTIME MNT_FORCE MNT_DETACH MNT_EXPIRE @@ -451,6 +453,7 @@ the returned procedure is called." (define MS_BIND 4096) (define MS_MOVE 8192) (define MS_STRICTATIME 16777216) +(define MS_LAZYTIME 33554432) (define MNT_FORCE 1) (define MNT_DETACH 2) -- cgit v1.2.3 From f69439dff438e59fbd24b76949b8767360f2cd72 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sat, 7 Dec 2019 20:41:24 +0100 Subject: build-system: qt: Fix output missing in wrapped variables. * guix/build/qt-build-system .scm (handle-output): Use directory of output, not its name. --- guix/build/qt-build-system.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 46fcad7848..be2b808901 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -90,8 +90,8 @@ add a dependency of that output on Qt." (unless (member output qt-wrap-excluded-outputs) (let ((bin-list (find-files-to-wrap directory)) (vars-to-wrap (variables-for-wrapping - (append (list output) - input-directories)))) + (append (list directory) + input-directories)))) (when (not (null? vars-to-wrap)) (for-each (cut apply wrap-program <> vars-to-wrap) bin-list))))))) -- cgit v1.2.3 From d0105e7f2902359de5e96d268a7e5850dae7dff7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 8 Dec 2019 07:18:46 +0900 Subject: emacs-build-system: Make the order of the phases more clear. * guix/build/emacs-build-system.scm (%standard-phases): Re-arrange to explicit the ordering of phases. --- guix/build/emacs-build-system.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index e2b792d3dc..41a42057fa 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -239,15 +239,14 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (add-after 'unpack 'add-source-to-load-path add-source-to-load-path) (delete 'bootstrap) (delete 'configure) - ;; Move the build phase after install: the .el files are byte compiled - ;; directly in the store. (delete 'build) (replace 'check check) (replace 'install install) - (add-after 'install 'build build) (add-after 'install 'make-autoloads make-autoloads) (add-after 'make-autoloads 'patch-el-files patch-el-files) - (add-after 'make-autoloads 'move-doc move-doc))) + ;; The .el files are byte compiled directly in the store. + (add-after 'patch-el-files 'build build) + (add-after 'build 'move-doc move-doc))) (define* (emacs-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) -- cgit v1.2.3 From add773c37a10e2c900fcfaff745e095b7fe96fbb Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 8 Dec 2019 11:47:23 +0900 Subject: emacs-build-system: Move the source directory to the start of EMACSLOADPATH. Fixes issue #38479 (see: https://bugs.gnu.org/38479). * guix/build/emacs-build-system.scm (add-source-to-load-path): Move the source directory to the start of the EMACSLOADPATH environment variable. Reported-by: Diego Nicola Barbato --- guix/build/emacs-build-system.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 41a42057fa..52c1ea177e 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -76,10 +76,10 @@ archive, a directory, or an Emacs Lisp file." (define* (add-source-to-load-path #:key dummy #:allow-other-keys) "Augment the EMACSLOADPATH environment variable with the source directory." (let* ((source-directory (getcwd)) - (emacs-load-path-value (string-append (getenv "EMACSLOADPATH") ":" - source-directory))) + (emacs-load-path-value (string-append source-directory ":" + (getenv "EMACSLOADPATH")))) (setenv "EMACSLOADPATH" emacs-load-path-value) - (format #t "source directory ~s appended to the `EMACSLOADPATH' \ + (format #t "source directory ~s prepended to the `EMACSLOADPATH' \ environment variable\n" source-directory))) (define* (build #:key outputs inputs #:allow-other-keys) -- cgit v1.2.3 From 7282f9496793227d7ac6f902976aecb663068ec1 Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 4 Dec 2019 19:06:31 +0100 Subject: lint: Add '--load-path' option. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/lint.scm (%options): Add '--load-path' option. * doc/guix.texi: Document it. * tests/guix-lint.sh: Test it. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 8 ++++++++ guix/scripts/lint.scm | 8 ++++++++ tests/guix-lint.sh | 11 +++++++++++ 3 files changed, 27 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 446534c576..d6c84e949d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9676,6 +9676,14 @@ and exit. Only enable the checkers specified in a comma-separated list using the names returned by @code{--list-checkers}. +@item --load-path=@var{directory} +@itemx -L @var{directory} +Add @var{directory} to the front of the package module search path +(@pxref{Package Modules}). + +This allows users to define their own packages and make them visible to +the command-line tools. + @end table @node Invoking guix size diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1668d02992..8d08c484f5 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; Copyright © 2017, 2018 Efraim Flashner ;;; Copyright © 2018, 2019 Arun Isaac +;;; Copyright © 2019 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:use-module (guix lint) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -94,6 +96,9 @@ run the checkers on all packages.\n")) -c, --checkers=CHECKER1,CHECKER2... only run the specified checkers")) (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -l, --list-checkers display the list of available lint checkers")) @@ -128,6 +133,9 @@ run the checkers on all packages.\n")) %local-checkers (alist-delete 'checkers result)))) + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) (option '(#\h "help") #f #f (lambda args (show-help) diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index 7ddc7c265b..f0df1fda3a 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -76,3 +76,14 @@ then true; else false; fi # Make sure specifying multiple packages works. guix lint -c inputs-should-be-native dummy dummy@42 dummy + + +# Use --load-path instead. +unset GUIX_PACKAGE_PATH + +out=`guix lint -L $module_dir -c synopsis,description dummy 2>&1` +if [ `grep_warning "$out"` -ne 3 ] +then false; else true; fi + +# Make sure specifying multiple packages works. +guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy -- cgit v1.2.3 From dc995fcd5a62496721757f4ecb7f9b9d65399b5c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Dec 2019 15:54:37 +0100 Subject: pack: Clarify the /bin/sh requirement for Singularity. * guix/scripts/pack.scm (squashfs-image)[symlinks*]: New variable. [build]: Use it instead of SYMLINKS. (guix-pack): Emit a warning and a hint when "bash" and "bash-minimal" are missing and PACK-FORMAT is 'squashfs. * doc/guix.texi (Invoking guix pack): Document the /bin/sh requirement for Singularity. --- doc/guix.texi | 17 ++++++++++++++++- guix/scripts/pack.scm | 21 ++++++++++++++++++++- 2 files changed, 36 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 3f646cd2ca..25efba118f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5053,7 +5053,7 @@ Yet another option is to produce a SquashFS image with the following command: @example -guix pack -f squashfs guile emacs geiser +guix pack -f squashfs bash guile emacs geiser @end example @noindent @@ -5088,6 +5088,21 @@ package names passed on the command line or in the manifest file. This produces a SquashFS image containing all the specified binaries and symlinks, as well as empty mount points for virtual file systems like procfs. + +@quotation Note +Singularity @emph{requires} you to provide @file{/bin/sh} in the image. +For that reason, @command{guix pack -f squashfs} always implies @code{-S +/bin=bin}. Thus, your @command{guix pack} invocation must always start +with something like: + +@example +guix pack -f squashfs bash @dots{} +@end example + +If you forget the @code{bash} (or similar) package, @command{singularity +run} and @command{singularity exec} will fail with an unhelpful ``no +such file or directory'' message. +@end quotation @end table @cindex relocatable binaries diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 61d18e2609..bbacc93bc0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -334,6 +334,16 @@ added to the pack." (define environment (singularity-environment-file profile)) + (define symlinks* + ;; Singularity requires /bin (specifically /bin/sh), so ensure that + ;; symlink is created. + (if (find (match-lambda + (("/bin" . _) #t) + (_ #f)) + symlinks) + symlinks + `(("/bin" -> "bin") ,@symlinks))) + (define build (with-imported-modules (source-module-closure '((guix build utils) @@ -407,7 +417,7 @@ added to the pack." "s" "777" "0" "0" (relative-file-name (dirname source) target))))))) - '#$symlinks) + '#$symlinks*) "-p" "/.singularity.d d 555 0 0" @@ -1049,9 +1059,18 @@ Create a bundle of PACKAGE.\n")) (entry-point (assoc-ref opts 'entry-point)) (profile-name (assoc-ref opts 'profile-name)) (gc-root (assoc-ref opts 'gc-root))) + (define (lookup-package package) + (manifest-lookup manifest (manifest-pattern (name package)))) + (when (null? (manifest-entries manifest)) (warning (G_ "no packages specified; building an empty pack~%"))) + (when (and (eq? pack-format 'squashfs) + (not (any lookup-package '("bash" "bash-minimal")))) + (warning (G_ "Singularity requires you to provide a shell~%")) + (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ +to your package list."))) + (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest -- cgit v1.2.3 From c20ba18304ee63f01895f092bb51bc2a9ce3303b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Dec 2019 17:21:31 +0100 Subject: profiles: Use 'getpwuid' when $USER and $LOGNAME are undefined. Reported by YOANN P . * guix/profiles.scm (%profile-directory): Fall back to 'getpwuid' when "USER" and "LOGNAME" are undefined. --- guix/profiles.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index f5e5cc33d6..616605151e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1727,7 +1727,9 @@ because the NUMBER is zero.)" (define %profile-directory (string-append %state-directory "/profiles/" (or (and=> (or (getenv "USER") - (getenv "LOGNAME")) + (getenv "LOGNAME") + (false-if-exception + (passwd:name (getpwuid (getuid))))) (cut string-append "per-user/" <>)) "default"))) -- cgit v1.2.3 From ddd59159004ca73c9449a27945116ff5069c3743 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Dec 2019 20:13:04 +0100 Subject: import: utils: 'recursive-import' returns packages in topological order. * guix/import/utils.scm (topological-sort): New procedure. (recursive-import): Rewrite to use it. * tests/import-utils.scm ("recursive-import"): New test. * guix/import/cran.scm (cran->guix-package): Always return two values. * guix/scripts/import/cran.scm (guix-import-cran): Remove 'reverse' call on 'cran-recursive-import' result. * guix/scripts/import/crate.scm (guix-import-crate): Likewise. * guix/scripts/import/elpa.scm (guix-import-elpa): Likewise. * guix/scripts/import/gem.scm (guix-import-gem): Likewise. * guix/scripts/import/hackage.scm (guix-import-hackage): Likewise. * guix/scripts/import/opam.scm (guix-import-opam): Likewise. * guix/scripts/import/pypi.scm (guix-import-pypi): Likewise. * guix/scripts/import/stackage.scm (guix-import-stackage): Likewise. * tests/gem.scm ("gem-recursive-import"): Change the order of package expressions accordingly. --- guix/import/cran.scm | 4 +- guix/import/utils.scm | 84 ++++++++++++++++++++++++---------------- guix/scripts/import/cran.scm | 7 ++-- guix/scripts/import/crate.scm | 5 +-- guix/scripts/import/elpa.scm | 7 ++-- guix/scripts/import/gem.scm | 5 +-- guix/scripts/import/hackage.scm | 5 +-- guix/scripts/import/opam.scm | 5 +-- guix/scripts/import/pypi.scm | 5 +-- guix/scripts/import/stackage.scm | 5 +-- tests/gem.scm | 22 +++++------ tests/import-utils.scm | 25 +++++++++++- 12 files changed, 105 insertions(+), 74 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index e47aff2b12..d9018cc7da 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. @@ -505,7 +505,7 @@ s-expression corresponding to that package, or #f on failure." ((bioconductor) ;; Retry import from CRAN (cran->guix-package package-name 'cran)) - (else #f))))))) + (else (values #f '())))))))) (define* (cran-recursive-import package-name #:optional (repo 'cran)) (recursive-import package-name repo diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 4694b6e7ef..ef7c13259d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -34,12 +34,14 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix download) + #:use-module (guix sets) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-41) @@ -377,40 +379,54 @@ separated by PRED." (chr (char-downcase chr))) name))) +(define (topological-sort nodes + node-dependencies + node-name) + "Perform a breadth-first traversal of the graph rooted at NODES, a list of +nodes, and return the list of nodes sorted in topological order. Call +NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to +obtain a node's uniquely identifying \"key\"." + (let loop ((nodes nodes) + (result '()) + (visited (set))) + (match nodes + (() + result) + ((head . tail) + (if (set-contains? visited (node-name head)) + (loop tail result visited) + (let ((dependencies (node-dependencies head))) + (loop (append dependencies tail) + (cons head result) + (set-insert (node-name head) visited)))))))) + (define* (recursive-import package-name repo #:key repo->guix-package guix-name #:allow-other-keys) - "Generate a stream of package expressions for PACKAGE-NAME and all its -dependencies." - (define (exists? dependency) - (not (null? (find-packages-by-name (guix-name dependency))))) - (define initial-state (list #f (list package-name) (list))) - (define (step state) - (match state - ((prev (next . rest) done) - (define (handle? dep) - (and - (not (equal? dep next)) - (not (member dep done)) - (not (exists? dep)))) - (receive (package . dependencies) (repo->guix-package next repo) - (list - (if package package '()) ;; default #f on failure would interrupt - (if package - (lset-union equal? rest (filter handle? (car dependencies))) - rest) - (cons next done)))) - ((prev '() done) - (list #f '() done)))) - - ;; Generate a lazy stream of package expressions for all unknown - ;; dependencies in the graph. - (stream-unfold - ;; map: produce a stream element - (match-lambda ((latest queue done) latest)) - ;; predicate - (match-lambda ((latest queue done) latest)) - ;; generator: update the queue - step - ;; initial state - (step initial-state))) + "Return a stream of package expressions for PACKAGE-NAME and all its +dependencies, sorted in topological order. For each package, +call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression +and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package +name corresponding to the upstream name." + (define-record-type + (make-node name package dependencies) + node? + (name node-name) + (package node-package) + (dependencies node-dependencies)) + + (define (exists? name) + (not (null? (find-packages-by-name (guix-name name))))) + + (define (lookup-node name) + (receive (package dependencies) (repo->guix-package name repo) + (make-node name package dependencies))) + + (list->stream ;TODO: remove streams + (map node-package + (topological-sort (list (lookup-node package-name)) + (lambda (node) + (map lookup-node + (remove exists? + (node-dependencies node)))) + node-name)))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index b6592f78a9..d47be584ae 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -98,10 +98,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (if (assoc-ref opts 'recursive) ;; Recursive import (map package->definition - (reverse - (stream->list - (cran-recursive-import package-name - (or (assoc-ref opts 'repo) 'cran))))) + (stream->list + (cran-recursive-import package-name + (or (assoc-ref opts 'repo) 'cran)))) ;; Single import (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 4690cceb4d..a388dc368d 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -101,9 +101,8 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (crate-recursive-import name)))) + (stream->list + (crate-recursive-import name))) (let ((sexp (crate->guix-package name version))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index f1ed5016ba..3cdb49eae4 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -101,10 +101,9 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (elpa-recursive-import package-name - (or (assoc-ref opts 'repo) 'gnu))))) + (stream->list + (elpa-recursive-import package-name + (or (assoc-ref opts 'repo) 'gnu)))) (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) (unless sexp (leave (G_ "failed to download package '~a'~%") package-name)) diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index b6d9ccaae4..afd7bf6d3e 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -95,9 +95,8 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (gem-recursive-import package-name 'rubygems)))) + (stream->list + (gem-recursive-import package-name 'rubygems))) (let ((sexp (gem->guix-package package-name))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f4aac61078..023cc1e700 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -130,9 +130,8 @@ version.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (apply hackage-recursive-import arguments)))) + (stream->list + (apply hackage-recursive-import arguments))) ;; Single import (apply hackage->guix-package arguments)))) (unless sexp (error-fn)) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index 2d249a213f..10410f714d 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -94,9 +94,8 @@ Import and convert the opam package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (opam-recursive-import package-name)))) + (stream->list + (opam-recursive-import package-name))) ;; Single import (let ((sexp (opam->guix-package package-name))) (unless sexp diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 7bd83818ba..f5f34b3c1b 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -95,9 +95,8 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (pypi-recursive-import package-name)))) + (stream->list + (pypi-recursive-import package-name))) ;; Single import (let ((sexp (pypi->guix-package package-name))) (unless sexp diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index b4b12581bf..9325341c84 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -110,9 +110,8 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse - (stream->list - (apply stackage-recursive-import arguments)))) + (stream->list + (apply stackage-recursive-import arguments))) ;; Single import (apply stackage->guix-package arguments)))) (unless sexp (error-fn)) diff --git a/tests/gem.scm b/tests/gem.scm index a12edb294c..82b2c3cea1 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -123,22 +123,21 @@ (_ (error "Unexpected URL: " url))))) (match (stream->list (gem-recursive-import "foo")) ((('package - ('name "ruby-foo") + ('name "ruby-bar") ('version "1.0.0") ('source ('origin ('method 'url-fetch) - ('uri ('rubygems-uri "foo" 'version)) + ('uri ('rubygems-uri "bar" 'version)) ('sha256 ('base32 "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) ('build-system 'ruby-build-system) ('propagated-inputs ('quasiquote - (("bundler" ('unquote 'bundler)) - ("ruby-bar" ('unquote 'ruby-bar))))) - ('synopsis "A cool gem") - ('description "This package provides a cool gem") + (('"bundler" ('unquote 'bundler))))) + ('synopsis "Another cool gem") + ('description "Another cool gem") ('home-page "https://example.com") ('license ('list 'license:expat 'license:asl2.0))) ('package @@ -157,21 +156,22 @@ ('home-page "https://bundler.io/") ('license 'license:expat)) ('package - ('name "ruby-bar") + ('name "ruby-foo") ('version "1.0.0") ('source ('origin ('method 'url-fetch) - ('uri ('rubygems-uri "bar" 'version)) + ('uri ('rubygems-uri "foo" 'version)) ('sha256 ('base32 "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) ('build-system 'ruby-build-system) ('propagated-inputs ('quasiquote - (('"bundler" ('unquote 'bundler))))) - ('synopsis "Another cool gem") - ('description "Another cool gem") + (("bundler" ('unquote 'bundler)) + ("ruby-bar" ('unquote 'ruby-bar))))) + ('synopsis "A cool gem") + ('description "This package provides a cool gem") ('home-page "https://example.com") ('license ('list 'license:expat 'license:asl2.0)))) #t) diff --git a/tests/import-utils.scm b/tests/import-utils.scm index c3ab25d788..3400433bbb 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -24,7 +24,9 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (gnu packages) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (test-begin "import-utils") @@ -41,6 +43,27 @@ 'license:lgpl2.0 (license->symbol license:lgpl2.0)) +(test-equal "recursive-import" + '((package ;package expressions in topological order + (name "bar")) + (package + (name "foo") + (inputs `(("bar" ,bar))))) + (stream->list + (recursive-import "foo" 'repo + #:repo->guix-package + (match-lambda* + (("foo" 'repo) + (values '(package + (name "foo") + (inputs `(("bar" ,bar)))) + '("bar"))) + (("bar" 'repo) + (values '(package + (name "bar")) + '()))) + #:guix-name identity))) + (test-assert "alist->package with simple source" (let* ((meta '(("name" . "hello") ("version" . "2.10") -- cgit v1.2.3 From 70a8e13277d4a44b89dd9ee2290b98105f0235f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Dec 2019 10:52:58 +0100 Subject: import: utils: 'recursive-import' returns a list rather than a stream. * guix/import/utils.scm (recursive-import): Remove 'list->stream' call. * guix/scripts/import/cran.scm (guix-import-cran): Remove 'stream->list' call. * guix/scripts/import/crate.scm (guix-import-crate): Likewise. * guix/scripts/import/elpa.scm (guix-import-elpa): Likewise. * guix/scripts/import/gem.scm (guix-import-gem): Likewise. * guix/scripts/import/hackage.scm (guix-import-hackage): Likewise. * guix/scripts/import/opam.scm (guix-import-opam): Likewise. * guix/scripts/import/pypi.scm (guix-import-pypi): Likewise. * guix/scripts/import/stackage.scm (guix-import-stackage): Likewise. * tests/gem.scm ("gem-recursive-import"): Likewise. * tests/import-utils.scm ("recursive-import"): Likewise. Co-authored-by: Brian Leung --- guix/import/utils.scm | 16 +++++++--------- guix/scripts/import/cran.scm | 6 ++---- guix/scripts/import/crate.scm | 4 +--- guix/scripts/import/elpa.scm | 6 ++---- guix/scripts/import/gem.scm | 4 +--- guix/scripts/import/hackage.scm | 4 +--- guix/scripts/import/opam.scm | 4 +--- guix/scripts/import/pypi.scm | 4 +--- guix/scripts/import/stackage.scm | 4 +--- tests/gem.scm | 3 +-- tests/import-utils.scm | 28 +++++++++++++--------------- 11 files changed, 31 insertions(+), 52 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index ef7c13259d..47fc8276a9 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -44,7 +44,6 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-41) #:export (factorize-uri flatten @@ -422,11 +421,10 @@ name corresponding to the upstream name." (receive (package dependencies) (repo->guix-package name repo) (make-node name package dependencies))) - (list->stream ;TODO: remove streams - (map node-package - (topological-sort (list (lookup-node package-name)) - (lambda (node) - (map lookup-node - (remove exists? - (node-dependencies node)))) - node-name)))) + (map node-package + (topological-sort (list (lookup-node package-name)) + (lambda (node) + (map lookup-node + (remove exists? + (node-dependencies node)))) + node-name))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index d47be584ae..d6f371ef3a 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -27,7 +27,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -98,9 +97,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (if (assoc-ref opts 'recursive) ;; Recursive import (map package->definition - (stream->list - (cran-recursive-import package-name - (or (assoc-ref opts 'repo) 'cran)))) + (cran-recursive-import package-name + (or (assoc-ref opts 'repo) 'cran))) ;; Single import (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index a388dc368d..92034dab3c 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -28,7 +28,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-crate)) @@ -101,8 +100,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (crate-recursive-import name))) + (crate-recursive-import name)) (let ((sexp (crate->guix-package name version))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index 3cdb49eae4..d270d2b4bc 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -27,7 +27,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-elpa)) @@ -101,9 +100,8 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (elpa-recursive-import package-name - (or (assoc-ref opts 'repo) 'gnu)))) + (elpa-recursive-import package-name + (or (assoc-ref opts 'repo) 'gnu))) (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) (unless sexp (leave (G_ "failed to download package '~a'~%") package-name)) diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index afd7bf6d3e..c64596b514 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -26,7 +26,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-gem)) @@ -95,8 +94,7 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (gem-recursive-import package-name 'rubygems))) + (gem-recursive-import package-name 'rubygems)) (let ((sexp (gem->guix-package package-name))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 023cc1e700..710e786a79 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -27,7 +27,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-hackage)) @@ -130,8 +129,7 @@ version.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (apply hackage-recursive-import arguments))) + (apply hackage-recursive-import arguments)) ;; Single import (apply hackage->guix-package arguments)))) (unless sexp (error-fn)) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index 10410f714d..20da1437fe 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -25,7 +25,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-opam)) @@ -94,8 +93,7 @@ Import and convert the opam package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (opam-recursive-import package-name))) + (opam-recursive-import package-name)) ;; Single import (let ((sexp (opam->guix-package package-name))) (unless sexp diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index f5f34b3c1b..33167174e2 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -26,7 +26,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -95,8 +94,7 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (pypi-recursive-import package-name))) + (pypi-recursive-import package-name)) ;; Single import (let ((sexp (pypi->guix-package package-name))) (unless sexp diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index 9325341c84..d77328dcbf 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -27,7 +27,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) - #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-stackage)) @@ -110,8 +109,7 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (stream->list - (apply stackage-recursive-import arguments))) + (apply stackage-recursive-import arguments)) ;; Single import (apply stackage->guix-package arguments)))) (unless sexp (error-fn)) diff --git a/tests/gem.scm b/tests/gem.scm index 82b2c3cea1..5158238d18 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -24,7 +24,6 @@ #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module ((guix build utils) #:select (delete-file-recursively)) - #:use-module (srfi srfi-41) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -121,7 +120,7 @@ (values (open-input-string test-bundler-json) (string-length test-bundler-json))) (_ (error "Unexpected URL: " url))))) - (match (stream->list (gem-recursive-import "foo")) + (match (gem-recursive-import "foo") ((('package ('name "ruby-bar") ('version "1.0.0") diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 3400433bbb..87dda3238f 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -24,7 +24,6 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (gnu packages) - #:use-module (srfi srfi-41) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -49,20 +48,19 @@ (package (name "foo") (inputs `(("bar" ,bar))))) - (stream->list - (recursive-import "foo" 'repo - #:repo->guix-package - (match-lambda* - (("foo" 'repo) - (values '(package - (name "foo") - (inputs `(("bar" ,bar)))) - '("bar"))) - (("bar" 'repo) - (values '(package - (name "bar")) - '()))) - #:guix-name identity))) + (recursive-import "foo" 'repo + #:repo->guix-package + (match-lambda* + (("foo" 'repo) + (values '(package + (name "foo") + (inputs `(("bar" ,bar)))) + '("bar"))) + (("bar" 'repo) + (values '(package + (name "bar")) + '()))) + #:guix-name identity)) (test-assert "alist->package with simple source" (let* ((meta '(("name" . "hello") -- cgit v1.2.3 From 263a267b75e472cb84428571580dabd99d5dff0c Mon Sep 17 00:00:00 2001 From: Brice Waegeneire Date: Tue, 26 Nov 2019 21:17:21 +0100 Subject: import: crate: Better handle license expressions. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/crate.scm (%dual-license-rx): Removed function. (crate->guix-package): Handle most of the multi-licensing cases. * tests/crate.scm (licenses): Add tests for some licenses. Co-authored-by: Ludovic Courtès --- guix/import/crate.scm | 17 ++++++++--------- tests/crate.scm | 23 +++++++++++++++++++++++ 2 files changed, 31 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 8dc014d232..4c3f8000d0 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -178,21 +178,20 @@ and LICENSE." (close-port port) pkg)) -(define %dual-license-rx - ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0". - ;; This regexp matches that. - (make-regexp "^(.*) OR (.*)$")) +(define (string->license string) + (filter-map (lambda (license) + (and (not (string-null? license)) + (not (any (lambda (elem) (string=? elem license)) + '("AND" "OR" "WITH"))) + (or (spdx-string->license license) + 'unknown-license!))) + (string-split string (string->char-set " /")))) (define* (crate->guix-package crate-name #:optional version) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure. When VERSION is specified, attempt to fetch that version; otherwise fetch the latest version of CRATE-NAME." - (define (string->license string) - (match (regexp-exec %dual-license-rx string) - (#f (list (spdx-string->license string))) - (m (list (spdx-string->license (match:substring m 1)) - (spdx-string->license (match:substring m 2)))))) (define (normal-dependency? dependency) (eq? (crate-dependency-kind dependency) 'normal)) diff --git a/tests/crate.scm b/tests/crate.scm index fc6a8ac24d..61933a8de8 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -233,6 +233,9 @@ (define test-source-hash "") +(define string->license + (@@ (guix import crate) string->license)) + (test-begin "crate") (test-equal "guix-package->crate-name" @@ -437,4 +440,24 @@ (x (pk 'fail x #f))))) +(test-equal "licenses: MIT OR Apache-2.0" + '(license:expat license:asl2.0) + (string->license "MIT OR Apache-2.0")) + +(test-equal "licenses: Apache-2.0 / MIT" + '(license:asl2.0 license:expat) + (string->license "Apache-2.0 / MIT")) + +(test-equal "licenses: Apache-2.0 WITH LLVM-exception" + '(license:asl2.0 unknown-license!) + (string->license "Apache-2.0 WITH LLVM-exception")) + +(test-equal "licenses: MIT/Apache-2.0 AND BSD-2-Clause" + '(license:expat license:asl2.0 unknown-license!) + (string->license "MIT/Apache-2.0 AND BSD-2-Clause")) + +(test-equal "licenses: MIT/Apache-2.0" + '(license:expat license:asl2.0) + (string->license "MIT/Apache-2.0")) + (test-end "crate") -- cgit v1.2.3