diff --git a/Makefile.am b/Makefile.am index 99bdcfa346..5dcd3c6fd3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -103,6 +103,7 @@ MODULES = \ guix/profiles.scm \ guix/serialization.scm \ guix/nar.scm \ + guix/narinfo.scm \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ diff --git a/guix/narinfo.scm b/guix/narinfo.scm new file mode 100644 index 0000000000..241090ec98 --- /dev/null +++ b/guix/narinfo.scm @@ -0,0 +1,326 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2014 Nikita Karetnikov +;;; Copyright © 2018 Kyle Meyer +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix narinfo) + #:use-module (guix pki) + #:use-module (guix i18n) + #:use-module (guix base32) + #:use-module (guix base64) + #:use-module (guix records) + #:use-module (guix diagnostics) + #:use-module (guix scripts substitute) + #:use-module (gcrypt hash) + #:use-module (gcrypt pk-crypto) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:use-module (web uri) + #: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-algorithm+value + + narinfo-hash->sha256 + narinfo-best-uri + + valid-narinfo? + + read-narinfo + write-narinfo + + string->narinfo + narinfo->string + + equivalent-narinfo?)) + +(define-record-type + (%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 + ;; 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 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 fields->alist + ;; The narinfo format is really just like recutils. + recutils->alist) + +(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." + (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 (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 %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)) + ("zstd" . ,(lambda () + (resolve-module '(zstd) #t #f #:ensure #f))) + ("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")) + ("lzip" #t) + (_ (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-sizecanonical-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? @@ -150,10 +130,6 @@ (define %narinfo-expired-cache-entry-removal-delay ;; 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) @@ -237,190 +213,6 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t) (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) - -(define-record-type - (%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 - ;; 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 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." - (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." @@ -741,22 +533,6 @@ (define (lookup-narinfos cache paths) (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 @@ -942,62 +718,6 @@ (define valid? (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)) - ("zstd" . ,(lambda () - (resolve-module '(zstd) #t #f #:ensure #f))) - ("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")) - ("lzip" #t) - (_ (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