Merge branch 'staging' into core-updates

6 files changed, 209 insertions, 72 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6b29c470fb..28864435df 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -226,18 +226,21 @@ matching URIs given in SOURCES."
          obj)))))
 
 (define (evaluate-replacement-specs specs proc)
-  "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on
-each package pair specified by SPECS.  Return the resulting list.  Raise an
-error if an element of SPECS uses invalid syntax, or if a package it refers to
-could not be found."
+  "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
+of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
+PROC is called with the package to be replaced and its replacement according
+to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
+package it refers to could not be found."
   (define not-equal
     (char-set-complement (char-set #\=)))
 
   (map (lambda (spec)
          (match (string-tokenize spec not-equal)
-           ((old new)
-            (proc (specification->package old)
-                  (specification->package new)))
+           ((spec new)
+            (cons spec
+                  (let ((new (specification->package new)))
+                    (lambda (old)
+                      (proc old new)))))
            (x
             (leave (G_ "invalid replacement specification: ~s~%") spec))))
        specs))
@@ -248,8 +251,10 @@ dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 called \"guile\" must be replaced with a dependency on a version 2.1 of
 \"guile\"."
-  (let* ((replacements (evaluate-replacement-specs replacement-specs cons))
-         (rewrite      (package-input-rewriting replacements)))
+  (let* ((replacements (evaluate-replacement-specs replacement-specs
+                                                   (lambda (old new)
+                                                     new)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -260,41 +265,47 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
-  (define (replacement-pair old new)
-    (cons old
-          (package (inherit old) (replacement new))))
+  (define (set-replacement old new)
+    (package (inherit old) (replacement new)))
 
   (let* ((replacements (evaluate-replacement-specs replacement-specs
-                                                   replacement-pair))
-         (rewrite      (package-input-rewriting replacements)))
+                                                   set-replacement))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
           obj))))
 
+(define %not-equal
+  (char-set-complement (char-set #\=)))
+
+(define (package-git-url package)
+  "Return the URL of the Git repository for package, or raise an error if
+the source of PACKAGE is not fetched from a Git repository."
+  (let ((source (package-source package)))
+    (cond ((and (origin? source)
+                (git-reference? (origin-uri source)))
+           (git-reference-url (origin-uri source)))
+          ((git-checkout? source)
+           (git-checkout-url source))
+          (else
+           (leave (G_ "the source of ~a is not a Git reference~%")
+                  (package-full-name package))))))
+
 (define (evaluate-git-replacement-specs specs proc)
   "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
 replacement package.  Raise an error if an element of SPECS uses invalid
 syntax, or if a package it refers to could not be found."
-  (define not-equal
-    (char-set-complement (char-set #\=)))
-
   (map (lambda (spec)
-         (match (string-tokenize spec not-equal)
-           ((name branch-or-commit)
-            (let* ((old    (specification->package name))
-                   (source (package-source old))
-                   (url    (cond ((and (origin? source)
-                                       (git-reference? (origin-uri source)))
-                                  (git-reference-url (origin-uri source)))
-                                 ((git-checkout? source)
-                                  (git-checkout-url source))
-                                 (else
-                                  (leave (G_ "the source of ~a is not a Git \
-reference~%")
-                                         (package-full-name old))))))
-              (cons old (proc old url branch-or-commit))))
+         (match (string-tokenize spec %not-equal)
+           ((spec branch-or-commit)
+            (define (replace old)
+              (let* ((source (package-source old))
+                     (url    (package-git-url old)))
+                (proc old url branch-or-commit)))
+
+            (cons spec replace))
            (x
             (leave (G_ "invalid replacement specification: ~s~%") spec))))
        specs))
@@ -307,13 +318,16 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using
   (define (replace old url branch)
     (package
       (inherit old)
-      (version (string-append "git." branch))
+      (version (string-append "git." (string-map (match-lambda
+                                                   (#\/ #\-)
+                                                   (chr chr))
+                                                 branch)))
       (source (git-checkout (url url) (branch branch)
                             (recursive? #t)))))
 
   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                        replace))
-         (rewrite      (package-input-rewriting replacements)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -331,16 +345,42 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
                               (if (< (string-length commit) 7)
                                   commit
                                   (string-take commit 7))))
-      (source (git-checkout (url url) (commit commit)))))
+      (source (git-checkout (url url) (commit commit)
+                            (recursive? #t)))))
 
   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                        replace))
-         (rewrite      (package-input-rewriting replacements)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
           obj))))
 
+(define (transform-package-source-git-url replacement-specs)
+  "Return a procedure that, when passed a package, replaces its dependencies
+according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
+\"guile-json=https://gitthing.com/…\" meaning that packages are built using
+a checkout of the Git repository at the given URL."
+  (define replacements
+    (map (lambda (spec)
+           (match (string-tokenize spec %not-equal)
+             ((spec url)
+              (cons spec
+                    (lambda (old)
+                      (package
+                        (inherit old)
+                        (source (git-checkout (url url)
+                                              (recursive? #t)))))))))
+         replacement-specs))
+
+  (define rewrite
+    (package-input-rewriting/spec replacements))
+
+  (lambda (store obj)
+    (if (package? obj)
+        (rewrite obj)
+        obj)))
+
 (define %transformations
   ;; Transformations that can be applied to things to build.  The car is the
   ;; key used in the option alist, and the cdr is the transformation
@@ -350,7 +390,8 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
     (with-input  . ,transform-package-inputs)
     (with-graft  . ,transform-package-inputs/graft)
     (with-branch . ,transform-package-source-branch)
-    (with-commit . ,transform-package-source-commit)))
+    (with-commit . ,transform-package-source-commit)
+    (with-git-url . ,transform-package-source-git-url)))
 
 (define %transformation-options
   ;; The command-line interface to the above transformations.
@@ -368,7 +409,9 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
           (option '("with-branch") #t #f
                   (parser 'with-branch))
           (option '("with-commit") #t #f
-                  (parser 'with-commit)))))
+                  (parser 'with-commit))
+          (option '("with-git-url") #t #f
+                  (parser 'with-git-url)))))
 
 (define (show-transformation-options-help)
   (display (G_ "
@@ -385,23 +428,32 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
                          build PACKAGE from the latest commit of BRANCH"))
   (display (G_ "
       --with-commit=PACKAGE=COMMIT
-                         build PACKAGE from COMMIT")))
+                         build PACKAGE from COMMIT"))
+  (display (G_ "
+      --with-git-url=PACKAGE=URL
+                         build PACKAGE from the repository at URL")))
 
 
 (define (options->transformation opts)
   "Return a procedure that, when passed an object to build (package,
 derivation, etc.), applies the transformations specified by OPTS."
   (define applicable
-    ;; List of applicable transformations as symbol/procedure pairs.
+    ;; List of applicable transformations as symbol/procedure pairs in the
+    ;; order in which they appear on the command line.
     (filter-map (match-lambda
-                  ((key . transform)
-                   (match (filter-map (match-lambda
-                                        ((k . arg)
-                                         (and (eq? k key) arg)))
-                                      opts)
-                     (()   #f)
-                     (args (cons key (transform args))))))
-                %transformations))
+                  ((key . value)
+                   (match (any (match-lambda
+                                 ((k . proc)
+                                  (and (eq? k key) proc)))
+                               %transformations)
+                     (#f
+                      #f)
+                     (transform
+                      ;; XXX: We used to pass TRANSFORM a list of several
+                      ;; arguments, but we now pass only one, assuming that
+                      ;; transform composes well.
+                      (cons key (transform (list value)))))))
+                (reverse opts)))
 
   (lambda (store obj)
     (fold (match-lambda*
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 7d0ecb0a4d..b6287d3a4c 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -85,7 +85,9 @@ Display information about the channels currently in use.\n"))
         (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
        ('channels
         (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
-                string))))))
+                string))
+       (_
+        (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%")))))))
 
 (define (channel->sexp channel)
   `(channel
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 8efeef3274..8fe81ad64b 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,6 +43,7 @@
             %bag-node-type
             %bag-with-origins-node-type
             %bag-emerged-node-type
+            %reverse-bag-node-type
             %derivation-node-type
             %reference-node-type
             %referrer-node-type
@@ -110,11 +111,21 @@ name."
 ;;; Reverse package DAG.
 ;;;
 
+(define (all-packages)            ;XXX: duplicated from (guix scripts refresh)
+  "Return the list of all the distro's packages."
+  (fold-packages (lambda (package result)
+                   ;; Ignore deprecated packages.
+                   (if (package-superseded package)
+                       result
+                       (cons package result)))
+                 '()
+                 #:select? (const #t)))           ;include hidden packages
+
 (define %reverse-package-node-type
   ;; For this node type we first need to compute the list of packages and the
   ;; list of back-edges.  Since we want to do it only once, we use the
   ;; promises below.
-  (let* ((packages   (delay (fold-packages cons '())))
+  (let* ((packages   (delay (all-packages)))
          (back-edges (delay (run-with-store #f    ;store not actually needed
                               (node-back-edges %package-node-type
                                                (force packages))))))
@@ -219,6 +230,21 @@ GNU-BUILD-SYSTEM have zero dependencies."
                           bag-node-edges-sans-bootstrap)
                  %store-monad))))
 
+(define %reverse-bag-node-type
+  ;; Type for the reverse traversal of package nodes via the "bag"
+  ;; representation, which includes implicit inputs.
+  (let* ((packages   (delay (package-closure (all-packages))))
+         (back-edges (delay (run-with-store #f    ;store not actually needed
+                              (node-back-edges %bag-node-type
+                                               (force packages))))))
+    (node-type
+     (name "reverse-bag")
+     (description "the reverse DAG of packages, including implicit inputs")
+     (convert nodes-from-package)
+     (identifier bag-node-identifier)
+     (label node-full-name)
+     (edges (lift1 (force back-edges) %store-monad)))))
+
 
 ;;;
 ;;; Derivation DAG.
@@ -375,6 +401,7 @@ package modules, while attempting to retain user package modules."
         %bag-node-type
         %bag-with-origins-node-type
         %bag-emerged-node-type
+        %reverse-bag-node-type
         %derivation-node-type
         %reference-node-type
         %referrer-node-type
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fbef079910..d237ae6e94 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -28,6 +28,7 @@
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix grafts)
+  #:autoload   (guix inferior) (inferior-package?)
   #:use-module (guix monads)
   #:use-module (guix modules)
   #:use-module (guix packages)
@@ -305,11 +306,13 @@ added to the pack."
     (with-imported-modules (source-module-closure
                             '((guix build utils)
                               (guix build store-copy)
+                              (guix build union)
                               (gnu build install))
                             #:select? not-config?)
       #~(begin
           (use-modules (guix build utils)
                        (guix build store-copy)
+                       ((guix build union) #:select (relative-file-name))
                        (gnu build install)
                        (srfi srfi-1)
                        (srfi srfi-26)
@@ -358,18 +361,25 @@ added to the pack."
                    ,@(append-map
                       (match-lambda
                         ((source '-> target)
-                         (list "-p"
-                               (string-join
-                                ;; name s mode uid gid symlink
-                                (list source
-                                      "s" "777" "0" "0"
-                                      (string-append #$profile "/" target))))))
+                         ;; Create relative symlinks to work around a bug in
+                         ;; Singularity 2.x:
+                         ;;   https://bugs.gnu.org/34913
+                         ;;   https://github.com/sylabs/singularity/issues/1487
+                         (let ((target (string-append #$profile "/" target)))
+                           (list "-p"
+                                 (string-join
+                                  ;; name s mode uid gid symlink
+                                  (list source
+                                        "s" "777" "0" "0"
+                                        (relative-file-name (dirname source)
+                                                            target)))))))
                       '#$symlinks)
 
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
-                   "-p" "/dev d 555 0 0"))
+                   "-p" "/dev d 555 0 0"
+                   "-p" "/home d 555 0 0"))
 
           (when database
             ;; Initialize /var/guix.
@@ -517,10 +527,14 @@ please email '~a'~%")
 ;;;
 
 (define* (wrapped-package package
-                          #:optional (compiler (c-compiler)))
+                          #:optional (compiler (c-compiler))
+                          #:key proot?)
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
+  (define (proot)
+    (specification->package "proot-static"))
+
   (define build
     (with-imported-modules (source-module-closure
                             '((guix build utils)
@@ -550,10 +564,19 @@ please email '~a'~%")
               (("@STORE_DIRECTORY@") (%store-directory)))
 
             (let* ((base   (strip-store-prefix program))
-                   (result (string-append #$output "/" base)))
+                   (result (string-append #$output "/" base))
+                   (proot  #$(and proot?
+                                  #~(string-drop
+                                     #$(file-append (proot) "/bin/proot")
+                                     (+ (string-length (%store-directory))
+                                        1)))))
               (mkdir-p (dirname result))
-              (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
-                      "run.c" "-o" result)
+              (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+                     "run.c" "-o" result
+                     (if proot
+                         (list (string-append "-DPROOT_PROGRAM=\""
+                                              proot "\""))
+                         '()))
               (delete-file "run.c")))
 
           (setvbuf (current-output-port) 'line)
@@ -573,7 +596,15 @@ please email '~a'~%")
                             (find-files #$(file-append package "/sbin"))
                             (find-files #$(file-append package "/libexec")))))))
 
-  (computed-file (string-append (package-full-name package "-") "R")
+  (computed-file (string-append
+                  (cond ((package? package)
+                         (package-full-name package "-"))
+                        ((inferior-package? package)
+                         (string-append (inferior-package-name package)
+                                        "-"
+                                        (inferior-package-version package)))
+                        (else "wrapper"))
+                  "R")
                  build))
 
 (define (map-manifest-entries proc manifest)
@@ -646,7 +677,12 @@ please email '~a'~%")
                    (exit 0)))
          (option '(#\R "relocatable") #f #f
                  (lambda (opt name arg result)
-                   (alist-cons 'relocatable? #t result)))
+                   (match (assq-ref result 'relocatable?)
+                     (#f
+                      (alist-cons 'relocatable? #t result))
+                     (_
+                      (alist-cons 'relocatable? 'proot
+                                  (alist-delete 'relocatable? result))))))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
@@ -821,11 +857,14 @@ Create a bundle of PACKAGE.\n"))
                                           #:graft? (assoc-ref opts 'graft?))))
           (let* ((dry-run?    (assoc-ref opts 'dry-run?))
                  (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 wrapped-package manifest)
+                                    (map-manifest-entries
+                                     (cut wrapped-package <> #:proot? proot?)
+                                     manifest)
                                     manifest)))
                  (pack-format (assoc-ref opts 'format))
                  (name        (string-append (symbol->string pack-format)
@@ -851,7 +890,14 @@ Create a bundle of PACKAGE.\n"))
             (run-with-store store
               (mlet* %store-monad ((profile (profile-derivation
                                              manifest
-                                             #:relative-symlinks? relocatable?
+
+                                             ;; 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)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index efff511299..b0c6a7ced7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -526,14 +527,14 @@ upgrading, #f otherwise."
   (define upgrade-regexps
     (filter-map (match-lambda
                   (('upgrade . regexp)
-                   (make-regexp* (or regexp "")))
+                   (make-regexp* (or regexp "") regexp/icase))
                   (_ #f))
                 opts))
 
   (define do-not-upgrade-regexps
     (filter-map (match-lambda
                   (('do-not-upgrade . regexp)
-                   (make-regexp* regexp))
+                   (make-regexp* regexp regexp/icase))
                   (_ #f))
                 opts))
 
@@ -686,7 +687,7 @@ processed, #f otherwise."
        #t)
 
       (('list-installed regexp)
-       (let* ((regexp    (and regexp (make-regexp* regexp)))
+       (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
               (manifest  (profile-manifest profile))
               (installed (manifest-entries manifest)))
          (leave-on-EPIPE
@@ -702,7 +703,7 @@ processed, #f otherwise."
          #t))
 
       (('list-available regexp)
-       (let* ((regexp    (and regexp (make-regexp* regexp)))
+       (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
               (available (fold-available-packages
                           (lambda* (name version result
                                          #:key outputs location
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d67b9f8185..97508f4bd6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -808,8 +808,17 @@ and TARGET arguments."
                  #~(begin
                      (use-modules (gnu build bootloader)
                                   (guix build utils)
-                                  (ice-9 binary-ports))
-                     (#$installer #$bootloader #$device #$target)))))
+                                  (ice-9 binary-ports)
+                                  (srfi srfi-34)
+                                  (srfi srfi-35))
+
+                     (guard (c ((message-condition? c) ;XXX: i18n
+                                (format (current-error-port) "error: ~a~%"
+                                        (condition-message c))
+                                (exit 1)))
+                       (#$installer #$bootloader #$device #$target)
+                       (format #t "bootloader successfully installed on '~a'~%"
+                               #$device))))))
 
 (define* (perform-action action os
                          #:key skip-safety-checks?