Merge branch 'master' into staging

10 files changed, 273 insertions, 116 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index a4c91550a6..141ef409d6 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -187,10 +187,13 @@ name decoding bug described at
 DIRECTORY.  Those authority certificates are checked when
 'peer-certificate-status' is later called."
   (let ((cred  (make-certificate-credentials))
-        (files (or (scandir directory
-                            (lambda (file)
-                              (string-suffix? ".pem" file)))
-                   '())))
+        (files (match (scandir directory (cut string-suffix? ".pem" <>))
+                 ((or #f ())
+                  ;; Some distros provide nothing but bundles (*.crt) under
+                  ;; /etc/ssl/certs, so look for them.
+                  (or (scandir directory (cut string-suffix? ".crt" <>))
+                      '()))
+                 (pem pem))))
     (for-each (lambda (file)
                 (let ((file (string-append directory "/" file)))
                   ;; Protect against dangling symlinks.
@@ -198,7 +201,7 @@ DIRECTORY.  Those authority certificates are checked when
                     (set-certificate-credentials-x509-trust-file!*
                      cred file
                      x509-certificate-format/pem))))
-              (or files '()))
+              files)
     cred))
 
 (define (peer-certificate session)
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 47a9eda9e6..f0c41812f1 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2018, 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -74,40 +74,14 @@ archive, a directory, or an Emacs Lisp file."
         #t)
       (gnu:unpack #:source source)))
 
-(define* (set-emacs-load-path #:key source inputs #:allow-other-keys)
-  (define (inputs->directories inputs)
-    "Extract the directory part from INPUTS."
-    (match inputs
-      (((names . directories) ...) directories)))
-
-  (define (input-directory->el-directory input-directory)
-    "Return the correct Emacs Lisp directory in INPUT-DIRECTORY or #f, if there
-is no Emacs Lisp directory."
-    (let ((legacy-elisp-directory (string-append input-directory %legacy-install-suffix))
-          (guix-elisp-directory
-           (string-append
-            input-directory %install-suffix "/"
-            (store-directory->elpa-name-version input-directory))))
-      (cond
-       ((file-exists? guix-elisp-directory) guix-elisp-directory)
-       ((file-exists? legacy-elisp-directory) legacy-elisp-directory)
-       (else #f))))
-
-  (define (input-directories->el-directories input-directories)
-    "Return the list of Emacs Lisp directories in INPUT-DIRECTORIES."
-    (filter-map input-directory->el-directory input-directories))
-
-  "Set the EMACSLOADPATH environment variable so that dependencies are found."
+(define* (add-source-to-load-path #:key dummy #:allow-other-keys)
+  "Augment the EMACSLOADPATH environment variable with the source directory."
   (let* ((source-directory (getcwd))
-         (input-elisp-directories (input-directories->el-directories
-                                   (inputs->directories inputs)))
-         (emacs-load-path-value
-          (string-join
-           (append input-elisp-directories (list source-directory))
-           ":" 'suffix)))
+         (emacs-load-path-value (string-append (getenv "EMACSLOADPATH") ":"
+                                               source-directory)))
     (setenv "EMACSLOADPATH" emacs-load-path-value)
-    (format #t "environment variable `EMACSLOADPATH' set to ~a\n"
-            emacs-load-path-value)))
+    (format #t "source directory ~s appended to the `EMACSLOADPATH' \
+environment variable\n" source-directory)))
 
 (define* (build #:key outputs inputs #:allow-other-keys)
   "Compile .el files."
@@ -269,7 +243,7 @@ second hyphen.  This corresponds to 'name-version' as used in ELPA packages."
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (replace 'unpack unpack)
-    (add-after 'unpack 'set-emacs-load-path set-emacs-load-path)
+    (add-after 'unpack 'add-source-to-load-path add-source-to-load-path)
     (delete 'bootstrap)
     (delete 'configure)
     ;; Move the build phase after install: the .el files are byte compiled
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 5fe3d85a7f..9cf07c9504 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -52,8 +52,8 @@
             hackage-package?))
 
 (define ghc-standard-libraries
-  ;; List of libraries distributed with ghc (8.4.3).
-  ;; Contents of ...-ghc-8.4.3/lib/ghc-8.4.3.
+  ;; List of libraries distributed with ghc (8.6.5).
+  ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5.
   '("ghc"
     "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
             ;; hackage-name->package-name takes this into account.
@@ -70,11 +70,13 @@
     "ghc-boot"
     "ghc-boot-th"
     "ghc-compact"
+    "ghc-heap"
     "ghc-prim"
     "ghci"
     "haskeline"
     "hpc"
     "integer-gmp"
+    "libiserv"
     "mtl"
     "parsec"
     "pretty"
diff --git a/guix/inferior.scm b/guix/inferior.scm
index b8e2f21f42..71dae89e92 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -89,6 +89,7 @@
             gexp->derivation-in-inferior
 
             %inferior-cache-directory
+            cached-channel-instance
             inferior-for-channels))
 
 ;;; Commentary:
@@ -635,6 +636,58 @@ failing when GUIX is too old and lacks the 'guix repl' command."
   (make-parameter (string-append (cache-directory #:ensure? #f)
                                  "/inferiors")))
 
+(define* (cached-channel-instance store
+                                  channels
+                                  #:key
+                                  (cache-directory (%inferior-cache-directory))
+                                  (ttl (* 3600 24 30)))
+  "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
+The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
+This procedure opens a new connection to the build daemon."
+  (define instances
+    (latest-channel-instances store channels))
+
+  (define key
+    (bytevector->base32-string
+     (sha256
+      (string->utf8
+       (string-concatenate (map channel-instance-commit instances))))))
+
+  (define cached
+    (string-append cache-directory "/" key))
+
+  (define (base32-encoded-sha256? str)
+    (= (string-length str) 52))
+
+  (define (cache-entries directory)
+    (map (lambda (file)
+           (string-append directory "/" file))
+         (scandir directory base32-encoded-sha256?)))
+
+  (define symlink*
+    (lift2 symlink %store-monad))
+
+  (define add-indirect-root*
+    (store-lift add-indirect-root))
+
+  (mkdir-p cache-directory)
+  (maybe-remove-expired-cache-entries cache-directory
+                                      cache-entries
+                                      #:entry-expiration
+                                      (file-expiration-time ttl))
+
+  (if (file-exists? cached)
+      cached
+      (run-with-store store
+        (mlet %store-monad ((profile
+                             (channel-instances->derivation instances)))
+          (mbegin %store-monad
+            (show-what-to-build* (list profile))
+            (built-derivations (list profile))
+            (symlink* (derivation->output-path profile) cached)
+            (add-indirect-root* cached)
+            (return cached))))))
+
 (define* (inferior-for-channels channels
                                 #:key
                                 (cache-directory (%inferior-cache-directory))
@@ -645,48 +698,10 @@ procedure opens a new connection to the build daemon.
 
 This is a convenience procedure that people may use in manifests passed to
 'guix package -m', for instance."
-  (with-store store
-    (let ()
-      (define instances
-        (latest-channel-instances store channels))
-
-      (define key
-        (bytevector->base32-string
-         (sha256
-          (string->utf8
-           (string-concatenate (map channel-instance-commit instances))))))
-
-      (define cached
-        (string-append cache-directory "/" key))
-
-      (define (base32-encoded-sha256? str)
-        (= (string-length str) 52))
-
-      (define (cache-entries directory)
-        (map (lambda (file)
-               (string-append directory "/" file))
-             (scandir directory base32-encoded-sha256?)))
-
-      (define symlink*
-        (lift2 symlink %store-monad))
-
-      (define add-indirect-root*
-        (store-lift add-indirect-root))
-
-      (mkdir-p cache-directory)
-      (maybe-remove-expired-cache-entries cache-directory
-                                          cache-entries
-                                          #:entry-expiration
-                                          (file-expiration-time ttl))
-
-      (if (file-exists? cached)
-          (open-inferior cached)
-          (run-with-store store
-            (mlet %store-monad ((profile
-                                 (channel-instances->derivation instances)))
-              (mbegin %store-monad
-                (show-what-to-build* (list profile))
-                (built-derivations (list profile))
-                (symlink* (derivation->output-path profile) cached)
-                (add-indirect-root* cached)
-                (return (open-inferior cached)))))))))
+  (define cached
+    (with-store store
+      (cached-channel-instance store
+                               channels
+                               #:cache-directory cache-directory
+                               #:ttl ttl)))
+  (open-inferior cached))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9ad7379bbe..ae78df9c5c 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -802,7 +802,15 @@ build---packages, gexps, derivations, and so on."
   (append-map (match-lambda
                 (('argument . (? string? spec))
                  (cond ((derivation-path? spec)
-                        (list (read-derivation-from-file spec)))
+                        (catch 'system-error
+                          (lambda ()
+                            (list (read-derivation-from-file spec)))
+                          (lambda args
+                            ;; Non-existent .drv files can be substituted down
+                            ;; the road, so don't error out.
+                            (if (= ENOENT (system-error-errno args))
+                                '()
+                                (apply throw args)))))
                        ((store-path? spec)
                         ;; Nothing to do; maybe for --log-file.
                         '())
@@ -934,7 +942,11 @@ needed."
                                    '())))
                    (items (filter-map (match-lambda
                                         (('argument . (? store-path? file))
-                                         (and (not (derivation-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))
@@ -965,7 +977,8 @@ needed."
                                (map (compose list derivation-file-name) drv)
                                roots))
                     ((not (assoc-ref opts 'dry-run?))
-                     (and (build-derivations store drv mode)
+                     (and (build-derivations store (append drv items)
+                                             mode)
                           (for-each show-derivation-outputs drv)
                           (for-each (cut register-root store <> <>)
                                     (map (lambda (drv)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index f311587ec3..27b7e4fd1c 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -62,6 +62,10 @@ Perform the deployment specified by FILE.\n"))
                  (lambda args
                    (show-help)
                    (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix deploy")))
+
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 920d6c01fe..89b3e389fc 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -800,6 +800,10 @@ last resort for relocation."
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+         (option '(#\d "derivation") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'derivation-only? #t result)))
+
          (option '(#\f "format") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'format (string->symbol arg) result)))
@@ -918,6 +922,8 @@ Create a bundle of PACKAGE.\n"))
   -r, --root=FILE        make FILE a symlink to the result, and register it
                          as a garbage collector root"))
   (display (G_ "
+  -d, --derivation       return the derivation of the pack"))
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (G_ "
       --bootstrap        use the bootstrap binaries to build the pack"))
@@ -1002,6 +1008,7 @@ Create a bundle of PACKAGE.\n"))
                                           (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)))
@@ -1070,11 +1077,15 @@ Create a bundle of PACKAGE.\n"))
                                                      #:archiver
                                                      archiver)))
                 (mbegin %store-monad
-                  (show-what-to-build* (list drv)
-                                       #:use-substitutes?
-                                       (assoc-ref opts 'substitutes?)
-                                       #:dry-run? dry-run?)
-                  (munless dry-run?
+                  (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)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 92aac6066e..ef8d5c8fd9 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -36,6 +36,8 @@
   #:autoload   (guix inferior) (open-inferior)
   #:use-module (guix scripts build)
   #:autoload   (guix build utils) (which)
+  #:use-module ((guix build syscalls)
+                #:select (with-file-lock/no-wait))
   #:use-module (guix git)
   #:use-module (git)
   #:use-module (gnu packages)
@@ -56,6 +58,8 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:export (display-profile-content
+            channel-list
+            with-git-error-handling
             guix-pull))
 
 
@@ -79,8 +83,6 @@
   (display (G_ "Usage: guix pull [OPTION]...
 Download and deploy the latest version of Guix.\n"))
   (display (G_ "
-      --verbose          produce verbose output"))
-  (display (G_ "
   -C, --channels=FILE    deploy the channels defined in FILE"))
   (display (G_ "
       --url=URL          download from the Git repository at URL"))
@@ -120,10 +122,7 @@ Download and deploy the latest version of Guix.\n"))
 
 (define %options
   ;; Specifications of the command-line options.
-  (cons* (option '("verbose") #f #f
-                 (lambda (opt name arg result)
-                   (alist-cons 'verbose? #t result)))
-         (option '(#\C "channels") #t #f
+  (cons* (option '(#\C "channels") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'channel-file arg result)))
          (option '(#\l "list-generations") #f #t
@@ -382,7 +381,7 @@ previous generation.  Return true if there are news to display."
   (display-channel-news profile))
 
 (define* (build-and-install instances profile
-                            #:key use-substitutes? verbose? dry-run?)
+                            #:key use-substitutes? dry-run?)
   "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
@@ -818,13 +817,16 @@ Use '~/.config/guix/channels.scm' instead."))
                                        (if (assoc-ref opts 'bootstrap?)
                                            %bootstrap-guile
                                            (canonical-package guile-2.2)))))
-                        (run-with-store store
-                          (build-and-install instances profile
-                                             #:dry-run?
-                                             (assoc-ref opts 'dry-run?)
-                                             #:use-substitutes?
-                                             (assoc-ref opts 'substitutes?)
-                                             #:verbose?
-                                             (assoc-ref opts 'verbose?))))))))))))))
+                        (with-file-lock/no-wait (string-append profile ".lock")
+                          (lambda (key . args)
+                            (leave (G_ "profile ~a is locked by another process~%")
+                                   profile))
+
+                          (run-with-store store
+                            (build-and-install instances profile
+                                               #:dry-run?
+                                               (assoc-ref opts 'dry-run?)
+                                               #:use-substitutes?
+                                               (assoc-ref opts 'substitutes?)))))))))))))))
 
 ;;; pull.scm ends here
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
new file mode 100644
index 0000000000..19e635555a
--- /dev/null
+++ b/guix/scripts/time-machine.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.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 time-machine)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module (guix inferior)
+  #:use-module (guix channels)
+  #:use-module (guix store)
+  #:use-module (guix status)
+  #:use-module ((guix utils)
+                #:select (%current-system))
+  #:use-module ((guix scripts pull)
+                #:select (with-git-error-handling channel-list))
+  #:use-module ((guix scripts build)
+                #:select (%standard-build-options
+                          show-build-options-help
+                          set-build-options-from-command-line))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:export (guix-time-machine))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define (show-help)
+  (display (G_ "Usage: guix time-machine [OPTION] -- COMMAND ARGS...
+Execute COMMAND ARGS... in an older version of Guix.\n"))
+  (display (G_ "
+  -C, --channels=FILE    deploy the channels defined in FILE"))
+  (display (G_ "
+      --url=URL          use the Git repository at URL"))
+  (display (G_ "
+      --commit=COMMIT    use the specified COMMIT"))
+  (display (G_ "
+      --branch=BRANCH    use the tip of the specified BRANCH"))
+  (newline)
+  (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
+  ;; Specifications of the command-line options.
+  (cons* (option '(#\C "channels") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'channel-file arg result)))
+         (option '("url") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'repository-url arg
+                               (alist-delete 'repository-url result))))
+         (option '("commit") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(commit . ,arg) result)))
+         (option '("branch") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(branch . ,arg) result)))
+         (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix time-machine")))
+
+         %standard-build-options))
+
+(define %default-options
+  ;; Alist of default option values.
+  `((system . ,(%current-system))
+    (substitutes? . #t)
+    (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
+    (graft? . #t)
+    (debug . 0)
+    (verbosity . 1)))
+
+(define (parse-args args)
+  "Parse the list of command line arguments ARGS."
+  ;; The '--' token is used to separate the command to run from the rest of
+  ;; the operands.
+  (let-values (((args command) (break (cut string=? "--" <>) args)))
+    (let ((opts (parse-command-line args %options
+                                    (list %default-options))))
+      (match command
+        (() opts)
+        (("--") opts)
+        (("--" command ...) (alist-cons 'exec command opts))))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-time-machine . args)
+  (with-error-handling
+    (with-git-error-handling
+     (let* ((opts         (parse-args args))
+            (channels     (channel-list opts))
+            (command-line (assoc-ref opts 'exec)))
+       (when command-line
+         (let* ((directory
+                 (with-store store
+                   (with-status-verbosity (assoc-ref opts 'verbosity)
+                     (set-build-options-from-command-line store opts)
+                     (cached-channel-instance store channels))))
+                (executable (string-append directory "/bin/guix")))
+           (apply execl (cons* executable executable command-line))))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 1f99c5b3f5..64853f2989 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -782,13 +782,11 @@ be determined."
           ;; the absolute file name by looking at %LOAD-PATH; doing this at
           ;; run time rather than expansion time is necessary to allow files
           ;; to be moved on the file system.
-          (cond ((not file-name)
-                 #f)                ;raising an error would upset Geiser users
-                ((string-prefix? "/" file-name)
-                 (dirname file-name))
-                (else
-                 #`(absolute-dirname #,file-name))))
-         (#f
+          (if (string-prefix? "/" file-name)
+              (dirname file-name)
+              #`(absolute-dirname #,file-name)))
+         ((or ('filename . #f) #f)
+          ;; raising an error would upset Geiser users
           #f))))))
 
 ;; A source location.