Merge branch 'master' into staging

8 files changed, 183 insertions, 67 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index 96d62ce062..9658cf9393 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -477,6 +477,12 @@ be used as a profile hook."
 
     (gexp->derivation-in-inferior "guix-package-cache" build
                                   profile
+
+                                  ;; If the Guix in PROFILE is too old and
+                                  ;; lacks 'guix repl', don't build the cache
+                                  ;; instead of failing.
+                                  #:silent-failure? #t
+
                                   #:properties '((type . profile-hook)
                                                  (hook . package-cache))
                                   #:local-build? #t)))
diff --git a/guix/describe.scm b/guix/describe.scm
index 670db63ce7..c31199c9cd 100644
--- a/guix/describe.scm
+++ b/guix/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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,11 +19,16 @@
 (define-module (guix describe)
   #:use-module (guix memoization)
   #:use-module (guix profiles)
+  #:use-module (guix packages)
+  #:use-module ((guix utils) #:select (location-file))
+  #:use-module ((guix store) #:select (%store-prefix))
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (current-profile
             current-profile-entries
-            package-path-entries))
+            package-path-entries
+
+            package-provenance))
 
 ;;; Commentary:
 ;;;
@@ -73,3 +78,37 @@ process lives in, when applicable."
                                       "/share/guile/site/"
                                       (effective-version))))
                 (current-profile-entries))))
