Merge remote-tracking branch 'origin/master' into core-updates

4 files changed, 87 insertions, 37 deletions

diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm
index b2cb02e639..432d51f6a7 100644
--- a/guix/build/dub-build-system.scm
+++ b/guix/build/dub-build-system.scm
@@ -91,11 +91,19 @@
           (grep* "sourceLibrary" "dub.sdl") ; note: format is different!
           (grep* "sourceLibrary" "dub.json"))
     #t
-    (zero? (apply system* `("dub" "build" ,@dub-build-flags)))))
+    (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags)))))
+      (substitute* ".dub/dub.json"
+        (("\"lastUpgrade\": \"[^\"]*\"")
+         "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))
+      status)))
 
 (define* (check #:key tests? #:allow-other-keys)
   (if tests?
-    (zero? (system* "dub" "test"))
+    (let ((status (zero? (system* "dub" "test"))))
+      (substitute* ".dub/dub.json"
+        (("\"lastUpgrade\": \"[^\"]*\"")
+         "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))
+      status)
     #t))
 
 (define* (install #:key inputs outputs #:allow-other-keys)
diff --git a/guix/man-db.scm b/guix/man-db.scm
index 5d62e0c82d..732aef1083 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -187,7 +187,8 @@
 
 (define (man-files directory)
   "Return the list of man pages found under DIRECTORY, recursively."
-  (find-files directory "\\.[0-9][a-z]?(\\.gz)?$"))
+  ;; Filter the list to ensure that broken symlinks are excluded.
+  (filter file-exists? (find-files directory "\\.[0-9][a-z]?(\\.gz)?$")))
 
 (define (mandb-entries directory)
   "Return mandb entries for the man pages found under DIRECTORY, recursively."
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 0571b874f1..57f2d82c5c 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -25,9 +25,12 @@
   #:use-module (guix packages)
   #:use-module (guix grafts)
 
+  #:use-module (guix utils)
+
   ;; Use the procedure that destructures "NAME-VERSION" forms.
-  #:use-module ((guix utils) #:hide (package-name->name+version))
-  #:use-module ((guix build utils) #:select (package-name->name+version))
+  #:use-module ((guix build utils)
+                #:select ((package-name->name+version
+                           . hyphen-package-name->name+version)))
 
   #:use-module (guix monads)
   #:use-module (guix gexp)
@@ -127,33 +130,37 @@ found.  Return #f if no build log was found."
 (define register-root*
   (store-lift register-root))
 
-(define (package-with-source store p uri)
+(define (numeric-extension? file-name)
+  "Return true if FILE-NAME ends with digits."
+  (string-every char-set:hex-digit (file-extension file-name)))
+
+(define (tarball-base-name file-name)
+  "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
+extensions."
+  ;; TODO: Factorize.
+  (cond ((not (file-extension file-name))
+         file-name)
+        ((numeric-extension? file-name)
+         file-name)
+        ((string=? (file-extension file-name) "tar")
+         (file-sans-extension file-name))
+        ((file-extension file-name)
+         =>
+         (match-lambda
+           ("scm" file-name)
+           (else  (tarball-base-name (file-sans-extension file-name)))))
+        (else
+         file-name)))
+
+(define* (package-with-source store p uri #:optional version)
   "Return a package based on P but with its source taken from URI.  Extract
 the new package's version number from URI."
-  (define (numeric-extension? file-name)
-    ;; Return true if FILE-NAME ends with digits.
-    (string-every char-set:hex-digit (file-extension file-name)))
-
-  (define (tarball-base-name file-name)
-    ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
-    ;; extensions.
-    ;; TODO: Factorize.
-    (cond ((not (file-extension file-name))
-           file-name)
-          ((numeric-extension? file-name)
-           file-name)
-          ((string=? (file-extension file-name) "tar")
-           (file-sans-extension file-name))
-          ((file-extension file-name)
-           (tarball-base-name (file-sans-extension file-name)))
-          (else
-           file-name)))
-
   (let ((base (tarball-base-name (basename uri))))
-    (let-values (((name version)
-                  (package-name->name+version base)))
+    (let-values (((_ version*)
+                  (hyphen-package-name->name+version base)))
       (package (inherit p)
-               (version (or version (package-version p)))
+               (version (or version version*
+                            (package-version p)))
 
                ;; Use #:recursive? #t to allow for directories.
                (source (download-to-store store uri
@@ -173,8 +180,23 @@ the new package's version number from URI."
 matching URIs given in SOURCES."
   (define new-sources
     (map (lambda (uri)
-           (cons (package-name->name+version (basename uri))
-                 uri))
+           (match (string-index uri #\=)
+             (#f
+              ;; Determine the package name and version from URI.
+              (call-with-values
+                  (lambda ()
+                    (hyphen-package-name->name+version
+                     (tarball-base-name (basename uri))))
+                (lambda (name version)
+                  (list name version uri))))
+             (index
+              ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
+              (call-with-values
+                  (lambda ()
+                    (package-name->name+version (string-take uri index)))
+                (lambda (name version)
+                  (list name version
+                        (string-drop uri (+ 1 index))))))))
          sources))
 
   (lambda (store obj)
@@ -182,10 +204,11 @@ matching URIs given in SOURCES."
                (result   '()))
       (match obj
         ((? package? p)
-         (let ((source (assoc-ref sources (package-name p))))
-           (if source
-               (package-with-source store p source)
-               p)))
+         (match (assoc-ref sources (package-name p))
+           ((version source)
+            (package-with-source store p source version))
+           (#f
+            p)))
         (_
          obj)))))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 36aed3331f..ebcf3e4f3b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -44,6 +44,7 @@
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu system mapped-devices)
   #:use-module (gnu system linux-container)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
@@ -621,6 +622,22 @@ any, are available.  Raise an error if they're not."
       ;; Better be safe than sorry.
       (exit 1))))
 
+(define (check-mapped-devices mapped-devices)
+  "Check that each of MAPPED-DEVICES is valid according to the 'check'
+procedure of its type."
+  (for-each (lambda (md)
+              (let ((check (mapped-device-kind-check
+                            (mapped-device-type md))))
+                ;; We expect CHECK to raise an exception with a detailed
+                ;; '&message' if something goes wrong, but handle the case
+                ;; where it just returns #f.
+                (unless (check md)
+                  (leave (G_ "~a: invalid '~a' mapped device~%")
+                         (location->string
+                          (source-properties->location
+                           (mapped-device-location md)))))))
+            mapped-devices))
+
 
 ;;;
 ;;; Action.
@@ -710,9 +727,10 @@ output when building a system derivation, such as a disk image."
   ;; Check whether the declared file systems exist.  This is better than
   ;; instantiating a broken configuration.  Assume that we can only check if
   ;; running as root.
-  (when (and (memq action '(init reconfigure))
-             (zero? (getuid)))
-    (check-file-system-availability (operating-system-file-systems os)))
+  (when (memq action '(init reconfigure))
+    (when (zero? (getuid))
+      (check-file-system-availability (operating-system-file-systems os)))
+    (check-mapped-devices (operating-system-mapped-devices os)))
 
   (mlet* %store-monad
       ((sys       (system-derivation-for-action os action