summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-03-27 00:12:15 +0100
committerMarius Bakke <mbakke@fastmail.com>2020-03-27 00:12:15 +0100
commit18af6870370226b4d502d7372844e7f2aded5887 (patch)
tree749d93209bd0cb9710ccaae2207df670f37eaa36 /guix
parent0ab8ad46322bea331ed5f5592843ba35e7f38b37 (diff)
parent3089b70d766bd9ec70e1464867130b7b864fbe17 (diff)
downloadpatches-18af6870370226b4d502d7372844e7f2aded5887.tar
patches-18af6870370226b4d502d7372844e7f2aded5887.tar.gz
Merge branch 'master' into core-updates
Conflicts: gnu/packages/icu4c.scm gnu/packages/man.scm gnu/packages/python-xyz.scm guix/scripts/environment.scm guix/scripts/pack.scm guix/scripts/package.scm guix/scripts/pull.scm guix/store.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/linux-module.scm162
-rw-r--r--guix/build/download.scm7
-rw-r--r--guix/build/emacs-utils.scm13
-rw-r--r--guix/build/linux-module-build-system.scm17
-rw-r--r--guix/build/syscalls.scm64
-rw-r--r--guix/cache.scm9
-rw-r--r--guix/import/cran.scm97
-rw-r--r--guix/import/crate.scm2
-rw-r--r--guix/licenses.scm12
-rw-r--r--guix/lint.scm50
-rw-r--r--guix/packages.scm8
-rw-r--r--guix/profiles.scm58
-rw-r--r--guix/progress.scm9
-rw-r--r--guix/scripts/archive.scm50
-rw-r--r--guix/scripts/build.scm118
-rw-r--r--guix/scripts/copy.scm89
-rw-r--r--guix/scripts/deploy.scm55
-rw-r--r--guix/scripts/environment.scm142
-rw-r--r--guix/scripts/lint.scm38
-rw-r--r--guix/scripts/pack.scm208
-rw-r--r--guix/scripts/package.scm33
-rw-r--r--guix/scripts/pull.scm137
-rwxr-xr-xguix/scripts/substitute.scm7
-rw-r--r--guix/scripts/system.scm98
-rw-r--r--guix/scripts/weather.scm7
-rw-r--r--guix/ssh.scm22
-rw-r--r--guix/status.scm10
-rw-r--r--guix/store.scm75
-rw-r--r--guix/ui.scm157
29 files changed, 1067 insertions, 687 deletions
diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index 1e1a07d0a2..ca104f7c75 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -45,27 +46,16 @@
(let ((module (resolve-interface '(gnu packages linux))))
(module-ref module 'linux-libre)))
-(define (default-kmod)
- "Return the default kmod package."
-
- ;; Do not use `@' to avoid introducing circular dependencies.
+(define (system->arch system)
(let ((module (resolve-interface '(gnu packages linux))))
- (module-ref module 'kmod)))
-
-(define (default-gcc)
- "Return the default gcc package."
-
- ;; Do not use `@' to avoid introducing circular dependencies.
- (let ((module (resolve-interface '(gnu packages gcc))))
- (module-ref module 'gcc-7)))
+ ((module-ref module 'system->linux-architecture) system)))
(define (make-linux-module-builder linux)
(package
(inherit linux)
(name (string-append (package-name linux) "-module-builder"))
- (native-inputs
- `(("linux" ,linux)
- ,@(package-native-inputs linux)))
+ (inputs
+ `(("linux" ,linux)))
(arguments
(substitute-keyword-arguments (package-arguments linux)
((#:phases phases)
@@ -97,33 +87,43 @@
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
- '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs))
-
- (and (not target) ;XXX: no cross-compilation
- (bag
- (name name)
- (system system)
- (host-inputs `(,@(if source
- `(("source" ,source))
- '())
- ,@inputs
- ,@(standard-packages)))
- (build-inputs `(("linux" ,linux) ; for "Module.symvers".
- ("linux-module-builder"
- ,(make-linux-module-builder linux))
- ,@native-inputs
- ;; TODO: Remove "gmp", "mpfr", "mpc" since they are
- ;; only needed to compile the gcc plugins. Maybe
- ;; remove "flex", "bison", "elfutils", "perl",
- ;; "openssl". That leaves very little ("bc", "gcc",
- ;; "kmod").
- ,@(package-native-inputs linux)))
- (outputs outputs)
- (build linux-module-build)
- (arguments (strip-keyword-arguments private-keywords arguments)))))
+ `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs
+ ,@(if target '() '(#:target))))
+
+ (bag
+ (name name)
+ (system system) (target target)
+ (build-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@native-inputs
+ ;; TODO: Remove "gmp", "mpfr", "mpc" since they are
+ ;; only needed to compile the gcc plugins. Maybe
+ ;; remove "flex", "bison", "elfutils", "perl",
+ ;; "openssl". That leaves very little ("bc", "gcc",
+ ;; "kmod").
+ ,@(package-native-inputs linux)
+ ,@(if target
+ ;; Use the standard cross inputs of
+ ;; 'gnu-build-system'.
+ (standard-cross-packages target 'host)
+ '())
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (host-inputs `(,@inputs
+ ("linux" ,linux)
+ ("linux-module-builder"
+ ,(make-linux-module-builder linux))))
+ (target-inputs (if target
+ (standard-cross-packages target 'target)
+ '()))
+ (outputs outputs)
+ (build (if target linux-module-build-cross linux-module-build))
+ (arguments (strip-keyword-arguments private-keywords arguments))))
(define* (linux-module-build store name inputs
#:key
+ target
(search-paths '())
(tests? #t)
(phases '(@ (guix build linux-module-build-system)
@@ -152,6 +152,8 @@
search-paths)
#:phases ,phases
#:system ,system
+ #:target ,target
+ #:arch ,(system->arch (or target system))
#:tests? ,tests?
#:outputs %outputs
#:inputs %build-inputs)))
@@ -173,6 +175,88 @@
#:guile-for-build guile-for-build
#:substitutable? substitutable?))
+(define* (linux-module-build-cross
+ store name
+ #:key
+ target native-drvs target-drvs
+ (guile #f)
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+ (tests? #f)
+ (phases '(@ (guix build linux-module-build-system)
+ %standard-phases))
+ (system (%current-system))
+ (substitutable? #t)
+ (imported-modules
+ %linux-module-build-system-modules)
+ (modules '((guix build linux-module-build-system)
+ (guix build utils))))
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (let ()
+ (define %build-host-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name path)
+ `(,name . ,path)))
+ native-drvs))
+
+ (define %build-target-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name (? package? pkg) sub ...)
+ (let ((drv (package-cross-derivation store pkg
+ target system)))
+ `(,name . ,(apply derivation->output-path drv sub))))
+ ((name path)
+ `(,name . ,path)))
+ target-drvs))
+
+ (linux-module-build #:name ,name
+ #:source ,(match (assoc-ref native-drvs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:target ,target
+ #:arch ,(system->arch (or target system))
+ #:outputs %outputs
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths
+ ',(map search-path-specification->sexp
+ search-paths)
+ #:native-search-paths
+ ',(map
+ search-path-specification->sexp
+ native-search-paths)
+ #:phases ,phases
+ #:tests? ,tests?))))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:system system
+ #:inputs (append native-drvs target-drvs)
+ #:outputs outputs
+ #:modules imported-modules
+ #:guile-for-build guile-for-build
+ #:substitutable? substitutable?))
+
(define linux-module-build-system
(build-system
(name 'linux-module)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index c647d00f6b..46af149b2f 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -693,6 +693,13 @@ otherwise simply ignore them."
(()
(format (current-error-port) "failed to download ~s from ~s~%"
file url)
+
+ ;; Remove FILE in case we made an incomplete download, for example due
+ ;; to ENOSPC.
+ (catch 'system-error
+ (lambda ()
+ (delete-file file))
+ (const #f))
#f))))
;;; download.scm ends here
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index ab64e3714c..5f7ba71244 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at>
;;;
;;; This file is part of GNU Guix.
@@ -21,6 +21,7 @@
(define-module (guix build emacs-utils)
#:use-module (guix build utils)
+ #:use-module (ice-9 format)
#:export (%emacs
emacs-batch-eval
emacs-batch-edit-file
@@ -47,10 +48,12 @@
expr
(format #f "~s" expr)))
-(define (emacs-batch-eval expr)
- "Run Emacs in batch mode, and execute the elisp code EXPR."
+(define* (emacs-batch-eval expr #:key dynamic?)
+ "Run Emacs in batch mode, and execute the Elisp code EXPR. If DYNAMIC? is
+true, evaluate using dynamic scoping."
(invoke (%emacs) "--quick" "--batch"
- (string-append "--eval=" (expr->string expr))))
+ (format #f "--eval=(eval '~a ~:[t~;nil~])"
+ (expr->string expr) dynamic?)))
(define (emacs-batch-edit-file file expr)
"Load FILE in Emacs using batch mode, and execute the elisp code EXPR."
@@ -70,7 +73,7 @@
(expr `(let ((backup-inhibited t)
(generated-autoload-file ,file))
(update-directory-autoloads ,directory))))
- (emacs-batch-eval expr)))
+ (emacs-batch-eval expr #:dynamic? #t)))
(define* (emacs-byte-compile-directory dir)
"Byte compile all files in DIR and its sub-directories."
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 8145d5a724..73d6b101f6 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,14 +34,13 @@
;; Code:
;; Copied from make-linux-libre's "configure" phase.
-(define* (configure #:key inputs target #:allow-other-keys)
+(define* (configure #:key inputs target arch #:allow-other-keys)
(setenv "KCONFIG_NOTIMESTAMP" "1")
(setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
- ;(let ((arch ,(system->linux-architecture
- ; (or (%current-target-system)
- ; (%current-system)))))
- ; (setenv "ARCH" arch)
- ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")))
+
+ (setenv "ARCH" arch)
+ (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))
+
(when target
(setenv "CROSS_COMPILE" (string-append target "-"))
(format #t "`CROSS_COMPILE' set to `~a'~%"
@@ -85,8 +85,9 @@
(replace 'install install)))
(define* (linux-module-build #:key inputs (phases %standard-phases)
- #:allow-other-keys #:rest args)
- "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance."
+ #:allow-other-keys #:rest args)
+ "Build the given package, applying all of PHASES in order, with a Linux
+kernel in attendance."
(apply gnu:gnu-build
#:inputs inputs #:phases phases
args))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ae79a9708f..0938ec0ff1 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1104,47 +1104,49 @@ exception if it's already taken."
#t)
(define (call-with-file-lock file thunk)
- (let ((port (catch 'system-error
- (lambda ()
- (lock-file file))
- (lambda args
- ;; When using the statically-linked Guile in the initrd,
- ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore
- ;; that error since we're typically the only process running
- ;; at this point.
- (if (= ENOSYS (system-error-errno args))
- #f
- (apply throw args))))))
+ (let ((port #f))
(dynamic-wind
(lambda ()
- #t)
+ (set! port
+ (catch 'system-error
+ (lambda ()
+ (lock-file file))
+ (lambda args
+ ;; When using the statically-linked Guile in the initrd,
+ ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore
+ ;; that error since we're typically the only process running
+ ;; at this point.
+ (if (= ENOSYS (system-error-errno args))
+ #f
+ (apply throw args))))))
thunk
(lambda ()
(when port
(unlock-file port))))))
(define (call-with-file-lock/no-wait file thunk handler)
- (let ((port (catch #t
- (lambda ()
- (lock-file file #:wait? #f))
- (lambda (key . args)
- (match key
- ('flock-error
- (apply handler args)
- ;; No open port to the lock, so return #f.
- #f)
- ('system-error
- ;; When using the statically-linked Guile in the initrd,
- ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore
- ;; that error since we're typically the only process running
- ;; at this point.
- (if (= ENOSYS (system-error-errno (cons key args)))
- #f
- (apply throw key args)))
- (_ (apply throw key args)))))))
+ (let ((port #f))
(dynamic-wind
(lambda ()
- #t)
+ (set! port
+ (catch #t
+ (lambda ()
+ (lock-file file #:wait? #f))
+ (lambda (key . args)
+ (match key
+ ('flock-error
+ (apply handler args)
+ ;; No open port to the lock, so return #f.
+ #f)
+ ('system-error
+ ;; When using the statically-linked Guile in the initrd,
+ ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore
+ ;; that error since we're typically the only process running
+ ;; at this point.
+ (if (= ENOSYS (system-error-errno (cons key args)))
+ #f
+ (apply throw key args)))
+ (_ (apply throw key args)))))))
thunk
(lambda ()
(when port
diff --git a/guix/cache.scm b/guix/cache.scm
index 1dc0083f1d..feff131068 100644
--- a/guix/cache.scm
+++ b/guix/cache.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,13 +33,6 @@
;;;
;;; Code:
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
(define (obsolete? date now ttl)
"Return #t if DATE is obsolete compared to NOW + TTL seconds."
(time>? (subtract-duration now (make-time time-duration 0 ttl))
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb8226f714..53b930acd0 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -21,6 +21,7 @@
(define-module (guix import cran)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 popen)
#:use-module ((ice-9 rdelim) #:select (read-string read-line))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
@@ -37,10 +38,14 @@
#:use-module (guix base32)
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix import utils)
- #:use-module ((guix build utils) #:select (find-files))
+ #:use-module ((guix build utils)
+ #:select (find-files
+ delete-file-recursively
+ with-directory-excursion))
#:use-module (guix utils)
#:use-module (guix git)
#:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
+ #:use-module (guix ui)
#:use-module (guix upstream)
#:use-module (guix packages)
#:use-module (gnu packages)
@@ -191,11 +196,26 @@ bioconductor package NAME, or #F if the package is unknown."
;; Little helper to download URLs only once.
(define download
(memoize
- (lambda* (url #:optional git)
+ (lambda* (url #:key method)
(with-store store
- (if git
- (latest-repository-commit store url)
- (download-to-store store url))))))
+ (cond
+ ((eq? method 'git)
+ (latest-repository-commit store url))
+ ((eq? method 'hg)
+ (call-with-temporary-directory
+ (lambda (dir)
+ (unless (zero? (system* "hg" "clone" url dir))
+ (leave (G_ "~A: hg download failed~%") url))
+ (with-directory-excursion dir
+ (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id"))
+ (changeset (string-trim-right (read-string port))))
+ (close-pipe port)
+ (for-each delete-file-recursively
+ (find-files dir "^\\.hg$" #:directories? #t))
+ (let ((store-directory
+ (add-to-store store (basename url) #t "sha256" dir)))
+ (values store-directory changeset)))))))
+ (else (download-to-store store url)))))))
(define (fetch-description repository name)
"Return an alist of the contents of the DESCRIPTION file for the R package
@@ -244,13 +264,25 @@ from ~s: ~a (~s)~%"
(and (string-prefix? "http" name)
;; Download the git repository at "NAME"
(call-with-values
- (lambda () (download name #t))
+ (lambda () (download name #:method 'git))
(lambda (dir commit)
(and=> (description->alist (with-input-from-file
(string-append dir "/DESCRIPTION") read-string))
(lambda (meta)
(cons* `(git . ,name)
`(git-commit . ,commit)
+ meta)))))))
+ ((hg)
+ (and (string-prefix? "http" name)
+ ;; Download the mercurial repository at "NAME"
+ (call-with-values
+ (lambda () (download name #:method 'hg))
+ (lambda (dir changeset)
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (cons* `(hg . ,name)
+ `(hg-changeset . ,changeset)
meta)))))))))
(define (listify meta field)
@@ -404,11 +436,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(let* ((base-url (case repository
((cran) %cran-url)
((bioconductor) %bioconductor-url)
- ((git) #f)))
+ ((git) #f)
+ ((hg) #f)))
(uri-helper (case repository
((cran) cran-uri)
((bioconductor) bioconductor-uri)
- ((git) #f)))
+ ((git) #f)
+ ((hg) #f)))
(name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title"))
(version (assoc-ref meta "Version"))
@@ -416,11 +450,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
;; Some packages have multiple home pages. Some have none.
(home-page (case repository
((git) (assoc-ref meta 'git))
+ ((hg) (assoc-ref meta 'hg))
(else (match (listify meta "URL")
((url rest ...) url)
(_ (string-append base-url name))))))
(source-url (case repository
((git) (assoc-ref meta 'git))
+ ((hg) (assoc-ref meta 'hg))
(else
(match (apply uri-helper name version
(case repository
@@ -431,9 +467,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
((? string? url) url)
(_ #f)))))
(git? (assoc-ref meta 'git))
- (source (download source-url git?))
+ (hg? (assoc-ref meta 'hg))
+ (source (download source-url #:method (cond
+ (git? 'git)
+ (hg? 'hg)
+ (else #f))))
(sysdepends (append
- (if (needs-zlib? source (not git?)) '("zlib") '())
+ (if (needs-zlib? source (not (or git? hg?))) '("zlib") '())
(filter (lambda (name)
(not (member name invalid-packages)))
(map string-downcase (listify meta "SystemRequirements")))))
@@ -451,33 +491,45 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(version ,(case repository
((git)
`(git-version ,version revision commit))
+ ((hg)
+ `(string-append ,version "-" revision "." changeset))
(else version)))
(source (origin
- (method ,(if git?
- 'git-fetch
- 'url-fetch))
+ (method ,(cond
+ (git? 'git-fetch)
+ (hg? 'hg-fetch)
+ (else 'url-fetch)))
(uri ,(case repository
((git)
`(git-reference
(url ,(assoc-ref meta 'git))
(commit commit)))
+ ((hg)
+ `(hg-reference
+ (url ,(assoc-ref meta 'hg))
+ (changeset changeset)))
(else
`(,(procedure-name uri-helper) ,name version
,@(or (and=> (assoc-ref meta 'bioconductor-type)
(lambda (type)
(list (list 'quote type))))
'())))))
- ,@(if git?
- '((file-name (git-file-name name version)))
- '())
+ ,@(cond
+ (git?
+ '((file-name (git-file-name name version))))
+ (hg?
+ '((file-name (string-append name "-" version "-checkout"))))
+ (else '()))
(sha256
(base32
,(bytevector->nix-base32-string
(case repository
((git)
(file-hash source (negate vcs-file?) #t))
+ ((hg)
+ (file-hash source (negate vcs-file?) #t))
(else (file-sha256 source))))))))
- ,@(if (not (and git?
+ ,@(if (not (and git? hg?
(equal? (string-append "r-" name)
(cran-guix-name name))))
`((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
@@ -486,9 +538,9 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
,@(maybe-inputs sysdepends)
,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
,@(maybe-inputs
- `(,@(if (needs-fortran? source (not git?))
+ `(,@(if (needs-fortran? source (not (or git? hg?)))
'("gfortran") '())
- ,@(if (needs-pkg-config? source (not git?))
+ ,@(if (needs-pkg-config? source (not (or git? hg?)))
'("pkg-config") '())
,@(if (needs-knitr? meta)
'("r-knitr") '()))
@@ -506,6 +558,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
`(let ((commit ,(assoc-ref meta 'git-commit))
(revision "1"))
,package))
+ ((hg)
+ `(let ((changeset ,(assoc-ref meta 'hg-changeset))
+ (revision "1"))
+ ,package))
(else package))
propagate)))
@@ -521,6 +577,9 @@ s-expression corresponding to that package, or #f on failure."
((git)
;; Retry import from Bioconductor
(cran->guix-package package-name 'bioconductor))
+ ((hg)
+ ;; Retry import from Bioconductor
+ (cran->guix-package package-name 'bioconductor))
((bioconductor)
;; Retry import from CRAN
(cran->guix-package package-name 'cran))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 57823c3639..0b4482e876 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -112,7 +112,7 @@ record or #f if it was not found."
(url (string-append (%crate-base-url) path)))
(match (assoc-ref (or (json-fetch url) '()) "dependencies")
((? vector? vector)
- (map json->crate-dependency (vector->list vector)))
+ (delete-duplicates (map json->crate-dependency (vector->list vector))))
(_
'()))))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 9153c3ccae..ab2ad3f169 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -75,10 +75,12 @@
ms-pl
ncsa
nmap
+ ogl-psi1.0
openldap2.8 openssl
perl-license
psfl public-domain
qpl
+ qwt1.0
repoze
ruby
sgifreeb2.0
@@ -517,6 +519,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"https://svn.nmap.org/nmap/COPYING"
"https://fedoraproject.org/wiki/Licensing/Nmap"))
+(define ogl-psi1.0
+ (license "Open Government Licence for Public Sector Information"
+ "https://www.nationalarchives.gov.uk/doc/open-government-licence/version/1/"
+ #f))
+
(define openssl
(license "OpenSSL"
"http://directory.fsf.org/wiki/License:OpenSSL"
@@ -549,6 +556,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"http://directory.fsf.org/wiki/License:QPLv1.0"
"http://www.gnu.org/licenses/license-list.html#QPL"))
+(define qwt1.0
+ (license "QWT 1.0"
+ "http://qwt.sourceforge.net/qwtlicense.html"
+ "GNU Lesser General Public License with exceptions"))
+
(define repoze
(license "Repoze"
"http://repoze.org/LICENSE.txt"
diff --git a/guix/lint.scm b/guix/lint.scm
index 40bddd0a41..2be3cc3ee3 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -100,7 +100,8 @@
lint-checker?
lint-checker-name
lint-checker-description
- lint-checker-check))
+ lint-checker-check
+ lint-checker-requires-store?))
;;;
@@ -155,7 +156,9 @@
;; 'certainty' level.
(name lint-checker-name)
(description lint-checker-description)
- (check lint-checker-check))
+ (check lint-checker-check)
+ (requires-store? lint-checker-requires-store?
+ (default #f)))
(define (properly-starts-sentence? s)
(string-match "^[(\"'`[:upper:][:digit:]]" s))
@@ -915,9 +918,9 @@ descriptions maintained upstream."
(define exception-with-kind-and-args?
(const #f))))
-(define (check-derivation package)
+(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."
- (define (try system)
+ (define (try store system)
(catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported.
(lambda ()
(guard (c ((store-protocol-error? c)
@@ -936,25 +939,29 @@ descriptions maintained upstream."
(G_ "failed to create ~a derivation: ~a")
(list system
(condition-message c)))))
- (with-store store
- ;; Disable grafts since it can entail rebuilds.
- (parameterize ((%graft? #f))
- (package-derivation store package system #:graft? #f)
-
- ;; If there's a replacement, make sure we can compute its
- ;; derivation.
- (match (package-replacement package)
- (#f #t)
- (replacement
- (package-derivation store replacement system
- #:graft? #f)))))))
+ (parameterize ((%graft? #f))
+ (package-derivation store package system #:graft? #f)
+
+ ;; If there's a replacement, make sure we can compute its
+ ;; derivation.
+ (match (package-replacement package)
+ (#f #t)
+ (replacement
+ (package-derivation store replacement system
+ #:graft? #f))))))
(lambda args
(make-warning package
(G_ "failed to create ~a derivation: ~s")
(list system args)))))
- (filter lint-warning?
- (map try (package-supported-systems package))))
+ (define (check-with-store store)
+ (filter lint-warning?
+ (map (cut try store <>) (package-supported-systems package))))
+
+ ;; For backwards compatability, don't rely on store being set
+ (or (and=> store check-with-store)
+ (with-store store
+ (check-with-store store))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
@@ -1328,9 +1335,10 @@ or a list thereof")
(description "Check for autogenerated tarballs")
(check check-source-unstable-tarball))
(lint-checker
- (name 'derivation)
- (description "Report failure to compile a package to a derivation")
- (check check-derivation))
+ (name 'derivation)
+ (description "Report failure to compile a package to a derivation")
+ (check check-derivation)
+ (requires-store? #t))
(lint-checker
(name 'patch-file-names)
(description "Validate file names and availability of patches")
diff --git a/guix/packages.scm b/guix/packages.scm
index 1ae16b60d1..ef96b5692f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -363,12 +363,12 @@ object."
(let ((field (assoc field inits)))
(match field
((_ value)
- (let ((props (source-properties value)))
- (and props
+ (let ((loc (and=> (source-properties value)
+ source-properties->location)))
+ (and loc
;; Preserve the original file name, which may be a
;; relative file name.
- (let ((loc (source-properties->location props)))
- (set-field loc (location-file) file)))))
+ (set-field loc (location-file) file))))
(_
#f))))
(_
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fbe34c8455..2a838d3a9a 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -10,6 +10,7 @@
;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -139,7 +140,9 @@
%current-profile
ensure-profile-directory
canonicalize-profile
- user-friendly-profile))
+ user-friendly-profile
+
+ linux-module-database))
;;; Commentary:
;;;
@@ -1139,6 +1142,51 @@ for both major versions of GTK+."
(hook . gtk-im-modules)))
(return #f)))))
+(define (linux-module-database manifest)
+ "Return a derivation that unites all the kernel modules of the manifest
+and creates the dependency graph of all these kernel modules.
+
+This is meant to be used as a profile hook."
+ (define kmod ; lazy reference
+ (module-ref (resolve-interface '(gnu packages linux)) 'kmod))
+ (define build
+ (with-imported-modules
+ (source-module-closure '((guix build utils)
+ (gnu build linux-modules)))
+ #~(begin
+ (use-modules (ice-9 ftw)
+ (ice-9 match)
+ (srfi srfi-1) ; append-map
+ (gnu build linux-modules))
+ (let* ((inputs '#$(manifest-inputs manifest))
+ (module-directories
+ (map (lambda (directory)
+ (string-append directory "/lib/modules"))
+ inputs))
+ (directory-entries
+ (lambda (directory)
+ (scandir directory (lambda (basename)
+ (not
+ (string-prefix? "." basename))))))
+ ;; Note: Should usually result in one entry.
+ (versions (delete-duplicates
+ (append-map directory-entries
+ module-directories))))
+ (match versions
+ ((version)
+ (let ((old-path (getenv "PATH")))
+ (setenv "PATH" #+(file-append kmod "/bin"))
+ (make-linux-module-directory inputs version #$output)
+ (setenv "PATH" old-path)))
+ (_ (error "Specified Linux kernel and Linux kernel modules
+are not all of the same version")))))))
+ (gexp->derivation "linux-module-database" build
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . linux-module-database))))
+
(define (xdg-desktop-database manifest)
"Return a derivation that builds the @file{mimeinfo.cache} database from
desktop files. It's used to query what applications can handle a given
@@ -1546,7 +1594,13 @@ are cross-built for TARGET."
;; Disable substitution because it would trigger a
;; connection to the substitute server, which is likely
;; to have no substitute to offer.
- #:substitutable? #f)))
+ #:substitutable? #f
+
+ #:properties `((type . profile)
+ (profile
+ (count
+ . ,(length
+ (manifest-entries manifest))))))))
(define* (profile-search-paths profile
#:optional (manifest (profile-manifest profile))
diff --git a/guix/progress.scm b/guix/progress.scm
index c7567a35fd..fec65b424c 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
@@ -96,13 +96,6 @@ stopped."
;;; File download progress report.
;;;
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
(define (nearest-exact-integer x)
"Given a real number X, return the nearest exact integer, with ties going to
the nearest exact even integer."
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 4f39920fe7..80f3b704d7 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -259,12 +259,7 @@ build and a list of store files to transfer."
resulting archive to the standard output port."
(let-values (((drv files)
(options->derivations+files store opts)))
- (show-what-to-build store drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?))
-
- (if (or (assoc-ref opts 'dry-run?)
- (build-derivations store drv))
+ (if (build-derivations store drv)
(export-paths store files (current-output-port)
#:recursive? (assoc-ref opts 'export-recursive?))
(leave (G_ "unable to export the given packages~%")))))
@@ -382,22 +377,27 @@ output port."
(with-status-verbosity (assoc-ref opts 'verbosity)
(with-store store
(set-build-options-from-command-line store opts)
- (cond ((assoc-ref opts 'export)
- (export-from-store store opts))
- ((assoc-ref opts 'import)
- (import-paths store (current-input-port)))
- ((assoc-ref opts 'missing)
- (let* ((files (lines (current-input-port)))
- (missing (remove (cut valid-path? store <>)
- files)))
- (format #t "~{~a~%~}" missing)))
- ((assoc-ref opts 'list)
- (list-contents (current-input-port)))
- ((assoc-ref opts 'extract)
- =>
- (lambda (target)
- (restore-file (current-input-port) target)))
- (else
- (leave
- (G_ "either '--export' or '--import' \
-must be specified~%"))))))))))))
+ (with-build-handler
+ (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (cond ((assoc-ref opts 'export)
+ (export-from-store store opts))
+ ((assoc-ref opts 'import)
+ (import-paths store (current-input-port)))
+ ((assoc-ref opts 'missing)
+ (let* ((files (lines (current-input-port)))
+ (missing (remove (cut valid-path? store <>)
+ files)))
+ (format #t "~{~a~%~}" missing)))
+ ((assoc-ref opts 'list)
+ (list-contents (current-input-port)))
+ ((assoc-ref opts 'extract)
+ =>
+ (lambda (target)
+ (restore-file (current-input-port) target)))
+ (else
+ (leave
+ (G_ "either '--export' or '--import' \
+must be specified~%")))))))))))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index da2a675ce2..af18d8b6f9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -952,64 +952,60 @@ needed."
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((current-terminal-columns (terminal-columns))
-
- ;; Set grafting upfront in case the user's input
- ;; depends on it (e.g., a manifest or code snippet that
- ;; calls 'gexp->derivation').
- (%graft? graft?))
- (let* ((mode (assoc-ref opts 'build-mode))
- (drv (options->derivations store opts))
- (urls (map (cut string-append <> "/log")
- (if (assoc-ref opts 'substitutes?)
- (or (assoc-ref opts 'substitute-urls)
- ;; XXX: This does not necessarily match the
- ;; daemon's substitute URLs.
- %default-substitute-urls)
- '())))
- (items (filter-map (match-lambda
- (('argument . (? store-path? file))
- ;; If FILE is a .drv that's not in
- ;; store, keep it so that it can be
- ;; substituted.
- (and (or (not (derivation-path? file))
- (not (file-exists? file)))
- file))
- (_ #f))
- opts))
- (roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
- opts)))
-
- (unless (or (assoc-ref opts 'log-file?)
- (assoc-ref opts 'derivations-only?))
- (show-what-to-build store drv
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?)
- #:mode mode))
-
- (cond ((assoc-ref opts 'log-file?)
- ;; Pass 'show-build-log' the output file names, not the
- ;; derivation file names, because there can be several
- ;; derivations leading to the same output.
- (for-each (cut show-build-log store <> urls)
- (delete-duplicates
- (append (map derivation->output-path drv)
- items))))
- ((assoc-ref opts 'derivations-only?)
- (format #t "~{~a~%~}" (map derivation-file-name drv))
- (for-each (cut register-root store <> <>)
- (map (compose list derivation-file-name) drv)
- roots))
- ((not (assoc-ref opts 'dry-run?))
- (and (build-derivations store (append drv items)
- mode)
- (for-each show-derivation-outputs drv)
- (for-each (cut register-root store <> <>)
- (map (lambda (drv)
- (map cdr
- (derivation->output-paths drv)))
- drv)
- roots))))))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (parameterize ((current-terminal-columns (terminal-columns))
+
+ ;; Set grafting upfront in case the user's input
+ ;; depends on it (e.g., a manifest or code snippet that
+ ;; calls 'gexp->derivation').
+ (%graft? graft?))
+ (let* ((mode (assoc-ref opts 'build-mode))
+ (drv (options->derivations store opts))
+ (urls (map (cut string-append <> "/log")
+ (if (assoc-ref opts 'substitutes?)
+ (or (assoc-ref opts 'substitute-urls)
+ ;; XXX: This does not necessarily match the
+ ;; daemon's substitute URLs.
+ %default-substitute-urls)
+ '())))
+ (items (filter-map (match-lambda
+ (('argument . (? store-path? file))
+ ;; If FILE is a .drv that's not in
+ ;; store, keep it so that it can be
+ ;; substituted.
+ (and (or (not (derivation-path? file))
+ (not (file-exists? file)))
+ file))
+ (_ #f))
+ opts))
+ (roots (filter-map (match-lambda
+ (('gc-root . root) root)
+ (_ #f))
+ opts)))
+
+ (cond ((assoc-ref opts 'log-file?)
+ ;; Pass 'show-build-log' the output file names, not the
+ ;; derivation file names, because there can be several
+ ;; derivations leading to the same output.
+ (for-each (cut show-build-log store <> urls)
+ (delete-duplicates
+ (append (map derivation->output-path drv)
+ items))))
+ ((assoc-ref opts 'derivations-only?)
+ (format #t "~{~a~%~}" (map derivation-file-name drv))
+ (for-each (cut register-root store <> <>)
+ (map (compose list derivation-file-name) drv)
+ roots))
+ (else
+ (and (build-derivations store (append drv items)
+ mode)
+ (for-each show-derivation-outputs drv)
+ (for-each (cut register-root store <> <>)
+ (map (lambda (drv)
+ (map cdr
+ (derivation->output-paths drv)))
+ drv)
+ roots)))))))))))
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 664cb32b7c..2fa31ecf45 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -61,49 +61,40 @@ number (or #f) corresponding to SPEC."
(x
(leave (G_ "~a: invalid SSH specification~%") spec))))
-(define (send-to-remote-host target opts)
+(define (send-to-remote-host local target opts)
"Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ;
package names, build the underlying packages before sending them."
- (with-store local
- (set-build-options-from-command-line local opts)
- (let-values (((user host port)
- (ssh-spec->user+host+port target))
- ((drv items)
- (options->derivations+files local opts)))
- (show-what-to-build local drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?))
+ (let-values (((user host port)
+ (ssh-spec->user+host+port target))
+ ((drv items)
+ (options->derivations+files local opts)))
+ (and (build-derivations local drv)
+ (let* ((session (open-ssh-session host #:user user
+ #:port (or port 22)))
+ (sent (send-files local items
+ (connect-to-remote-daemon session)
+ #:recursive? #t)))
+ (format #t "~{~a~%~}" sent)
+ sent))))
- (and (or (assoc-ref opts 'dry-run?)
- (build-derivations local drv))
- (let* ((session (open-ssh-session host #:user user
- #:port (or port 22)))
- (sent (send-files local items
- (connect-to-remote-daemon session)
- #:recursive? #t)))
- (format #t "~{~a~%~}" sent)
- sent)))))
-
-(define (retrieve-from-remote-host source opts)
+(define (retrieve-from-remote-host local source opts)
"Retrieve ITEMS from SOURCE."
- (with-store local
- (let*-values (((user host port)
- (ssh-spec->user+host+port source))
- ((session)
- (open-ssh-session host #:user user #:port (or port 22)))
- ((remote)
- (connect-to-remote-daemon session)))
- (set-build-options-from-command-line local opts)
- ;; TODO: Here we could to compute and build the derivations on REMOTE
- ;; rather than on LOCAL (one-off offloading) but that is currently too
- ;; slow due to the many RPC round trips. So we just assume that REMOTE
- ;; contains ITEMS.
- (let*-values (((drv items)
- (options->derivations+files local opts))
- ((retrieved)
- (retrieve-files local items remote #:recursive? #t)))
- (format #t "~{~a~%~}" retrieved)
- retrieved))))
+ (let*-values (((user host port)
+ (ssh-spec->user+host+port source))
+ ((session)
+ (open-ssh-session host #:user user #:port (or port 22)))
+ ((remote)
+ (connect-to-remote-daemon session)))
+ ;; TODO: Here we could to compute and build the derivations on REMOTE
+ ;; rather than on LOCAL (one-off offloading) but that is currently too
+ ;; slow due to the many RPC round trips. So we just assume that REMOTE
+ ;; contains ITEMS.
+ (let*-values (((drv items)
+ (options->derivations+files local opts))
+ ((retrieved)
+ (retrieve-files local items remote #:recursive? #t)))
+ (format #t "~{~a~%~}" retrieved)
+ retrieved)))
;;;
@@ -142,6 +133,10 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(let ((level (string->number* arg)))
(alist-cons 'verbosity level
(alist-delete 'verbosity result)))))
+ (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+
(option '(#\h "help") #f #f
(lambda args
(show-help)
@@ -176,7 +171,13 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(let* ((opts (parse-command-line args %options (list %default-options)))
(source (assoc-ref opts 'source))
(target (assoc-ref opts 'destination)))
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (cond (target (send-to-remote-host target opts))
- (source (retrieve-from-remote-host source opts))
- (else (leave (G_ "use '--to' or '--from'~%"))))))))
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (cond (target (send-to-remote-host store target opts))
+ (source (retrieve-from-remote-host store source opts))
+ (else (leave (G_ "use '--to' or '--from'~%"))))))))))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ad05c333dc..f70d41f35c 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 David Thompson <davet@gnu.org>
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -97,6 +98,22 @@ Perform the deployment specified by FILE.\n"))
environment-modules))))
(load* file module)))
+(define (show-what-to-deploy machines)
+ "Show the list of machines to deploy, MACHINES."
+ (let ((count (length machines)))
+ (format (current-error-port)
+ (N_ "The following ~*machine will be deployed:~%"
+ "The following ~d machines will be deployed:~%"
+ count)
+ count)
+ (display (indented-string
+ (fill-paragraph (string-join (map machine-display-name machines)
+ ", ")
+ (- (%text-width) 2) 2)
+ 2)
+ (current-error-port))
+ (display "\n\n" (current-error-port))))
+
(define (guix-deploy . args)
(define (handle-argument arg result)
(alist-cons 'file arg result))
@@ -105,22 +122,28 @@ Perform the deployment specified by FILE.\n"))
#:argument-handler handle-argument))
(file (assq-ref opts 'file))
(machines (or (and file (load-source-file file)) '())))
+ (show-what-to-deploy machines)
+
(with-status-verbosity (assoc-ref opts 'verbosity)
(with-store store
(set-build-options-from-command-line store opts)
- (for-each (lambda (machine)
- (info (G_ "deploying to ~a...~%")
- (machine-display-name machine))
- (parameterize ((%graft? (assq-ref opts 'graft?)))
- (guard (c ((message-condition? c)
- (report-error (G_ "failed to deploy ~a: ~a~%")
- (machine-display-name machine)
- (condition-message c)))
- ((deploy-error? c)
- (when (deploy-error-should-roll-back c)
- (info (G_ "rolling back ~a...~%")
- (machine-display-name machine))
- (run-with-store store (roll-back-machine machine)))
- (apply throw (deploy-error-captured-args c))))
- (run-with-store store (deploy-machine machine)))))
- machines)))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?))
+ (for-each (lambda (machine)
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
+ (parameterize ((%graft? (assq-ref opts 'graft?)))
+ (guard (c ((message-condition? c)
+ (report-error (G_ "failed to deploy ~a: ~a~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((deploy-error? c)
+ (when (deploy-error-should-roll-back c)
+ (info (G_ "rolling back ~a...~%")
+ (machine-display-name machine))
+ (run-with-store store (roll-back-machine machine)))
+ (apply throw (deploy-error-captured-args c))))
+ (run-with-store store (deploy-machine machine))
+ (info (G_ "successfully deployed ~a~%")
+ (machine-display-name machine)))))
+ machines))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index e2fe8051b9..e6f45d3eba 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -362,19 +362,6 @@ for the corresponding packages."
opts)
manifest-entry=?)))
-(define* (build-environment derivations opts)
- "Build the DERIVATIONS required by the environment using the build options
-in OPTS."
- (let ((substitutes? (assoc-ref opts 'substitutes?))
- (dry-run? (assoc-ref opts 'dry-run?)))
- (mbegin %store-monad
- (show-what-to-build* derivations
- #:use-substitutes? substitutes?
- #:dry-run? dry-run?)
- (if dry-run?
- (return #f)
- (built-derivations derivations)))))
-
(define (manifest->derivation manifest system bootstrap?)
"Return the derivation for a profile of MANIFEST.
BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
@@ -718,67 +705,68 @@ message if any test fails."
(with-store store
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (define manifest
- (options/resolve-packages store opts))
-
- (set-build-options-from-command-line store opts)
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (default-guile)))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (manifest->derivation
- manifest system bootstrap?))
- (profile -> (derivation->output-path prof-drv))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (build-environment (if (derivation? bash)
- (list prof-drv bash)
- (list prof-drv))
- opts)
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (cond
- ((assoc-ref opts 'dry-run?)
- (return #t))
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- (derivation->output-path bash)
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:white-list white-list
- #:link-profile? link-prof?
- #:network? network?
- #:map-cwd? (not no-cwd?))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (define manifest
+ (options/resolve-packages store opts))
+
+ (set-build-options-from-command-line store opts)
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile)))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (manifest->derivation
+ manifest system bootstrap?))
+ (profile -> (derivation->output-path prof-drv))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (built-derivations (if (derivation? bash)
+ (list prof-drv bash)
+ (list prof-drv)))
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?)))))))))))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 8d08c484f5..97ffd57301 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -30,6 +30,7 @@
#:use-module (guix packages)
#:use-module (guix lint)
#:use-module (guix ui)
+ #:use-module (guix store)
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module (gnu packages)
@@ -53,7 +54,7 @@
(lint-warning-message lint-warning))))
warnings))
-(define (run-checkers package checkers)
+(define* (run-checkers package checkers #:key store)
"Run the given CHECKERS on PACKAGE."
(let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
@@ -63,7 +64,9 @@
(lint-checker-name checker))
(force-output (current-error-port)))
(emit-warnings
- ((lint-checker-check checker) package)))
+ (if (lint-checker-requires-store? checker)
+ ((lint-checker-check checker) package #:store store)
+ ((lint-checker-check checker) package))))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
@@ -167,12 +170,27 @@ run the checkers on all packages.\n"))
(_ #f))
(reverse opts)))
(checkers (or (assoc-ref opts 'checkers) %all-checkers)))
- (cond
- ((assoc-ref opts 'list?)
+
+ (when (assoc-ref opts 'list?)
(list-checkers-and-exit checkers))
- ((null? args)
- (fold-packages (lambda (p r) (run-checkers p checkers)) '()))
- (else
- (for-each (lambda (spec)
- (run-checkers (specification->package spec) checkers))
- args)))))
+
+ (let ((any-lint-checker-requires-store?
+ (any lint-checker-requires-store? checkers)))
+
+ (define (call-maybe-with-store proc)
+ (if any-lint-checker-requires-store?
+ (with-store store
+ (proc store))
+ (proc #f)))
+
+ (call-maybe-with-store
+ (lambda (store)
+ (cond
+ ((null? args)
+ (fold-packages (lambda (p r) (run-checkers p checkers
+ #:store store)) '()))
+ (else
+ (for-each (lambda (spec)
+ (run-checkers (specification->package spec) checkers
+ #:store store))
+ args))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 045fd1643e..9d981c05d6 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -373,6 +373,10 @@ added to the pack."
;; file system since it's useless in this case.
"-no-recovery"
+ ;; Do not attempt to store extended attributes.
+ ;; See <https://bugs.gnu.org/40043>.
+ "-no-xattrs"
+
;; Set file times and the file system creation time to
;; one second after the Epoch.
"-all-time" "1" "-mkfs-time" "1"
@@ -1022,108 +1026,106 @@ Create a bundle of PACKAGE.\n"))
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (default-guile))
- (assoc-ref opts 'system)
- #:graft? (assoc-ref opts 'graft?))))
- (let* ((dry-run? (assoc-ref opts 'dry-run?))
- (derivation? (assoc-ref opts 'derivation-only?))
- (relocatable? (assoc-ref opts 'relocatable?))
- (proot? (eq? relocatable? 'proot))
- (manifest (let ((manifest (manifest-from-args store opts)))
- ;; Note: We cannot honor '--bootstrap' here because
- ;; 'glibc-bootstrap' lacks 'libc.a'.
- (if relocatable?
- (map-manifest-entries
- (cut wrapped-manifest-entry <> #:proot? proot?)
- manifest)
- manifest)))
- (pack-format (assoc-ref opts 'format))
- (name (string-append (symbol->string pack-format)
- "-pack"))
- (target (assoc-ref opts 'target))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (compressor (if bootstrap?
- bootstrap-xz
- (assoc-ref opts 'compressor)))
- (archiver (if (equal? pack-format 'squashfs)
- squashfs-tools
- (if bootstrap?
- %bootstrap-coreutils&co
- tar)))
- (symlinks (assoc-ref opts 'symlinks))
- (build-image (match (assq-ref %formats pack-format)
- ((? procedure? proc) proc)
- (#f
- (leave (G_ "~a: unknown pack format~%")
- pack-format))))
- (localstatedir? (assoc-ref opts 'localstatedir?))
- (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} \
+ (with-build-handler (build-notifier #:dry-run?
+ (assoc-ref opts 'dry-run?)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (default-guile))
+ (assoc-ref opts 'system)
+ #:graft? (assoc-ref opts 'graft?))))
+ (let* ((derivation? (assoc-ref opts 'derivation-only?))
+ (relocatable? (assoc-ref opts 'relocatable?))
+ (proot? (eq? relocatable? 'proot))
+ (manifest (let ((manifest (manifest-from-args store opts)))
+ ;; Note: We cannot honor '--bootstrap' here because
+ ;; 'glibc-bootstrap' lacks 'libc.a'.
+ (if relocatable?
+ (map-manifest-entries
+ (cut wrapped-manifest-entry <> #:proot? proot?)
+ manifest)
+ manifest)))
+ (pack-format (assoc-ref opts 'format))
+ (name (string-append (symbol->string pack-format)
+ "-pack"))
+ (target (assoc-ref opts 'target))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (compressor (if bootstrap?
+ bootstrap-xz
+ (assoc-ref opts 'compressor)))
+ (archiver (if (equal? pack-format 'squashfs)
+ squashfs-tools
+ (if bootstrap?
+ %bootstrap-coreutils&co
+ tar)))
+ (symlinks (assoc-ref opts 'symlinks))
+ (build-image (match (assq-ref %formats pack-format)
+ ((? procedure? proc) proc)
+ (#f
+ (leave (G_ "~a: unknown pack format~%")
+ pack-format))))
+ (localstatedir? (assoc-ref opts 'localstatedir?))
+ (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
-
- ;; Always produce relative
- ;; symlinks for Singularity (see
- ;; <https://bugs.gnu.org/34913>).
- #:relative-symlinks?
- (or relocatable?
- (eq? 'squashfs pack-format))
-
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
- #:locales? (not bootstrap?)
- #:target target))
- (drv (build-image name profile
- #:target
- target
- #:compressor
- compressor
- #:symlinks
- symlinks
- #:localstatedir?
- localstatedir?
- #:entry-point
- entry-point
- #:profile-name
- profile-name
- #:archiver
- archiver)))
- (mbegin %store-monad
- (munless derivation?
- (show-what-to-build* (list drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?))
- (mwhen derivation?
- (return (format #t "~a~%"
- (derivation-file-name drv))))
- (munless (or derivation? dry-run?)
- (built-derivations (list drv))
- (mwhen gc-root
- (register-root* (match (derivation->output-paths drv)
- (((names . items) ...)
- items))
- gc-root))
- (return (format #t "~a~%"
- (derivation->output-path drv))))))
- #:system (assoc-ref opts 'system))))))))
+ (run-with-store store
+ (mlet* %store-monad ((profile (profile-derivation
+ manifest
+
+ ;; Always produce relative
+ ;; symlinks for Singularity (see
+ ;; <https://bugs.gnu.org/34913>).
+ #:relative-symlinks?
+ (or relocatable?
+ (eq? 'squashfs pack-format))
+
+ #:hooks (if bootstrap?
+ '()
+ %default-profile-hooks)
+ #:locales? (not bootstrap?)
+ #:target target))
+ (drv (build-image name profile
+ #:target
+ target
+ #:compressor
+ compressor
+ #:symlinks
+ symlinks
+ #:localstatedir?
+ localstatedir?
+ #:entry-point
+ entry-point
+ #:profile-name
+ profile-name
+ #:archiver
+ archiver)))
+ (mbegin %store-monad
+ (mwhen derivation?
+ (return (format #t "~a~%"
+ (derivation-file-name drv))))
+ (munless derivation?
+ (built-derivations (list drv))
+ (mwhen gc-root
+ (register-root* (match (derivation->output-paths drv)
+ (((names . items) ...)
+ items))
+ gc-root))
+ (return (format #t "~a~%"
+ (derivation->output-path drv))))))
+ #:system (assoc-ref opts 'system)))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index bdddc11b7b..8af0a7a27e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -130,8 +130,7 @@ denote ranges as interpreted by 'matching-generations'."
#:key
(hooks %default-profile-hooks)
allow-collisions?
- bootstrap? use-substitutes?
- dry-run?)
+ bootstrap?)
"Build a new generation of PROFILE, a file name, using the packages
specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true,
do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile
@@ -142,12 +141,8 @@ hooks\" run when building the profile."
#:hooks (if bootstrap? '() hooks)
#:locales? (not bootstrap?))))
(prof (derivation->output-path prof-drv)))
- (show-what-to-build store (list prof-drv)
- #:use-substitutes? use-substitutes?
- #:dry-run? dry-run?)
(cond
- (dry-run? #t)
((and (file-exists? profile)
(and=> (readlink* profile) (cut string=? prof <>)))
(format (current-error-port) (G_ "nothing to be done~%")))
@@ -164,10 +159,6 @@ hooks\" run when building the profile."
(switch-symlinks profile (basename name))
(unless (string=? profile %current-profile)
(register-gc-root store name))
- (format #t (N_ "~a package in profile~%"
- "~a packages in profile~%"
- count)
- count)
(display-search-path-hint entries profile)))
(warn-about-disk-space profile))))))
@@ -918,9 +909,7 @@ processed, #f otherwise."
#:dry-run? dry-run?)
(build-and-use-profile store profile new
#:allow-collisions? allow-collisions?
- #:bootstrap? bootstrap?
- #:use-substitutes? substitutes?
- #:dry-run? dry-run?)))))
+ #:bootstrap? bootstrap?)))))
;;;
@@ -949,10 +938,14 @@ option processing with 'parse-command-line'."
(%graft? (assoc-ref opts 'graft?)))
(with-status-verbosity (assoc-ref opts 'verbosity)
(set-build-options-from-command-line (%store) opts)
- (parameterize ((%guile-for-build
- (package-derivation
- (%store)
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (default-guile)))))
- (process-actions (%store) opts)))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (parameterize ((%guile-for-build
+ (package-derivation
+ (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (default-guile)))))
+ (process-actions (%store) opts))))))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 1c5456026c..dbd02431fe 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -269,7 +269,7 @@ code, to PORT."
(let ((body (or (assoc-ref body language)
(assoc-ref body (%default-message-language))
"")))
- (format port " ~a~%"
+ (format port "~a~%"
(indented-string
(parameterize ((%text-width (- (%text-width) 4)))
(string-trim-right
@@ -389,8 +389,7 @@ previous generation. Return true if there are news to display."
(display-channel-news profile))
-(define* (build-and-install instances profile
- #:key use-substitutes? dry-run?)
+(define* (build-and-install instances profile)
"Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is
true, display what would be built without actually building it."
(define update-profile
@@ -403,29 +402,27 @@ true, display what would be built without actually building it."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
(mbegin %store-monad
(update-profile profile manifest
- #:use-substitutes? use-substitutes?
- #:hooks %channel-profile-hooks
- #:dry-run? dry-run?)
- (munless dry-run?
- (return (newline))
- (return
- (let ((more? (list (display-profile-news profile #:concise? #t)
- (display-channel-news-headlines profile))))
- (when (any ->bool more?)
- (display-hint
- (G_ "Run @command{guix pull --news} to read all the news.")))))
- (if guix-command
- (let ((new (map (cut string-append <> "/bin/guix")
- (list (user-friendly-profile profile)
- profile))))
- ;; Is the 'guix' command previously in $PATH the same as the new
- ;; one? If the answer is "no", then suggest 'hash guix'.
- (unless (member guix-command new)
- (display-hint (format #f (G_ "After setting @code{PATH}, run
+ #:hooks %channel-profile-hooks)
+
+ (return
+ (let ((more? (list (display-profile-news profile #:concise? #t)
+ (display-channel-news-headlines profile))))
+ (newline)
+ (when (any ->bool more?)
+ (display-hint
+ (G_ "Run @command{guix pull --news} to read all the news.")))))
+ (if guix-command
+ (let ((new (map (cut string-append <> "/bin/guix")
+ (list (user-friendly-profile profile)
+ profile))))
+ ;; Is the 'guix' command previously in $PATH the same as the new
+ ;; one? If the answer is "no", then suggest 'hash guix'.
+ (unless (member guix-command new)
+ (display-hint (format #f (G_ "After setting @code{PATH}, run
@command{hash guix} to make sure your shell refers to @file{~a}.")
- (first new))))
- (return #f))
- (return #f))))))
+ (first new))))
+ (return #f))
+ (return #f)))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
@@ -523,19 +520,6 @@ true, display what would be built without actually building it."
;;; Queries.
;;;
-(define (indented-string str indent)
- "Return STR with each newline preceded by IDENT spaces."
- (define indent-string
- (make-list indent #\space))
-
- (list->string
- (string-fold-right (lambda (chr result)
- (if (eqv? chr #\newline)
- (cons chr (append indent-string result))
- (cons chr result)))
- '()
- str)))
-
(define profile-package-alist
(mlambda (profile)
"Return a name/version alist representing the packages in PROFILE."
@@ -592,7 +576,7 @@ Return true when there is more package info to display."
(define (pretty str column)
(indented-string (fill-paragraph str (- (%text-width) 4)
column)
- 4))
+ 4 #:initial-indent? #f))
(define concise/max-item-count
;; Maximum number of items to display when CONCISE? is true.
@@ -760,10 +744,12 @@ Use '~/.config/guix/channels.scm' instead."))
(define (guix-pull . args)
(with-error-handling
(with-git-error-handling
- (let* ((opts (parse-command-line args %options
- (list %default-options)))
- (channels (channel-list opts))
- (profile (or (assoc-ref opts 'profile) %current-profile)))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
+ (substitutes? (assoc-ref opts 'substitutes?))
+ (dry-run? (assoc-ref opts 'dry-run?))
+ (channels (channel-list opts))
+ (profile (or (assoc-ref opts 'profile) %current-profile)))
(cond ((assoc-ref opts 'query)
(process-query opts profile))
((assoc-ref opts 'generation)
@@ -773,38 +759,37 @@ Use '~/.config/guix/channels.scm' instead."))
(with-status-verbosity (assoc-ref opts 'verbosity)
(parameterize ((%current-system (assoc-ref opts 'system))
(%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line store opts)
- (ensure-default-profile)
- (honor-x509-certificates store)
-
- (let ((instances (latest-channel-instances store channels)))
- (format (current-error-port)
- (N_ "Building from this channel:~%"
- "Building from these channels:~%"
- (length instances)))
- (for-each (lambda (instance)
- (let ((channel
- (channel-instance-channel instance)))
- (format (current-error-port)
- " ~10a~a\t~a~%"
- (channel-name channel)
- (channel-url channel)
- (string-take
- (channel-instance-commit instance)
- 7))))
- instances)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (default-guile)))))
- (with-profile-lock profile
- (run-with-store store
- (build-and-install instances profile
- #:dry-run?
- (assoc-ref opts 'dry-run?)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)))))))))))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ substitutes?
+ #:dry-run? dry-run?)
+ (set-build-options-from-command-line store opts)
+ (ensure-default-profile)
+ (honor-x509-certificates store)
+
+ (let ((instances (latest-channel-instances store channels)))
+ (format (current-error-port)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (default-guile)))))
+ (with-profile-lock profile
+ (run-with-store store
+ (build-and-install instances profile)))))))))))))))
;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index dfb975a24a..95b47a7816 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -102,13 +102,6 @@
;;;
;;; Code:
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
(define %narinfo-cache-directory
;; A local cache of narinfos, to avoid going to the network. Most of the
;; time, 'guix substitute' is called by guix-daemon as root and stores its
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index ac2475c551..61a3c95dbd 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -27,6 +27,7 @@
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
#:autoload (guix store database) (register-path)
+ #:use-module (guix describe)
#:use-module (guix grafts)
#:use-module (guix gexp)
#:use-module (guix derivations)
@@ -403,7 +404,6 @@ STORE is an open connection to the store."
#:old-entries old-entries)))
(drvs -> (list bootcfg)))
(mbegin %store-monad
- (show-what-to-build* drvs)
(built-derivations drvs)
;; Only install bootloader configuration file.
(install-bootloader local-eval bootloader-config bootcfg
@@ -719,16 +719,11 @@ checking this by themselves in their 'check' procedure."
(define (maybe-suggest-running-guix-pull)
"Suggest running 'guix pull' if this has never been done before."
- ;; The reason for this is that the 'guix' binding that we see here comes
- ;; from either ~/.config/latest or, if it's missing, from the
- ;; globally-installed Guix, which is necessarily older. See
- ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for
- ;; a discussion.
- (define latest
- (string-append (config-directory) "/current"))
-
- (unless (file-exists? latest)
- (warning (G_ "~a not found: 'guix pull' was never run~%") latest)
+ ;; Check whether we're running a 'guix pull'-provided 'guix' command. When
+ ;; 'current-profile' returns #f, we may be running the globally-installed
+ ;; 'guix' and thus run the risk of deploying an older 'guix'. See
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html>
+ (unless (or (current-profile) (getenv "GUIX_UNINSTALLED"))
(warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%"))
(warning (G_ "Failing to do that may downgrade your system!~%"))))
@@ -837,8 +832,7 @@ static checks."
(% (if derivations-only?
(return (for-each (compose println derivation-file-name)
drvs))
- (maybe-build drvs #:dry-run? dry-run?
- #:use-substitutes? use-substitutes?))))
+ (built-derivations drvs))))
(if (or dry-run? derivations-only?)
(return #f)
@@ -1139,42 +1133,46 @@ resulting from command-line parsing."
(with-store store
(set-build-options-from-command-line store opts)
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (case action
- ((extension-graph)
- (export-extension-graph os (current-output-port)))
- ((shepherd-graph)
- (export-shepherd-graph os (current-output-port)))
- (else
- (unless (memq action '(build init))
- (warn-about-old-distro #:suggested-command
- "guix system reconfigure"))
-
- (perform-action action os
- #:dry-run? dry?
- #:derivations-only? (assoc-ref opts
- 'derivations-only?)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:skip-safety-checks?
- (assoc-ref opts 'skip-safety-checks?)
- #:file-system-type (assoc-ref opts 'file-system-type)
- #:image-size (assoc-ref opts 'image-size)
- #:full-boot? (assoc-ref opts 'full-boot?)
- #:container-shared-network?
- (assoc-ref opts 'container-shared-network?)
- #:mappings (filter-map (match-lambda
- (('file-system-mapping . m)
- m)
- (_ #f))
- opts)
- #:install-bootloader? bootloader?
- #:target target-file
- #:bootloader-target bootloader-target
- #:gc-root (assoc-ref opts 'gc-root)))))
- #:target target
- #:system system))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (case action
+ ((extension-graph)
+ (export-extension-graph os (current-output-port)))
+ ((shepherd-graph)
+ (export-shepherd-graph os (current-output-port)))
+ (else
+ (unless (memq action '(build init))
+ (warn-about-old-distro #:suggested-command
+ "guix system reconfigure"))
+
+ (perform-action action os
+ #:dry-run? dry?
+ #:derivations-only? (assoc-ref opts
+ 'derivations-only?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:skip-safety-checks?
+ (assoc-ref opts 'skip-safety-checks?)
+ #:file-system-type (assoc-ref opts 'file-system-type)
+ #:image-size (assoc-ref opts 'image-size)
+ #:full-boot? (assoc-ref opts 'full-boot?)
+ #:container-shared-network?
+ (assoc-ref opts 'container-shared-network?)
+ #:mappings (filter-map (match-lambda
+ (('file-system-mapping . m)
+ m)
+ (_ #f))
+ opts)
+ #:install-bootloader? bootloader?
+ #:target target-file
+ #:bootloader-target bootloader-target
+ #:gc-root (assoc-ref opts 'gc-root)))))
+ #:target target
+ #:system system)))
(warn-about-disk-space)))
(define (resolve-subcommand name)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index a9e0cba92a..eb76771452 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -106,13 +106,6 @@ scope."
'()
packages)))))
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 56b49b177f..2d7ca7d01d 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -405,11 +405,24 @@ to the system ACL file if it has not yet been authorized."
"Send the subset of FILES from LOCAL (a local store) that's missing to
REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES.
Return the list of store items actually sent."
+ (define (inferior-remote-eval* exp session)
+ (guard (c ((inferior-exception? c)
+ (match (inferior-exception-arguments c)
+ (('quit 7)
+ (report-module-error (remote-store-host remote)))
+ (_
+ (report-inferior-exception c (remote-store-host remote))))))
+ (inferior-remote-eval exp session)))
+
;; Compute the subset of FILES missing on SESSION and send them.
(let* ((files (if recursive? (requisites local files) files))
(session (channel-get-session (store-connection-socket remote)))
- (missing (inferior-remote-eval
+ (missing (inferior-remote-eval*
`(begin
+ (eval-when (load expand eval)
+ (unless (resolve-module '(guix) #:ensure #f)
+ (exit 7)))
+
(use-modules (guix)
(srfi srfi-1) (srfi srfi-26))
@@ -567,4 +580,9 @@ own module directory. Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to
check.")
host)))
+(define (report-inferior-exception exception host)
+ "Report EXCEPTION, an &inferior-exception that occurred on HOST."
+ (raise-error (G_ "exception occurred on remote host '~A': ~s")
+ host (inferior-exception-arguments exception)))
+
;;; ssh.scm ends here
diff --git a/guix/status.scm b/guix/status.scm
index cbea4151f2..4b2edc2f3c 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -476,6 +476,14 @@ addition to build events."
"applying ~a grafts for ~a..."
count))
count drv)))
+ ('profile
+ (let ((count (match (assq-ref properties 'profile)
+ (#f 0)
+ (lst (or (assq-ref lst 'count) 0)))))
+ (format port (info (N_ "building profile with ~a package..."
+ "building profile with ~a packages..."
+ count))
+ count)))
('profile-hook
(let ((hook-type (assq-ref properties 'hook)))
(or (and=> (hook-message hook-type)
diff --git a/guix/store.scm b/guix/store.scm
index d42f76f48d..5dea264811 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
@@ -105,6 +105,7 @@
add-file-tree-to-store
file-mapping->tree
binary-file
+ with-build-handler
build-things
build
query-failed-paths
@@ -1262,6 +1263,46 @@ to a tree suitable for 'add-file-tree-to-store' and 'interned-file-tree'."
'()
mapping)))
+(define current-build-prompt
+ ;; When true, this is the prompt to abort to when 'build-things' is called.
+ (make-parameter #f))
+
+(define (call-with-build-handler handler thunk)
+ "Register HANDLER as a \"build handler\" and invoke THUNK."
+ (define tag
+ (make-prompt-tag "build handler"))
+
+ (parameterize ((current-build-prompt tag))
+ (call-with-prompt tag
+ thunk
+ (lambda (k . args)
+ ;; Since HANDLER may call K, which in turn may call 'build-things'
+ ;; again, reinstate a prompt (thus, it's not a tail call.)
+ (call-with-build-handler handler
+ (lambda ()
+ (apply handler k args)))))))
+
+(define (invoke-build-handler store things mode)
+ "Abort to 'current-build-prompt' if it is set."
+ (or (not (current-build-prompt))
+ (abort-to-prompt (current-build-prompt) store things mode)))
+
+(define-syntax-rule (with-build-handler handler exp ...)
+ "Register HANDLER as a \"build handler\" and invoke THUNK. When
+'build-things' is called within the dynamic extent of the call to THUNK,
+HANDLER is invoked like so:
+
+ (HANDLER CONTINUE STORE THINGS MODE)
+
+where CONTINUE is the continuation, and the remaining arguments are those that
+were passed to 'build-things'.
+
+Build handlers are useful to announce a build plan with 'show-what-to-build'
+and to implement dry runs (by not invoking CONTINUE) in a way that gracefully
+deals with \"dynamic dependencies\" such as grafts---derivations that depend
+on the build output of a previous derivation."
+ (call-with-build-handler handler (lambda () exp ...)))
+
(define build-things
(let ((build (operation (build-things (string-list things)
(integer mode))
@@ -1276,20 +1317,24 @@ outputs, and return when the worker is done building them. Elements of THINGS
that are not derivations can only be substituted and not built locally.
Alternately, an element of THING can be a derivation/output name pair, in
which case the daemon will attempt to substitute just the requested output of
-the derivation. Return #t on success."
- (let ((things (map (match-lambda
- ((drv . output) (string-append drv "!" output))
- (thing thing))
- things)))
- (parameterize ((current-store-protocol-version
- (store-connection-version store)))
- (if (>= (store-connection-minor-version store) 15)
- (build store things mode)
- (if (= mode (build-mode normal))
- (build/old store things)
- (raise (condition (&store-protocol-error
- (message "unsupported build mode")
- (status 1)))))))))))
+the derivation. Return #t on success.
+
+When a handler is installed with 'with-build-handler', it is called any time
+'build-things' is called."
+ (or (not (invoke-build-handler store things mode))
+ (let ((things (map (match-lambda
+ ((drv . output) (string-append drv "!" output))
+ (thing thing))
+ things)))
+ (parameterize ((current-store-protocol-version
+ (store-connection-version store)))
+ (if (>= (store-connection-minor-version store) 15)
+ (build store things mode)
+ (if (= mode (build-mode normal))
+ (build/old store things)
+ (raise (condition (&store-protocol-error
+ (message "unsupported build mode")
+ (status 1))))))))))))
(define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session.
diff --git a/guix/ui.scm b/guix/ui.scm
index 6f1ca9c0b2..1e24fe5dca 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -93,6 +93,7 @@
string->number*
size->number
show-derivation-outputs
+ build-notifier
show-what-to-build
show-what-to-build*
show-manifest-transaction
@@ -103,6 +104,7 @@
read/eval
read/eval-package-expression
check-available-space
+ indented-string
fill-paragraph
%text-width
texi->plain-text
@@ -912,8 +914,10 @@ that the rest."
derivations listed in DRV using MODE, a 'build-mode' value. The elements of
DRV can be either derivations or derivation inputs.
-Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?,
-check and report what is prerequisites are available for download."
+Return two values: a Boolean indicating whether there's something to build,
+and a Boolean indicating whether there's something to download. When
+USE-SUBSTITUTES?, check and report what is prerequisites are available for
+download."
(define inputs
(map (match-lambda
((? derivation? drv) (derivation-input drv))
@@ -933,7 +937,7 @@ check and report what is prerequisites are available for download."
colorize-store-file-name
identity))
- (let*-values (((build download)
+ (let*-values (((build/full download)
(derivation-build-plan store inputs
#:mode mode
#:substitutable-info
@@ -957,7 +961,7 @@ check and report what is prerequisites are available for download."
#:hook ,hook
#:build ,(cons file build))))))))
'(#:graft () #:hook () #:build ())
- build)
+ build/full)
((#:graft graft #:hook hook #:build build)
(values graft hook build)))))
(define installed-size
@@ -1040,11 +1044,51 @@ check and report what is prerequisites are available for download."
(check-available-space installed-size)
- (pair? build)))
+ (values (pair? build/full) (pair? download))))
(define show-what-to-build*
(store-lift show-what-to-build))
+(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t))
+ "Return a procedure suitable for 'with-build-handler' that, when
+'build-things' is called, invokes 'show-what-to-build' to display the build
+plan. When DRY-RUN? is true, the 'with-build-handler' form returns without
+any build happening."
+ (define not-comma
+ (char-set-complement (char-set #\,)))
+
+ (define (read-derivation-from-file* item)
+ (catch 'system-error
+ (lambda ()
+ (read-derivation-from-file item))
+ (const #f)))
+
+ (lambda (continue store things mode)
+ (define inputs
+ ;; List of derivation inputs to build. Filter out non-existent '.drv'
+ ;; files because the daemon transparently tries to substitute them.
+ (filter-map (match-lambda
+ (((? derivation-path? drv) . output)
+ (let ((drv (read-derivation-from-file* drv))
+ (outputs (string-tokenize output not-comma)))
+ (and drv (derivation-input drv outputs))))
+ ((? derivation-path? drv)
+ (and=> (read-derivation-from-file* drv)
+ derivation-input))
+ (_
+ #f))
+ things))
+
+ (let-values (((build? download?)
+ (show-what-to-build store inputs
+ #:dry-run? dry-run?
+ #:use-substitutes? use-substitutes?
+ #:mode mode)))
+
+ (unless (and (or build? download?)
+ dry-run?)
+ (continue #t)))))
+
(define (right-arrow port)
"Return either a string containing the 'RIGHT ARROW' character, or an ASCII
replacement if PORT is not Unicode-capable."
@@ -1060,36 +1104,77 @@ replacement if PORT is not Unicode-capable."
(lambda (key . args)
"->"))))
+(define* (tabulate rows #:key (initial-indent 0) (max-width 25)
+ (inter-column " "))
+ "Return a list of strings where each string is a tabulated representation of
+an element of ROWS. All the ROWS must be lists of the same number of cells.
+
+Add INITIAL-INDENT white space at the beginning of each row. Ensure that
+columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a
+separator between subsequent columns."
+ (define column-widths
+ ;; List of column widths.
+ (let loop ((rows rows)
+ (widths '()))
+ (match rows
+ (((? null?) ...)
+ (reverse widths))
+ (((column rest ...) ...)
+ (loop rest
+ (cons (min (apply max (map string-length column))
+ max-width)
+ widths))))))
+
+ (define indent
+ (make-string initial-indent #\space))
+
+ (define (string-pad-right* str len)
+ (if (> (string-length str) len)
+ str
+ (string-pad-right str len)))
+
+ (map (lambda (row)
+ (string-trim-right
+ (string-append indent
+ (string-join
+ (map string-pad-right* row column-widths)
+ inter-column))))
+ rows))
+
(define* (show-manifest-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings name version output item)
- (map (lambda (name version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a\t~a"
- name
- (equal? output "out") output version
- (if (package? item)
- (package-output store item output)
- item)))
- name version output item))
+ (define (package-strings names versions outputs)
+ (tabulate (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ versions)
+ #:initial-indent 3))
(define → ;an arrow that can be represented on stderr
(right-arrow (current-error-port)))
- (define (upgrade-string name old-version new-version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
- name (equal? output "out") output
- old-version → new-version
- (if (package? item)
- (package-output store item output)
- item)))
+ (define (upgrade-string names old-version new-version outputs)
+ (tabulate (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ (map (lambda (old new)
+ (if (string=? old new)
+ (G_ "(dependencies changed)")
+ (string-append old " " → " " new)))
+ old-version new-version))
+ #:initial-indent 3))
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
((($ <manifest-entry> name version output item) ..1)
(let ((len (length name))
- (remove (package-strings name version output item)))
+ (remove (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be removed:~%~{~a~%~}~%"
@@ -1106,8 +1191,8 @@ replacement if PORT is not Unicode-capable."
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (downgrade (map upgrade-string
- name old-version new-version output item)))
+ (downgrade (upgrade-string name old-version new-version
+ output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be downgraded:~%~{~a~%~}~%"
@@ -1124,8 +1209,9 @@ replacement if PORT is not Unicode-capable."
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (upgrade (map upgrade-string
- name old-version new-version output item)))
+ (upgrade (upgrade-string name
+ old-version new-version
+ output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"
@@ -1141,7 +1227,7 @@ replacement if PORT is not Unicode-capable."
(match install
((($ <manifest-entry> name version output item _) ..1)
(let ((len (length name))
- (install (package-strings name version output item)))
+ (install (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be installed:~%~{~a~%~}~%"
@@ -1163,6 +1249,23 @@ replacement if PORT is not Unicode-capable."
(lambda ()
body ...)))))
+(define* (indented-string str indent
+ #:key (initial-indent? #t))
+ "Return STR with each newline preceded by IDENT spaces. When
+INITIAL-INDENT? is true, the first line is also indented."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ (if initial-indent?
+ (string-append (list->string indent-string) str)
+ str))))
+
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.