+
+(define (package-provenance package)
+  "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
+property of manifest entries, or #f if it could not be determined."
+  (define (entry-source entry)
+    (match (assq 'source
+                 (manifest-entry-properties entry))
+      (('source value) value)
+      (_ #f)))
+
+  (match (and=> (package-location package) location-file)
+    (#f #f)
+    (file
+     (let ((file (if (string-prefix? "/" file)
+                     file
+                     (search-path %load-path file))))
+       (and file
+            (string-prefix? (%store-prefix) file)
+
+            ;; Always store information about the 'guix' channel and
+            ;; optionally about the specific channel FILE comes from.
+            (or (let ((main  (and=> (find (lambda (entry)
+                                            (string=? "guix"
+                                                      (manifest-entry-name entry)))
+                                          (current-profile-entries))
+                                    entry-source))
+                      (extra (any (lambda (entry)
+                                    (let ((item (manifest-entry-item entry)))
+                                      (and (string-prefix? item file)
+                                           (entry-source entry))))
+                                  (current-profile-entries))))
+                  (and main
+                       `(,main
+                         ,@(if extra (list extra) '()))))))))))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 027418a98d..63c95141d7 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -513,10 +513,15 @@ PACKAGE must be live."
   (inferior-package->derivation package system #:target target))
 
 (define* (gexp->derivation-in-inferior name exp guix
+                                       #:key silent-failure?
+                                       #:allow-other-keys
                                        #:rest rest)
   "Return a derivation that evaluates EXP with GUIX, an instance of Guix as
 returned for example by 'channel-instances->derivation'.  Other arguments are
-passed as-is to 'gexp->derivation'."
+passed as-is to 'gexp->derivation'.
+
+When SILENT-FAILURE? is true, create an empty output directory instead of
+failing when GUIX is too old and lacks the 'guix repl' command."
   (define script
     ;; EXP wrapped with a proper (set! %load-path …) prologue.
     (scheme-file "inferior-script.scm" exp))
@@ -539,9 +544,23 @@ passed as-is to 'gexp->derivation'."
           (write `(primitive-load #$script) pipe)
 
           (unless (zero? (close-pipe pipe))
-            (error "inferior failed" #+guix)))))
-
-  (apply gexp->derivation name trampoline rest))
+            (if #$silent-failure?
+                (mkdir #$output)
+                (error "inferior failed" #+guix))))))
+
+  (define (drop-extra-keyword lst)
+    (let loop ((lst lst)
+               (result '()))
+      (match lst
+        (()
+         (reverse result))
+        ((#:silent-failure? _ . rest)
+         (loop rest result))
+        ((kw value . tail)
+         (loop tail (cons* value kw result))))))
+
+  (apply gexp->derivation name trampoline
+         (drop-extra-keyword rest)))
 
 
 ;;;
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 4ef3ed188c..d22c3fa36e 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -50,6 +50,7 @@
             cpl1.0
             edl1.0
             epl1.0
+            epl2.0
             expat
             freetype
             freebsd-doc
@@ -274,6 +275,11 @@ at URI, which may be a file:// URI pointing the package's tree."
            "http://directory.fsf.org/wiki/License:EPLv1.0"
            "https://www.gnu.org/licenses/license-list#EPL"))
 
+(define epl2.0
+  (license "EPL 2.0"
+           "https://www.eclipse.org/legal/epl-2.0/"
+           "https://www.gnu.org/licenses/license-list#EPL2"))
+
 (define expat
   (license "Expat"
            "http://directory.fsf.org/wiki/License:Expat"
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 86e15d9bab..e2ecddfbfc 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -32,6 +32,7 @@
   #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix describe)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
   #:use-module (guix build-system gnu)
@@ -678,6 +679,9 @@ please email '~a'~%")
                      (x
                       (leave (G_ "~a: invalid symlink specification~%")
                              arg)))))
+         (option '("save-provenance") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'save-provenance? #t result)))
          (option '("localstatedir") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'localstatedir? #t result)))
@@ -726,6 +730,8 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
   (display (G_ "
+      --save-provenance  save provenance information"))
+  (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
   (display (G_ "
       --profile-name=NAME
@@ -772,13 +778,32 @@ Create a bundle of PACKAGE.\n"))
                                   (list (transform store package) "out")))
                                (filter-map maybe-package-argument opts)))
            (manifest-file (assoc-ref opts 'manifest)))
+      (define properties
+        (if (assoc-ref opts 'save-provenance?)
+            (lambda (package)
+              (match (package-provenance package)
+                (#f
+                 (warning (G_ "could not determine provenance of package ~a~%")
+                          (package-full-name package))
+                 '())
+                (sexp
+                 `((provenance . ,sexp)))))
+            (const '())))
+
       (cond
        ((and manifest-file (not (null? packages)))
         (leave (G_ "both a manifest and a package list were given~%")))
        (manifest-file
         (let ((user-module (make-user-module '((guix profiles) (gnu)))))
           (load* manifest-file user-module)))
-       (else (packages->manifest packages)))))
+       (else
+        (manifest
+         (map (match-lambda
+                ((package output)
+                 (package->manifest-entry package output
+                                          #:properties
+                                          (properties package))))
+              packages))))))
 
   (with-error-handling
     (with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 0e70315708..efff511299 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -36,7 +36,7 @@
   #:use-module (guix config)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
-  #:autoload   (guix describe) (current-profile-entries)
+  #:autoload   (guix describe) (package-provenance)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
   #:use-module (ice-9 format)
@@ -552,40 +552,6 @@ upgrading, #f otherwise."
       (output "out")                              ;XXX: wild guess
       (item item))))
 
-(define (package-provenance package)
-  "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
-property of manifest entries, or #f if it could not be determined."
-  (define (entry-source entry)
-    (match (assq 'source
-                 (manifest-entry-properties entry))
-      (('source value) value)
-      (_ #f)))
-
-  (match (and=> (package-location package) location-file)
-    (#f #f)
-    (file
-     (let ((file (if (string-prefix? "/" file)
-                     file
-                     (search-path %load-path file))))
-       (and file
-            (string-prefix? (%store-prefix) file)
-
-            ;; Always store information about the 'guix' channel and
-            ;; optionally about the specific channel FILE comes from.
-            (or (let ((main  (and=> (find (lambda (entry)
-                                            (string=? "guix"
-                                                      (manifest-entry-name entry)))
-                                          (current-profile-entries))
-                                    entry-source))
-                      (extra (any (lambda (entry)
-                                    (let ((item (manifest-entry-item entry)))
-                                      (and (string-prefix? item file)
-                                           (entry-source entry))))
-                                  (current-profile-entries))))
-                  (and main
-                       `(,main
-                         ,@(if extra (list extra) '()))))))))))
-
 (define (package->manifest-entry* package output)
   "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
 the resulting manifest entry."
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 4791f49865..88d05dc42e 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -96,6 +96,31 @@ create it and initialize it as a new database."
                   (lambda ()
                     (sqlite-close db)))))
 
+;; XXX: missing in guile-sqlite3@0.1.0
+(define SQLITE_BUSY 5)
+
+(define (call-with-transaction db proc)
+  "Start a transaction with DB (make as many attempts as necessary) and run
+PROC.  If PROC exits abnormally, abort the transaction, otherwise commit the
+transaction after it finishes."
+  (catch 'sqlite-error
+    (lambda ()
+      ;; We use begin immediate here so that if we need to retry, we
+      ;; figure that out immediately rather than because some SQLITE_BUSY
+      ;; exception gets thrown partway through PROC - in which case the
+      ;; part already executed (which may contain side-effects!) would be
+      ;; executed again for every retry.
+      (sqlite-exec db "begin immediate;")
+      (let ((result (proc)))
+        (sqlite-exec db "commit;")
+        result))
+    (lambda (key who error description)
+      (if (= error SQLITE_BUSY)
+          (call-with-transaction db proc)
+          (begin
+            (sqlite-exec db "rollback;")
+            (throw 'sqlite-error who error description))))))
+
 (define %default-database-file
   ;; Default location of the store database.
   (string-append %store-database-directory "/db.sqlite"))
@@ -172,9 +197,9 @@ ids of items referred to."
                 (sqlite-bind-arguments stmt #:referrer referrer
                                        #:reference reference)
                 (sqlite-fold cons '() stmt)       ;execute it
-                (sqlite-finalize stmt)
                 (last-insert-row-id db))
-              references)))
+              references)
+    (sqlite-finalize stmt)))
 
 (define* (sqlite-register db #:key path (references '())
                           deriver hash nar-size time)
@@ -305,6 +330,7 @@ Write a progress report to LOG-PORT."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
+
     ;; When TO-REGISTER is already registered, skip it.  This makes a
     ;; significant differences when 'register-closures' is called
     ;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
@@ -325,12 +351,14 @@ Write a progress report to LOG-PORT."
   (mkdir-p db-dir)
   (parameterize ((sql-schema schema))
     (with-database (string-append db-dir "/db.sqlite") db
-      (let* ((prefix   (format #f "registering ~a items" (length items)))
-             (progress (progress-reporter/bar (length items)
-                                              prefix log-port)))
-        (call-with-progress-reporter progress
-          (lambda (report)
-            (for-each (lambda (item)
-                        (register db item)
-                        (report))
-                      items)))))))
+      (call-with-transaction db
+          (lambda ()
+            (let* ((prefix   (format #f "registering ~a items" (length items)))
+                   (progress (progress-reporter/bar (length items)
+                                                    prefix log-port)))
+              (call-with-progress-reporter progress
+                (lambda (report)
+                  (for-each (lambda (item)
+                              (register db item)
+                              (report))
+                            items)))))))))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 9163478099..55683dd9b7 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
@@ -23,7 +23,7 @@
   #:use-module (guix utils)
   #:use-module (guix discovery)
   #:use-module ((guix download)
-                #:select (download-to-store))
+                #:select (download-to-store url-fetch))
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix ui)
@@ -37,6 +37,8 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (upstream-source
@@ -340,17 +342,13 @@ values: the item from LST1 and the item from LST2 that match PRED."
       (()
        (values #f #f)))))
 
-(define* (package-update store package updaters
-                         #:key (key-download 'interactive))
-  "Return the new version, the file name of the new version tarball, and input
-changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
-KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
-values: 'always', 'never', and 'interactive' (default)."
-  (match (package-latest-release* package updaters)
+(define* (package-update/url-fetch store package source
+                                   #:key key-download)
+  "Return the version, tarball, and input changes needed to update PACKAGE to
+SOURCE, an <upstream-source>."
+  (match source
     (($ <upstream-source> _ version urls signature-urls changes)
-     (let*-values (((name)
-                    (package-name package))
-                   ((archive-type)
+     (let*-values (((archive-type)
                     (match (and=> (package-source package) origin-uri)
                       ((? string? uri)
                        (let ((type (file-extension (basename uri))))
@@ -373,7 +371,36 @@ values: 'always', 'never', and 'interactive' (default)."
                            (or signature-urls (circular-list #f)))))
        (let ((tarball (download-tarball store url signature-url
                                         #:key-download key-download)))
-         (values version tarball changes))))
+         (values version tarball changes))))))
+
+(define %method-updates
+  ;; Mapping of origin methods to source update procedures.
+  `((,url-fetch . ,package-update/url-fetch)))
+
+(define* (package-update store package updaters
+                         #:key (key-download 'interactive))
+  "Return the new version, the file name of the new version tarball, and input
+changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default)."
+  (match (package-latest-release* package updaters)
+    ((? upstream-source? source)
+     (let ((method (match (package-source package)
+                     ((? origin? origin)
+                      (origin-method origin))
+                     (_
+                      #f))))
+       (match (assq method %method-updates)
+         (#f
+          (raise (condition (&message
+                             (message (format #f (G_ "cannot download for \
+this method: ~s")
+                                              method)))
+                            (&error-location
+                             (location (package-location package))))))
+         ((_ . update)
+          (update store package source
+                  #:key-download key-download)))))
     (#f
      (values #f #f #f))))