diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 53 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 143 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 50 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 33 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 256 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 8 |
10 files changed, 341 insertions, 230 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1a941d1a73..3fb210ee91 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix monads) @@ -50,6 +51,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -318,27 +320,28 @@ the input port." ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) (let ((opts (parse-command-line args %options (list %default-options)))) - (cond ((assoc-ref opts 'generate-key) - => - generate-key-pair) - ((assoc-ref opts 'authorize) - (authorize-key)) - (else - (let ((store (open-connection))) - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (_ "either '--export' or '--import' \ -must be specified~%"))))))))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (cond ((assoc-ref opts 'generate-key) + => + generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) + (else + (with-store store + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (_ "either '--export' or '--import' \ +must be specified~%")))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8725ddad88..b25bf50d2b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -296,6 +296,8 @@ options handled by 'set-build-options-from-command-line', and listed in --substitute-urls=URLS fetch substitute from URLS if they are authorized")) (display (_ " + --no-grafts do not graft packages")) + (display (_ " --no-build-hook do not attempt to offload builds via the build hook")) (display (_ " --max-silent-time=SECONDS @@ -379,6 +381,12 @@ options handled by 'set-build-options-from-command-line', and listed in (string-tokenize arg) (alist-delete 'substitute-urls result)) rest))) + (option '("no-grafts") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'graft? #f + (alist-delete 'graft? result eq?)) + rest))) (option '("no-build-hook") #f #f (lambda (opt name arg result . rest) (apply values @@ -452,8 +460,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) (display (_ " - --no-grafts do not graft packages")) - (display (_ " -d, --derivations return the derivation paths of the given packages")) (display (_ " --check rebuild items to check for non-determinism issues")) @@ -461,6 +467,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (_ " + -q, --quiet do not show the build log")) + (display (_ " --log-file return the log file names for the given derivations")) (newline) (show-build-options-help) @@ -528,13 +536,12 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\q "quiet") #f #f + (lambda (opt name arg result) + (alist-cons 'quiet? #t result))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) - (option '("no-grafts") #f #f - (lambda (opt name arg result) - (alist-cons 'graft? #f - (alist-delete 'graft? result eq?)))) (append %transformation-options %standard-build-options))) @@ -590,15 +597,16 @@ build." (parameterize ((%graft? graft?)) (append-map (match-lambda ((? package? p) - (match src - (#f - (list (package->derivation store p system))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (let ((s (package-source p))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) ((? derivation? drv) (list drv)) ((? procedure? proc) @@ -631,55 +639,66 @@ needed." ;;; (define (guix-build . args) + (define opts + (parse-command-line args %options + (list %default-options))) + + (define quiet? + (assoc-ref opts 'quiet?)) + (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let* ((opts (parse-command-line args %options - (list %default-options))) - (store (open-connection)) - (mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - + (with-store store + ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))) + + (parameterize ((current-build-output-port (if quiet? + (%make-void-port "w") + (current-error-port)))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0e462de4bf..b122b4cd40 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 David Thompson <davet@gnu.org> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -176,9 +177,9 @@ COMMAND or an interactive shell in that environment.\n")) (show-bug-report-information)) (define %default-options - ;; Default to opening a new shell. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -525,7 +526,8 @@ message if any test fails." (with-store store ;; Use the bootstrap Guile when requested. - (parameterize ((%guile-for-build + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation store (if bootstrap? diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index dcc4701779..b0d7c08582 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -19,6 +19,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) #:use-module (guix graph) + #:use-module (guix grafts) #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) @@ -340,8 +341,12 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (define (guix-graph . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) + (let* ((opts (args-fold* args %options + (lambda (opt name arg . rest) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (type (assoc-ref opts 'node-type)) (packages (filter-map (match-lambda (('argument . spec) @@ -352,7 +357,9 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) opts))) (with-store store (run-with-store store - (mlet %store-monad ((nodes (mapm %store-monad + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad (node-type-convert type) packages))) (export-graph (concatenate nodes) diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 4e84278a78..f2c20026b6 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -46,7 +46,7 @@ (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME -includes a suffix constituted by a dash followed by a numerical version (as +includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e729398742..27b9e155ec 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -20,10 +20,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) + #:use-module (guix http-client) #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix records) @@ -40,7 +41,8 @@ #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri)) + open-connection-for-uri + close-connection)) #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) @@ -295,7 +297,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (force-output port) (read-response port)) (lambda () - (close port)))) + (close-connection port)))) (case (response-code response) ((301 302 307) @@ -551,7 +553,15 @@ descriptions maintained upstream." (format #f (_ "failed to create derivation: ~a") (condition-message c))))) (with-store store - (package-derivation store package)))) + ;; Disable grafts since it can entail rebuilds. + (package-derivation store package #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement #:graft? #f)))))) (lambda args (emit-warning package (format #f (_ "failed to create derivation: ~s~%") @@ -585,18 +595,30 @@ Common Platform Enumeration (CPE) name." ;; TODO: Add more. (_ name))) +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal.." + (guard (c ((http-get-error? c) + (warning (_ "failed to retrieve CVE vulnerabilities \ +from ~s: ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())) + (catch 'getaddrinfo-error + (lambda () + (current-vulnerabilities)) + (lambda (key errcode) + (warning (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())))) + (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc - ;; Catch networking errors to allow network-less - ;; operation. - (catch 'getaddrinfo-error - (lambda () - (current-vulnerabilities)) - (lambda (key errcode) - (warn (_ "failed to lookup NIST host: ~a~%") - (gai-strerror errcode)) - (warn (_ "assuming no CVE vulnerabilities~%")) - '())))))) + (current-vulnerabilities*))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." ((force lookup) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f65834386b..1d88b33996 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -22,6 +22,7 @@ (define-module (guix scripts package) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -319,6 +320,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((max-silent-time . 3600) (verbosity . 0) + (graft? . #t) (substitutes? . #t))) (define (show-help) @@ -837,7 +839,8 @@ processed, #f otherwise." #:argument-handler handle-argument))) (with-error-handling (or (process-query opts) - (parameterize ((%store (open-connection))) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index e999cce1fd..8f0cb7decd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) @@ -274,19 +275,23 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (_ "missing store item argument\n"))) ((file) (leave-on-EPIPE - (with-store store - (set-build-options store - #:use-substitutes? #t - #:substitute-urls urls) + ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; packages, and (2) they do not make any difference on the + ;; resulting size. + (parameterize ((%graft? #f)) + (with-store store + (set-build-options store + #:use-substitutes? #t + #:substitute-urls urls) - (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) - (if map-file - (begin - (profile->page-map profile map-file) - (return #t)) - (display-profile* profile))) - #:system system)))) + (run-with-store store + (mlet* %store-monad ((item (ensure-store-item file)) + (profile (store-profile item))) + (if map-file + (begin + (profile->page-map profile map-file) + (return #t)) + (display-profile* profile))) + #:system system))))) ((files ...) (leave (_ "too many arguments\n"))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 01cc3f129e..4563f3df0f 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -19,7 +19,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix records) @@ -32,6 +32,8 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation + open-connection-for-uri + close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -49,6 +51,7 @@ #: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) @@ -106,15 +109,18 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. This is a reasonable default value (corresponds to the TTL for - ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to - ;; state what their TTL is in /nix-cache-info. (XXX) + ;; 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. + ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). (* 3 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)) @@ -162,23 +168,20 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) +(define* (fetch uri #:key (buffered? #t) (timeout? #t)) "Return a binary input port to URI and the number of bytes it's expected to -provide. If QUIET-404? is true, HTTP 404 error conditions are passed through -to the caller without emitting an error message." +provide." (case (uri-scheme uri) ((file) (let ((port (open-file (uri-path uri) (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) - ((http) + ((http https) (guard (c ((http-get-error? c) - (let ((code (http-get-error-code c))) - (if (and (= code 404) quiet-404?) - (raise c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - code (http-get-error-reason c)))))) + (leave (_ "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: @@ -198,13 +201,16 @@ to the caller without emitting an error message." (unless (or (guile-version>? "2.0.9") (version>? (version) "2.0.9.39")) (when port - (close-port port)))) + (close-connection port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri)) - (unless buffered? + (set! port (open-connection-for-uri uri)) + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) - (http-fetch uri #:text? #f #:port port)))))))) + (http-fetch uri #:text? #f #:port port)))))) + (else + (leave (_ "unsupported substitute URI scheme: ~a~%") + (uri->string uri))))) (define-record-type <cache-info> (%make-cache-info url store-directory wants-mass-query?) @@ -214,19 +220,46 @@ to the caller without emitting an error message." (wants-mass-query? cache-info-wants-mass-query?)) (define (download-cache-info url) - "Download the information for the cache at URL. Return a <cache-info> -object on success, or #f on failure." - (define (download url) - ;; Download the `nix-cache-info' from URL, and return its contents as an - ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) - - (and=> (download (string-append url "/nix-cache-info")) - (lambda (properties) - (alist->record properties - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))))) + "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 (open-connection-for-uri uri + #:timeout %fetch-timeout))) + (guard (c ((http-get-error? c) + (warning (_ "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 (_ "ignoring substitute server at '~s'~%") url) + (values #f #f))) + (values (read-cache-info (http-fetch uri + #: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> @@ -423,18 +456,18 @@ for PATH." (call-with-input-file cache-file (lambda (p) (match (read p) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value #f)) + ('date date) ('ttl _) ('value #f)) ;; A cached negative lookup. (if (obsolete? date now %narinfo-negative-ttl) (values #f #f) (values #t #f))) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value value)) + ('date date) ('ttl ttl) ('value value)) ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) + (if (obsolete? date now ttl) (values #f #f) (values #t (string->narinfo value cache-uri)))) (('narinfo ('version v) _ ...) @@ -442,16 +475,19 @@ for PATH." (lambda _ (values #f #f)))) -(define (cache-narinfo! cache-url path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO -may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." +(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 1) + `(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))) @@ -475,20 +511,35 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url proc seed requests) - "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +(define* (http-multiple-get base-uri proc seed requests + #:key port) + "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." - (let connect ((requests requests) +'fold'. Return the final result. When PORT is specified, use it as the +initial connection on which HTTP requests are sent." + (let connect ((port port) + (requests requests) (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-socket-for-uri base-url))) + (let ((p (or port (open-connection-for-uri base-uri)))) + ;; For HTTPS, P is not a file port and does not support 'setvbuf'. + (when (file-port? p) + (setvbuf p _IOFBF (expt 2 16))) + ;; Send all of REQUESTS in a row. - (setvbuf p _IOFBF (expt 2 16)) - (for-each (cut write-request <> p) requests) - (force-output p) + ;; 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))) + ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. + (when (module-variable (resolve-interface '(web http)) + 'http-proxy-port?) + (set-http-proxy-port?! buffer (http-proxy-port? p))) + + (for-each (cut write-request <> buffer) requests) + (put-bytevector p (get)) + (force-output p)) ;; Now start processing responses. (let loop ((requests requests) @@ -505,8 +556,8 @@ read the response body, and the previous result, starting with SEED, à la ;; Note that even upon "Connection: close", we can read from BODY. (match (assq 'connection (response-headers resp)) (('connection 'close) - (close-port p) - (connect tail result)) ;try again + (close-connection p) + (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -539,40 +590,41 @@ if file doesn't exist, and the narinfo otherwise." (set! done (+ 1 done))))) (define (handle-narinfo-response request response port result) - (let ((len (response-content-length response))) + (let* ((code (response-code response)) + (len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. - (case (response-code response) - ((200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo) - (update-progress!) - (cons narinfo result))) - ((404) ; failure - (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (cache-narinfo! url - (find (cut string-contains <> hash-part) paths) - #f) - (update-progress!) - result)) - (else ; transient failure - (if len - (get-bytevector-n port len) - (read-to-eof port)) - result)))) - - (define (do-fetch uri) + (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)) + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! url + (find (cut string-contains <> hash-part) paths) + #f + (if (= 404 code) + ttl + %narinfo-transient-error-ttl)) + (update-progress!) + result)))) + + (define (do-fetch uri port) (case (and=> uri uri-scheme) - ((http) + ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) - (let ((result (http-multiple-get url + (let ((result (http-multiple-get uri handle-narinfo-response '() - requests))) + requests + #:port port))) + (close-connection port) (newline (current-error-port)) result))) ((file #f) @@ -585,17 +637,17 @@ if file doesn't exist, and the narinfo otherwise." (leave (_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (define cache-info - (download-cache-info url)) - - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url)) - (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - #f)))) + (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 (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + (close-connection port) + #f))))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no @@ -657,12 +709,12 @@ indefinitely." (call-with-input-file file (lambda (port) (match (read port) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value #f)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl _) ('value #f)) (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value _)) - (obsolete? date now %narinfo-ttl)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl ttl) ('value _)) + (obsolete? date now ttl)) (_ #t))))) (lambda args ;; FILE may have been deleted. @@ -724,7 +776,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (make-custom-binary-input-port "progress-port-proc" read! #f #f - (cut close-port port))) + (cut close-connection port))) (define-syntax with-networking (syntax-rules () @@ -902,15 +954,9 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) -(define-syntax-rule (or* a b) - (let ((first a)) - (if (or (not first) (string-null? first)) - b - first))) - (define %cache-urls - (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client - (find-daemon-option "substitute-urls")) ;admin + (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((urls ...) urls) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 401aa8b60a..8ebeb4d595 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -21,6 +21,7 @@ #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) @@ -127,7 +128,8 @@ TARGET, and register them." (define (install-grub* grub.cfg device target) "This is a variant of 'install-grub' with error handling, lifted in %STORE-MONAD" - (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (let* ((gc-root (string-append target %gc-roots-directory + "/grub.cfg")) (temp-gc-root (string-append gc-root ".new")) (delete-file (lift1 delete-file %store-monad)) (make-symlink (lift2 switch-symlinks %store-monad)) @@ -685,6 +687,7 @@ Build the operating system declared in FILE according to ACTION.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) @@ -812,6 +815,7 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (process-command command args opts)))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (process-command command args opts))))) ;;; system.scm ends here |