summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2021-03-05 22:56:40 +0000
committerChristopher Baines <mail@cbaines.net>2021-03-06 00:18:30 +0000
commita8448da0f4a090818104e64dd79f90b0e50d5e77 (patch)
tree494c58b4724f12cd9de0db9b0a7096de2b922c0f /guix
parent4f4b749e75b38b8c08b4f67ef51c2c8740999e28 (diff)
parenta714af38d5d1046081524d859cde4cd8fd12a923 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build/profiles.scm4
-rw-r--r--guix/build/renpy-build-system.scm7
-rw-r--r--guix/build/syscalls.scm116
-rw-r--r--guix/describe.scm70
-rw-r--r--guix/download.scm8
-rw-r--r--guix/ftp-client.scm15
-rw-r--r--guix/gexp.scm211
-rw-r--r--guix/grafts.scm12
-rw-r--r--guix/http-client.scm123
-rw-r--r--guix/import/cran.scm2
-rw-r--r--guix/import/crate.scm15
-rw-r--r--guix/import/hackage.scm4
-rw-r--r--guix/narinfo.scm1
-rw-r--r--guix/openpgp.scm11
-rw-r--r--guix/packages.scm53
-rw-r--r--guix/profiles.scm9
-rw-r--r--guix/scripts.scm9
-rw-r--r--guix/scripts/challenge.scm2
-rw-r--r--guix/scripts/environment.scm13
-rw-r--r--guix/scripts/pack.scm31
-rw-r--r--guix/scripts/package.scm6
-rw-r--r--guix/scripts/pull.scm11
-rwxr-xr-xguix/scripts/substitute.scm540
-rw-r--r--guix/scripts/system.scm140
-rw-r--r--guix/scripts/weather.scm2
-rw-r--r--guix/serialization.scm56
-rw-r--r--guix/store.scm18
-rw-r--r--guix/substitutes.scm366
-rw-r--r--guix/tests.scm4
-rw-r--r--guix/ui.scm6
30 files changed, 1071 insertions, 794 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index b42f498a80..a40c3f96de 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -170,8 +170,8 @@ SEARCH-PATHS."
(display "\
;; This file was automatically generated and is for internal use only.
;; It cannot be passed to the '--manifest' option.
-;; Run 'guix package --export-manifest' if to export a file suitable
-;; for '--manifest'.\n\n"
+;; Run 'guix package --export-manifest' if you want to export a file
+;; suitable for '--manifest'.\n\n"
p)
(pretty-print manifest p)))
diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm
index 464fc97b13..66683971c5 100644
--- a/guix/build/renpy-build-system.scm
+++ b/guix/build/renpy-build-system.scm
@@ -57,7 +57,7 @@
(delete-file (string-append data "/renpy-build.json"))
(call-with-output-file launcher
(lambda (port)
- (format port "#!~a~%~a ~a \"$@\""
+ (format port "#!~a~%~a ~s \"$@\""
(which "bash")
(which "renpy")
data)))
@@ -77,8 +77,9 @@
(string-append out "/share/applications/" executable-name ".desktop")
#:name (assoc-ref json-dump "name")
#:generic-name (assoc-ref build "display_name")
- #:exec (string-append (which "renpy") " "
- out "/share/renpy/" directory-name)
+ #:exec (format #f "~a ~s"
+ (which "renpy")
+ (string-append out "/share/renpy/" directory-name))
#:categories '("Game" "Visual Novel")))
#t)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 85c1c45f81..552343a481 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -43,9 +43,10 @@
MS_NOEXEC
MS_REMOUNT
MS_NOATIME
+ MS_STRICTATIME
+ MS_RELATIME
MS_BIND
MS_MOVE
- MS_STRICTATIME
MS_LAZYTIME
MNT_FORCE
MNT_DETACH
@@ -53,7 +54,18 @@
UMOUNT_NOFOLLOW
restart-on-EINTR
+
+ mount?
+ mount-device-number
+ mount-source
+ mount-point
+ mount-type
+ mount-options
+ mount-flags
+
+ mounts
mount-points
+
swapon
swapoff
@@ -466,6 +478,7 @@ the returned procedure is called."
(define MS_NOATIME 1024)
(define MS_BIND 4096)
(define MS_MOVE 8192)
+(define MS_RELATIME 2097152)
(define MS_STRICTATIME 16777216)
(define MS_LAZYTIME 33554432)
@@ -519,17 +532,106 @@ constants from <sys/mount.h>."
(when update-mtab?
(remove-from-mtab target)))))
-(define (mount-points)
- "Return the mounts points for currently mounted file systems."
- (call-with-input-file "/proc/mounts"
+;; Mount point information.
+(define-record-type <mount>
+ (%mount source point devno type options)
+ mount?
+ (devno mount-device-number) ;st_dev
+ (source mount-source) ;string
+ (point mount-point) ;string
+ (type mount-type) ;string
+ (options mount-options)) ;string
+
+(define (option-string->mount-flags str)
+ "Parse the \"option string\" STR as it appears in /proc/mounts and similar,
+and return two values: a mount bitmask (inclusive or of MS_* constants), and
+the remaining unprocessed options."
+ ;; Why do we need to do this? Because mount flags and mount options are
+ ;; often lumped together; this is the case in /proc/mounts & co., so we need
+ ;; to extract the bits that actually correspond to mount flags.
+
+ (define not-comma
+ (char-set-complement (char-set #\,)))
+
+ (define lst
+ (string-tokenize str not-comma))
+
+ (let loop ((options lst)
+ (mask 0)
+ (remainder '()))
+ (match options
+ (()
+ (values mask (string-concatenate-reverse remainder)))
+ ((head . tail)
+ (letrec-syntax ((match-options (syntax-rules (=>)
+ ((_)
+ (loop tail mask
+ (cons head remainder)))
+ ((_ (str => bit) rest ...)
+ (if (string=? str head)
+ (loop tail (logior bit mask)
+ remainder)
+ (match-options rest ...))))))
+ (match-options ("rw" => 0)
+ ("ro" => MS_RDONLY)
+ ("nosuid" => MS_NOSUID)
+ ("nodev" => MS_NODEV)
+ ("noexec" => MS_NOEXEC)
+ ("relatime" => MS_RELATIME)
+ ("noatime" => MS_NOATIME)))))))
+
+(define (mount-flags mount)
+ "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of
+MS_* constants."
+ (option-string->mount-flags (mount-options mount)))
+
+(define (octal-decode str)
+ "Decode octal escapes from STR and return the corresponding string. STR may
+look like this: \"white\\040space\", which is decoded as \"white space\"."
+ (define char-set:octal
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
+ (define (octal? c)
+ (char-set-contains? char-set:octal c))
+
+ (let loop ((chars (string->list str))
+ (result '()))
+ (match chars
+ (()
+ (list->string (reverse result)))
+ ((#\\ (? octal? a) (? octal? b) (? octal? c) . rest)
+ (loop rest
+ (cons (integer->char
+ (string->number (list->string (list a b c)) 8))
+ result)))
+ ((head . tail)
+ (loop tail (cons head result))))))
+
+(define (mounts)
+ "Return the list of mounts (<mount> records) visible in the namespace of the
+current process."
+ (define (string->device-number str)
+ (match (string-split str #\:)
+ (((= string->number major) (= string->number minor))
+ (+ (* major 256) minor))))
+
+ (call-with-input-file "/proc/self/mountinfo"
(lambda (port)
(let loop ((result '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse result)
(match (string-tokenize line)
- ((source mount-point _ ...)
- (loop (cons mount-point result))))))))))
+ ((id parent-id major:minor root mount-point
+ options _ type source _ ...)
+ (let ((devno (string->device-number major:minor)))
+ (loop (cons (%mount (octal-decode source)
+ (octal-decode mount-point)
+ devno type options)
+ result)))))))))))
+
+(define (mount-points)
+ "Return the mounts points for currently mounted file systems."
+ (map mount-point (mounts)))
(define swapon
(let ((proc (syscall->procedure int "swapon" (list '* int))))
diff --git a/guix/describe.scm b/guix/describe.scm
index 6a31c707f0..0683ad8a27 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -23,7 +23,9 @@
#:use-module ((guix utils) #:select (location-file))
#:use-module ((guix store) #:select (%store-prefix store-path?))
#:use-module ((guix config) #:select (%state-directory))
- #:autoload (guix channels) (sexp->channel manifest-entry-channel)
+ #:autoload (guix channels) (channel-name
+ sexp->channel
+ manifest-entry-channel)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (current-profile
@@ -33,6 +35,7 @@
package-path-entries
package-provenance
+ package-channels
manifest-entry-with-provenance
manifest-entry-provenance))
@@ -144,6 +147,26 @@ when applicable."
"/site-ccache")))
(current-channel-entries))))
+(define (package-channels package)
+ "Return the list of channels providing PACKAGE or an empty list if it could
+not be determined."
+ (match (and=> (package-location package) location-file)
+ (#f '())
+ (file
+ (let ((file (if (string-prefix? "/" file)
+ file
+ (search-path %load-path file))))
+ (if (and file
+ (string-prefix? (%store-prefix) file))
+ (filter-map
+ (lambda (entry)
+ (let ((item (manifest-entry-item entry)))
+ (and (or (string-prefix? item file)
+ (string=? "guix" (manifest-entry-name entry)))
+ (manifest-entry-channel entry))))
+ (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."
@@ -153,36 +176,31 @@ property of manifest entries, or #f if it could not be determined."
(('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) '()))))))))))
+ (let* ((channels (package-channels package))
+ (names (map (compose symbol->string channel-name) channels)))
+ ;; 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))
+ (name (manifest-entry-name entry)))
+ (and (member name names)
+ (not (string=? name "guix"))
+ (entry-source entry))))
+ (current-profile-entries))))
+ (and main
+ `(,main
+ ,@(if extra (list extra) '())))))))
(define (manifest-entry-with-provenance entry)
"Return ENTRY with an additional 'provenance' property if it's not already
there."
(let ((properties (manifest-entry-properties entry)))
- (if (assq 'properties properties)
+ (if (assq 'provenance properties)
entry
(let ((item (manifest-entry-item entry)))
(manifest-entry
diff --git a/guix/download.scm b/guix/download.scm
index 494825860e..579996f090 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -535,9 +535,9 @@ own. This helper makes it easier to deal with \"tar bombs\"."
#~(begin
(use-modules (guix build utils))
(mkdir #$output)
- (setenv "PATH" (string-append #$gzip "/bin"))
+ (setenv "PATH" (string-append #+gzip "/bin"))
(chdir #$output)
- (invoke (string-append #$tar "/bin/tar")
+ (invoke (string-append #+tar "/bin/tar")
"xf" #$drv)))
#:system system
#:guile-for-build guile
@@ -574,7 +574,7 @@ own. This helper makes it easier to deal with \"zip bombs\"."
(use-modules (guix build utils))
(mkdir #$output)
(chdir #$output)
- (invoke (string-append #$unzip "/bin/unzip")
+ (invoke (string-append #+unzip "/bin/unzip")
#$drv)))
#:system system
#:guile-for-build guile
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
index 8d5adcb8ed..9cc34cc7ec 100644
--- a/guix/ftp-client.scm
+++ b/guix/ftp-client.scm
@@ -216,6 +216,17 @@ TIMEOUT, an ETIMEDOUT error is raised."
(else
(throw 'ftp-error conn "PASV" 227 message)))))
+(define (ftp-epsv conn)
+ (let* ((message (%ftp-command "EPSV" 229 (ftp-connection-socket conn))))
+ (string->number
+ (match:substring (string-match "\\(...([0-9]+).\\)" message) 1))))
+
+(define (ftp-passive conn)
+ "Enter passive mode using EPSV or PASV, return a data connection port on
+success."
+ ;; IPv6 only works with EPSV, so try it first.
+ (or (false-if-exception (ftp-epsv conn)) (ftp-pasv conn)))
+
(define (address-with-port sa port)
"Return a socket-address object based on SA, but with PORT."
(let ((fam (sockaddr:fam sa))
@@ -232,7 +243,7 @@ TIMEOUT, an ETIMEDOUT error is raised."
(if directory
(ftp-chdir conn directory))
- (let* ((port (ftp-pasv conn))
+ (let* ((port (ftp-passive conn))
(ai (ftp-connection-addrinfo conn))
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
(addrinfo:protocol ai))))
@@ -281,7 +292,7 @@ must be closed before CONN can be used for other purposes."
;; Ask for "binary mode".
(%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
- (let* ((port (ftp-pasv conn))
+ (let* ((port (ftp-passive conn))
(ai (ftp-connection-addrinfo conn))
(s (with-fluids ((%default-port-encoding #f))
(socket (addrinfo:fam ai) (addrinfo:socktype ai)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 2735d25d0c..78ce19956c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -120,8 +120,6 @@
file-like?
lower-object
- lower-inputs
-
&gexp-error
gexp-error?
&gexp-input-error
@@ -759,19 +757,28 @@ attribute that is traversed."
(append (let ((attribute (self-attribute gexp)))
(validate gexp attribute)
attribute)
- (append-map (match-lambda
- (($ <gexp-input> (? gexp? exp))
- (gexp-attribute exp self-attribute
- #:validate validate))
- (($ <gexp-input> (lst ...))
- (append-map (lambda (item)
- (gexp-attribute item self-attribute
- #:validate
- validate))
- lst))
- (_
- '()))
- (gexp-references gexp)))
+ (reverse
+ (fold (lambda (input result)
+ (match input
+ (($ <gexp-input> (? gexp? exp))
+ (append (gexp-attribute exp self-attribute
+ #:validate validate)
+ result))
+ (($ <gexp-input> (lst ...))
+ (fold/tree (lambda (obj result)
+ (match obj
+ ((? gexp? exp)
+ (append (gexp-attribute exp self-attribute
+ #:validate validate)
+ result))
+ (_
+ result)))
+ result
+ lst))
+ (_
+ result)))
+ '()
+ (gexp-references gexp))))
equal?)
'())) ;plain Scheme data type
@@ -828,8 +835,7 @@ list."
(one-of symbol? string? keyword? pair? null? array?
number? boolean? char?)))
-(define* (lower-inputs inputs
- #:key system target)
+(define (lower-inputs inputs system target)
"Turn any object from INPUTS into a derivation input for SYSTEM or a store
item (a \"source\"); return the corresponding input list as a monadic value.
When TARGET is true, use it as the cross-compilation target triplet."
@@ -842,24 +848,23 @@ When TARGET is true, use it as the cross-compilation target triplet."
(with-monad %store-monad
(>>= (mapm/accumulate-builds
(match-lambda
- (((? struct? thing) sub-drv ...)
- (mlet %store-monad ((obj (lower-object
- thing system #:target target)))
+ (($ <gexp-input> (? store-item? item))
+ (return item))
+ (($ <gexp-input> thing output native?)
+ (mlet %store-monad ((obj (lower-object thing system
+ #:target
+ (and (not native?)
+ target))))
(return (match obj
((? derivation? drv)
- (let ((outputs (if (null? sub-drv)
- '("out")
- sub-drv)))
- (derivation-input drv outputs)))
+ (derivation-input drv (list output)))
((? store-item? item)
item)
((? self-quoting?)
;; Some inputs such as <system-binding> can lower to
;; a self-quoting object that FILTERM will filter
;; out.
- #f)))))
- (((? store-item? item))
- (return item)))
+ #f))))))
inputs)
filterm)))
@@ -867,11 +872,17 @@ When TARGET is true, use it as the cross-compilation target triplet."
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:reference-graphs argument, lower it such that each INPUT is replaced by the
corresponding <derivation-input> or store item."
+ (define tuple->gexp-input
+ (match-lambda
+ ((thing)
+ (%gexp-input thing "out" (not target)))
+ ((thing output)
+ (%gexp-input thing output (not target)))))
+
(match graphs
(((file-names . inputs) ...)
- (mlet %store-monad ((inputs (lower-inputs inputs
- #:system system
- #:target target)))
+ (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
+ system target)))
(return (map cons file-names inputs))))))
(define* (lower-references lst #:key system target)
@@ -941,6 +952,15 @@ second element is the derivation to compile them."
modules
system extensions guile deprecation-warnings module-path))
+(define (sexp->string sexp)
+ "Like 'object->string', but deterministic and slightly faster."
+ ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is
+ ;; faster.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (lambda (port)
+ (write sexp port)))))
+
(define* (lower-gexp exp
#:key
(module-path %load-path)
@@ -991,16 +1011,9 @@ derivations--e.g., code evaluated for its side effects."
(guile (if guile-for-build
(return guile-for-build)
(default-guile-derivation system)))
- (normals (lower-inputs (gexp-inputs exp)
- #:system system
- #:target target))
- (natives (lower-inputs (gexp-native-inputs exp)
- #:system system
- #:target #f))
- (inputs -> (append normals natives))
- (sexp (gexp->sexp exp
- #:system system
- #:target target))
+ (inputs (lower-inputs (gexp-inputs exp)
+ system target))
+ (sexp (gexp->sexp exp system target))
(extensions -> (gexp-extensions exp))
(exts (mapm %store-monad
(lambda (obj)
@@ -1159,7 +1172,7 @@ The other arguments are as for 'derivation'."
(return #f)))
(guile -> (lowered-gexp-guile lowered))
(builder (text-file script-name
- (object->string
+ (sexp->string
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
@@ -1203,42 +1216,60 @@ The other arguments are as for 'derivation'."
#:substitutable? substitutable?
#:properties properties))))
-(define* (gexp-inputs exp #:key native?)
- "Return the input list for EXP. When NATIVE? is true, return only native
-references; otherwise, return only non-native references."
- ;; TODO: Return <gexp-input> records instead of tuples.
+(define (fold/tree proc seed lst)
+ "Like 'fold', but recurse into sub-lists of LST and accept improper lists."
+ (let loop ((obj lst)
+ (result seed))
+ (match obj
+ ((head . tail)
+ (loop tail (loop head result)))
+ (_
+ (proc obj result)))))
+
+(define (gexp-inputs exp)
+ "Return the list of <gexp-input> for EXP."
+ (define set-gexp-input-native?
+ (match-lambda
+ (($ <gexp-input> thing output)
+ (%gexp-input thing output #t))))
+
+ (define (interesting? obj)
+ (or (file-like? obj)
+ (and (string? obj) (direct-store-path? obj))))
+
(define (add-reference-inputs ref result)
(match ref
(($ <gexp-input> (? gexp? exp) _ #t)
- (if native?
- (append (gexp-inputs exp)
- (gexp-inputs exp #:native? #t)
- result)
- result))
- (($ <gexp-input> (? gexp? exp) _ #f)
- (append (gexp-inputs exp #:native? native?)
+ (append (map set-gexp-input-native? (gexp-inputs exp))
result))
+ (($ <gexp-input> (? gexp? exp) _ #f)
+ (append (gexp-inputs exp) result))
(($ <gexp-input> (? string? str))
(if (direct-store-path? str)
- (cons `(,str) result)
+ (cons ref result)
result))
(($ <gexp-input> (? struct? thing) output n?)
- (if (and (eqv? n? native?) (lookup-compiler thing))
+ (if (lookup-compiler thing)
;; THING is a derivation, or a package, or an origin, etc.
- (cons `(,thing ,output) result)
+ (cons ref result)
result))
- (($ <gexp-input> (lst ...) output n?)
- (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)))
+ (($ <gexp-input> (? pair? lst) output n?)
+ ;; XXX: Scan LST for inputs. Inherit N?.
+ (fold/tree (lambda (obj result)
+ (match obj
+ ((? gexp-input? x)
+ (cons (%gexp-input (gexp-input-thing x)
+ (gexp-input-output x)
+ n?)
+ result))
+ ((? interesting? x)
+ (cons (%gexp-input x "out" n?) result))
+ ((? gexp? x)
+ (append (gexp-inputs x) result))
+ (_
+ result)))
+ result
+ lst))
(_
;; Ignore references to other kinds of objects.
result)))
@@ -1247,9 +1278,6 @@ references; otherwise, return only non-native references."
'()
(gexp-references exp)))
-(define gexp-native-inputs
- (cut gexp-inputs <> #:native? #t))
-
(define (gexp-outputs exp)
"Return the outputs referred to by EXP as a list of strings."
(define (add-reference-output ref result)
@@ -1258,24 +1286,22 @@ references; otherwise, return only non-native references."
(cons name result))
(($ <gexp-input> (? gexp? exp))
(append (gexp-outputs exp) result))
- (($ <gexp-input> (lst ...) output native?)
- ;; XXX: Automatically convert LST.
- (add-reference-output (map (match-lambda
- ((? gexp-input? x) x)
- (x (%gexp-input x "out" native?)))
- lst)
- result))
- ((lst ...)
- (fold-right add-reference-output result lst))
+ (($ <gexp-input> (? pair? lst))
+ ;; XXX: Scan LST for outputs.
+ (fold/tree (lambda (obj result)
+ (match obj
+ (($ <gexp-output> name) (cons name result))
+ ((? gexp? x) (append (gexp-outputs x) result))
+ (_ result)))
+ result
+ lst))
(_
result)))
(delete-duplicates
- (add-reference-output (gexp-references exp) '())))
+ (fold add-reference-output '() (gexp-references exp))))
-(define* (gexp->sexp exp #:key
- (system (%current-system))
- (target (%current-target-system)))
+(define (gexp->sexp exp system target)
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
(define* (reference->sexp ref #:optional native?)
@@ -1288,17 +1314,19 @@ and in the current monad setting (system type, etc.)"
(return `((@ (guile) getenv) ,output)))
(($ <gexp-input> (? gexp? exp) output n?)
(gexp->sexp exp
- #:system system
- #:target (if (or n? native?) #f target)))
+ system (if (or n? native?) #f target)))
(($ <gexp-input> (refs ...) output n?)
(mapm %store-monad
(lambda (ref)
;; XXX: Automatically convert REF to an gexp-input.
- (reference->sexp
- (if (gexp-input? ref)
- ref
- (%gexp-input ref "out" n?))
- (or n? native?)))
+ (if (or (symbol? ref) (number? ref)
+ (boolean? ref) (null? ref) (array? ref))
+ (return ref)
+ (reference->sexp
+ (if (gexp-input? ref)
+ ref
+ (%gexp-input ref "out" n?))
+ (or n? native?))))
refs))
(($ <gexp-input> (? struct? thing) output n?)
(let ((target (if (or n? native?) #f target)))
@@ -1685,6 +1713,7 @@ TARGET, a GNU triplet."
;; TODO: Pass MODULES as an environment variable.
(gexp->derivation name build
#:system system
+ #:target target
#:guile-for-build guile
#:local-build? #t
#:env-vars
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 910dcadc8a..fd8a108092 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -323,14 +323,14 @@ DRV, and graft DRV itself to refer to those grafted dependencies."
;; Whether to honor package grafts by default.
(make-parameter #t))
-(define (set-grafting enable?)
- "This monadic procedure enables grafting when ENABLE? is true, and disables
-it otherwise. It returns the previous setting."
+(define-inlinable (set-grafting enable?)
+ ;; This monadic procedure enables grafting when ENABLE? is true, and
+ ;; disables it otherwise. It returns the previous setting.
(lambda (store)
(values (%graft? enable?) store)))
-(define (grafting?)
- "Return a Boolean indicating whether grafting is enabled."
+(define-inlinable (grafting?)
+ ;; Return a Boolean indicating whether grafting is enabled.
(lambda (store)
(values (%graft?) store)))
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 553640fe9e..2d7458a56e 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -21,8 +21,11 @@
(define-module (guix http-client)
#:use-module (web uri)
+ #:use-module (web http)
#:use-module ((web client) #:hide (open-socket-for-uri))
+ #:use-module (web request)
#:use-module (web response)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
@@ -35,6 +38,7 @@
#:use-module (guix utils)
#:use-module (guix base64)
#:autoload (gcrypt hash) (sha256)
+ #:autoload (gnutls) (error/invalid-session)
#:use-module ((guix build utils)
#:select (mkdir-p dump-port))
#:use-module ((guix build download)
@@ -50,6 +54,7 @@
http-get-error-reason
http-fetch
+ http-multiple-get
%http-cache-ttl
http-fetch/cached))
@@ -70,6 +75,7 @@
(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
+ (open-connection guix:open-connection-for-uri)
(keep-alive? #f)
(verify-certificate? #t)
(headers '((user-agent . "GNU Guile")))
@@ -92,10 +98,10 @@ Raise an '&http-get-error' condition if downloading fails."
(let loop ((uri (if (string? uri)
(string->uri uri)
uri)))
- (let ((port (or port (guix:open-connection-for-uri uri
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (let ((port (or port (open-connection uri
+ #:verify-certificate?
+ verify-certificate?
+ #:timeout timeout)))
(headers (match (uri-userinfo uri)
((? string? str)
(cons (cons 'Authorization
@@ -138,6 +144,115 @@ Raise an '&http-get-error' condition if downloading fails."
(uri->string uri) code
(response-reason-phrase resp))))))))))))
+(define* (http-multiple-get base-uri proc seed requests
+ #:key port (verify-certificate? #t)
+ (open-connection guix:open-connection-for-uri)
+ (keep-alive? #t)
+ (batch-size 1000))
+ "Send all of REQUESTS to the server at BASE-URI. Call PROC for each
+response, passing it the request object, the response, a port from which to
+read the response body, and the previous result, starting with SEED, à la
+'fold'. Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI. When KEEP-ALIVE? is false, close the connection port before
+returning."
+ (let connect ((port port)
+ (requests requests)
+ (result seed))
+ (define batch
+ (if (>= batch-size (length requests))
+ requests
+ (take requests batch-size)))
+
+ ;; (format (current-error-port) "connecting (~a requests left)..."
+ ;; (length requests))
+ (let ((p (or port (open-connection base-uri
+ #:verify-certificate?
+ verify-certificate?))))
+ ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
+ (when (file-port? p)
+ (setvbuf p 'block (expt 2 16)))
+
+ ;; Send BATCH in a row.
+ ;; XXX: Do our own caching to work around inefficiencies when
+ ;; communicating over TLS: <http://bugs.gnu.org/22966>.
+ (let-values (((buffer get) (open-bytevector-output-port)))
+ ;; Inherit the HTTP proxying property from P.
+ (set-http-proxy-port?! buffer (http-proxy-port? p))
+
+ (catch #t
+ (lambda ()
+ (for-each (cut write-request <> buffer)
+ batch)
+ (put-bytevector p (get))
+ (force-output p))
+ (lambda (key . args)
+ ;; If PORT becomes unusable, open a fresh connection and
+ ;; retry.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session)))
+ (begin
+ (close-port p) ; close the broken port
+ (connect #f
+ requests
+ result))
+ (apply throw key args)))))
+
+ ;; Now start processing responses.
+ (let loop ((sent batch)
+ (processed 0)
+ (result result))
+ (match sent
+ (()
+ (match (drop requests processed)
+ (()
+ (unless keep-alive?
+ (close-port p))
+ (reverse result))
+ (remainder
+ (connect p remainder result))))
+ ((head tail ...)
+ (catch #t
+ (lambda ()
+ (let* ((resp (read-response p))
+ (body (response-body-port resp))
+ (result (proc head resp body result)))
+ ;; The server can choose to stop responding at any time,
+ ;; in which case we have to try again. Check whether
+ ;; that is the case. Note that even upon "Connection:
+ ;; close", we can read from BODY.
+ (match (assq 'connection (response-headers resp))
+ (('connection 'close)
+ (close-port p)
+ (connect #f ;try again
+ (drop requests (+ 1 processed))
+ result))
+ (_
+ (loop tail (+ 1 processed) result))))) ;keep going
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection
+ ;; in the meantime, we get EPIPE. In that case, open a
+ ;; fresh connection and retry. We might also get
+ ;; 'bad-response or a similar exception from (web response)
+ ;; later on, once we've sent the request, or a
+ ;; ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session))
+ (memq key
+ '(bad-response bad-header bad-header-component)))
+ (begin
+ (close-port p)
+ (connect #f ; try again
+ (drop requests (+ 1 processed))
+ result))
+ (apply throw key args))))))))))
+
;;;
;;; Caching.
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index e8caf080fd..dbc858cb84 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -361,7 +361,7 @@ empty list when the FIELD cannot be found."
(define (directory-needs-fortran? dir)
"Check if the directory DIR contains Fortran source files."
- (match (find-files dir "\\.f(90|95)?")
+ (match (find-files dir "\\.f(90|95)$")
(() #f)
(_ #t)))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index aee1b01c9f..287ffd2536 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -192,9 +193,7 @@ and LICENSE."
(maybe-cargo-inputs cargo-inputs)
(maybe-cargo-development-inputs
cargo-development-inputs)))
- (home-page ,(match home-page
- ('null "")
- (_ home-page)))
+ (home-page ,home-page)
(synopsis ,synopsis)
(description ,(beautify-description description))
(license ,(match license
@@ -304,8 +303,14 @@ look up the development dependencs for the given crate."
#:version (crate-version-number version*)
#:cargo-inputs cargo-inputs
#:cargo-development-inputs cargo-development-inputs
- #:home-page (or (crate-home-page crate)
- (crate-repository crate))
+ #:home-page
+ (let ((home-page (crate-home-page crate)))
+ (if (string? home-page)
+ home-page
+ (let ((repository (crate-repository crate)))
+ (if (string? repository)
+ repository
+ ""))))
#:synopsis (crate-description crate)
#:description (crate-description crate)
#:license (and=> (crate-version-license version*)
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 6ca4f65cb0..9f992ffe8e 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -344,8 +344,8 @@ respectively."
(memoize hackage->guix-package))
(define* (hackage-recursive-import package-name . args)
- (recursive-import package-name #f
- #:repo->guix-package (lambda (name repo)
+ (recursive-import package-name
+ #:repo->guix-package (lambda* (name #:key repo version)
(apply hackage->guix-package/m
(cons name args)))
#:guix-name hackage-name->package-name))
diff --git a/guix/narinfo.scm b/guix/narinfo.scm
index d3deba28bd..2d06124017 100644
--- a/guix/narinfo.scm
+++ b/guix/narinfo.scm
@@ -25,7 +25,6 @@
#:use-module (guix base64)
#:use-module (guix records)
#:use-module (guix diagnostics)
- #:use-module (guix scripts substitute)
#:use-module (gcrypt hash)
#:use-module (gcrypt pk-crypto)
#:use-module (rnrs bytevectors)
diff --git a/guix/openpgp.scm b/guix/openpgp.scm
index 648c359621..9de7feb644 100644
--- a/guix/openpgp.scm
+++ b/guix/openpgp.scm
@@ -538,17 +538,6 @@ signature."
(raise (condition
(&openpgp-invalid-signature-error (port port))))))))
-(define (hash-algorithm-name algorithm) ;XXX: should be in Guile-Gcrypt
- "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
- (letrec-syntax ((->name (syntax-rules ()
- ((_) #f)
- ((_ name rest ...)
- (if (= algorithm (hash-algorithm name))
- 'name
- (->name rest ...))))))
- (->name sha1 sha256 sha384 sha512 sha224
- sha3-224 sha3-256 sha3-384 sha3-512)))
-
(define (verify-openpgp-signature sig keyring dataport)
"Verify that the data read from DATAPORT matches SIG, an
<openpgp-signature>. Fetch the public key of the issuer of SIG from KEYRING,
diff --git a/guix/packages.scm b/guix/packages.scm
index 67ef6ea146..2dbcc7ba8b 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -428,7 +428,7 @@ name of its URI."
(define-syntax-rule (package/inherit p overrides ...)
"Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any. P must be a bare
+transformation is done to the package P's replacement, if any. P must be a bare
identifier, and will be bound to either P or its replacement when evaluating
OVERRIDES."
(let loop ((p p))
@@ -478,29 +478,34 @@ object."
(match (package-location package)
(($ <location> file line column)
- (catch 'system-error
- (lambda ()
- ;; In general we want to keep relative file names for modules.
- (call-with-input-file (search-path %load-path file)
- (lambda (port)
- (goto port line column)
- (match (read port)
- (('package inits ...)
- (let ((field (assoc field inits)))
- (match field
- ((_ value)
- (let ((loc (and=> (source-properties value)
- source-properties->location)))
- (and loc
- ;; Preserve the original file name, which may be a
- ;; relative file name.
- (set-field loc (location-file) file))))
- (_
- #f))))
- (_
- #f)))))
- (lambda _
- #f)))
+ (match (search-path %load-path file)
+ ((? string? file-found)
+ (catch 'system-error
+ (lambda ()
+ ;; In general we want to keep relative file names for modules.
+ (call-with-input-file file-found
+ (lambda (port)
+ (goto port line column)
+ (match (read port)
+ (('package inits ...)
+ (let ((field (assoc field inits)))
+ (match field
+ ((_ value)
+ (let ((loc (and=> (source-properties value)
+ source-properties->location)))
+ (and loc
+ ;; Preserve the original file name, which may be a
+ ;; relative file name.
+ (set-field loc (location-file) file))))
+ (_
+ #f))))
+ (_
+ #f)))))
+ (lambda _
+ #f)))
+ (#f
+ ;; FILE could not be found in %LOAD-PATH.
+ #f)))
(_ #f)))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 36cb30c191..7a207589b0 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -362,9 +362,16 @@ file name."
#t
lst)))
+(define (default-properties package)
+ "Return the default properties of a manifest entry for PACKAGE."
+ ;; Preserve transformation options by default.
+ (match (assq-ref (package-properties package) 'transformations)
+ (#f '())
+ (transformations `((transformations . ,transformations)))))
+
(define* (package->manifest-entry package #:optional (output "out")
#:key (parent (delay #f))
- (properties '()))
+ (properties (default-properties package)))
"Return a manifest entry for the OUTPUT of package PACKAGE."
;; For each dependency, keep a promise pointing to its "parent" entry.
(letrec* ((deps (map (match-lambda
diff --git a/guix/scripts.scm b/guix/scripts.scm
index c9ea9f2e29..3aabaf5c9c 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
@@ -118,7 +118,12 @@ procedure, but both the category and synopsis are meant to be read (parsed) by
according to'string-distance'."
(define (options->long-names options)
(filter string? (append-map option-names options)))
- (string-closest guess (options->long-names options) #:threshold 3))
+ (match guess
+ ((? string?)
+ (match (string-split guess #\=)
+ ((name rest ...)
+ (string-closest name (options->long-names options) #:threshold 3))))
+ (_ #f)))
(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index cc9cbe6f27..4ec3be99ca 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -27,7 +27,7 @@
#:use-module (guix packages)
#:use-module ((guix progress) #:hide (dump-port*))
#:use-module (guix serialization)
- #:use-module (guix scripts substitute)
+ #:use-module (guix substitutes)
#:use-module (guix narinfo)
#:use-module (rnrs bytevectors)
#:autoload (guix http-client) (http-fetch)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index a39347743e..0360761683 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -745,14 +745,15 @@ message if any test fails."
(with-status-verbosity (assoc-ref opts 'verbosity)
(define manifest-from-opts
(options/resolve-packages store opts))
- (when (and profile
- (> (length (manifest-entries manifest-from-opts)) 0))
- (leave (G_ "'--profile' cannot be used with package options~%")))
(define manifest
(if profile
- (profile-manifest profile)
- manifest-from-opts))
+ (profile-manifest profile)
+ manifest-from-opts))
+
+ (when (and profile
+ (> (length (manifest-entries manifest-from-opts)) 0))
+ (leave (G_ "'--profile' cannot be used with package options~%")))
(set-build-options-from-command-line store opts)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 169cbc2500..d12fbaff6a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
@@ -1179,24 +1179,19 @@ Create a bundle of PACKAGE.\n"))
manifest))
identity))
- (define (with-transformations manifest)
- (map-manifest-entries manifest-entry-with-transformations
- manifest))
-
(with-provenance
- (with-transformations
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (packages->manifest packages)))))))
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages))))))
(with-error-handling
(with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 8234a1703d..fc5bf8137b 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -235,14 +235,12 @@ non-zero relevance score."
(case (version-compare candidate-version version)
((>)
(manifest-transaction-install-entry
- (manifest-entry-with-transformations
- (package->manifest-entry* pkg output))
+ (package->manifest-entry* pkg output)
transaction))
((<)
transaction)
((=)
- (let* ((new (manifest-entry-with-transformations
- (package->manifest-entry* pkg output))))
+ (let* ((new (package->manifest-entry* pkg output)))
;; Here we want to determine whether the NEW actually
;; differs from ENTRY, but we need to intercept
;; 'build-things' calls because they would prevent us from
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 4e0ab5d341..07613240a8 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
-;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,7 +39,7 @@
close-inferior)
#:use-module (guix scripts build)
#:use-module (guix scripts describe)
- #:autoload (guix build utils) (which)
+ #:autoload (guix build utils) (which mkdir-p)
#:use-module ((guix build syscalls)
#:select (with-file-lock/no-wait))
#:use-module (guix git)
@@ -91,11 +91,11 @@ Download and deploy the latest version of Guix.\n"))
(display (G_ "
-C, --channels=FILE deploy the channels defined in FILE"))
(display (G_ "
- --url=URL download from the Git repository at URL"))
+ --url=URL download \"guix\" channel from the Git repository at URL"))
(display (G_ "
- --commit=COMMIT download the specified COMMIT"))
+ --commit=COMMIT download the specified \"guix\" channel COMMIT"))
(display (G_ "
- --branch=BRANCH download the tip of the specified BRANCH"))
+ --branch=BRANCH download the tip of the specified \"guix\" channel BRANCH"))
(display (G_ "
--allow-downgrades allow downgrades to earlier channel revisions"))
(display (G_ "
@@ -521,6 +521,7 @@ true, display what would be built without actually building it."
(catch 'system-error
(lambda ()
(false-if-exception (delete-file link))
+ (mkdir-p (dirname link))
(symlink %current-profile link))
(lambda args
(leave (G_ "while creating symlink '~a': ~a~%")
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index f9bcead045..5866b8bb0a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -24,6 +24,7 @@
#:use-module (guix scripts)
#:use-module (guix narinfo)
#:use-module (guix store)
+ #:use-module (guix substitutes)
#:use-module (guix utils)
#:use-module (guix combinators)
#:use-module (guix config)
@@ -39,40 +40,28 @@
#:use-module (guix cache)
#:use-module (gcrypt pk-crypto)
#:use-module (guix pki)
- #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix build download)
#:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
- . guix:open-connection-for-uri)
- store-path-abbreviation byte-count->string))
- #:autoload (gnutls) (error/invalid-session)
+ . guix:open-connection-for-uri)))
#:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (ice-9 rdelim)
- #:use-module (ice-9 regex)
#:use-module (ice-9 match)
#: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)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (web uri)
- #:use-module (web http)
- #:use-module (web request)
- #:use-module (web response)
#:use-module (guix http-client)
- #:export (lookup-narinfos
- lookup-narinfos/diverse
-
- %allow-unauthenticated-substitutes?
+ #:export (%allow-unauthenticated-substitutes?
%error-to-file-descriptor-4?
substitute-urls
@@ -89,16 +78,9 @@
;;;
;;; Code:
-(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
- ;; cached data in /var/guix/…. However, when invoked from 'guix challenge'
- ;; as a user, it stores its cache in ~/.cache.
- (if (zero? (getuid))
- (or (and=> (getenv "XDG_CACHE_HOME")
- (cut string-append <> "/guix/substitute"))
- (string-append %state-directory "/substitute/cache"))
- (string-append (cache-directory #:ensure? #f) "/substitute")))
+(define %narinfo-expired-cache-entry-removal-delay
+ ;; How often we want to remove files corresponding to expired cache entries.
+ (* 7 24 3600))
(define (warn-about-missing-authentication)
(warning (G_ "authentication and authorization of substitutes \
@@ -112,24 +94,6 @@ disabled!~%"))
(and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
(cut string-ci=? <> "yes"))))
-(define %narinfo-ttl
- ;; Number of seconds during which cached narinfo lookups are considered
- ;; valid for substitute servers that do not advertise a TTL via the
- ;; 'Cache-Control' response header.
- (* 36 3600))
-
-(define %narinfo-negative-ttl
- ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
- (* 1 3600))
-
-(define %narinfo-transient-error-ttl
- ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
- (* 10 60))
-
-(define %narinfo-expired-cache-entry-removal-delay
- ;; How often we want to remove files corresponding to expired cache entries.
- (* 7 24 3600))
-
(define %fetch-timeout
;; Number of seconds after which networking is considered "slow".
5)
@@ -169,128 +133,6 @@ again."
(sigaction SIGALRM SIG_DFL)
(apply values result)))))
-(define* (fetch uri #:key (buffered? #t) (timeout? #t)
- (keep-alive? #f) (port #f))
- "Return a binary input port to URI and the number of bytes it's expected to
-provide.
-
-When PORT is true, use it as the underlying I/O port for HTTP transfers; when
-PORT is false, open a new connection for URI. When KEEP-ALIVE? is true, the
-connection (typically PORT) is kept open once data has been fetched from URI."
- (case (uri-scheme uri)
- ((file)
- (let ((port (open-file (uri-path uri)
- (if buffered? "rb" "r0b"))))
- (values port (stat:size (stat port)))))
- ((http https)
- (guard (c ((http-get-error? c)
- (leave (G_ "download from '~a' failed: ~a, ~s~%")
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))))
- ;; Test this with:
- ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
- ;; and then cancel with:
- ;; sudo tc qdisc del dev eth0 root
- (let ((port port))
- (with-timeout (if timeout?
- %fetch-timeout
- 0)
- (begin
- (warning (G_ "while fetching ~a: server is somewhat slow~%")
- (uri->string uri))
- (warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (begin
- (when (or (not port) (port-closed? port))
- (set! port (guix:open-connection-for-uri
- uri #:verify-certificate? #f)))
- (unless (or buffered? (not (file-port? port)))
- (setvbuf port 'none))
- (http-fetch uri #:text? #f #:port port
- #:keep-alive? keep-alive?
- #:verify-certificate? #f))))))
- (else
- (leave (G_ "unsupported substitute URI scheme: ~a~%")
- (uri->string uri)))))
-
-(define (narinfo-cache-file cache-url path)
- "Return the name of the local file that contains an entry for PATH. The
-entry is stored in a sub-directory specific to CACHE-URL."
- ;; The daemon does not sanitize its input, so PATH could be something like
- ;; "/gnu/store/foo". Gracefully handle that.
- (match (store-path-hash-part path)
- (#f
- (leave (G_ "'~a' does not name a store item~%") path))
- ((? string? hash-part)
- (string-append %narinfo-cache-directory "/"
- (bytevector->base32-string (sha256 (string->utf8 cache-url)))
- "/" hash-part))))
-
-(define (cached-narinfo cache-url path)
- "Check locally if we have valid info about PATH coming from CACHE-URL.
-Return two values: a Boolean indicating whether we have valid cached info, and
-that info, which may be either #f (when PATH is unavailable) or the narinfo
-for PATH."
- (define now
- (current-time time-monotonic))
-
- (define cache-file
- (narinfo-cache-file cache-url path))
-
- (catch 'system-error
- (lambda ()
- (call-with-input-file cache-file
- (lambda (p)
- (match (read p)
- (('narinfo ('version 2)
- ('cache-uri cache-uri)
- ('date date) ('ttl ttl) ('value #f))
- ;; A cached negative lookup.
- (if (obsolete? date now ttl)
- (values #f #f)
- (values #t #f)))
- (('narinfo ('version 2)
- ('cache-uri cache-uri)
- ('date date) ('ttl ttl) ('value value))
- ;; A cached positive lookup
- (if (obsolete? date now ttl)
- (values #f #f)
- (values #t (string->narinfo value cache-uri))))
- (('narinfo ('version v) _ ...)
- (values #f #f))))))
- (lambda _
- (values #f #f))))
-
-(define (cache-narinfo! cache-url path narinfo ttl)
- "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
-given TTL (a number of seconds or #f). NARINFO may be #f, in which case it
-indicates that PATH is unavailable at CACHE-URL."
- (define now
- (current-time time-monotonic))
-
- (define (cache-entry cache-uri narinfo)
- `(narinfo (version 2)
- (cache-uri ,cache-uri)
- (date ,(time-second now))
- (ttl ,(or ttl
- (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
- (value ,(and=> narinfo narinfo->string))))
-
- (let ((file (narinfo-cache-file cache-url path)))
- (mkdir-p (dirname file))
- (with-atomic-file-output file
- (lambda (out)
- (write (cache-entry cache-url narinfo) out))))
-
- narinfo)
-
-(define (narinfo-request cache-url path)
- "Return an HTTP request for the narinfo of PATH at CACHE-URL."
- (let ((url (string-append cache-url "/" (store-path-hash-part path)
- ".narinfo"))
- (headers '((User-Agent . "GNU Guile"))))
- (build-request (string->uri url) #:method 'GET #:headers headers)))
-
(define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
@@ -305,80 +147,6 @@ return its MAX-LENGTH first elements and its tail."
(values (reverse result) lst)
(loop (+ 1 len) tail (cons head result)))))))
-(define* (http-multiple-get base-uri proc seed requests
- #:key port (verify-certificate? #t)
- (open-connection guix:open-connection-for-uri)
- (keep-alive? #t)
- (batch-size 1000))
- "Send all of REQUESTS to the server at BASE-URI. Call PROC for each
-response, passing it the request object, the response, a port from which to
-read the response body, and the previous result, starting with SEED, à la
-'fold'. Return the final result.
-
-When PORT is specified, use it as the initial connection on which HTTP
-requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
-a URI. When KEEP-ALIVE? is false, close the connection port before
-returning."
- (let connect ((port port)
- (requests requests)
- (result seed))
- (define batch
- (at-most batch-size requests))
-
- ;; (format (current-error-port) "connecting (~a requests left)..."
- ;; (length requests))
- (let ((p (or port (open-connection base-uri
- #:verify-certificate?
- verify-certificate?))))
- ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
- (when (file-port? p)
- (setvbuf p 'block (expt 2 16)))
-
- ;; Send BATCH in a row.
- ;; XXX: Do our own caching to work around inefficiencies when
- ;; communicating over TLS: <http://bugs.gnu.org/22966>.
- (let-values (((buffer get) (open-bytevector-output-port)))
- ;; Inherit the HTTP proxying property from P.
- (set-http-proxy-port?! buffer (http-proxy-port? p))
-
- (for-each (cut write-request <> buffer)
- batch)
- (put-bytevector p (get))
- (force-output p))
-
- ;; Now start processing responses.
- (let loop ((sent batch)
- (processed 0)
- (result result))
- (match sent
- (()
- (match (drop requests processed)
- (()
- (unless keep-alive?
- (close-port p))
- (reverse result))
- (remainder
- (connect p remainder result))))
- ((head tail ...)
- (let* ((resp (read-response p))
- (body (response-body-port resp))
- (result (proc head resp body result)))
- ;; The server can choose to stop responding at any time, in which
- ;; case we have to try again. Check whether that is the case.
- ;; Note that even upon "Connection: close", we can read from BODY.
- (match (assq 'connection (response-headers resp))
- (('connection 'close)
- (close-port p)
- (connect #f ;try again
- (drop requests (+ 1 processed))
- result))
- (_
- (loop tail (+ 1 processed) result)))))))))) ;keep going
-
-(define (read-to-eof port)
- "Read from PORT until EOF is reached. The data are discarded."
- (dump-port port (%make-void-port "w")))
-
(define (narinfo-from-file file url)
"Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
if file doesn't exist, and the narinfo otherwise."
@@ -391,191 +159,6 @@ if file doesn't exist, and the narinfo otherwise."
#f
(apply throw args)))))
-(define %unreachable-hosts
- ;; Set of names of unreachable hosts.
- (make-hash-table))
-
-(define* (open-connection-for-uri/maybe uri
- #:key
- fresh?
- (time %fetch-timeout))
- "Open a connection to URI via 'open-connection-for-uri/cached' and return a
-port to it, or, if connection failed, print a warning and return #f. Pass
-#:fresh? to 'open-connection-for-uri/cached'."
- (define host
- (uri-host uri))
-
- (catch #t
- (lambda ()
- (open-connection-for-uri/cached uri #:timeout time
- #:fresh? fresh?))
- (match-lambda*
- (('getaddrinfo-error error)
- (unless (hash-ref %unreachable-hosts host)
- (hash-set! %unreachable-hosts host #t) ;warn only once
- (warning (G_ "~a: host not found: ~a~%")
- host (gai-strerror error)))
- #f)
- (('system-error . args)
- (unless (hash-ref %unreachable-hosts host)
- (hash-set! %unreachable-hosts host #t)
- (warning (G_ "~a: connection failed: ~a~%") host
- (strerror
- (system-error-errno `(system-error ,@args)))))
- #f)
- (args
- (apply throw args)))))
-
-(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)
- (total (length paths)))
- (lambda ()
- (display "\r\x1b[K" (current-error-port)) ;erase current line
- (force-output (current-error-port))
- (format (current-error-port)
- (G_ "updating substitutes from '~a'... ~5,1f%")
- 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))
- (cache (response-cache-control response))
- (ttl (and cache (assoc-ref cache 'max-age))))
- (update-progress!)
-
- ;; Make sure to read no more than LEN bytes since subsequent bytes may
- ;; belong to the next response.
- (if (= code 200) ; hit
- (let ((narinfo (read-narinfo port url #:size len)))
- (if (string=? (dirname (narinfo-path narinfo))
- (%store-prefix))
- (begin
- (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
- (cons narinfo result))
- result))
- (let* ((path (uri-path (request-uri request)))
- (hash-part (basename
- (string-drop-right path 8)))) ;drop ".narinfo"
- (if len
- (get-bytevector-n port len)
- (read-to-eof port))
- (cache-narinfo! url (hash-part->path hash-part) #f
- (if (or (= 404 code) (= 202 code))
- ttl
- %narinfo-transient-error-ttl))
- result))))
-
- (define (do-fetch uri)
- (case (and=> uri uri-scheme)
- ((http https)
- ;; Note: Do not check HTTPS server certificates to avoid depending
- ;; on the X.509 PKI. We can do it because we authenticate
- ;; narinfos, which provides a much stronger guarantee.
- (let* ((requests (map (cut narinfo-request url <>) paths))
- (result (call-with-cached-connection uri
- (lambda (port)
- (if port
- (begin
- (update-progress!)
- (http-multiple-get uri
- handle-narinfo-response '()
- requests
- #:open-connection
- open-connection-for-uri/cached
- #:verify-certificate? #f
- #:port port))
- '()))
- open-connection-for-uri/maybe)))
- (newline (current-error-port))
- result))
- ((file #f)
- (let* ((base (string-append (uri-path uri) "/"))
- (files (map (compose (cut string-append base <> ".narinfo")
- store-path-hash-part)
- paths)))
- (filter-map (cut narinfo-from-file <> url) files)))
- (else
- (leave (G_ "~s: unsupported server URI scheme~%")
- (if uri (uri-scheme uri) url)))))
-
- (do-fetch (string->uri url)))
-
-(define (lookup-narinfos cache paths)
- "Return the narinfos for PATHS, invoking the server at CACHE when no
-information is available locally."
- (let-values (((cached missing)
- (fold2 (lambda (path cached missing)
- (let-values (((valid? value)
- (cached-narinfo cache path)))
- (if valid?
- (if value
- (values (cons value cached) missing)
- (values cached missing))
- (values cached (cons path missing)))))
- '()
- '()
- paths)))
- (if (null? missing)
- cached
- (let ((missing (fetch-narinfos cache missing)))
- (append cached (or missing '()))))))
-
-(define (lookup-narinfos/diverse caches paths authorized?)
- "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
-That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
-cache, and so on.
-
-Return a list of narinfos for PATHS or a subset thereof. The returned
-narinfos are either AUTHORIZED?, or they claim a hash that matches an
-AUTHORIZED? narinfo."
- (define (select-hit result)
- (lambda (path)
- (match (vhash-fold* cons '() path result)
- ((one)
- one)
- ((several ..1)
- (let ((authorized (find authorized? (reverse several))))
- (and authorized
- (find (cut equivalent-narinfo? <> authorized)
- several)))))))
-
- (let loop ((caches caches)
- (paths paths)
- (result vlist-null) ;path->narinfo vhash
- (hits '())) ;paths
- (match paths
- (() ;we're done
- ;; Now iterate on all the HITS, and return exactly one match for each
- ;; hit: the first narinfo that is authorized, or that has the same hash
- ;; as an authorized narinfo, in the order of CACHES.
- (filter-map (select-hit result) hits))
- (_
- (match caches
- ((cache rest ...)
- (let* ((narinfos (lookup-narinfos cache paths))
- (definite (map narinfo-path (filter authorized? narinfos)))
- (missing (lset-difference string=? paths definite))) ;XXX: perf
- (loop rest missing
- (fold vhash-cons result
- (map narinfo-path narinfos) narinfos)
- (append definite hits))))
- (() ;that's it
- (filter-map (select-hit result) hits)))))))
-
(define (lookup-narinfo caches path authorized?)
"Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
was found."
@@ -629,7 +212,9 @@ was found."
;; lookup errors are typically the first one, and because other errors are
;; a subset of `system-error', which is harder to filter.
((_ exp ...)
- (catch #t
+ ;; Use a pre-unwind handler so that re-throwing preserves useful
+ ;; backtraces. 'with-throw-handler' works for Guile 2.2 and 3.0.
+ (with-throw-handler #t
(lambda () exp ...)
(match-lambda*
(('getaddrinfo-error error)
@@ -706,14 +291,18 @@ authorized substitutes."
(match (string-tokenize command)
(("have" paths ..1)
;; Return the subset of PATHS available in CACHE-URLS.
- (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+ (let ((substitutable (lookup-narinfos/diverse
+ cache-urls paths valid?
+ #:open-connection open-connection-for-uri/cached)))
(for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))
substitutable)
(newline)))
(("info" paths ..1)
;; Reply info about PATHS if it's in CACHE-URLS.
- (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+ (let ((substitutable (lookup-narinfos/diverse
+ cache-urls paths valid?
+ #:open-connection open-connection-for-uri/cached)))
(for-each display-narinfo-data substitutable)
(newline)))
(wtf
@@ -726,7 +315,7 @@ authorized substitutes."
(define open-connection-for-uri/cached
(let ((cache '()))
- (lambda* (uri #:key fresh? timeout verify-certificate?)
+ (lambda* (uri #:key fresh? (timeout %fetch-timeout) verify-certificate?)
"Return a connection for URI, possibly reusing a cached connection.
When FRESH? is true, delete any cached connections for URI and open a new one.
Return #f if URI's scheme is 'file' or #f.
@@ -769,32 +358,6 @@ server certificates."
(drain-input socket)
socket))))))))
-(define* (call-with-cached-connection uri proc
- #:optional
- (open-connection
- open-connection-for-uri/cached))
- (let ((port (open-connection uri)))
- (catch #t
- (lambda ()
- (proc port))
- (lambda (key . args)
- ;; If PORT was cached and the server closed the connection in the
- ;; meantime, we get EPIPE. In that case, open a fresh connection and
- ;; retry. We might also get 'bad-response or a similar exception from
- ;; (web response) later on, once we've sent the request, or a
- ;; ERROR/INVALID-SESSION from GnuTLS.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (eq? (first args) error/invalid-session))
- (memq key '(bad-response bad-header bad-header-component)))
- (proc (open-connection uri #:fresh? #t))
- (apply throw key args))))))
-
-(define-syntax-rule (with-cached-connection uri port exp ...)
- "Bind PORT with EXP... to a socket connected to URI."
- (call-with-cached-connection uri (lambda (port) exp ...)))
-
(define* (process-substitution store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
@@ -819,6 +382,38 @@ the current output port."
(apply dump-file/deduplicate
(append args (list #:store (%store-prefix)))))
+ (define (fetch uri)
+ (case (uri-scheme uri)
+ ((file)
+ (let ((port (open-file (uri-path uri) "r0b")))
+ (values port (stat:size (stat port)))))
+ ((http https)
+ (guard (c ((http-get-error? c)
+ (leave (G_ "download from '~a' failed: ~a, ~s~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))))
+ ;; Test this with:
+ ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
+ ;; and then cancel with:
+ ;; sudo tc qdisc del dev eth0 root
+ (with-timeout %fetch-timeout
+ (begin
+ (warning (G_ "while fetching ~a: server is somewhat slow~%")
+ (uri->string uri))
+ (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+ (call-with-connection-error-handling
+ uri
+ (lambda ()
+ (http-fetch uri #:text? #f
+ #:open-connection open-connection-for-uri/cached
+ #:keep-alive? #t
+ #:buffered? #f
+ #:verify-certificate? #f))))))
+ (else
+ (leave (G_ "unsupported substitute URI scheme: ~a~%")
+ (uri->string uri)))))
+
(unless narinfo
(leave (G_ "no valid substitute for '~a'~%")
store-item))
@@ -832,10 +427,7 @@ the current output port."
(let*-values (((raw download-size)
;; 'guix publish' without '--cache' doesn't specify a
;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
- (with-cached-connection uri port
- (fetch uri #:buffered? #f #:timeout? #f
- #:port port
- #:keep-alive? #t)))
+ (fetch uri))
((progress)
(let* ((dl-size (or download-size
(and (equal? compression "none")
@@ -1006,6 +598,24 @@ default value."
;; 'guix-daemon' expects.
(make-parameter #t))
+;; The daemon's agent code opens file descriptor 4 for us and this is where
+;; stderr should go.
+(define-syntax-rule (with-redirected-error-port exp ...)
+ "Evaluate EXP... with the current error port redirected to file descriptor 4
+if needed, as expected by the daemon's agent."
+ (let ((thunk (lambda () exp ...)))
+ (if (%error-to-file-descriptor-4?)
+ (parameterize ((current-error-port (fdopen 4 "wl")))
+ ;; Redirect diagnostics to file descriptor 4 as well.
+ (guix-warning-port (current-error-port))
+
+ ;; 'with-continuation-barrier' captures the initial value of
+ ;; 'current-error-port' to report backtraces in case of uncaught
+ ;; exceptions. Without it, backtraces would be printed to FD 2,
+ ;; thereby confusing the daemon.
+ (with-continuation-barrier thunk))
+ (thunk))))
+
(define-command (guix-substitute . args)
(category internal)
(synopsis "implement the build daemon's substituter protocol")
@@ -1020,14 +630,7 @@ default value."
(define deduplicate?
(find-daemon-option "deduplicate"))
- ;; The daemon's agent code opens file descriptor 4 for us and this is where
- ;; stderr should go.
- (parameterize ((current-error-port (if (%error-to-file-descriptor-4?)
- (fdopen 4 "wl")
- (current-error-port))))
- ;; Redirect diagnostics to file descriptor 4 as well.
- (guix-warning-port (current-error-port))
-
+ (with-redirected-error-port
(mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cache-entries %narinfo-cache-directory
cached-narinfo-files
@@ -1092,8 +695,7 @@ default value."
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
-;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
-;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
+;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
;;; End:
;;; substitute.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 19b8c5163c..e3cf99acc6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure."
;;; Action.
;;;
-(define* (system-derivation-for-action os action
- #:key image-size image-type
- full-boot? container-shared-network?
- mappings label
- volatile-root?)
- "Return as a monadic value the derivation for OS according to ACTION."
- (mlet %store-monad ((target (current-target-system)))
+(define* (system-derivation-for-action image action
+ #:key
+ full-boot?
+ container-shared-network?
+ mappings)
+ "Return as a monadic value the derivation for IMAGE according to ACTION."
+ (mlet %store-monad ((target (current-target-system))
+ (os -> (image-operating-system image))
+ (image-size -> (image-size image)))
(case action
((build init reconfigure)
(operating-system-derivation os))
@@ -695,8 +697,6 @@ checking this by themselves in their 'check' procedure."
os
#:mappings mappings
#:shared-network? container-shared-network?))
- ((vm-image)
- (system-qemu-image os #:disk-image-size image-size))
((vm)
(system-qemu-image/shared-store-script os
#:full-boot? full-boot?
@@ -705,21 +705,12 @@ checking this by themselves in their 'check' procedure."
image-size
(* 70 (expt 2 20)))
#:mappings mappings))
- ((image disk-image)
- (let* ((base-image (os->image os #:type image-type))
- (base-target (image-target base-image)))
- (when (eq? action 'disk-image)
- (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
- (lower-object
- (system-image
- (image
- (inherit (if label
- (image-with-label base-image label)
- base-image))
- (target (or base-target target))
- (size image-size)
- (operating-system os)
- (volatile-root? volatile-root?))))))
+ ((image disk-image vm-image)
+ (when (eq? action 'disk-image)
+ (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
+ (when (eq? action 'vm-image)
+ (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
+ (lower-object (system-image image)))
((docker-image)
(system-docker-image os
#:shared-network? container-shared-network?)))))
@@ -765,7 +756,7 @@ and TARGET arguments."
(set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
(return (primitive-eval (lowered-gexp-sexp lowered))))))
-(define* (perform-action action os
+(define* (perform-action action image
#:key
(validate-reconfigure ensure-forward-reconfigure)
save-provenance?
@@ -773,17 +764,13 @@ and TARGET arguments."
install-bootloader?
dry-run? derivations-only?
use-substitutes? bootloader-target target
- image-size image-type
- volatile-root?
- full-boot? label container-shared-network?
+ full-boot?
+ container-shared-network?
(mappings '())
(gc-root #f))
- "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install
+ "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install
bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
-target root directory; IMAGE-SIZE is the size of the image to be built, for
-the 'vm-image' and 'image' actions. IMAGE-TYPE is the type of image to
-be built. When VOLATILE-ROOT? is #t, the root file system is mounted
-volatile.
+target root directory.
FULL-BOOT? is used for the 'vm' action; it determines whether to
boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK?
@@ -805,6 +792,9 @@ static checks."
'()
(map boot-parameters->menu-entry (profile-boot-parameters))))
+ (define os
+ (image-operating-system image))
+
(define bootloader
(operating-system-bootloader os))
@@ -827,11 +817,7 @@ static checks."
(check-initrd-modules os)))
(mlet* %store-monad
- ((sys (system-derivation-for-action os action
- #:label label
- #:image-type image-type
- #:image-size image-size
- #:volatile-root? volatile-root?
+ ((sys (system-derivation-for-action image action
#:full-boot? full-boot?
#:container-shared-network? container-shared-network?
#:mappings mappings))
@@ -969,8 +955,6 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "\
vm build a virtual machine image that shares the host's store\n"))
(display (G_ "\
- vm-image build a freestanding virtual machine image\n"))
- (display (G_ "\
image build a Guix System image\n"))
(display (G_ "\
docker-image build a Docker image\n"))
@@ -999,7 +983,7 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "
-t, --image-type=TYPE for 'image', produce an image of TYPE"))
(display (G_ "
- --image-size=SIZE for 'vm-image', produce an image of SIZE"))
+ --image-size=SIZE for 'image', produce an image of SIZE"))
(display (G_ "
--no-bootloader for 'init', do not install a bootloader"))
(display (G_ "
@@ -1017,8 +1001,8 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "
-N, --network for 'container', allow containers to access the network"))
(display (G_ "
- -r, --root=FILE for 'vm', 'vm-image', 'image', 'container',
- and 'build', make FILE a symlink to the result, and
+ -r, --root=FILE for 'vm', 'image', 'container' and 'build',
+ make FILE a symlink to the result, and
register it as a garbage collector root"))
(display (G_ "
--full-boot for 'vm', make a full boot sequence"))
@@ -1169,9 +1153,9 @@ Some ACTIONS support additional ARGS.\n"))
ACTION must be one of the sub-commands that takes an operating system
declaration as an argument (a file name.) OPTS is the raw alist of options
resulting from command-line parsing."
- (define (ensure-operating-system file-or-exp obj)
- (unless (operating-system? obj)
- (leave (G_ "'~a' does not return an operating system~%")
+ (define (ensure-operating-system-or-image file-or-exp obj)
+ (unless (or (operating-system? obj) (image? obj))
+ (leave (G_ "'~a' does not return an operating system or an image~%")
file-or-exp))
obj)
@@ -1185,27 +1169,47 @@ resulting from command-line parsing."
(expr (assoc-ref opts 'expression))
(system (assoc-ref opts 'system))
(target (assoc-ref opts 'target))
- (transform (if save-provenance?
- (cut operating-system-with-provenance <> file)
- identity))
- (os (transform
- (ensure-operating-system
- (or file expr)
- (cond
- ((and expr file)
- (leave
- (G_ "both file and expression cannot be specified~%")))
- (expr
- (read/eval expr))
- (file
- (load* file %user-module
- #:on-error (assoc-ref opts 'on-error)))
- (else
- (leave (G_ "no configuration specified~%")))))))
-
+ (transform (lambda (obj)
+ (if (and save-provenance? (operating-system? obj))
+ (operating-system-with-provenance obj file)
+ obj)))
+ (obj (transform
+ (ensure-operating-system-or-image
+ (or file expr)
+ (cond
+ ((and expr file)
+ (leave
+ (G_ "both file and expression cannot be specified~%")))
+ (expr
+ (read/eval expr))
+ (file
+ (load* file %user-module
+ #:on-error (assoc-ref opts 'on-error)))
+ (else
+ (leave (G_ "no configuration specified~%")))))))
(dry? (assoc-ref opts 'dry-run?))
(bootloader? (assoc-ref opts 'install-bootloader?))
(label (assoc-ref opts 'label))
+ (image-type (lookup-image-type-by-name
+ (assoc-ref opts 'image-type)))
+ (image (let* ((image-type (if (eq? action 'vm-image)
+ qcow2-image-type
+ image-type))
+ (image-size (assoc-ref opts 'image-size))
+ (volatile? (assoc-ref opts 'volatile-root?))
+ (base-image (if (operating-system? obj)
+ (os->image obj
+ #:type image-type)
+ obj))
+ (base-target (image-target base-image)))
+ (image
+ (inherit (if label
+ (image-with-label base-image label)
+ base-image))
+ (target (or base-target target))
+ (size image-size)
+ (volatile-root? volatile?))))
+ (os (image-operating-system image))
(target-file (match args
((first second) second)
(_ #f)))
@@ -1241,7 +1245,7 @@ resulting from command-line parsing."
(warn-about-old-distro #:suggested-command
"guix system reconfigure"))
- (perform-action action os
+ (perform-action action image
#:dry-run? dry?
#:derivations-only? (assoc-ref opts
'derivations-only?)
@@ -1250,11 +1254,6 @@ resulting from command-line parsing."
(assoc-ref opts 'skip-safety-checks?)
#:validate-reconfigure
(assoc-ref opts 'validate-reconfigure)
- #:image-type (lookup-image-type-by-name
- (assoc-ref opts 'image-type))
- #:image-size (assoc-ref opts 'image-size)
- #:volatile-root?
- (assoc-ref opts 'volatile-root?)
#:full-boot? (assoc-ref opts 'full-boot?)
#:container-shared-network?
(assoc-ref opts 'container-shared-network?)
@@ -1264,7 +1263,6 @@ resulting from command-line parsing."
(_ #f))
opts)
#:install-bootloader? bootloader?
- #:label label
#:target target-file
#:bootloader-target bootloader-target
#:gc-root (assoc-ref opts 'gc-root)))))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 97e4a73802..9e94bff5a3 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -32,7 +32,7 @@
#:use-module (guix gexp)
#:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module ((guix build utils) #:select (every*))
- #:use-module (guix scripts substitute)
+ #:use-module (guix substitutes)
#:use-module (guix narinfo)
#:use-module (guix http-client)
#:use-module (guix ci)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 9d0739f6c5..9b888a7d25 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -199,6 +199,37 @@ substitute invalid byte sequences with question marks. This is a
(define write-store-path-list write-string-list)
(define read-store-path-list read-string-list)
+(define-syntax write-literal-strings
+ (lambda (s)
+ "Write the given literal strings to PORT in an optimized fashion, without
+any run-time allocations or computations."
+ (define (padding len)
+ (let ((m (modulo len 8)))
+ (if (zero? m)
+ 0
+ (- 8 m))))
+
+ (syntax-case s ()
+ ((_ port strings ...)
+ (let* ((bytes (map string->utf8 (syntax->datum #'(strings ...))))
+ (len (fold (lambda (bv size)
+ (+ size 8 (bytevector-length bv)
+ (padding (bytevector-length bv))))
+ 0
+ bytes))
+ (bv (make-bytevector len))
+ (zeros (make-bytevector 8 0)))
+ (fold (lambda (str offset)
+ (let ((len (bytevector-length str)))
+ (bytevector-u32-set! bv offset len (endianness little))
+ (bytevector-copy! str 0 bv (+ 8 offset) len)
+ (bytevector-copy! zeros 0 bv (+ 8 offset len)
+ (padding len))
+ (+ offset 8 len (padding len))))
+ 0
+ bytes)
+ #`(put-bytevector port #,bv))))))
+
(define-condition-type &nar-read-error &nar-error
nar-read-error?
@@ -332,14 +363,12 @@ which case you can use 'identity'."
(define-values (type size)
(file-type+size f))
- (write-string "(" p)
+ (write-literal-strings p "(")
(case type
((regular executable)
- (write-string "type" p)
- (write-string "regular" p)
+ (write-literal-strings p "type" "regular")
(when (eq? 'executable type)
- (write-string "executable" p)
- (write-string "" p))
+ (write-literal-strings p "executable" ""))
(let ((input (file-port f)))
(dynamic-wind
(const #t)
@@ -348,28 +377,23 @@ which case you can use 'identity'."
(lambda ()
(close-port input)))))
((directory)
- (write-string "type" p)
- (write-string "directory" p)
+ (write-literal-strings p "type" "directory")
(let ((entries (postprocess-entries (directory-entries f))))
(for-each (lambda (e)
(let* ((f (string-append f "/" e)))
- (write-string "entry" p)
- (write-string "(" p)
- (write-string "name" p)
+ (write-literal-strings p "entry" "(" "name")
(write-string e p)
- (write-string "node" p)
+ (write-literal-strings p "node")
(dump f)
- (write-string ")" p)))
+ (write-literal-strings p ")")))
entries)))
((symlink)
- (write-string "type" p)
- (write-string "symlink" p)
- (write-string "target" p)
+ (write-literal-strings p "type" "symlink" "target")
(write-string (symlink-target f) p))
(else
(raise (condition (&message (message "unsupported file type"))
(&nar-error (file f) (port port))))))
- (write-string ")" p)))
+ (write-literal-strings p ")")))
(define port-conversion-strategy
(fluid->parameter %default-port-conversion-strategy))
diff --git a/guix/store.scm b/guix/store.scm
index 81bb9eb847..37ae6cfedd 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1835,18 +1835,21 @@ and RESULT is typically its derivation."
(if (profiled? "object-cache")
(let ((fresh 0)
(lookups 0)
- (hits 0))
+ (hits 0)
+ (size 0))
(register-profiling-hook!
"object-cache"
(lambda ()
(format (current-error-port) "Store object cache:
fresh caches: ~5@a
lookups: ~5@a
- hits: ~5@a (~,1f%)~%"
+ hits: ~5@a (~,1f%)
+ cache size: ~5@a entries~%"
fresh lookups hits
(if (zero? lookups)
100.
- (* 100. (/ hits lookups))))))
+ (* 100. (/ hits lookups)))
+ size)))
(lambda (hit? cache)
(set! fresh
@@ -1854,12 +1857,13 @@ and RESULT is typically its derivation."
(+ 1 fresh)
fresh))
(set! lookups (+ 1 lookups))
- (set! hits (if hit? (+ hits 1) hits))))
+ (set! hits (if hit? (+ hits 1) hits))
+ (set! size (+ (if hit? 0 1)
+ (vlist-length cache)))))
(lambda (x y)
#t)))
-(define* (lookup-cached-object object #:optional (keys '())
- #:key (vhash-fold* vhash-foldq*))
+(define-inlinable (lookup-cached-object object keys vhash-fold*)
"Return the cached object in the store connection corresponding to OBJECT
and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of
additional keys to match against, and which are compared with 'equal?'.
@@ -1890,7 +1894,7 @@ Return #f on failure and the cached result otherwise."
OBJECT/KEYS, or return its cached value. Use VHASH-CONS to insert OBJECT into
the cache, and VHASH-FOLD* to look it up."
(mlet %store-monad ((cached (lookup-cached-object object keys
- #:vhash-fold* vhash-fold*)))
+ vhash-fold*)))
(if cached
(return cached)
(>>= (mthunk)
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
new file mode 100644
index 0000000000..dc94ccc8e4
--- /dev/null
+++ b/guix/substitutes.scm
@@ -0,0 +1,366 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix substitutes)
+ #:use-module (guix narinfo)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix combinators)
+ #:use-module (guix config)
+ #:use-module (guix records)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base32)
+ #:use-module (guix base64)
+ #:use-module (guix cache)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (guix pki)
+ #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+ #:use-module ((guix build download)
+ #:select ((open-connection-for-uri
+ . guix:open-connection-for-uri)))
+ #:use-module (guix progress)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #: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-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (web uri)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (guix http-client)
+ #:export (%narinfo-cache-directory
+
+ call-with-connection-error-handling
+
+ lookup-narinfos
+ lookup-narinfos/diverse))
+
+(define %narinfo-ttl
+ ;; Number of seconds during which cached narinfo lookups are considered
+ ;; valid for substitute servers that do not advertise a TTL via the
+ ;; 'Cache-Control' response header.
+ (* 36 3600))
+
+(define %narinfo-negative-ttl
+ ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
+ (* 1 3600))
+
+(define %narinfo-transient-error-ttl
+ ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
+ (* 10 60))
+
+(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
+ ;; cached data in /var/guix/…. However, when invoked from 'guix challenge'
+ ;; as a user, it stores its cache in ~/.cache.
+ (if (zero? (getuid))
+ (or (and=> (getenv "XDG_CACHE_HOME")
+ (cut string-append <> "/guix/substitute"))
+ (string-append %state-directory "/substitute/cache"))
+ (string-append (cache-directory #:ensure? #f) "/substitute")))
+
+(define (narinfo-cache-file cache-url path)
+ "Return the name of the local file that contains an entry for PATH. The
+entry is stored in a sub-directory specific to CACHE-URL."
+ ;; The daemon does not sanitize its input, so PATH could be something like
+ ;; "/gnu/store/foo". Gracefully handle that.
+ (match (store-path-hash-part path)
+ (#f
+ (leave (G_ "'~a' does not name a store item~%") path))
+ ((? string? hash-part)
+ (string-append %narinfo-cache-directory "/"
+ (bytevector->base32-string (sha256 (string->utf8 cache-url)))
+ "/" hash-part))))
+
+(define (cache-narinfo! cache-url path narinfo ttl)
+ "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
+given TTL (a number of seconds or #f). NARINFO may be #f, in which case it
+indicates that PATH is unavailable at CACHE-URL."
+ (define now
+ (current-time time-monotonic))
+
+ (define (cache-entry cache-uri narinfo)
+ `(narinfo (version 2)
+ (cache-uri ,cache-uri)
+ (date ,(time-second now))
+ (ttl ,(or ttl
+ (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
+ (value ,(and=> narinfo narinfo->string))))
+
+ (let ((file (narinfo-cache-file cache-url path)))
+ (mkdir-p (dirname file))
+ (with-atomic-file-output file
+ (lambda (out)
+ (write (cache-entry cache-url narinfo) out))))
+
+ narinfo)
+
+(define %unreachable-hosts
+ ;; Set of names of unreachable hosts.
+ (make-hash-table))
+
+(define* (call-with-connection-error-handling uri proc)
+ "Call PROC, and catch if a connection fails, print a warning and return #f."
+ (define host
+ (uri-host uri))
+
+ (catch #t
+ proc
+ (match-lambda*
+ (('getaddrinfo-error error)
+ (unless (hash-ref %unreachable-hosts host)
+ (hash-set! %unreachable-hosts host #t) ;warn only once
+ (warning (G_ "~a: host not found: ~a~%")
+ host (gai-strerror error)))
+ #f)
+ (('system-error . args)
+ (unless (hash-ref %unreachable-hosts host)
+ (hash-set! %unreachable-hosts host #t)
+ (warning (G_ "~a: connection failed: ~a~%") host
+ (strerror
+ (system-error-errno `(system-error ,@args)))))
+ #f)
+ (args
+ (apply throw args)))))
+
+(define (narinfo-request cache-url path)
+ "Return an HTTP request for the narinfo of PATH at CACHE-URL."
+ (let ((url (string-append cache-url "/" (store-path-hash-part path)
+ ".narinfo"))
+ (headers '((User-Agent . "GNU Guile"))))
+ (build-request (string->uri url) #:method 'GET #:headers headers)))
+
+(define (narinfo-from-file file url)
+ "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
+if file doesn't exist, and the narinfo otherwise."
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file file
+ (cut read-narinfo <> url)))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ #f
+ (apply throw args)))))
+
+(define* (fetch-narinfos url paths
+ #:key (open-connection guix:open-connection-for-uri))
+ "Retrieve all the narinfos for PATHS from the cache at URL and return them."
+ (define update-progress!
+ (let ((done 0)
+ (total (length paths)))
+ (lambda ()
+ (display "\r\x1b[K" (current-error-port)) ;erase current line
+ (force-output (current-error-port))
+ (format (current-error-port)
+ (G_ "updating substitutes from '~a'... ~5,1f%")
+ 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 (read-to-eof port)
+ "Read from PORT until EOF is reached. The data are discarded."
+ (dump-port port (%make-void-port "w")))
+
+ (define (handle-narinfo-response request response port result)
+ (let* ((code (response-code response))
+ (len (response-content-length response))
+ (cache (response-cache-control response))
+ (ttl (and cache (assoc-ref cache 'max-age))))
+ (update-progress!)
+
+ ;; Make sure to read no more than LEN bytes since subsequent bytes may
+ ;; belong to the next response.
+ (if (= code 200) ; hit
+ (let ((narinfo (read-narinfo port url #:size len)))
+ (if (string=? (dirname (narinfo-path narinfo))
+ (%store-prefix))
+ (begin
+ (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
+ (cons narinfo result))
+ result))
+ (let* ((path (uri-path (request-uri request)))
+ (hash-part (basename
+ (string-drop-right path 8)))) ;drop ".narinfo"
+ (if len
+ (get-bytevector-n port len)
+ (read-to-eof port))
+ (cache-narinfo! url (hash-part->path hash-part) #f
+ (if (or (= 404 code) (= 202 code))
+ ttl
+ %narinfo-transient-error-ttl))
+ result))))
+
+ (define (do-fetch uri)
+ (case (and=> uri uri-scheme)
+ ((http https)
+ ;; Note: Do not check HTTPS server certificates to avoid depending
+ ;; on the X.509 PKI. We can do it because we authenticate
+ ;; narinfos, which provides a much stronger guarantee.
+ (let* ((requests (map (cut narinfo-request url <>) paths))
+ (result (begin
+ (update-progress!)
+ (call-with-connection-error-handling
+ uri
+ (lambda ()
+ (http-multiple-get uri
+ handle-narinfo-response '()
+ requests
+ #:open-connection open-connection
+ #:verify-certificate? #f))))))
+ (newline (current-error-port))
+ result))
+ ((file #f)
+ (let* ((base (string-append (uri-path uri) "/"))
+ (files (map (compose (cut string-append base <> ".narinfo")
+ store-path-hash-part)
+ paths)))
+ (filter-map (cut narinfo-from-file <> url) files)))
+ (else
+ (leave (G_ "~s: unsupported server URI scheme~%")
+ (if uri (uri-scheme uri) url)))))
+
+ (do-fetch (string->uri url)))
+
+(define (cached-narinfo cache-url path)
+ "Check locally if we have valid info about PATH coming from CACHE-URL.
+Return two values: a Boolean indicating whether we have valid cached info, and
+that info, which may be either #f (when PATH is unavailable) or the narinfo
+for PATH."
+ (define now
+ (current-time time-monotonic))
+
+ (define cache-file
+ (narinfo-cache-file cache-url path))
+
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file cache-file
+ (lambda (p)
+ (match (read p)
+ (('narinfo ('version 2)
+ ('cache-uri cache-uri)
+ ('date date) ('ttl ttl) ('value #f))
+ ;; A cached negative lookup.
+ (if (obsolete? date now ttl)
+ (values #f #f)
+ (values #t #f)))
+ (('narinfo ('version 2)
+ ('cache-uri cache-uri)
+ ('date date) ('ttl ttl) ('value value))
+ ;; A cached positive lookup
+ (if (obsolete? date now ttl)
+ (values #f #f)
+ (values #t (string->narinfo value cache-uri))))
+ (('narinfo ('version v) _ ...)
+ (values #f #f))))))
+ (lambda _
+ (values #f #f))))
+
+(define* (lookup-narinfos cache paths
+ #:key (open-connection guix:open-connection-for-uri))
+ "Return the narinfos for PATHS, invoking the server at CACHE when no
+information is available locally."
+ (let-values (((cached missing)
+ (fold2 (lambda (path cached missing)
+ (let-values (((valid? value)
+ (cached-narinfo cache path)))
+ (if valid?
+ (if value
+ (values (cons value cached) missing)
+ (values cached missing))
+ (values cached (cons path missing)))))
+ '()
+ '()
+ paths)))
+ (if (null? missing)
+ cached
+ (let ((missing (fetch-narinfos cache missing
+ #:open-connection open-connection)))
+ (append cached (or missing '()))))))
+
+(define* (lookup-narinfos/diverse caches paths authorized?
+ #:key (open-connection
+ guix:open-connection-for-uri))
+ "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
+cache, and so on.
+
+Return a list of narinfos for PATHS or a subset thereof. The returned
+narinfos are either AUTHORIZED?, or they claim a hash that matches an
+AUTHORIZED? narinfo."
+ (define (select-hit result)
+ (lambda (path)
+ (match (vhash-fold* cons '() path result)
+ ((one)
+ one)
+ ((several ..1)
+ (let ((authorized (find authorized? (reverse several))))
+ (and authorized
+ (find (cut equivalent-narinfo? <> authorized)
+ several)))))))
+
+ (let loop ((caches caches)
+ (paths paths)
+ (result vlist-null) ;path->narinfo vhash
+ (hits '())) ;paths
+ (match paths
+ (() ;we're done
+ ;; Now iterate on all the HITS, and return exactly one match for each
+ ;; hit: the first narinfo that is authorized, or that has the same hash
+ ;; as an authorized narinfo, in the order of CACHES.
+ (filter-map (select-hit result) hits))
+ (_
+ (match caches
+ ((cache rest ...)
+ (let* ((narinfos (lookup-narinfos cache paths
+ #:open-connection open-connection))
+ (definite (map narinfo-path (filter authorized? narinfos)))
+ (missing (lset-difference string=? paths definite))) ;XXX: perf
+ (loop rest missing
+ (fold vhash-cons result
+ (map narinfo-path narinfos) narinfos)
+ (append definite hits))))
+ (() ;that's it
+ (filter-map (select-hit result) hits)))))))
+
+;;; substitutes.scm ends here
diff --git a/guix/tests.scm b/guix/tests.scm
index da75835099..4c6c7d95db 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -143,7 +143,7 @@ no external store to talk to."
(lambda ()
;; Since we're using a different store we must clear the
;; package-derivation cache.
- (hash-clear! (@@ (guix packages) %derivation-cache))
+ (hash-clear! (@@ (guix derivations) %derivation-cache))
(proc store))
(lambda ()
diff --git a/guix/ui.scm b/guix/ui.scm
index 9cea405456..7fbd4c63a2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -552,7 +552,9 @@ Report bugs to: ~a.") %guix-bug-report-address)
~a home page: <~a>") %guix-package-name %guix-home-page-url)
(format #t (G_ "
General help using Guix and GNU software: <~a>")
- "https://guix.gnu.org/help/")
+ ;; TRANSLATORS: Change the "/en" bit of this URL appropriately if
+ ;; the web site is translated in your language.
+ (G_ "https://guix.gnu.org/en/help/"))
(newline))
(define (augmented-system-error-handler file)
@@ -1968,7 +1970,7 @@ way."
display-generation-change))
(define (switch-to-generation* profile number)
- "Like 'switch-generation', but display what is happening."
+ "Like 'switch-to-generation', but display what is happening."
(let ((previous (switch-to-generation profile number)))
(display-generation-change previous number)))