diff options
author | Christopher Baines <mail@cbaines.net> | 2021-03-05 22:56:40 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2021-03-06 00:18:30 +0000 |
commit | a8448da0f4a090818104e64dd79f90b0e50d5e77 (patch) | |
tree | 494c58b4724f12cd9de0db9b0a7096de2b922c0f /guix/scripts | |
parent | 4f4b749e75b38b8c08b4f67ef51c2c8740999e28 (diff) | |
parent | a714af38d5d1046081524d859cde4cd8fd12a923 (diff) | |
download | guix-patches-a8448da0f4a090818104e64dd79f90b0e50d5e77.tar guix-patches-a8448da0f4a090818104e64dd79f90b0e50d5e77.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/challenge.scm | 2 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 13 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 31 | ||||
-rw-r--r-- | guix/scripts/package.scm | 6 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 11 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 540 | ||||
-rw-r--r-- | guix/scripts/system.scm | 140 | ||||
-rw-r--r-- | guix/scripts/weather.scm | 2 |
8 files changed, 170 insertions, 575 deletions
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) |