diff options
Diffstat (limited to 'guix/scripts/substitute.scm')
| -rwxr-xr-x | guix/scripts/substitute.scm | 298 |
1 files changed, 13 insertions, 285 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index e53de8c304..f9bcead045 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix narinfo) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix combinators) @@ -67,29 +69,8 @@ #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) - #:export (narinfo-signature->canonical-sexp - - narinfo? - narinfo-path - narinfo-uris - narinfo-uri-base - narinfo-compressions - narinfo-file-hashes - narinfo-file-sizes - narinfo-hash - narinfo-size - narinfo-references - narinfo-deriver - narinfo-system - narinfo-signature - - narinfo-hash->sha256 - narinfo-best-uri - - lookup-narinfos + #:export (lookup-narinfos lookup-narinfos/diverse - read-narinfo - write-narinfo %allow-unauthenticated-substitutes? %error-to-file-descriptor-4? @@ -149,10 +130,6 @@ disabled!~%")) ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) -(define fields->alist - ;; The narinfo format is really just like recutils. - recutils->alist) - (define %fetch-timeout ;; Number of seconds after which networking is considered "slow". 5) @@ -236,191 +213,6 @@ connection (typically PORT) is kept open once data has been fetched from URI." (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) - -(define-record-type <narinfo> - (%make-narinfo path uri-base uris compressions file-sizes file-hashes - nar-hash nar-size references deriver system - signature contents) - narinfo? - (path narinfo-path) - (uri-base narinfo-uri-base) ;URI of the cache it originates from - (uris narinfo-uris) ;list of strings - (compressions narinfo-compressions) ;list of strings - (file-sizes narinfo-file-sizes) ;list of (integers | #f) - (file-hashes narinfo-file-hashes) - (nar-hash narinfo-hash) - (nar-size narinfo-size) - (references narinfo-references) - (deriver narinfo-deriver) - (system narinfo-system) - (signature narinfo-signature) ; canonical sexp - ;; The original contents of a narinfo file. This field is needed because we - ;; want to preserve the exact textual representation for verification purposes. - ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> - ;; for more information. - (contents narinfo-contents)) - -(define (narinfo-hash-algorithm+value narinfo) - "Return two values: the hash algorithm used by NARINFO and its value as a -bytevector." - (match (string-tokenize (narinfo-hash narinfo) - (char-set-complement (char-set #\:))) - ((algorithm base32) - (values (lookup-hash-algorithm (string->symbol algorithm)) - (nix-base32-string->bytevector base32))) - (_ - (raise (formatted-message - (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) - -(define (narinfo-hash->sha256 hash) - "If the string HASH denotes a sha256 hash, return it as a bytevector. -Otherwise return #f." - (and (string-prefix? "sha256:" hash) - (nix-base32-string->bytevector (string-drop hash 7)))) - -(define (narinfo-signature->canonical-sexp str) - "Return the value of a narinfo's 'Signature' field as a canonical sexp." - (match (string-split str #\;) - ((version host-name sig) - (let ((maybe-number (string->number version))) - (cond ((not (number? maybe-number)) - (leave (G_ "signature version must be a number: ~s~%") - version)) - ;; Currently, there are no other versions. - ((not (= 1 maybe-number)) - (leave (G_ "unsupported signature version: ~a~%") - maybe-number)) - (else - (let ((signature (utf8->string (base64-decode sig)))) - (catch 'gcry-error - (lambda () - (string->canonical-sexp signature)) - (lambda (key proc err) - (leave (G_ "signature is not a valid \ -s-expression: ~s~%") - signature)))))))) - (x - (leave (G_ "invalid format of the signature field: ~a~%") x)))) - -(define (narinfo-maker str cache-url) - "Return a narinfo constructor for narinfos originating from CACHE-URL. STR -must contain the original contents of a narinfo file." - (lambda (path urls compressions file-hashes file-sizes - nar-hash nar-size references deriver system - signature) - "Return a new <narinfo> object." - (define len (length urls)) - (%make-narinfo path cache-url - ;; Handle the case where URL is a relative URL. - (map (lambda (url) - (or (string->uri url) - (string->uri - (string-append cache-url "/" url)))) - urls) - compressions - (match file-sizes - (() (make-list len #f)) - ((lst ...) (map string->number lst))) - (match file-hashes - (() (make-list len #f)) - ((lst ...) (map string->number lst))) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system - (false-if-exception - (and=> signature narinfo-signature->canonical-sexp)) - str))) - -(define* (read-narinfo port #:optional url - #:key size) - "Read a narinfo from PORT. If URL is true, it must be a string used to -build full URIs from relative URIs found while reading PORT. When SIZE is -true, read at most SIZE bytes from PORT; otherwise, read as much as possible. - -No authentication and authorization checks are performed here!" - (let ((str (utf8->string (if size - (get-bytevector-n port size) - (get-bytevector-all port))))) - (alist->record (call-with-input-string str fields->alist) - (narinfo-maker str url) - '("StorePath" "URL" "Compression" - "FileHash" "FileSize" "NarHash" "NarSize" - "References" "Deriver" "System" - "Signature") - '("URL" "Compression" "FileSize" "FileHash")))) - -(define (narinfo-sha256 narinfo) - "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a -'Signature' field." - (define %mandatory-fields - ;; List of fields that must be signed. If they are not signed, the - ;; narinfo is considered unsigned. - '("StorePath" "NarHash" "References")) - - (let ((contents (narinfo-contents narinfo))) - (match (string-contains contents "Signature:") - (#f #f) - (index - (let* ((above-signature (string-take contents index)) - (signed-fields (match (call-with-input-string above-signature - fields->alist) - (((fields . values) ...) fields)))) - (and (every (cut member <> signed-fields) %mandatory-fields) - (sha256 (string->utf8 above-signature)))))))) - -(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) - #:key verbose?) - "Return #t if NARINFO's signature is not valid." - (or (%allow-unauthenticated-substitutes?) - (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo)) - (uri (uri->string (first (narinfo-uris narinfo))))) - (and hash signature - (signature-case (signature hash acl) - (valid-signature #t) - (invalid-signature - (when verbose? - (format (current-error-port) - "invalid signature for substitute at '~a'~%" - uri)) - #f) - (hash-mismatch - (when verbose? - (format (current-error-port) - "hash mismatch for substitute at '~a'~%" - uri)) - #f) - (unauthorized-key - (when verbose? - (format (current-error-port) - "substitute at '~a' is signed by an \ -unauthorized party~%" - uri)) - #f) - (corrupt-signature - (when verbose? - (format (current-error-port) - "corrupt signature for substitute at '~a'~%" - uri)) - #f)))))) - -(define (write-narinfo narinfo port) - "Write NARINFO to PORT." - (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) - -(define (narinfo->string narinfo) - "Return the external representation of NARINFO." - (call-with-output-string (cut write-narinfo narinfo <>))) - -(define (string->narinfo str cache-uri) - "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of -the cache STR originates form." - (call-with-input-string str (cut read-narinfo <> cache-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." @@ -742,22 +534,6 @@ information is available locally." (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (equivalent-narinfo? narinfo1 narinfo2) - "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe -the same store item. This ignores unnecessary metadata such as the Nar URL." - (and (string=? (narinfo-hash narinfo1) - (narinfo-hash narinfo2)) - - ;; The following is not needed if all we want is to download a valid - ;; nar, but it's necessary if we want valid narinfo. - (string=? (narinfo-path narinfo1) - (narinfo-path narinfo2)) - (equal? (narinfo-references narinfo1) - (narinfo-references narinfo2)) - - (= (narinfo-size narinfo1) - (narinfo-size narinfo2)))) - (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 @@ -918,11 +694,14 @@ expected by the daemon." "Reply to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." - (define (valid? obj) - (valid-narinfo? obj acl)) + (define valid? + (if (%allow-unauthenticated-substitutes?) + (begin + (warn-about-missing-authentication) - (when (%allow-unauthenticated-substitutes?) - (warn-about-missing-authentication)) + (const #t)) + (lambda (obj) + (valid-narinfo? obj acl)))) (match (string-tokenize command) (("have" paths ..1) @@ -940,59 +719,6 @@ authorized substitutes." (wtf (error "unknown `--query' command" wtf)))) -(define %compression-methods - ;; Known compression methods and a thunk to determine whether they're - ;; supported. See 'decompressed-port' in (guix utils). - `(("gzip" . ,(const #t)) - ("lzip" . ,(const #t)) - ("xz" . ,(const #t)) - ("bzip2" . ,(const #t)) - ("none" . ,(const #t)))) - -(define (supported-compression? compression) - "Return true if COMPRESSION, a string, denotes a supported compression -method." - (match (assoc-ref %compression-methods compression) - (#f #f) - (supported? (supported?)))) - -(define (compresses-better? compression1 compression2) - "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; -this is a rough approximation." - (match compression1 - ("none" #f) - ("gzip" (string=? compression2 "none")) - (_ (or (string=? compression2 "none") - (string=? compression2 "gzip"))))) - -(define (narinfo-best-uri narinfo) - "Select the \"best\" URI to download NARINFO's nar, and return three values: -the URI, its compression method (a string), and the compressed file size." - (define choices - (filter (match-lambda - ((uri compression file-size) - (supported-compression? compression))) - (zip (narinfo-uris narinfo) - (narinfo-compressions narinfo) - (narinfo-file-sizes narinfo)))) - - (define (file-size<? c1 c2) - (match c1 - ((uri1 compression1 (? integer? file-size1)) - (match c2 - ((uri2 compression2 (? integer? file-size2)) - (< file-size1 file-size2)) - (_ #t))) - ((uri compression1 #f) - (match c2 - ((uri2 compression2 _) - (compresses-better? compression1 compression2)))) - (_ #f))) ;we can't tell - - (match (sort choices 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'. @@ -1079,7 +805,9 @@ DESTINATION is in the store, deduplicate its files. Print a status line on the current output port." (define narinfo (lookup-narinfo cache-urls store-item - (cut valid-narinfo? <> acl))) + (if (%allow-unauthenticated-substitutes?) + (const #t) + (cut valid-narinfo? <> acl)))) (define destination-in-store? (string-prefix? (string-append (%store-prefix) "/") |