summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorEfraim Flashner <efraim@flashner.co.il>2019-12-12 04:10:59 +0200
committerEfraim Flashner <efraim@flashner.co.il>2019-12-12 04:10:59 +0200
commitc9e676d0b141f510c19e26edb1e6fad079b9b502 (patch)
tree79abb4a4b92ecf4504a46e55ffa7971a06c8a5df /guix
parentd45720d8b456e82380601d77e25bd05c6e0dc36a (diff)
parentdcb7ce500bd025455982d74c3384c707f35bbb46 (diff)
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build/emacs-build-system.scm13
-rw-r--r--guix/build/qt-build-system.scm4
-rw-r--r--guix/build/syscalls.scm3
-rw-r--r--guix/derivations.scm52
-rw-r--r--guix/import/cran.scm4
-rw-r--r--guix/import/crate.scm17
-rw-r--r--guix/import/utils.scm84
-rw-r--r--guix/profiles.scm4
-rw-r--r--guix/scripts/import/cran.scm7
-rw-r--r--guix/scripts/import/crate.scm5
-rw-r--r--guix/scripts/import/elpa.scm7
-rw-r--r--guix/scripts/import/gem.scm5
-rw-r--r--guix/scripts/import/hackage.scm5
-rw-r--r--guix/scripts/import/opam.scm5
-rw-r--r--guix/scripts/import/pypi.scm5
-rw-r--r--guix/scripts/import/stackage.scm5
-rw-r--r--guix/scripts/lint.scm8
-rw-r--r--guix/scripts/pack.scm21
-rw-r--r--guix/scripts/pull.scm1
-rw-r--r--guix/scripts/system.scm107
20 files changed, 233 insertions, 129 deletions
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index e2b792d3dc..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)
@@ -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)
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)))))))
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 <davet@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;;
;;; 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)
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)
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 <rekado@elephly.net>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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/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/guix/import/utils.scm b/guix/import/utils.scm
index 4694b6e7ef..47fc8276a9 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -34,15 +34,16 @@
#: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)
#:export (factorize-uri
flatten
@@ -377,40 +378,53 @@ 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 <node>
+ (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)))
+
+ (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/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")))
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index b6592f78a9..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,10 +97,8 @@ 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)))))
+ (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..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,9 +100,7 @@ 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))))
+ (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..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,10 +100,8 @@ 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)))))
+ (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..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,9 +94,7 @@ 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))))
+ (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..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,9 +129,7 @@ version.\n"))
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
- (reverse
- (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 2d249a213f..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,9 +93,7 @@ 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))))
+ (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..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,9 +94,7 @@ 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))))
+ (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..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,9 +109,7 @@ 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))))
+ (apply stackage-recursive-import arguments))
;; Single import
(apply stackage->guix-package arguments))))
(unless sexp (error-fn))
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 <me@tobias.gr>
;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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/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
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 5f0dce2093..3e9570753d 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
@@ -722,7 +767,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
@@ -875,6 +922,8 @@ Some ACTIONS support additional ARGS.\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_ "\
switch-generation switch to an existing operating system configuration\n"))
@@ -918,16 +967,18 @@ Some ACTIONS support additional ARGS.\n"))
(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_ "
--skip-checks skip file system and initrd module safety checks"))
@@ -979,6 +1030,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 +1101,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?))
@@ -1136,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
@@ -1175,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))))))