diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/avahi.scm | 9 | ||||
| -rw-r--r-- | guix/build-system/r.scm | 2 | ||||
| -rw-r--r-- | guix/ci.scm | 10 | ||||
| -rw-r--r-- | guix/download.scm | 21 | ||||
| -rw-r--r-- | guix/glob.scm | 15 | ||||
| -rw-r--r-- | guix/http-client.scm | 12 | ||||
| -rw-r--r-- | guix/import/cran.scm | 10 | ||||
| -rw-r--r-- | guix/import/opam.scm | 58 | ||||
| -rw-r--r-- | guix/import/utils.scm | 4 | ||||
| -rw-r--r-- | guix/profiles.scm | 52 | ||||
| -rw-r--r-- | guix/progress.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/import/opam.scm | 10 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 253 | ||||
| -rw-r--r-- | guix/self.scm | 26 | ||||
| -rw-r--r-- | guix/store/database.scm | 2 |
16 files changed, 331 insertions, 170 deletions
diff --git a/guix/avahi.scm b/guix/avahi.scm index 8a82fd3beb..aa90a5cdd4 100644 --- a/guix/avahi.scm +++ b/guix/avahi.scm @@ -92,6 +92,7 @@ when STOP-LOOP? procedure returns true." (define* (avahi-browse-service-thread proc #:key types + (ignore-local? #t) (family AF_INET) (stop-loop? (const #f)) (timeout 100)) @@ -116,7 +117,9 @@ when STOP-LOOP? procedure returns true." ;; Add the service if the host is unknown. This means that if a ;; service is available on multiple network interfaces for a single ;; host, only the first interface found will be considered. - (unless (hash-ref %known-hosts service-name) + (unless (or (hash-ref %known-hosts service-name) + (and ignore-local? + (member lookup-result-flag/local flags))) (let* ((address (inet-ntop family address)) (local-address (interface->ip-address interface)) (service* (avahi-service @@ -144,8 +147,8 @@ when STOP-LOOP? procedure returns true." ((eq? event browser-event/remove) (let ((service (hash-ref %known-hosts service-name))) (when service - (proc 'remove-service service) - (hash-remove! %known-hosts service-name)))))) + (proc 'remove-service service) + (hash-remove! %known-hosts service-name)))))) (define client-callback (lambda (client state) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 5ef982d66a..e2bf41f18d 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -59,7 +59,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.11" + (string-append "https://bioconductor.org/packages/3.12" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/ci.scm b/guix/ci.scm index 7a03befc7c..f429bf198f 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -31,6 +31,7 @@ build? build-id build-derivation + build-evaluation build-system build-status build-timestamp @@ -49,6 +50,7 @@ %query-limit queued-builds latest-builds + evaluation latest-evaluations evaluations-for-commit)) @@ -71,6 +73,7 @@ json->build (id build-id "id") ;integer (derivation build-derivation) ;string | #f + (evaluation build-evaluation) ;integer (system build-system) ;string (status build-status "buildstatus" ) ;integer (timestamp build-timestamp) ;integer @@ -138,6 +141,13 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM." ;; 'latestbuilds', but Cuirass does. (map json->build (vector->list latest)))) +(define (evaluation url evaluation) + "Return the given EVALUATION performed by the CI server at URL." + (let ((evaluation (json-fetch + (string-append url "/api/evaluation?id=" + (number->string evaluation))))) + (json->evaluation evaluation))) + (define* (latest-evaluations url #:optional (limit %query-limit)) "Return the latest evaluations performed by the CI server at URL." (map json->evaluation diff --git a/guix/download.scm b/guix/download.scm index c24e0132c7..494825860e 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -248,22 +248,13 @@ (imagemagick ;; from http://www.imagemagick.org/script/download.php ;; (without mirrors that are unavailable or not up to date) - ;; mirrors keeping old versions at the top level - "https://sunsite.icm.edu.pl/packages/ImageMagick/" - ;; mirrors moving old versions to "legacy" - "http://mirror.checkdomain.de/imagemagick/" - "http://ftp.surfnet.nl/pub/ImageMagick/" - "http://mirror.searchdaimon.com/ImageMagick" - "http://mirror.is.co.za/pub/imagemagick/" - "http://www.imagemagick.org/download/" - "ftp://mirror.aarnet.edu.au/pub/imagemagick/" - "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/" - "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/" + "https://sunsite.icm.edu.pl/packages/ImageMagick/releases" + "http://mirror.checkdomain.de/imagemagick/releases" + "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/releases" "ftp://ftp.nluug.nl/pub/ImageMagick/" - "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/" - "ftp://ftp.fifi.org/pub/ImageMagick/" - ;; one legacy location as a last resort - "http://www.imagemagick.org/download/legacy/") + "http://www.imagemagick.org/download/releases/" + ;; Try this if all else fails (normally contains just the latest version). + "http://www.imagemagick.org/download/") (debian "http://ftp.de.debian.org/debian/" "http://ftp.fr.debian.org/debian/" diff --git a/guix/glob.scm b/guix/glob.scm index a9fc744802..d73783cd30 100644 --- a/guix/glob.scm +++ b/guix/glob.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Giacomo Leidi <goodoldpaul@autistici.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,6 +62,11 @@ STR, a glob pattern such as \"foo*\" or \"foo??bar\"." (flatten (reverse (if (null? pending) result (cons-string pending result))))) + ((#\* #\* #\/ . rest) + (if (zero? brackets) + (loop rest '() 0 + (cons* '**/ (cons-string pending result))) + (loop rest (cons '**/ pending) brackets result))) (((and chr (or #\? #\*)) . rest) (let ((wildcard (match chr (#\? '?) @@ -121,6 +127,15 @@ STR, a glob pattern such as \"foo*\" or \"foo??bar\"." (string-null? str)) (('*) #t) + (('**/) + #t) + (('**/ suffix . rest) + (let ((rest (if (eq? '* suffix) (cdr rest) rest)) + (suffix (if (eq? '* suffix) (car rest) suffix))) + (match (string-contains str suffix) + (#f #f) + (index (loop rest (string-drop str + (+ index (string-length suffix)))))))) (('* suffix . rest) (match (string-contains str suffix) (#f #f) diff --git a/guix/http-client.scm b/guix/http-client.scm index a767175d67..553640fe9e 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> @@ -70,6 +70,7 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t) + (keep-alive? #f) (verify-certificate? #t) (headers '((user-agent . "GNU Guile"))) timeout) @@ -79,6 +80,9 @@ textual. Follow any HTTP redirection. When BUFFERED? is #f, return an unbuffered port, suitable for use in `filtered-port'. HEADERS is an alist of extra HTTP headers. +When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is +not closed upon completion. + When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. TIMEOUT specifies the timeout in seconds for connection establishment; when @@ -104,11 +108,7 @@ Raise an '&http-get-error' condition if downloading fails." (setvbuf port 'none)) (let*-values (((resp data) (http-get uri #:streaming? #t #:port port - ;; XXX: When #:keep-alive? is true, if DATA is - ;; a chunked-encoding port, closing DATA won't - ;; close PORT, leading to a file descriptor - ;; leak. - #:keep-alive? #f + #:keep-alive? keep-alive? #:headers headers)) ((code) (response-code resp))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d6baa6b5e5..1d25a5125e 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -142,9 +143,9 @@ package definition." (define %cran-url "https://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.11. Bioconductor packages should be +;; The latest Bioconductor release is 3.12. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.11") +(define %bioconductor-version "3.12") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -585,7 +586,10 @@ s-expression corresponding to that package, or #f on failure." ((bioconductor) ;; Retry import from CRAN (cran->guix-package package-name #:repo 'cran)) - (else (values #f '())))))))) + (else + (raise (condition + (&message + (message "couldn't find meta-data for R package"))))))))))) (define* (cran-recursive-import package-name #:key (repo 'cran)) (recursive-import package-name diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 867812124d..670973b193 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -120,12 +120,29 @@ (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":"))) -(define (get-opam-repository) +(define* (get-opam-repository #:optional repo) "Update or fetch the latest version of the opam repository and return the path to the repository." - (receive (location commit _) - (update-cached-checkout "https://github.com/ocaml/opam-repository") - location)) + (let ((url (cond + ((or (not repo) (equal? repo 'opam)) + "https://github.com/ocaml/opam-repository") + ((string-prefix? "coq-" (symbol->string repo)) + "https://github.com/coq/opam-coq-archive") + ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive") + (else (throw 'unknown-repository repo))))) + (receive (location commit _) + (update-cached-checkout url) + (cond + ((or (not repo) (equal? repo 'opam)) + location) + ((equal? repo 'coq) + (string-append location "/released")) + ((string-prefix? "coq-" (symbol->string repo)) + (string-append location "/" (substring (symbol->string repo) 4))) + (else location))))) + +;; Prevent Guile 3 from inlining this procedure so we can mock it in tests. +(set! get-opam-repository get-opam-repository) (define (latest-version versions) "Find the most recent version from a list of versions." @@ -161,6 +178,7 @@ path to the repository." (substitute-char (cond ((equal? name "ocamlfind") "ocaml-findlib") + ((equal? name "coq") name) ((string-prefix? "ocaml" name) name) ((string-prefix? "conf-" name) (substring name 5)) (else (string-append "ocaml-" name))) @@ -235,12 +253,15 @@ path to the repository." (equal? "ocaml" name)) names))) -(define (depends->inputs depends) +(define (filter-dependencies depends) + "Remove implicit dependencies from the list of dependencies in @var{depends}." (filter (lambda (name) - (and (not (equal? "" name)) - (not (equal? "ocaml" name)) - (not (equal? "ocamlfind" name)))) - (map dependency->input depends))) + (and (not (member name '("" "ocaml" "ocamlfind" "dune" "jbuilder"))) + (not (string-prefix? "base-" name)))) + depends)) + +(define (depends->inputs depends) + (filter-dependencies (map dependency->input depends))) (define (depends->native-inputs depends) (filter (lambda (name) (not (equal? "" name))) @@ -261,18 +282,19 @@ path to the repository." (substring version 1) version))))) -(define* (opam->guix-package name #:key (repository (get-opam-repository)) version) +(define* (opam->guix-package name #:key (repo 'opam) version) "Import OPAM package NAME from REPOSITORY (a directory name) or, if REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." - (and-let* ((opam-file (opam-fetch name repository)) + (and-let* ((opam-file (opam-fetch name (get-opam-repository repo))) (version (assoc-ref opam-file "version")) - (opam-content (pk (assoc-ref opam-file "metadata"))) + (opam-content (assoc-ref opam-file "metadata")) (url-dict (metadata-ref opam-content "url")) (source-url (or (metadata-ref url-dict "src") (metadata-ref url-dict "archive"))) (requirements (metadata-ref opam-content "depends")) - (dependencies (dependency-list->names requirements)) + (names (dependency-list->names requirements)) + (dependencies (filter-dependencies names)) (native-dependencies (depends->native-inputs requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) (native-inputs (dependency-list->inputs @@ -282,10 +304,7 @@ or #f on failure." (lambda (name) (not (member name '("dune" "jbuilder")))) native-dependencies)))) - ;; If one of these are required at build time, it means we - ;; can use the much nicer dune-build-system. - (let ((use-dune? (or (member "dune" (append dependencies native-dependencies)) - (member "jbuilder" (append dependencies native-dependencies))))) + (let ((use-dune? (member "dune" names))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -322,10 +341,11 @@ or #f on failure." (not (member name '("dune" "jbuilder")))) dependencies)))))))) -(define (opam-recursive-import package-name) +(define* (opam-recursive-import package-name #:key repo) (recursive-import package-name #:repo->guix-package opam->guix-package - #:guix-name ocaml-name->guix-name)) + #:guix-name ocaml-name->guix-name + #:repo repo)) (define (guix-name->opam-name name) (if (string-prefix? "ocaml-" name) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 7de95349cd..e227c2e42d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -275,9 +275,9 @@ version. If APPEND-VERSION?/string is a string, append this string." (cond ((string? append-version?/string) (string-append name "-" append-version?/string)) - ((= append-version?/string #t) + ((eq? append-version?/string #t) (string-append name "-" (version-major+minor version))) - ((#t) version))) + (else name))) ,guix-package)))) (define (build-system-modules) diff --git a/guix/profiles.scm b/guix/profiles.scm index 1b15257210..59a313ea08 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -399,22 +399,24 @@ denoting a specific output of a package." 'inferior-package->manifest-entry)) (manifest - (map (match-lambda - (((? package? package) output) - (package->manifest-entry package output)) - ((? package? package) - (package->manifest-entry package)) - ((thing output) - (if inferiors-loaded? - ((inferior->entry) thing output) - (throw 'wrong-type-arg 'packages->manifest - "Wrong package object: ~S" (list thing) (list thing)))) - (thing - (if inferiors-loaded? - ((inferior->entry) thing) - (throw 'wrong-type-arg 'packages->manifest - "Wrong package object: ~S" (list thing) (list thing))))) - packages))) + (delete-duplicates + (map (match-lambda + (((? package? package) output) + (package->manifest-entry package output)) + ((? package? package) + (package->manifest-entry package)) + ((thing output) + (if inferiors-loaded? + ((inferior->entry) thing output) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing)))) + (thing + (if inferiors-loaded? + ((inferior->entry) thing) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing))))) + packages) + manifest-entry=?))) (define (manifest->gexp manifest) "Return a representation of MANIFEST as a gexp." @@ -716,6 +718,12 @@ replace it." (manifest-pattern (name (manifest-entry-name entry)) (output (manifest-entry-output entry)))) + (define manifest-entry-pair=? + (match-lambda* + (((m1a . m2a) (m1b . m2b)) + (and (manifest-entry=? m1a m1b) + (manifest-entry=? m2a m2b))) + (_ #f))) (let loop ((input (manifest-transaction-install transaction)) (install '()) @@ -724,8 +732,16 @@ replace it." (match input (() (let ((remove (manifest-transaction-remove transaction))) - (values (manifest-matching-entries manifest remove) - (reverse install) (reverse upgrade) (reverse downgrade)))) + (values (delete-duplicates + (manifest-matching-entries manifest remove) + manifest-entry=?) + (delete-duplicates (reverse install) manifest-entry=?) + (delete-duplicates + (reverse upgrade) + manifest-entry-pair=?) + (delete-duplicates + (reverse downgrade) + manifest-entry-pair=?)))) ((entry rest ...) ;; Check whether installing ENTRY corresponds to the installation of a ;; new package or to an upgrade. diff --git a/guix/progress.scm b/guix/progress.scm index fec65b424c..cd80ae620a 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -337,9 +337,10 @@ should be a <progress-reporter> object." (report total) (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) -(define (progress-report-port reporter port) +(define* (progress-report-port reporter port #:key (close? #t)) "Return a port that continuously reports the bytes read from PORT using -REPORTER, which should be a <progress-reporter> object." +REPORTER, which should be a <progress-reporter> object. When CLOSE? is true, +PORT is closed when the returned port is closed." (match reporter (($ <progress-reporter> start report stop) (let* ((total 0) @@ -364,5 +365,6 @@ REPORTER, which should be a <progress-reporter> object." ;; trace. (unless (zero? total) (stop)) - (close-port port))))))) + (when close? + (close-port port)))))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 33944c4a3f..20e82ae2ca 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -97,10 +97,11 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) ((package-name) (if (assoc-ref opts 'recursive) ;; Recursive import - (map package->definition - (filter identity - (cran-recursive-import package-name - #:repo (or (assoc-ref opts 'repo) 'cran)))) + (with-error-handling + (map package->definition + (filter identity + (cran-recursive-import package-name + #:repo (or (assoc-ref opts 'repo) 'cran))))) ;; Single import (let ((sexp (cran->guix-package package-name #:repo (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index 20da1437fe..da9392821c 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -45,6 +45,8 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (display (G_ " -r, --recursive import packages recursively")) (display (G_ " + --repo import packages from this opam repository")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -58,6 +60,9 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import opam"))) + (option '(#f "repo") #t #f + (lambda (opt name arg result) + (alist-cons 'repo arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -79,6 +84,7 @@ Import and convert the opam package for PACKAGE-NAME.\n")) %default-options)) (let* ((opts (parse-options)) + (repo (and=> (assoc-ref opts 'repo) string->symbol)) (args (filter-map (match-lambda (('argument . value) value) @@ -93,9 +99,9 @@ Import and convert the opam package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (opam-recursive-import package-name)) + (opam-recursive-import package-name #:repo repo)) ;; Single import - (let ((sexp (opam->guix-package package-name))) + (let ((sexp (opam->guix-package package-name #:repo repo))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index feae2df9cb..25075eedff 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -88,6 +88,7 @@ write-narinfo %allow-unauthenticated-substitutes? + %error-to-file-descriptor-4? substitute-urls guix-substitute)) @@ -124,11 +125,7 @@ disabled!~%")) ;; purposes, and should be avoided otherwise. (make-parameter (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") - (cut string-ci=? <> "yes")) - (lambda (value) - (when value - (warn-about-missing-authentication)) - value))) + (cut string-ci=? <> "yes")))) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered @@ -191,9 +188,14 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t)) +(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." +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) @@ -209,7 +211,7 @@ provide." ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) + (let ((port port)) (with-timeout (if timeout? %fetch-timeout 0) @@ -220,10 +222,11 @@ provide." (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))) + 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~%") @@ -481,17 +484,17 @@ indicates that PATH is unavailable at CACHE-URL." (build-request (string->uri url) #:method 'GET #:headers headers))) (define (at-most max-length lst) - "If LST is shorter than MAX-LENGTH, return it; otherwise return its -MAX-LENGTH first elements." + "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise +return its MAX-LENGTH first elements and its tail." (let loop ((len 0) (lst lst) (result '())) (match lst (() - (reverse result)) + (values (reverse result) '())) ((head . tail) (if (>= len max-length) - (reverse result) + (values (reverse result) lst) (loop (+ 1 len) tail (cons head result))))))) (define* (http-multiple-get base-uri proc seed requests @@ -893,6 +896,9 @@ authorized substitutes." (define (valid? obj) (valid-narinfo? obj acl)) + (when (%allow-unauthenticated-substitutes?) + (warn-about-missing-authentication)) + (match (string-tokenize command) (("have" paths ..1) ;; Return the subset of PATHS available in CACHE-URLS. @@ -962,6 +968,68 @@ the URI, its compression method (a string), and the compressed file size." (((uri compression file-size) _ ...) (values uri compression file-size)))) +(define %max-cached-connections + ;; Maximum number of connections kept in cache by + ;; 'open-connection-for-uri/cached'. + 16) + +(define open-connection-for-uri/cached + (let ((cache '())) + (lambda* (uri #:key fresh?) + "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." + (define host (uri-host uri)) + (define scheme (uri-scheme uri)) + (define key (list host scheme (uri-port uri))) + + (and (not (memq scheme '(file #f))) + (match (assoc-ref cache key) + (#f + ;; Open a new connection to URI and evict old entries from + ;; CACHE, if any. + (let-values (((socket) + (guix:open-connection-for-uri + uri #:verify-certificate? #f)) + ((new-cache evicted) + (at-most (- %max-cached-connections 1) cache))) + (for-each (match-lambda + ((_ . port) + (false-if-exception (close-port port)))) + evicted) + (set! cache (alist-cons key socket new-cache)) + socket)) + (socket + (if (or fresh? (port-closed? socket)) + (begin + (false-if-exception (close-port socket)) + (set! cache (alist-delete key cache)) + (open-connection-for-uri/cached uri)) + (begin + ;; Drain input left from the previous use. + (drain-input socket) + socket)))))))) + +(define (call-with-cached-connection uri proc) + (let ((port (open-connection-for-uri/cached 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. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (memq key '(bad-response bad-header bad-header-component))) + (proc (open-connection-for-uri/cached 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 print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to @@ -984,10 +1052,12 @@ DESTINATION as a nar file. Verify the substitute against ACL." (G_ "Downloading ~a...~%") (uri->string uri))) (let*-values (((raw download-size) - ;; Note that Hydra currently generates Nars on the fly - ;; and doesn't specify a Content-Length, so - ;; DOWNLOAD-SIZE is #f in practice. - (fetch uri #:buffered? #f #:timeout? #f)) + ;; '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))) ((progress) (let* ((dl-size (or download-size (and (equal? compression "none") @@ -1001,7 +1071,9 @@ DESTINATION as a nar file. Verify the substitute against ACL." (uri->string uri) dl-size (current-error-port) #:abbreviation nar-uri-abbreviation)))) - (progress-report-port reporter raw))) + ;; Keep RAW open upon completion so we can later reuse + ;; the underlying connection. + (progress-report-port reporter raw #:close? #f))) ((input pids) ;; NOTE: This 'progress' port of current process will be ;; closed here, while the child process doing the @@ -1017,7 +1089,10 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Skip a line after what 'progress-reporter/file' printed, and another ;; one to visually separate substitutions. - (display "\n\n" (current-error-port))))) + (display "\n\n" (current-error-port)) + + ;; Tell the daemon that we're done. + (display "success\n" (current-output-port))))) ;;; @@ -1128,6 +1203,11 @@ default value." (unless (string->uri uri) (leave (G_ "~a: invalid URI~%") uri))) +(define %error-to-file-descriptor-4? + ;; Whether to direct 'current-error-port' to file descriptor 4 like + ;; 'guix-daemon' expects. + (make-parameter #t)) + (define-command (guix-substitute . args) (category internal) (synopsis "implement the build daemon's substituter protocol") @@ -1139,71 +1219,78 @@ default value." ((= string->number number) (> number 0)) (_ #f))) - (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cache-entries %narinfo-cache-directory - cached-narinfo-files - #:entry-expiration - cached-narinfo-expiration-time - #:cleanup-period - %narinfo-expired-cache-entry-removal-delay) - (check-acl-initialized) - - ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly - ;; when we know we cannot substitute, but we must emit a newline on stdout - ;; when everything is alright. - (when (null? (substitute-urls)) - (exit 0)) - - ;; Say hello (see above.) - (newline) - (force-output (current-output-port)) - - ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error message. - (for-each validate-uri (substitute-urls)) - - ;; Attempt to install the client's locale so that messages are suitably - ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default so - ;; don't change it. - (match (or (find-daemon-option "untrusted-locale") - (find-daemon-option "locale")) - (#f #f) - (locale (false-if-exception (setlocale LC_MESSAGES locale)))) - - (catch 'system-error - (lambda () - (set-thread-name "guix substitute")) - (const #t)) ;GNU/Hurd lacks 'prctl' - - (with-networking - (with-error-handling ; for signature errors - (match args - (("--query") - (let ((acl (current-acl))) - (let loop ((command (read-line))) - (or (eof-object? command) - (begin - (process-query command - #:cache-urls (substitute-urls) - #:acl acl) - (loop (read-line))))))) - (("--substitute" store-path destination) - ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. - ;; Specify the number of columns of the terminal so the progress - ;; report displays nicely. - (parameterize ((current-terminal-columns (client-terminal-columns))) - (process-substitution store-path destination - #:cache-urls (substitute-urls) - #:acl (current-acl) - #:print-build-trace? print-build-trace?))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix substitute")) - (("--help") - (show-help)) - (opts - (leave (G_ "~a: unrecognized options~%") opts)))))) + ;; 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)) + + (mkdir-p %narinfo-cache-directory) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) + (check-acl-initialized) + + ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error + ;; message. + (for-each validate-uri (substitute-urls)) + + ;; Attempt to install the client's locale so that messages are suitably + ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default + ;; so don't change it. + (match (or (find-daemon-option "untrusted-locale") + (find-daemon-option "locale")) + (#f #f) + (locale (false-if-exception (setlocale LC_MESSAGES locale)))) + + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' + + (with-networking + (with-error-handling ; for signature errors + (match args + (("--query") + (let ((acl (current-acl))) + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (process-query command + #:cache-urls (substitute-urls) + #:acl acl) + (loop (read-line))))))) + (("--substitute") + ;; Download STORE-PATH and store it as a Nar in file DESTINATION. + ;; Specify the number of columns of the terminal so the progress + ;; report displays nicely. + (parameterize ((current-terminal-columns (client-terminal-columns))) + (let loop () + (match (read-line) + ((? eof-object?) + #t) + ((= string-tokenize ("substitute" store-path destination)) + (process-substitution store-path destination + #:cache-urls (substitute-urls) + #:acl (current-acl) + #:print-build-trace? + print-build-trace?) + (loop)))))) + ((or ("-V") ("--version")) + (show-version-and-exit "guix substitute")) + (("--help") + (show-help)) + (opts + (leave (G_ "~a: unrecognized options~%") opts))))))) ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) +;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) ;;; End: ;;; substitute.scm ends here diff --git a/guix/self.scm b/guix/self.scm index c0de14b79a..7cda6656c9 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -649,18 +649,26 @@ load path." (program-file "guix-command" #~(begin + ;; Remove the empty extension from the search path. + (set! %load-extensions '(".scm")) + (set! %load-path - (cons (string-append #$module-directory - "/share/guile/site/" - (effective-version)) - %load-path)) + (append (list (string-append #$module-directory + "/share/guile/site/" + (effective-version)) + (string-append #$guile "/share/guile/" + (effective-version))) + %load-path)) (set! %load-compiled-path - (cons (string-append #$module-directory - "/lib/guile/" - (effective-version) - "/site-ccache") - %load-compiled-path)) + (append (list (string-append #$module-directory + "/lib/guile/" + (effective-version) + "/site-ccache") + (string-append #$guile "/lib/guile/" + (effective-version) + "/ccache")) + %load-compiled-path)) ;; To maximize the chances that locales are set up right ;; out-of-the-box, bundle "common" UTF-8 locales. diff --git a/guix/store/database.scm b/guix/store/database.scm index 2ea63b17aa..b36b127630 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,7 +21,6 @@ (define-module (guix store database) #:use-module (sqlite3) #:use-module (guix config) - #:use-module (guix gexp) #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) @@ -29,7 +28,6 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) - #:use-module (guix utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) |