Merge branch 'master' into core-updates

 Conflicts:
	gnu/local.mk
	gnu/packages/python-xyz.scm
	gnu/packages/xml.scm
	guix/gexp.scm
	po/guix/POTFILES.in

8 files changed, 211 insertions, 109 deletions

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
new file mode 100644
index 0000000000..978cfb2a81
--- /dev/null
+++ b/guix/scripts/deploy.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 David Thompson <davet@gnu.org>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts deploy)
+  #:use-module (gnu machine)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts build)
+  #:use-module (guix store)
+  #:use-module (guix ui)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:export (guix-deploy))
+
+;;; Commentary:
+;;;
+;;; This program provides a command-line interface to (gnu machine), allowing
+;;; users to perform remote deployments through specification files.
+;;;
+;;; Code:
+
+
+
+(define (show-help)
+  (display (G_ "Usage: guix deploy [OPTION] FILE...
+Perform the deployment specified by FILE.\n"))
+  (show-build-options-help)
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         %standard-build-options))
+
+(define %default-options
+  '((system . ,(%current-system))
+    (substitutes? . #t)
+    (build-hook? . #t)
+    (graft? . #t)
+    (debug . 0)
+    (verbosity . 1)))
+
+(define (load-source-file file)
+  "Load FILE as a user module."
+  (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh)))))
+    (load* file module)))
+
+(define (guix-deploy . args)
+  (define (handle-argument arg result)
+    (alist-cons 'file arg result))
+  (let* ((opts (parse-command-line args %options (list %default-options)
+                                   #:argument-handler handle-argument))
+         (file (assq-ref opts 'file))
+         (machines (or (and file (load-source-file file)) '())))
+    (with-store store
+      (set-build-options-from-command-line store opts)
+      (for-each (lambda (machine)
+                  (info (G_ "deploying to ~a...") (machine-display-name machine))
+                  (run-with-store store (deploy-machine machine)))
+                machines))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index ac269083c8..f7f7edda48 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -163,6 +163,10 @@ COMMAND or an interactive shell in that environment.\n"))
                          user into an isolated container, use the name USER
                          with home directory /home/USER"))
   (display (G_ "
+      --no-cwd           do not share current working directory with an
+                         isolated container"))
+
+  (display (G_ "
       --share=SPEC       for containers, share writable host file system
                          according to SPEC"))
   (display (G_ "
@@ -270,6 +274,9 @@ use '--preserve' instead~%"))
                  (lambda (opt name arg result)
                    (alist-cons 'user arg
                                (alist-delete 'user result eq?))))
+         (option '("no-cwd") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'no-cwd? #t result)))
          (option '("share") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'file-system-mapping
@@ -445,7 +452,8 @@ regexps in WHITE-LIST."
            ((_ . status) status)))))
 
 (define* (launch-environment/container #:key command bash user user-mappings
-                                       profile manifest link-profile? network?)
+                                       profile manifest link-profile? network?
+                                       map-cwd?)
   "Run COMMAND within a container that features the software in PROFILE.
 Environment variables are set according to the search paths of MANIFEST.
 The global shell is BASH, a file name for a GNU Bash binary in the
@@ -480,26 +488,29 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
             ;; /bin/sh, the current working directory, and possibly networking
             ;; configuration files within the container.
             (mappings
-             (override-user-mappings
-              user home
-              (append user-mappings
-                      ;; Current working directory.
-                      (list (file-system-mapping
-                             (source cwd)
-                             (target cwd)
-                             (writable? #t)))
-                      ;; When in Rome, do as Nix build.cc does: Automagically
-                      ;; map common network configuration files.
-                      (if network?
-                          %network-file-mappings
-                          '())
-                      ;; Mappings for the union closure of all inputs.
-                      (map (lambda (dir)
-                             (file-system-mapping
-                              (source dir)
-                              (target dir)
-                              (writable? #f)))
-                           reqs))))
+             (append
+              (override-user-mappings
+               user home
+               (append user-mappings
+                       ;; Share current working directory, unless asked not to.
+                       (if map-cwd?
+                           (list (file-system-mapping
+                                  (source cwd)
+                                  (target cwd)
+                                  (writable? #t)))
+                           '())))
+              ;; When in Rome, do as Nix build.cc does: Automagically
+              ;; map common network configuration files.
+              (if network?
+                  %network-file-mappings
+                  '())
+              ;; Mappings for the union closure of all inputs.
+              (map (lambda (dir)
+                     (file-system-mapping
+                      (source dir)
+                      (target dir)
+                      (writable? #f)))
+                   reqs)))
             (file-systems (append %container-file-systems
                                   (map file-system-mapping->bind-mount
                                        mappings))))
@@ -537,8 +548,10 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
             (write-group groups)
 
             ;; For convenience, start in the user's current working
-            ;; directory rather than the root directory.
-            (chdir (override-user-dir user home cwd))
+            ;; directory or, if unmapped, the home directory.
+            (chdir (if map-cwd?
+                       (override-user-dir user home cwd)
+                       home-dir))
 
             (primitive-exit/status
              ;; A container's environment is already purified, so no need to
@@ -664,6 +677,7 @@ message if any test fails."
            (container? (assoc-ref opts 'container?))
            (link-prof? (assoc-ref opts 'link-profile?))
            (network?   (assoc-ref opts 'network?))
+           (no-cwd?    (assoc-ref opts 'no-cwd?))
            (user       (assoc-ref opts 'user))
            (bootstrap? (assoc-ref opts 'bootstrap?))
            (system     (assoc-ref opts 'system))
@@ -684,6 +698,9 @@ message if any test fails."
         (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
       (when (and (not container?) user)
         (leave (G_ "'--user' cannot be used without '--container'~%")))
+      (when (and (not container?) no-cwd?)
+        (leave (G_ "--no-cwd cannot be used without --container~%")))
+
 
       (with-store store
         (with-status-verbosity (assoc-ref opts 'verbosity)
@@ -740,7 +757,9 @@ message if any test fails."
                                                     #:profile profile
                                                     #:manifest manifest
                                                     #:link-profile? link-prof?
-                                                    #:network? network?)))
+                                                    #:network? network?
+                                                    #:map-cwd? (not no-cwd?))))
+
                    (else
                     (return
                      (exit/status
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 9a57e5fd1e..31657326b6 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -104,11 +104,14 @@ Invoke the garbage collector.\n"))
           '()))))
 
 (define (delete-old-generations store profile pattern)
-  "Remove the generations of PROFILE that match PATTERN, a duration pattern.
-Do nothing if none matches."
+  "Remove the generations of PROFILE that match PATTERN, a duration pattern;
+do nothing if none matches.  If PATTERN is #f, delete all generations but the
+current one."
   (let* ((current (generation-number profile))
-         (numbers (matching-generations pattern profile
-                                        #:duration-relation >)))
+         (numbers (if (not pattern)
+                      (profile-generations profile)
+                      (matching-generations pattern profile
+                                            #:duration-relation >))))
 
     ;; Make sure we don't inadvertently remove the current generation.
     (delete-generations store profile (delv current numbers))))
@@ -155,8 +158,7 @@ is deprecated; use '-D'~%"))
                         (when (and arg (not (string->duration arg)))
                           (leave (G_ "~s does not denote a duration~%")
                                  arg))
-                        (alist-cons 'delete-generations (or arg "")
-                                    result)))))
+                        (alist-cons 'delete-generations arg result)))))
         (option '("optimize") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'optimize
@@ -287,9 +289,9 @@ is deprecated; use '-D'~%"))
          (assert-no-extra-arguments)
          (let ((min-freed  (assoc-ref opts 'min-freed))
                (free-space (assoc-ref opts 'free-space)))
-           (match (assoc-ref opts 'delete-generations)
+           (match (assq 'delete-generations opts)
              (#f #t)
-             ((? string? pattern)
+             ((_ . pattern)
               (delete-generations store pattern)))
            (cond
             (free-space
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c8cb7b959d..1524607623 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -27,6 +27,7 @@
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
+  #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (guix grafts)
   #:autoload   (guix inferior) (inferior-package?)
   #:use-module (guix monads)
@@ -285,6 +286,32 @@ added to the pack."
                     build
                     #:references-graphs `(("profile" ,profile))))
 
+(define (singularity-environment-file profile)
+  "Return a shell script that defines the environment variables corresponding
+to the search paths of PROFILE."
+  (define build
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  `((guix profiles)
+                                    (guix search-paths))
+                                  #:select? not-config?))
+        #~(begin
+            (use-modules (guix profiles) (guix search-paths)
+                         (ice-9 match))
+
+            (call-with-output-file #$output
+              (lambda (port)
+                (for-each (match-lambda
+                            ((spec . value)
+                             (format port "~a=~a~%export ~a~%"
+                                     (search-path-specification-variable spec)
+                                     value
+                                     (search-path-specification-variable spec))))
+                          (profile-search-paths #$profile))))))))
+
+  (computed-file "singularity-environment.sh" build))
+
 (define* (squashfs-image name profile
                          #:key target
                          (profile-name "guix-profile")
@@ -304,6 +331,9 @@ added to the pack."
          (file-append (store-database (list profile))
                       "/db/db.sqlite")))
 
+  (define environment
+    (singularity-environment-file profile))
+
   (define build
     (with-imported-modules (source-module-closure
                             '((guix build utils)
@@ -338,6 +368,7 @@ added to the pack."
                  `(,@(map store-info-item
                           (call-with-input-file "profile"
                             read-reference-graph))
+                   #$environment
                    ,#$output
 
                    ;; Do not perform duplicate checking because we
@@ -378,10 +409,19 @@ added to the pack."
                                                             target)))))))
                       '#$symlinks)
 
+                   "-p" "/.singularity.d d 555 0 0"
+
+                   ;; Create the environment file.
+                   "-p" "/.singularity.d/env d 555 0 0"
+                   "-p" ,(string-append
+                          "/.singularity.d/env/90-environment.sh s 777 0 0 "
+                          (relative-file-name "/.singularity.d/env"
+                                              #$environment))
+
                    ;; Create /.singularity.d/actions, and optionally the 'run'
                    ;; script, used by 'singularity run'.
-                   "-p" "/.singularity.d d 555 0 0"
                    "-p" "/.singularity.d/actions d 555 0 0"
+
                    ,@(if entry-point
                          `(;; This one if for Singularity 2.x.
                            "-p"
@@ -440,11 +480,24 @@ the image."
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
     (with-extensions (list guile-json guile-gcrypt)
-      (with-imported-modules (source-module-closure '((guix docker)
-                                                      (guix build store-copy))
-                                                    #:select? not-config?)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  `((guix docker)
+                                    (guix build store-copy)
+                                    (guix profiles)
+                                    (guix search-paths))
+                                  #:select? not-config?))
         #~(begin
-            (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+            (use-modules (guix docker) (guix build store-copy)
+                         (guix profiles) (guix search-paths)
+                         (srfi srfi-19) (ice-9 match))
+
+            (define environment
+              (map (match-lambda
+                     ((spec . value)
+                      (cons (search-path-specification-variable spec)
+                            value)))
+                   (profile-search-paths #$profile)))
 
             (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -455,6 +508,7 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
+                                #:environment environment
                                 #:entry-point #$(and entry-point
                                                      #~(string-append #$profile "/"
                                                                       #$entry-point))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7b277b63f1..a43c96516f 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -98,7 +98,7 @@ denote ranges as interpreted by 'matching-generations'."
     (cond ((not (file-exists? profile))            ; XXX: race condition
            (raise (condition (&profile-not-found-error
                               (profile profile)))))
-          ((string-null? pattern)
+          ((not pattern)
            (delete-generations store profile
                                (delv current (profile-generations profile))))
           ;; Do not delete the zeroth generation.
@@ -120,9 +120,7 @@ denote ranges as interpreted by 'matching-generations'."
              (let ((numbers (delv current numbers)))
                (when (null-list? numbers)
                  (leave (G_ "no matching generation~%")))
-               (delete-generations store profile numbers))))
-          (else
-           (leave (G_ "invalid syntax: ~a~%") pattern)))))
+               (delete-generations store profile numbers)))))))
 
 (define* (build-and-use-profile store profile manifest
                                 #:key
@@ -457,12 +455,12 @@ command-line option~%")
                            arg-handler)))
          (option '(#\l "list-generations") #f #t
                  (lambda (opt name arg result arg-handler)
-                   (values (cons `(query list-generations ,(or arg ""))
+                   (values (cons `(query list-generations ,arg)
                                  result)
                            #f)))
          (option '(#\d "delete-generations") #f #t
                  (lambda (opt name arg result arg-handler)
-                   (values (alist-cons 'delete-generations (or arg "")
+                   (values (alist-cons 'delete-generations arg
                                        result)
                            #f)))
          (option '(#\S "switch-generation") #t #f
@@ -683,7 +681,7 @@ processed, #f otherwise."
         (cond ((not (file-exists? profile))       ; XXX: race condition
                (raise (condition (&profile-not-found-error
                                   (profile profile)))))
-              ((string-null? pattern)
+              ((not pattern)
                (match (profile-generations profile)
                  (()
                   #t)
@@ -697,10 +695,7 @@ processed, #f otherwise."
                      (exit 1)
                      (begin
                        (list-generation display-profile-content (car numbers))
-                       (diff-profiles profile numbers)))))
-              (else
-               (leave (G_ "invalid syntax: ~a~%")
-                      pattern))))
+                       (diff-profiles profile numbers)))))))
        #t)
 
       (('list-installed regexp)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 2d428546c9..7895c19914 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -117,7 +117,7 @@ Download and deploy the latest version of Guix.\n"))
                    (alist-cons 'channel-file arg result)))
          (option '(#\l "list-generations") #f #t
                  (lambda (opt name arg result)
-                   (cons `(query list-generations ,(or arg ""))
+                   (cons `(query list-generations ,arg)
                          result)))
          (option '(#\N "news") #f #f
                  (lambda (opt name arg result)
@@ -486,7 +486,7 @@ list of package changes.")))))
       (cond ((not (file-exists? profile))         ; XXX: race condition
              (raise (condition (&profile-not-found-error
                                 (profile profile)))))
-            ((string-null? pattern)
+            ((not pattern)
              (list-generations profile (profile-generations profile)))
             ((matching-generations pattern profile)
              =>
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index 02169e8004..e1cc759fc8 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +19,7 @@
 (define-module (guix scripts repl)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module (guix repl)
   #:use-module (guix utils)
   #:use-module (guix packages)
   #:use-module (gnu packages)
@@ -29,8 +30,7 @@
   #:autoload   (system repl repl) (start-repl)
   #:autoload   (system repl server)
                   (make-tcp-server-socket make-unix-domain-server-socket)
-  #:export (machine-repl
-            guix-repl))
+  #:export (guix-repl))
 
 ;;; Commentary:
 ;;;
@@ -68,62 +68,12 @@ Start a Guile REPL in the Guix execution environment.\n"))
   (newline)
   (show-bug-report-information))
 
-(define (self-quoting? x)
-  "Return #t if X is self-quoting."
-  (letrec-syntax ((one-of (syntax-rules ()
-                            ((_) #f)
-                            ((_ pred rest ...)
-                             (or (pred x)
-                                 (one-of rest ...))))))
-    (one-of symbol? string? pair? null? vector?
-            bytevector? number? boolean?)))
-
 (define user-module
   ;; Module where we execute user code.
   (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
     (beautify-user-module! module)
     module))
 
-(define* (machine-repl #:optional
-                       (input (current-input-port))
-                       (output (current-output-port)))
-  "Run a machine-usable REPL over ports INPUT and OUTPUT.
-
-The protocol of this REPL is meant to be machine-readable and provides proper
-support to represent multiple-value returns, exceptions, objects that lack a
-read syntax, and so on.  As such it is more convenient and robust than parsing
-Guile's REPL prompt."
-  (define (value->sexp value)
-    (if (self-quoting? value)
-        `(value ,value)
-        `(non-self-quoting ,(object-address value)
-                           ,(object->string value))))
-
-  (write `(repl-version 0 0) output)
-  (newline output)
-  (force-output output)
-
-  (let loop ()
-    (match (read input)
-      ((? eof-object?) #t)
-      (exp
-       (catch #t
-         (lambda ()
-           (let ((results (call-with-values
-                              (lambda ()
-
-                                (primitive-eval exp))
-                            list)))
-             (write `(values ,@(map value->sexp results))
-                    output)
-             (newline output)
-             (force-output output)))
-         (lambda (key . args)
-           (write `(exception ,key ,@(map value->sexp args)))
-           (newline output)
-           (force-output output)))
-       (loop)))))
-
 (define (call-with-connection spec thunk)
   "Dynamically-bind the current input and output ports according to SPEC and
 call THUNK."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9a..67a4071684 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -614,7 +614,7 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
   (cond ((not (file-exists? profile))             ; XXX: race condition
          (raise (condition (&profile-not-found-error
                             (profile profile)))))
-        ((string-null? pattern)
+        ((not pattern)
          (for-each display-system-generation (profile-generations profile)))
         ((matching-generations pattern profile)
          =>
@@ -622,9 +622,7 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
            (if (null-list? numbers)
                (exit 1)
                (leave-on-EPIPE
-                (for-each display-system-generation numbers)))))
-        (else
-         (leave (G_ "invalid syntax: ~a~%") pattern))))
+                (for-each display-system-generation numbers)))))))
 
 
 ;;;
@@ -1232,7 +1230,7 @@ argument list and OPTS is the option alist."
     ;; an operating system configuration file.
     ((list-generations)
      (let ((pattern (match args
-                      (() "")
+                      (() #f)
                       ((pattern) pattern)
                       (x (leave (G_ "wrong number of arguments~%"))))))
        (list-generations pattern)))
@@ -1242,7 +1240,7 @@ argument list and OPTS is the option alist."
     ;; operating system configuration file.
     ((delete-generations)
      (let ((pattern (match args
-                      (() "")
+                      (() #f)
                       ((pattern) pattern)
                       (x (leave (G_ "wrong number of arguments~%"))))))
        (with-store store