Merge branch 'master' into core-updates

13 files changed, 222 insertions, 91 deletions

diff --git a/guix/base32.scm b/guix/base32.scm
index 7b2e2a6712..49f191ba26 100644
--- a/guix/base32.scm
+++ b/guix/base32.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +28,8 @@
             bytevector->nix-base32-string
             base32-string->bytevector
             nix-base32-string->bytevector
+            %nix-base32-charset
+            %rfc4648-base32-charset
             &invalid-base32-character
             invalid-base32-character?
             invalid-base32-character-value
@@ -152,11 +154,17 @@ the previous application or INIT."
     #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
     #\p #\q #\r #\s #\v #\w #\x #\y #\z))
 
+(define %nix-base32-charset
+  (list->char-set (vector->list %nix-base32-chars)))
+
 (define %rfc4648-base32-chars
   #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
     #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
     #\2 #\3 #\4 #\5 #\6 #\7))
 
+(define %rfc4648-base32-charset
+  (list->char-set (vector->list %rfc4648-base32-chars)))
+
 (define bytevector->base32-string
   (make-bytevector->base32-string bytevector-quintet-fold
                                   %rfc4648-base32-chars))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 41208e32a8..55b0df3911 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -92,6 +92,7 @@
             all-network-interface-names
             network-interface-names
             network-interface-netmask
+            network-interface-running?
             loopback-network-interface?
             network-interface-address
             set-network-interface-netmask
@@ -1160,6 +1161,7 @@ bytes."
 (define-as-needed IFF_UP #x1)                     ;Interface is up
 (define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
 (define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
+(define-as-needed IFF_RUNNING #x40)               ;interface RFC2863 OPER_UP
 
 (define IF_NAMESIZE 16)                           ;maximum interface name size
 
@@ -1334,6 +1336,13 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_LOOPBACK)))))
 
