Merge branch 'master' into core-updates

10 files changed, 160 insertions, 85 deletions

diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 21cb620d59..6470cfec97 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -81,6 +81,20 @@
   "Replace invalid characters in STR with a hyphen."
   (string-join (string-tokenize str valid-char-set) "-"))
 
+(define (normalize-dependency dependency)
+  "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
+dependency-def form described by
+<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>."
+  (match dependency
+    ((':version name rest ...)
+     `(:version ,(normalize-string name) ,@rest))
+    ((':feature feature-specification dependency-specification)
+     `(:feature
+       ,feature-specification
+       ,(normalize-dependency dependency-specification)))
+    ((? string? name) (normalize-string name))
+    (require-specification require-specification)))
+
 (define (inputs->asd-file-map inputs)
   "Produce a hash table of the form (system . asd-file), where system is the
 name of an ASD system, and asd-file is the full path to its definition."
@@ -105,9 +119,9 @@ name of an ASD system, and asd-file is the full path to its definition."
 
 (define (lisp-eval-program program)
   "Evaluate PROGRAM with a given LISP implementation."
-  (unless (zero? (apply system*
-                        (lisp-invocation program)))
-    (error "lisp-eval-program failed!" (%lisp) program)))
+  (define invocation (lisp-invocation program))
+  (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation)
+  (apply invoke invocation))
 
 (define (spread-statements program argument-name)
   "Return a list with the statements from PROGRAM spread between
@@ -138,8 +152,7 @@ with PROGRAM."
 first."
   (lisp-eval-program
    `((require :asdf)
-     (let ((*package* (find-package :asdf)))
-       (load ,asd-file))
+     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
      (asdf:operate 'asdf:compile-bundle-op ,system))))
 
 (define (system-dependencies system asd-file)
@@ -148,8 +161,7 @@ asdf:system-depends-on.  First load the system's ASD-FILE."
   (define deps-file ".deps.sexp")
   (define program
     `((require :asdf)
-      (let ((*package* (find-package :asdf)))
-        (load ,asd-file))
+      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
       (with-open-file
        (stream ,deps-file :direction :output)
        (format stream
@@ -189,19 +201,18 @@ asdf:system-depends-on.  First load the system's ASD-FILE."
 Also load TEST-ASD-FILE if necessary."
   (lisp-eval-program
    `((require :asdf)
-     (let ((*package* (find-package :asdf)))
-       (load ,asd-file)
-       ,@(if test-asd-file
-             `((load ,test-asd-file))
-             ;; Try some likely files.
-             (map (lambda (file)
-                    `(when (uiop:file-exists-p ,file)
-                       (load ,file)))
-                  (list
-                   (string-append system "-tests.asd")
-                   (string-append system "-test.asd")
-                   "tests.asd"
-                   "test.asd"))))
+     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
+     ,@(if test-asd-file
+           `((asdf:load-asd (truename ,test-asd-file)))
+           ;; Try some likely files.
+           (map (lambda (file)
+                  `(when (uiop:file-exists-p ,file)
+                     (asdf:load-asd (truename ,file))))
+                (list
+                 (string-append system "-tests.asd")
+                 (string-append system "-test.asd")
+                 "tests.asd"
+                 "test.asd")))
      (asdf:test-system ,system))))
 
 (define (string->lisp-keyword . strings)
@@ -273,16 +284,24 @@ system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
            (system-dependencies system system-asd-file)))
       (if (eq? 'NIL deps)
           '()
-          (map normalize-string deps))))
+          (map normalize-dependency deps))))
 
   (define lisp-input-map
     (inputs->asd-file-map inputs))
 
+  (define dependency-name
+    (match-lambda
+      ((':version name _ ...) name)
+      ((':feature _ dependency-specification)
+       (dependency-name dependency-specification))
+      ((? string? name) name)
+      (_ #f)))
+
   (define registry
     (filter-map hash-get-handle
                 (make-list (length dependencies)
                            lisp-input-map)
-                dependencies))
+                (map dependency-name dependencies)))
 
   (call-with-output-file asd-file
     (lambda (port)
diff --git a/guix/channels.scm b/guix/channels.scm
index cf833db8b9..2e7bffae9f 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -207,10 +207,16 @@ INSTANCES."
             (guix-channel? (channel-instance-channel instance)))
           instances))
 
-  ;; Guile-Gcrypt is a dependency of CORE-INSTANCE.
-  (define guile-gcrypt
-    (module-ref (resolve-interface '(gnu packages gnupg))
-                'guile-gcrypt))
+  (define dependencies
+    ;; Dependencies of CORE-INSTANCE.
+    ;; FIXME: It would be best not to hard-wire this information here and
+    ;; instead query it to CORE-INSTANCE.
+    (list (module-ref (resolve-interface '(gnu packages gnupg))
+                      'guile-gcrypt)
+          (module-ref (resolve-interface '(gnu packages guile))
+                      'guile-git)
+          (module-ref (resolve-interface '(gnu packages guile))
+                      'guile-bytestructures)))
 
   (mlet %store-monad ((core (build-channel-instance core-instance)))
     (mapm %store-monad
@@ -218,7 +224,7 @@ INSTANCES."
             (if (eq? instance core-instance)
                 (return core)
                 (build-channel-instance instance
-                                        (list core guile-gcrypt))))
+                                        (cons core dependencies))))
           instances)))
 
 (define (whole-package-for-legacy name modules)
diff --git a/guix/git-download.scm b/guix/git-download.scm
index e6e0ec2ac5..24cf11be5e 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -179,24 +179,28 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout."
 
 (define (git-predicate directory)
   "Return a predicate that returns true if a file is part of the Git checkout
-living at DIRECTORY.  Upon Git failure, return #f instead of a predicate.
+living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
+upon Git errors, return #f instead of a predicate.
 
 The returned predicate takes two arguments FILE and STAT where FILE is an
 absolute file name and STAT is the result of 'lstat'."
-  (let* ((files  (git-file-list directory))
-         (inodes (fold (lambda (file result)
-                         (let ((stat
-                                (lstat (string-append directory "/"
-                                                      file))))
-                           (vhash-consv (stat:ino stat) (stat:dev stat)
-                                        result)))
-                       vlist-null
-                       files)))
-    (lambda (file stat)
-      ;; Comparing file names is always tricky business so we rely on inode
-      ;; numbers instead.
-      (match (vhash-assv (stat:ino stat) inodes)
-        ((_ . dev) (= dev (stat:dev stat)))
-        (#f        #f)))))
+  (catch 'git-error
+    (lambda ()
+      (let* ((files  (git-file-list directory))
+             (inodes (fold (lambda (file result)
+                             (let ((stat
+                                    (lstat (string-append directory "/"
+                                                          file))))
+                               (vhash-consv (stat:ino stat) (stat:dev stat)
+                                            result)))
+                           vlist-null
+                           files)))
+        (lambda (file stat)
+          ;; Comparing file names is always tricky business so we rely on inode
+          ;; numbers instead.
+          (match (vhash-assv (stat:ino stat) inodes)
+            ((_ . dev) (= dev (stat:dev stat)))
+            (#f        #f)))))
+    (const #f)))
 
 ;;; git-download.scm ends here
diff --git a/guix/git.scm b/guix/git.scm
index 3d0eb93d9b..d007916662 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -36,7 +36,8 @@
             latest-repository-commit))
 
 (define %repository-cache-directory
-  (make-parameter "/var/cache/guix/checkouts"))
+  (make-parameter (string-append (cache-directory #:ensure? #f)
+                                 "/checkouts")))
 
 (define-syntax-rule (with-libgit2 thunk ...)
   (begin
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
index ac0ed5ab2d..b30ce461b4 100644
--- a/guix/gnupg.scm
+++ b/guix/gnupg.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -24,9 +24,12 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 i18n)
   #:use-module (srfi srfi-1)
-  #:use-module (guix ui)
+  #:use-module (guix i18n)
+  #:use-module ((guix utils) #:select (config-directory))
+  #:use-module ((guix build utils) #:select (mkdir-p))
   #:export (%gpg-command
             %openpgp-key-server
+            current-keyring
             gnupg-verify
             gnupg-verify*
             gnupg-status-good-signature?
@@ -42,13 +45,25 @@
   ;; The GnuPG 2.x command-line program name.
   (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
 
+(define %gpgv-command
+  ;; The 'gpgv' program.
+  (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
+
+(define current-keyring
+  ;; The default keyring of "trusted keys".
+  (make-parameter (string-append (config-directory #:ensure? #f)
+                                 "/gpg/trustedkeys.kbx")))
+
 (define %openpgp-key-server
   ;; The default key server.  Note that keys.gnupg.net appears to be
   ;; unreliable.
   (make-parameter "pgp.mit.edu"))
 
-(define (gnupg-verify sig file)
-  "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
+(define* (gnupg-verify sig file
+                       #:optional (keyring (current-keyring)))
+  "Verify signature SIG for FILE against the keys in KEYRING.  All the keys in
+KEYRING as assumed to be \"trusted\", whether or not they expired or were
+revoked.  Return a status s-exp if GnuPG failed."
 
   (define (status-line->sexp line)
     ;; See file `doc/DETAILS' in GnuPG.
@@ -117,8 +132,8 @@
           (loop (read-line input)
                 (cons (status-line->sexp line) result)))))
 
-  (let* ((pipe   (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1"
-                             "--verify" sig file))
+  (let* ((pipe   (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
+                             "--keyring" keyring sig file))
          (status (parse-status pipe)))
     ;; Ignore PIPE's exit status since STATUS above should contain all the
     ;; info we need.
@@ -145,12 +160,21 @@ missing key."
            (_ #f)))
        status))
 
-(define (gnupg-receive-keys key-id server)
-  (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id))
+(define* (gnupg-receive-keys key-id server
+                             #:optional (keyring (current-keyring)))
+  (unless (file-exists? keyring)
+    (mkdir-p (dirname keyring))
+    (call-with-output-file keyring (const #t)))   ;create an empty keybox
+
+  (system* (%gpg-command) "--keyserver" server
+           "--no-default-keyring" "--keyring" keyring
+           "--recv-keys" key-id))
 
 (define* (gnupg-verify* sig file
-                        #:key (key-download 'interactive)
-                              (server (%openpgp-key-server)))
+                        #:key
+                        (key-download 'interactive)
+                        (server (%openpgp-key-server))
+                        (keyring (current-keyring)))
   "Like `gnupg-verify', but try downloading the public key if it's missing.
 Return #t if the signature was good, #f otherwise.  KEY-DOWNLOAD specifies a
 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
@@ -161,15 +185,17 @@ and 'interactive' (default)."
           (define (download-and-try-again)
             ;; Download the missing key and try again.
             (begin
-              (gnupg-receive-keys missing server)
-              (gnupg-status-good-signature? (gnupg-verify sig file))))
+              (gnupg-receive-keys missing server keyring)
+              (gnupg-status-good-signature? (gnupg-verify sig file
+                                                          keyring))))
 
           (define (receive?)
             (let ((answer
-                   (begin (format #t (G_ "~a~a~%")
-                                  "Would you like to download this key "
-                                  "and add it to your keyring?")
-                          (read-line))))
+                   (begin
+                     (format #t (G_ "Would you like to add this key \
+to keyring '~a'?~%")
+                             keyring)
+                     (read-line))))
               (string-match (locale-yes-regexp) answer)))
 
           (and missing
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fdff07d0e3..c1a20fe26c 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -134,8 +134,10 @@ in the format specified by FMT."
                     ;; Show most recently installed packages last.
                     (reverse
                      (manifest-entries
-                      (profile-manifest (generation-file-name profile
-                                                              number)))))))))
+                      (profile-manifest
+                       (if (zero? number)
+                           profile
+                           (generation-file-name profile number))))))))))
   (display-package-search-path fmt))
 
 
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 346ca4ea88..145a574dba 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -439,6 +439,10 @@ package modules, while attempting to retain user package modules."
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
+        (option '(#\s "system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'system arg
+                              (alist-delete 'system result eq?))))
         (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
@@ -462,6 +466,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
       --list-types       list the available graph types"))
   (display (G_ "
   -e, --expression=EXPR  consider the package EXPR evaluates to"))
+  (display (G_ "
+  -s, --system=SYSTEM    consider the graph for SYSTEM--e.g., \"i686-linux\""))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -472,7 +478,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
 
 (define %default-options
   `((node-type . ,%package-node-type)
-    (backend   . ,%graphviz-backend)))
+    (backend   . ,%graphviz-backend)
+    (system    . ,(%current-system))))
 
 
 ;;;
@@ -508,7 +515,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
               (export-graph (concatenate nodes)
                             (current-output-port)
                             #:node-type type
-                            #:backend backend)))))))
+                            #:backend backend))
+            #:system (assq-ref opts 'system))))))
   #t)
 
 ;;; graph.scm ends here
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 976e054a84..10e1a99e54 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -176,17 +176,18 @@ Download and deploy the latest version of Guix.\n"))
          (certs (string-append (derivation->output-path drv)
                                "/etc/ssl/certs")))
     (build-derivations store (list drv))
-
-    ;; In the past Guile-Git would not provide this procedure.
-    (if (module-defined? (resolve-interface '(git))
-                         'set-tls-certificate-locations!)
-        (set-tls-certificate-locations! certs)
-        (begin
-          ;; In this case we end up using whichever certificates OpenSSL
-          ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
-          (warning (G_ "cannot enforce use of the Let's Encrypt \
-certificates~%"))
-          (warning (G_ "please upgrade Guile-Git~%"))))))
+    (set-tls-certificate-locations! certs)))
+
+(define (honor-x509-certificates store)
+  "Use the right X.509 certificates for Git checkouts over HTTPS."
+  (let ((file      (getenv "SSL_CERT_FILE"))
+        (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
+    (if (or (and file (file-exists? file))
+            (and=> (stat directory #f)
+                   (lambda (st)
+                     (> (stat:nlink st) 2))))
+        (set-tls-certificate-locations! directory file)
+        (honor-lets-encrypt-certificates! store))))
 
 (define (report-git-error error)
   "Report the given Guile-Git error."
@@ -233,7 +234,9 @@ way and displaying details about the channel's source code."
             ;; Show most recently installed packages last.
             (reverse
              (manifest-entries
-              (profile-manifest (generation-file-name profile number))))))
+              (profile-manifest (if (zero? number)
+                                    profile
+                                    (generation-file-name profile number)))))))
 
 (define (indented-string str indent)
   "Return STR with each newline preceded by IDENT spaces."
@@ -431,13 +434,7 @@ Use '~/.config/guix/channels.scm' instead."))
                 (parameterize ((%graft? (assoc-ref opts 'graft?))
                                (%repository-cache-directory cache))
                   (set-build-options-from-command-line store opts)
-
-                  ;; When certificates are already installed, use them.
-                  ;; Otherwise, use the Let's Encrypt certificates, which we
-                  ;; know Savannah uses.
-                  (let ((certs (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
-                    (unless (file-exists? certs)
-                      (honor-lets-encrypt-certificates! store)))
+                  (honor-x509-certificates store)
 
                   (let ((instances (latest-channel-instances store channels)))
                     (format (current-error-port)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index bcc23bd39c..58fc64db1f 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.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, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@@ -89,6 +89,9 @@
                 (lambda (opt name arg result)
                   (alist-cons 'list-dependent? #t result)))
 
+        (option '("keyring") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'keyring arg result)))
         (option '("key-server") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'key-server arg result)))
@@ -139,6 +142,8 @@ specified with `--select'.\n"))
                          be rebuilt as a result of upgrading PACKAGE..."))
   (newline)
   (display (G_ "
+      --keyring=FILE     use FILE as the keyring of upstream OpenPGP keys"))
+  (display (G_ "
       --key-server=HOST  use HOST as the OpenPGP key server"))
   (display (G_ "
       --gpg=COMMAND      use COMMAND as the GnuPG 2.x command"))
@@ -437,7 +442,11 @@ update would trigger a complete rebuild."
                                 (%openpgp-key-server)))
                            (%gpg-command
                             (or (assoc-ref opts 'gpg-command)
-                                (%gpg-command))))
+                                (%gpg-command)))
+                           (current-keyring
+                            (or (assoc-ref opts 'keyring)
+                                (string-append (config-directory)
+                                               "/upstream/trustedkeys.kbx"))))
               (for-each
                (cut update-package store <> updaters
                     #:key-download key-download
diff --git a/guix/store.scm b/guix/store.scm
index af7f6980cf..f88cdefe87 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -770,6 +770,7 @@ bytevector) as its internal buffer, and a thunk to flush this output port."
 
   (define (flush)
     (put-bytevector port buffer 0 total)
+    (force-output port)
     (set! total 0))
 
   (define (write bv offset count)
@@ -927,6 +928,7 @@ path."
              (write-int (if recursive? 1 0) port)
              (write-string hash-algo port)
              (write-file file-name port #:select? select?)
+             (write-buffered-output server)
              (let loop ((done? (process-stderr server)))
                (or done? (loop (process-stderr server))))
              (read-store-path port)))))
@@ -1042,6 +1044,7 @@ an arbitrary directory layout in the store without creating a derivation."
                            #:file-port file-port
                            #:symlink-target symlink-target
                            #:directory-entries directory-entries)
+          (write-buffered-output server)
           (let loop ((done? (process-stderr server)))
             (or done? (loop (process-stderr server))))
           (let ((result (read-store-path port)))