summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLeo Famulari <leo@famulari.name>2017-07-23 03:42:12 -0400
committerLeo Famulari <leo@famulari.name>2017-07-23 03:42:12 -0400
commit6c1a317e29c45e85e3a0e050612cdefe470b100c (patch)
treee65dedf933090b1a9f8398655b3b20eba49fae96 /guix
parentb7158b767b7fd9f0379dfe08083c48a0cf0f3d50 (diff)
parent9478c05955643f8ff95dabccc1e42b20abb88049 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/base32.scm10
-rw-r--r--guix/build/syscalls.scm9
-rw-r--r--guix/download.scm51
-rw-r--r--guix/gexp.scm46
-rw-r--r--guix/licenses.scm7
-rw-r--r--guix/profiles.scm34
-rw-r--r--guix/scripts/environment.scm7
-rw-r--r--guix/scripts/package.scm25
-rw-r--r--guix/scripts/publish.scm35
-rw-r--r--guix/scripts/size.scm43
-rwxr-xr-xguix/scripts/substitute.scm28
-rw-r--r--guix/scripts/system.scm8
-rw-r--r--guix/store.scm10
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