+(define (network-interface-running? name)
+  "Return true if NAME designates a running network interface."
+  (let* ((sock  (socket SOCK_STREAM AF_INET 0))
+         (flags (network-interface-flags sock name)))
+    (close-port sock)
+    (not (zero? (logand flags IFF_RUNNING)))))
+
 (define-as-needed (set-network-interface-flags socket name flags)
   "Set the flag of network interface NAME to FLAGS."
   (let ((req (make-bytevector ifreq-struct-size)))
diff --git a/guix/download.scm b/guix/download.scm
index c1da515477..d7590d4110 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -277,7 +277,56 @@
        "http://kde.mirrors.tds.net/pub/kde/"
        ;; Oceania
        "http://ftp.kddlabs.co.jp/pub/X11/kde/"
-       "http://kde.mirror.uber.com.au/"))))
+       "http://kde.mirror.uber.com.au/")
+      (openbsd
+       "https://ftp.openbsd.org/pub/OpenBSD/"
+       ;; Anycast CDN redirecting to your friendly local mirror.
+       "https://mirrors.evowise.com/pub/OpenBSD/"
+       ;; Other HTTPS mirrors from https://www.openbsd.org/ftp.html
+       "https://mirror.aarnet.edu.au/pub/OpenBSD/"
+       "https://ftp2.eu.openbsd.org/pub/OpenBSD/"
+       "https://openbsd.c3sl.ufpr.br/pub/OpenBSD/"
+       "https://openbsd.ipacct.com/pub/OpenBSD/"
+       "https://ftp.OpenBSD.org/pub/OpenBSD/"
+       "https://openbsd.cs.toronto.edu/pub/OpenBSD/"
+       "https://openbsd.delfic.org/pub/OpenBSD/"
+       "https://openbsd.mirror.netelligent.ca/pub/OpenBSD/"
+       "https://mirrors.ucr.ac.cr/pub/OpenBSD/"
+       "https://mirrors.dotsrc.org/pub/OpenBSD/"
+       "https://mirror.one.com/pub/OpenBSD/"
+       "https://ftp.fr.openbsd.org/pub/OpenBSD/"
+       "https://ftp2.fr.openbsd.org/pub/OpenBSD/"
+       "https://mirrors.ircam.fr/pub/OpenBSD/"
+       "https://ftp.spline.de/pub/OpenBSD/"
+       "https://mirror.hs-esslingen.de/pub/OpenBSD/"
+       "https://ftp.halifax.rwth-aachen.de/openbsd/"
+       "https://ftp.hostserver.de/pub/OpenBSD/"
+       "https://ftp.fau.de/pub/OpenBSD/"
+       "https://ftp.cc.uoc.gr/pub/OpenBSD/"
+       "https://openbsd.hk/pub/OpenBSD/"
+       "https://ftp.heanet.ie/pub/OpenBSD/"
+       "https://openbsd.mirror.garr.it/pub/OpenBSD/"
+       "https://mirror.litnet.lt/pub/OpenBSD/"
+       "https://mirror.meerval.net/pub/OpenBSD/"
+       "https://ftp.nluug.nl/pub/OpenBSD/"
+       "https://ftp.bit.nl/pub/OpenBSD/"
+       "https://mirrors.dalenys.com/pub/OpenBSD/"
+       "https://ftp.icm.edu.pl/pub/OpenBSD/"
+       "https://ftp.rnl.tecnico.ulisboa.pt/pub/OpenBSD/"
+       "https://mirrors.pidginhost.com/pub/OpenBSD/"
+       "https://mirror.yandex.ru/pub/OpenBSD/"
+       "https://ftp.eu.openbsd.org/pub/OpenBSD/"
+       "https://ftp.yzu.edu.tw/pub/OpenBSD/"
+       "https://www.mirrorservice.org/pub/OpenBSD/"
+       "https://anorien.csc.warwick.ac.uk/pub/OpenBSD/"
+       "https://mirror.bytemark.co.uk/pub/OpenBSD/"
+       "https://mirrors.sonic.net/pub/OpenBSD/"
+       "https://ftp3.usa.openbsd.org/pub/OpenBSD/"
+       "https://mirrors.syringanetworks.net/pub/OpenBSD/"
+       "https://openbsd.mirror.constant.com/pub/OpenBSD/"
+       "https://ftp4.usa.openbsd.org/pub/OpenBSD/"
+       "https://ftp5.usa.openbsd.org/pub/OpenBSD/"
+       "https://mirror.esc7.net/pub/OpenBSD/"))))
 
 (define %mirror-file
   ;; Copy of the list of mirrors to a file.  This allows us to keep a single
diff --git a/guix/gexp.scm b/guix/gexp.scm
index d9c4cb461e..2622c5cb62 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -269,8 +269,9 @@ vicinity of DIRECTORY."
           (string-append directory "/" file))
          (else file))))
 
