diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 164 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/time-machine.scm | 2 |
12 files changed, 135 insertions, 133 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fba0f73826..3318ef0889 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -55,7 +55,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ae78df9c5c..a853ac6c7d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -504,7 +504,7 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --no-grafts do not graft packages")) (display (G_ " - --no-build-hook do not attempt to offload builds via the build hook")) + --no-offload do not attempt to offload builds")) (display (G_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) @@ -545,7 +545,8 @@ talking to a remote daemon\n"))) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:substitute-urls (assoc-ref opts 'substitute-urls) - #:use-build-hook? (assoc-ref opts 'build-hook?) + #:offload? (and (assoc-ref opts 'offload?) + (not (assoc-ref opts 'keep-failed?))) #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) #:print-build-trace (assoc-ref opts 'print-build-trace?) @@ -610,11 +611,15 @@ talking to a remote daemon\n"))) (alist-cons 'graft? #f (alist-delete 'graft? result eq?)) rest))) - (option '("no-build-hook") #f #f + (option '("no-offload" "no-build-hook") #f #f (lambda (opt name arg result . rest) + (when (string=? name "no-build-hook") + (warning (G_ "'--no-build-hook' is deprecated; \ +use '--no-offload' instead~%"))) + (apply values - (alist-cons 'build-hook? #f - (alist-delete 'build-hook? result)) + (alist-cons 'offload? #f + (alist-delete 'offload? result)) rest))) (option '("max-silent-time") #t #f (lambda (opt name arg result . rest) @@ -659,7 +664,7 @@ talking to a remote daemon\n"))) `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index ce70f2f0b3..664cb32b7c 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -158,7 +158,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 27b7e4fd1c..bc0ceabd3f 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -84,7 +84,7 @@ Perform the deployment specified by FILE.\n")) (debug . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d78ca0f303..f04363750e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -191,7 +191,7 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1384f6b41d..18473684eb 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -60,7 +60,7 @@ ;;; retrieving the build output(s) over SSH upon success. ;;; ;;; This command should not be used directly; instead, it is called on-demand -;;; by the daemon, unless it was started with '--no-build-hook' or a client +;;; by the daemon, unless it was started with '--no-offload' or a client ;;; inhibited build hooks. ;;; ;;; Code: diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 89b3e389fc..61d18e2609 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -759,7 +759,7 @@ last resort for relocation." (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) @@ -965,7 +965,10 @@ Create a bundle of PACKAGE.\n")) (list (transform store package) "out"))) (reverse (filter-map maybe-package-argument opts)))) - (manifest-file (assoc-ref opts 'manifest))) + (manifests (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts))) (define properties (if (assoc-ref opts 'save-provenance?) (lambda (package) @@ -979,11 +982,15 @@ Create a bundle of PACKAGE.\n")) (const '()))) (cond - ((and manifest-file (not (null? packages))) + ((and (not (null? manifests)) (not (null? packages))) (leave (G_ "both a manifest and a package list were given~%"))) - (manifest-file - (let ((user-module (make-user-module '((guix profiles) (gnu))))) - (load* manifest-file user-module))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) (else (manifest (map (match-lambda diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index bcd03a1df9..97436feee7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -318,7 +318,7 @@ Alternately, see @command{guix package --search-paths -p ~s}.") (debug . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t))) @@ -832,32 +832,17 @@ processed, #f otherwise." (unless dry-run? (delete-matching-generations store profile pattern))) -(define* (manifest-action store profile file opts - #:key dry-run?) - "Change PROFILE to contain the packages specified in FILE." - (let* ((user-module (make-user-module '((guix profiles) (gnu)))) - (manifest (load* file user-module)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (substitutes? (assoc-ref opts 'substitutes?)) - (allow-collisions? (assoc-ref opts 'allow-collisions?))) - (if dry-run? - (format #t (G_ "would install new manifest from '~a' with ~d entries~%") - file (length (manifest-entries manifest))) - (format #t (G_ "installing new manifest from '~a' with ~d entries~%") - file (length (manifest-entries manifest)))) - (build-and-use-profile store profile manifest - #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))) +(define (load-manifest file) + "Load the user-profile manifest (Scheme code) from FILE and return it." + (let ((user-module (make-user-module '((guix profiles) (gnu))))) + (load* file user-module))) (define %actions ;; List of actions that may be processed. The car of each pair is the ;; action's symbol in the option list; the cdr is the action's procedure. `((roll-back? . ,roll-back-action) (switch-generation . ,switch-generation-action) - (delete-generations . ,delete-generations-action) - (manifest . ,manifest-action))) + (delete-generations . ,delete-generations-action))) (define (process-actions store opts) "Process any install/remove/upgrade action from OPTS." @@ -896,7 +881,13 @@ processed, #f otherwise." opts) ;; Then, process normal package removal/installation/upgrade. - (let* ((manifest (profile-manifest profile)) + (let* ((files (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts)) + (manifest (match files + (() (profile-manifest profile)) + (_ (concatenate-manifests (map load-manifest files))))) (step1 (options->removable opts manifest (manifest-transaction))) (step2 (options->installable opts manifest step1)) @@ -904,12 +895,23 @@ processed, #f otherwise." (inherit step2) (install (map transform-entry (manifest-transaction-install step2))))) - (new (manifest-perform-transaction manifest step3))) + (new (manifest-perform-transaction manifest step3)) + (trans (if (null? files) + step3 + (fold manifest-transaction-install-entry + step3 + (manifest-entries manifest))))) (warn-about-old-distro) - (unless (manifest-transaction-null? step3) - (show-manifest-transaction store manifest step3 + (unless (manifest-transaction-null? trans) + ;; When '--manifest' is used, display information about TRANS as if we + ;; were starting from an empty profile. + (show-manifest-transaction store + (if (null? files) + manifest + (make-manifest '())) + trans #:dry-run? dry-run?) (build-and-use-profile store profile new #:allow-collisions? allow-collisions? diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index ef8d5c8fd9..a74776bd7b 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -71,7 +71,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index dba08edf50..ba2fb291d8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -86,6 +86,8 @@ read-narinfo write-narinfo + %allow-unauthenticated-substitutes? + substitute-urls guix-substitute)) @@ -118,15 +120,21 @@ (string-append %state-directory "/substitute/cache")) (string-append (cache-directory #:ensure? #f) "/substitute"))) +(define (warn-about-missing-authentication) + (warning (G_ "authentication and authorization of substitutes \ +disabled!~%")) + #t) + (define %allow-unauthenticated-substitutes? ;; Whether to allow unchecked substitutes. This is useful for testing ;; purposes, and should be avoided otherwise. - (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") - (cut string-ci=? <> "yes")) - (begin - (warning (G_ "authentication and authorization of substitutes \ -disabled!~%")) - #t))) + (make-parameter + (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") + (cut string-ci=? <> "yes")) + (lambda (value) + (when value + (warn-about-missing-authentication)) + value))) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered @@ -227,58 +235,6 @@ provide." (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) -(define-record-type <cache-info> - (%make-cache-info url store-directory wants-mass-query?) - cache-info? - (url cache-info-url) - (store-directory cache-info-store-directory) - (wants-mass-query? cache-info-wants-mass-query?)) - -(define (download-cache-info url) - "Download the information for the cache at URL. On success, return a -<cache-info> object and a port on which to send further HTTP requests. On -failure, return #f and #f." - (define uri - (string->uri (string-append url "/nix-cache-info"))) - - (define (read-cache-info port) - (alist->record (fields->alist port) - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))) - - (catch #t - (lambda () - (case (uri-scheme uri) - ((file) - (values (call-with-input-file (uri-path uri) - read-cache-info) - #f)) - ((http https) - (let ((port (guix:open-connection-for-uri - uri - #:verify-certificate? #f - #:timeout %fetch-timeout))) - (guard (c ((http-get-error? c) - (warning (G_ "while fetching '~a': ~a (~s)~%") - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - (close-connection port) - (warning (G_ "ignoring substitute server at '~s'~%") url) - (values #f #f))) - (values (read-cache-info (http-fetch uri - #:verify-certificate? #f - #:port port - #:keep-alive? #t)) - port)))))) - (lambda (key . args) - (case key - ((getaddrinfo-error system-error) - ;; Silently ignore the error: probably due to lack of network access. - (values #f #f)) - (else - (apply throw key args)))))) - (define-record-type <narinfo> (%make-narinfo path uri-base uris compressions file-sizes file-hashes @@ -422,7 +378,7 @@ No authentication and authorization checks are performed here!" (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) #:key verbose?) "Return #t if NARINFO's signature is not valid." - (or %allow-unauthenticated-substitutes? + (or (%allow-unauthenticated-substitutes?) (let ((hash (narinfo-sha256 narinfo)) (signature (narinfo-signature narinfo)) (uri (uri->string (first (narinfo-uris narinfo))))) @@ -628,6 +584,41 @@ 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 + (verify-certificate? #f) + (time %fetch-timeout)) + "Open a connection to URI and return a port to it, or, if connection failed, +print a warning and return #f." + (define host + (uri-host uri)) + + (catch #t + (lambda () + (guix:open-connection-for-uri uri + #:verify-certificate? verify-certificate? + #:timeout time)) + (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! @@ -657,13 +648,18 @@ if file doesn't exist, and the narinfo otherwise." (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))) - (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) - (update-progress!) - (cons narinfo result)) + (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" @@ -674,26 +670,28 @@ if file doesn't exist, and the narinfo otherwise." (if (= 404 code) ttl %narinfo-transient-error-ttl)) - (update-progress!) result)))) - (define (do-fetch uri port) + (define (do-fetch uri) (case (and=> uri uri-scheme) ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - - ;; 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 ((result (http-multiple-get uri - handle-narinfo-response '() - requests - #:verify-certificate? #f - #:port port))) - (close-connection port) - (newline (current-error-port)) - result))) + (match (open-connection-for-uri/maybe uri) + (#f + '()) + (port + (update-progress!) + ;; 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 ((result (http-multiple-get uri + handle-narinfo-response '() + requests + #:verify-certificate? #f + #:port port))) + (close-port port) + (newline (current-error-port)) + result))))) ((file #f) (let* ((base (string-append (uri-path uri) "/")) (files (map (compose (cut string-append base <> ".narinfo") @@ -704,17 +702,7 @@ if file doesn't exist, and the narinfo otherwise." (leave (G_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (let-values (((cache-info port) - (download-cache-info url))) - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url) port) ;reuse PORT - (begin - (warning (G_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - (close-connection port) - #f))))) + (do-fetch (string->uri url))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 27b014db68..e49c9d36b9 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1013,7 +1013,7 @@ Some ACTIONS support additional ARGS.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 19e635555a..1e800e160f 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -94,7 +94,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) |