-(define-syntax-rule (local-file file rest ...)
-  "Return an object representing local file FILE to add to the store; this
+(define-syntax local-file
+  (lambda (s)
+    "Return an object representing local file FILE to add to the store; this
 object can be used in a gexp.  If FILE is a relative file name, it is looked
 up relative to the source file where this form appears.  FILE will be added to
 the store under NAME--by default the base name of FILE.
@@ -283,10 +284,23 @@ When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 where FILE is the entry's absolute file name and STAT is the result of
 'lstat'; exclude entries for which SELECT? does not return true.
 
-This is the declarative counterpart of the 'interned-file' monadic procedure."
-  (%local-file file
-               (delay (absolute-file-name file (current-source-directory)))
-               rest ...))
+This is the declarative counterpart of the 'interned-file' monadic procedure.
+It is implemented as a macro to capture the current source directory where it
+appears."
+    (syntax-case s ()
+      ((_ file rest ...)
+       #'(%local-file file
+                      (delay (absolute-file-name file (current-source-directory)))
+                      rest ...))
+      ((_)
+       #'(syntax-error "missing file name"))
+      (id
+       (identifier? #'id)
+       ;; XXX: We could return #'(lambda (file . rest) ...).  However,
+       ;; (syntax-source #'id) is #f so (current-source-directory) would not
+       ;; work.  Thus, simply forbid this form.
+       #'(syntax-error
+          "'local-file' is a macro and cannot be used like this")))))
 
 (define (local-file-absolute-file-name file)
   "Return the absolute file name for FILE, a <local-file> instance.  A
@@ -706,15 +720,17 @@ references; otherwise, return only non-native references."
            (cons `(,thing ,output) result)
            result))
       (($ <gexp-input> (lst ...) output n?)
-       (if (eqv? native? n?)
-           (fold-right add-reference-inputs result
-                       ;; XXX: For now, automatically convert LST to a list of
-                       ;; gexp-inputs.
-                       (map (match-lambda
-                              ((? gexp-input? x) x)
-                              (x (%gexp-input x "out" (or n? native?))))
-                            lst))
-           result))
+       (fold-right add-reference-inputs result
+                   ;; XXX: For now, automatically convert LST to a list of
+                   ;; gexp-inputs.  Inherit N?.
+                   (map (match-lambda
+                          ((? gexp-input? x)
+                           (%gexp-input (gexp-input-thing x)
+                                        (gexp-input-output x)
+                                        n?))
+                          (x
+                           (%gexp-input x "out" n?)))
+                        lst)))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 1bed56af20..b7dadd9750 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -12,6 +12,7 @@
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Petter <petter@mykolab.ch>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,6 +68,7 @@
             lppl1.3a lppl1.3a+
             lppl1.3b lppl1.3b+
             lppl1.3c lppl1.3c+
+            miros
             mpl1.0 mpl1.1 mpl2.0
             ms-pl
             ncsa
@@ -452,6 +454,11 @@ at URI, which may be a file:// URI pointing the package's tree."
            "https://www.latex-project.org/lppl/lppl-1-3c/"
            "LaTeX Project Public License 1.3c or later"))
 
+(define miros
+  (license "MirOS"
+           "https://www.mirbsd.org/MirOS-Licence.htm"
+           "MirOS License"))
+
 (define mpl1.0
   (license "MPL 1.0"
            "http://www.mozilla.org/MPL/1.0/"
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 85c1722d62..b3732f61ed 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1313,40 +1313,6 @@ are cross-built for TARGET."
 (define (generation-numbers profile)
   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
 former profiles were found."
-  (define* (scandir name #:optional (select? (const #t))
-                    (entry<? (@ (ice-9 i18n) string-locale<?)))
-    ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
-    (define (enter? dir stat result)
-      (and stat (string=? dir name)))
-
-    (define (visit basename result)
-      (if (select? basename)
-          (cons basename result)
-          result))
-
-    (define (leaf name stat result)
-      (and result
-           (visit (basename name) result)))
-
-    (define (down name stat result)
-      (visit "." '()))
-
-    (define (up name stat result)
-      (visit ".." result))
-
-    (define (skip name stat result)
-      ;; All the sub-directories are skipped.
-      (visit (basename name) result))
-
-    (define (error name* stat errno result)
-      (if (string=? name name*)             ; top-level NAME is unreadable
-          result
-          (visit (basename name*) result)))
-
-    (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
-           (lambda (files)
-             (sort files entry<?))))
-
   (match (scandir (dirname profile)
                   (cute regexp-exec (profile-regexp profile) <>))
     (#f                                         ; no profile directory
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 0abc509a35..95ba199d97 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -313,9 +313,7 @@ in OPTS."
                            #:dry-run? dry-run?)
       (if dry-run?
           (return #f)
-          (mbegin %store-monad
-            (set-build-options-from-command-line* opts)
-            (built-derivations derivations))))))
+          (built-derivations derivations)))))
 
 (define (inputs->profile-derivation inputs system bootstrap?)
   "Return the derivation for a profile consisting of INPUTS for SYSTEM.
@@ -580,6 +578,8 @@ message if any test fails."
       (when container? (assert-container-features))
 
       (with-store store
+        (set-build-options-from-command-line store opts)
+
         ;; Use the bootstrap Guile when requested.
         (parameterize ((%graft? (assoc-ref opts 'graft?))
                        (%guile-for-build
@@ -588,7 +588,6 @@ message if any test fails."
                          (if bootstrap?
                              %bootstrap-guile
                              (canonical-package guile-2.0)))))
-          (set-build-options-from-command-line store opts)
           (run-with-store store
             ;; Containers need a Bourne shell at /bin/sh.
             (mlet* %store-monad ((bash       (environment-bash container?
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 58da3113a0..8da7a3fd3a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -84,12 +84,16 @@
   "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE.  Otherwise
 return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
 '-p' was omitted."                           ; see <http://bugs.gnu.org/17939>
-  (if (and %user-profile-directory
-           (string=? (canonicalize-path (dirname profile))
-                     (dirname %user-profile-directory))
-           (string=? (basename profile) (basename %user-profile-directory)))
-      %current-profile
-      profile))
+
+  ;; Trim trailing slashes so that the basename comparison below works as
+  ;; intended.
+  (let ((profile (string-trim-right profile #\/)))
+    (if (and %user-profile-directory
+             (string=? (canonicalize-path (dirname profile))
+                       (dirname %user-profile-directory))
+             (string=? (basename profile) (basename %user-profile-directory)))
+        %current-profile
+        profile)))
 
 (define (user-friendly-profile profile)
   "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
@@ -709,9 +713,12 @@ processed, #f otherwise."
                (raise (condition (&profile-not-found-error
                                   (profile profile)))))
               ((string-null? pattern)
-               (list-generation display-profile-content
-                                (car (profile-generations profile)))
-               (diff-profiles profile (profile-generations profile)))
+               (match (profile-generations profile)
+                 (()
+                  #t)
+                 ((first rest ...)
+                  (list-generation display-profile-content first)
+                  (diff-profiles profile (cons first rest)))))
               ((matching-generations pattern profile)
                =>
                (lambda (numbers)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a7e3e6d629..ade3c49a54 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -385,6 +385,24 @@ at a time."
                     (string-suffix? ".narinfo" file)))
       '()))
 
+(define (nar-expiration-time ttl)
+  "Return the narinfo expiration time (in seconds since the Epoch).  The
+expiration time is +inf.0 when passed an item that is still in the store; in
+other cases, it is the last-access time of the item plus TTL.
+
+This policy allows us to keep cached nars that correspond to valid store
+items.  Failing that, we could eventually have to recompute them and return
+404 in the meantime."
+  (let ((expiration-time (file-expiration-time ttl)))
+    (lambda (file)
+      (let ((item (string-append (%store-prefix) "/"
+                                 (basename file ".narinfo"))))
+        ;; Note: We don't need to use 'valid-path?' here because FILE would
+        ;; not exist if ITEM were not valid in the first place.
+        (if (file-exists? item)
+            +inf.0
+            (expiration-time file))))))
+
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compression %no-compression)
                                 (nar-path "nar")
@@ -417,7 +435,8 @@ requested using POOL."
                      (display (call-with-input-file cached
                                 read-string)
                               port))))
-          ((valid-path? store item)
+          ((and (file-exists? item)        ;cheaper than the 'valid-path?' RPC
+                (valid-path? store item))
            ;; Nothing in cache: bake the narinfo and nar in the background and
            ;; return 404.
            (eventually pool
@@ -435,7 +454,7 @@ requested using POOL."
                  (maybe-remove-expired-cache-entries cache
                                                      narinfo-files
                                                      #:entry-expiration
-                                                     (file-expiration-time ttl)
+                                                     (nar-expiration-time ttl)
                                                      #:delete-entry delete-entry
                                                      #:cleanup-period ttl))))
            (not-found request
@@ -565,13 +584,13 @@ has the given HASH of type ALGO."
                                " speaking.  Welcome!")))
                          port)))))
 
-(define extract-narinfo-hash
-  (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
-    (lambda (str)
-      "Return the hash within the narinfo resource string STR, or false if STR
+(define (extract-narinfo-hash str)
+  "Return the hash within the narinfo resource string STR, or false if STR
 is invalid."
-      (and=> (regexp-exec regexp str)
-             (cut match:substring <> 1)))))
+  (and (string-suffix? ".narinfo" str)
+       (let ((base (string-drop-right str 8)))
+         (and (string-every %nix-base32-charset base)
+              base))))
 
 (define (get-request? request)
   "Return #t if REQUEST uses the GET method."
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index 52f7cdd972..1e54d3f218 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -77,8 +77,22 @@ if ITEM is not in the store."
              (leave (G_ "no available substitute information for '~a'~%")
                     item)))))))
 
-(define* (display-profile profile #:optional (port (current-output-port)))
-  "Display PROFILE, a list of PROFILE objects, to PORT."
+(define profile-closure<?
+  (match-lambda*
+    ((($ <profile> name1 self1 total1)
+      ($ <profile> name2 self2 total2))
+     (< total1 total2))))
+
+(define profile-self<?
+  (match-lambda*
+    ((($ <profile> name1 self1 total1)
+      ($ <profile> name2 self2 total2))
+     (< self1 self2))))
+
+(define* (display-profile profile #:optional (port (current-output-port))
+                          #:key (profile<? profile-closure<?))
+  "Display PROFILE, a list of PROFILE objects, to PORT.  Sort entries
+according to PROFILE<?."
   (define MiB (expt 2 20))
 
   (format port "~64a ~8a ~a\n"
@@ -89,11 +103,7 @@ if ITEM is not in the store."
                  (format port "~64a  ~6,1f  ~6,1f ~5,1f%\n"
                          name (/ total MiB) (/ self MiB)
                          (* 100. (/ self whole 1.)))))
-              (sort profile
-                    (match-lambda*
-                      ((($ <profile> name1 self1 total1)
-                        ($ <profile> name2 self2 total2))
-                       (> total1 total2)))))
+              (sort profile (negate profile<?)))
     (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.))))
 
 (define display-profile*
@@ -224,6 +234,9 @@ Report the size of PACKAGE and its dependencies.\n"))
                          fetch substitute from URLS if they are authorized"))
   (display (G_ "
   -s, --system=SYSTEM    consider packages for SYSTEM--e.g., \"i686-linux\""))
+  ;; TRANSLATORS: "closure" and "self" must not be translated.
+  (display (G_ "
+      --sort=KEY         sort according to KEY--\"closure\" or \"self\""))
   (display (G_ "
   -m, --map-file=FILE    write to FILE a graphical map of disk usage"))
   (newline)
@@ -247,6 +260,15 @@ Report the size of PACKAGE and its dependencies.\n"))
                                      (string-tokenize arg)
                                      (alist-delete 'substitute-urls result))
                          rest)))
+        (option '("sort") #t #f
+                (lambda (opt name arg result . rest)
+                  (match arg
+                    ("closure"
+                     (alist-cons 'profile<? profile-closure<? result))
+                    ("self"
+                     (alist-cons 'profile<? profile-self<? result))
+                    (_
+                     (leave (G_ "~a: invalid sorting key~%") arg)))))
         (option '(#\m "map-file") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'map-file arg result)))
@@ -259,7 +281,8 @@ Report the size of PACKAGE and its dependencies.\n"))
                   (show-version-and-exit "guix size")))))
 
 (define %default-options
-  `((system . ,(%current-system))))
+  `((system . ,(%current-system))
+    (profile<? . ,profile-closure<?)))
 
 
 ;;;
@@ -273,6 +296,7 @@ Report the size of PACKAGE and its dependencies.\n"))
                                    (('argument . file) file)
                                    (_ #f))
                                  opts))
+           (profile<? (assoc-ref opts 'profile<?))
            (map-file (assoc-ref opts 'map-file))
            (system   (assoc-ref opts 'system))
            (urls     (assoc-ref opts 'substitute-urls)))
@@ -298,5 +322,6 @@ Report the size of PACKAGE and its dependencies.\n"))
                       (begin
                         (profile->page-map profile map-file)
                         (return #t))
-                      (display-profile* profile)))
+                      (display-profile* profile (current-output-port)
+                                        #:profile<? profile<?)))
                 #:system system)))))))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 71f30030b6..35282f9027 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -47,6 +47,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 vlist)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -96,6 +97,13 @@
 ;;;
 ;;; Code:
 
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
 (define %narinfo-cache-directory
   ;; A local cache of narinfos, to avoid going to the network.  Most of the
   ;; time, 'guix substitute' is called by guix-daemon as root and stores its
@@ -593,15 +601,27 @@ if file doesn't exist, and the narinfo otherwise."
 (define (fetch-narinfos url paths)
   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
   (define update-progress!
-    (let ((done 0))
+    (let ((done 0)
+          (total (length paths)))
       (lambda ()
         (display #\cr (current-error-port))
         (force-output (current-error-port))
         (format (current-error-port)
                 (G_ "updating list of substitutes from '~a'... ~5,1f%")
-                url (* 100. (/ done (length paths))))
+                url (* 100. (/ done total)))
         (set! done (+ 1 done)))))
 
+  (define hash-part->path
+    (let ((mapping (fold (lambda (path result)
+                           (vhash-cons (store-path-hash-part path) path
+                                       result))
+                         vlist-null
+                         paths)))
+      (lambda (hash)
+        (match (vhash-assoc hash mapping)
+          (#f #f)
+          ((_ . path) path)))))
+
   (define (handle-narinfo-response request response port result)
     (let* ((code   (response-code response))
            (len    (response-content-length response))
@@ -620,9 +640,7 @@ if file doesn't exist, and the narinfo otherwise."
             (if len
                 (get-bytevector-n port len)
                 (read-to-eof port))
-            (cache-narinfo! url
-                            (find (cut string-contains <> hash-part) paths)
-                            #f
+            (cache-narinfo! url (hash-part->path hash-part) #f
                             (if (= 404 code)
                                 ttl
                                 %narinfo-transient-error-ttl))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 65dd92e8b7..0fcb6a9b0f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -579,8 +579,12 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
                                                 (* 70 (expt 2 20)))
                                             #:mappings mappings))
     ((disk-image)
-     (system-disk-image os #:disk-image-size image-size
-                           #:file-system-type file-system-type))))
+     (system-disk-image os
+                        #:name (match file-system-type
+                                 ("iso9660" "image.iso")
+                                 (_         "disk-image"))
+                        #:disk-image-size image-size
+                        #:file-system-type file-system-type))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
diff --git a/guix/store.scm b/guix/store.scm
index a207d478e6..2563d26fa0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -897,6 +897,7 @@ path."
                           #:key (select? true))
            ;; We don't use the 'operation' macro so we can pass SELECT? to
            ;; 'write-file'.
+           (record-operation 'add-to-store)
            (let ((port (nix-server-socket server)))
              (write-int (operation-id add-to-store) port)
              (write-string basename port)
@@ -1548,9 +1549,12 @@ valid inputs."
 (define (store-path-hash-part path)
   "Return the hash part of PATH as a base32 string, or #f if PATH is not a
 syntactically valid store path."
-  (let ((path-rx (store-regexp* (%store-prefix))))
-    (and=> (regexp-exec path-rx path)
-           (cut match:substring <> 1))))
+  (and (string-prefix? (%store-prefix) path)
+       (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
+         (and (> (string-length base) 33)
+              (let ((hash (string-take base 32)))
+                (and (string-every %nix-base32-charset hash)
+                     hash))))))
 
 (define (log-file store file)
   "Return the build log file for FILE, or #f if none could be found.  FILE