From patchwork Thu Dec 24 17:22:19 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 25929 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id E69C527BC06; Thu, 24 Dec 2020 17:23:41 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL,SPF_HELO_PASS,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 9D0B827BC05 for ; Thu, 24 Dec 2020 17:23:37 +0000 (GMT) Received: from localhost ([::1]:42096 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ksUKu-0007cr-Nz for patchwork@mira.cbaines.net; Thu, 24 Dec 2020 12:23:36 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:46152) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ksUKM-0006Vl-Kc for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:44420) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ksUKM-0007cB-Bu for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ksUKM-0003hs-8f for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute script to module. References: <87y2hn9l8j.fsf@cbaines.net> In-Reply-To: <87y2hn9l8j.fsf@cbaines.net> Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 24 Dec 2020 17:23:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 45409 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 45409@debbugs.gnu.org Received: via spool by 45409-submit@debbugs.gnu.org id=B45409.160883055114182 (code B ref 45409); Thu, 24 Dec 2020 17:23:02 +0000 Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:31 +0000 Received: from localhost ([127.0.0.1]:55963 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJq-0003ge-5a for submit@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:31 -0500 Received: from mira.cbaines.net ([212.71.252.8]:56754) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJk-0003g8-Q4 for 45409@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:26 -0500 Received: from localhost (188.29.98.108.threembb.co.uk [188.29.98.108]) by mira.cbaines.net (Postfix) with ESMTPSA id A841C17AE0 for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:23 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 62cd78b7 for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC) From: Christopher Baines Date: Thu, 24 Dec 2020 17:22:19 +0000 Message-Id: <20201224172221.21057-1-mail@cbaines.net> X-Mailer: git-send-email 2.29.2 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches This separation between the code for dealing with narinfos from the code doing that for a purpose should make things clearer, and better support components other that the substitute script in using this code. This is just moving the code around, no code should have been significantly changed. * guix/scripts/substitute.scm (): Move record type to (guix narinfo). (fields->alist, narinfo-hash-algorithm+value, narinfo-hash->sha256, narinfo-signature->canonical-sexp, narinfo-maker, read-narinfo, narinfo-sha256, valid-narinfo?, write-narinfo, narinfo->string, string->narinfo, equivalent-narinfo?, supported-compression?, compresses-better?, narinfo-best-uri): Move procedures to (guix narinfo). (%compression-methods): Move variable to (guix narinfo). * guix/narinfo.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/narinfo.scm | 326 ++++++++++++++++++++++++++++++++++++ guix/scripts/challenge.scm | 1 + guix/scripts/substitute.scm | 282 +------------------------------ guix/scripts/weather.scm | 1 + 5 files changed, 331 insertions(+), 280 deletions(-) create mode 100644 guix/narinfo.scm diff --git a/Makefile.am b/Makefile.am index e0ee65fcce..8ca837a3ee 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..3ecb2f039e --- /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 ui) + #: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." + (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 (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)) + ("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-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? @@ -148,10 +128,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) @@ -235,191 +211,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 - (%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." - (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." @@ -741,22 +532,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 @@ -939,59 +714,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 X-Patchwork-Id: 25928 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id ED05627BC05; Thu, 24 Dec 2020 17:23:14 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL,SPF_HELO_PASS,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 7A30317AE0 for ; Thu, 24 Dec 2020 17:23:14 +0000 (GMT) Received: from localhost ([::1]:39886 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ksUKX-0006hI-DA for patchwork@mira.cbaines.net; Thu, 24 Dec 2020 12:23:13 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:46150) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ksUKM-0006Uz-9U for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:44419) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ksUKL-0007c6-VR for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ksUKL-0003hl-S2 for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#45409] [PATCH 2/3] guix: Untangle (guix narinfo) from (guix scripts substitute). Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 24 Dec 2020 17:23:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 45409 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 45409@debbugs.gnu.org Received: via spool by 45409-submit@debbugs.gnu.org id=B45409.160883054714165 (code B ref 45409); Thu, 24 Dec 2020 17:23:01 +0000 Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:27 +0000 Received: from localhost ([127.0.0.1]:55961 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJm-0003gJ-5J for submit@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:27 -0500 Received: from mira.cbaines.net ([212.71.252.8]:56756) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJk-0003g9-O2 for 45409@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:25 -0500 Received: from localhost (188.29.98.108.threembb.co.uk [188.29.98.108]) by mira.cbaines.net (Postfix) with ESMTPSA id C0ED127BC05 for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:23 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id d37596f4 for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC) From: Christopher Baines Date: Thu, 24 Dec 2020 17:22:20 +0000 Message-Id: <20201224172221.21057-2-mail@cbaines.net> X-Mailer: git-send-email 2.29.2 In-Reply-To: <20201224172221.21057-1-mail@cbaines.net> References: <20201224172221.21057-1-mail@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches Moving the code left the %allow-unauthenticated-substitutes? parameter working across both modules, which isn't very clear. Instead just use %allow-unauthenticated-substitutes? in the substitute module. * guix/scripts/substitute.scm (process-query, process-substitution): Change the authorized? argument to lookup-narinfo and lookup-narinfos/diverse based on %allow-unauthenticated-substitutes?. * guix/narinfo.scm (valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?. --- guix/narinfo.scm | 63 ++++++++++++++++++------------------- guix/scripts/substitute.scm | 16 +++++++--- 2 files changed, 42 insertions(+), 37 deletions(-) diff --git a/guix/narinfo.scm b/guix/narinfo.scm index 3ecb2f039e..8aa9e53ebd 100644 --- a/guix/narinfo.scm +++ b/guix/narinfo.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; Copyright © 2018 Kyle Meyer +;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +27,6 @@ #: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) @@ -209,38 +209,37 @@ No authentication and authorization checks are performed here!" (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) #:key verbose?) "Return #t if NARINFO's signature is not valid." - (or (%allow-unauthenticated-substitutes?) - (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 \ + (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)))))) + 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." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 72242b73f1..e2d30f1760 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 ;;; Copyright © 2014 Nikita Karetnikov ;;; Copyright © 2018 Kyle Meyer +;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -692,11 +693,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) @@ -797,7 +801,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) "/") From patchwork Thu Dec 24 17:22:21 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 25930 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A03E127BC06; Thu, 24 Dec 2020 17:23:49 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL,SPF_HELO_PASS,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id E579527BC05 for ; Thu, 24 Dec 2020 17:23:45 +0000 (GMT) Received: from localhost ([::1]:42766 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ksUL3-0007tH-2E for patchwork@mira.cbaines.net; Thu, 24 Dec 2020 12:23:45 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:46158) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ksUKN-0006Wt-3d for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:44421) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ksUKM-0007cK-RZ for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ksUKM-0003i0-O6 for guix-patches@gnu.org; Thu, 24 Dec 2020 12:23:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#45409] [PATCH 3/3] guix: Split (guix substitute) from (guix scripts substitute). Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 24 Dec 2020 17:23:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 45409 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 45409@debbugs.gnu.org Received: via spool by 45409-submit@debbugs.gnu.org id=B45409.160883056214201 (code B ref 45409); Thu, 24 Dec 2020 17:23:02 +0000 Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:42 +0000 Received: from localhost ([127.0.0.1]:55965 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJr-0003gh-Bp for submit@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:42 -0500 Received: from mira.cbaines.net ([212.71.252.8]:56758) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ksUJk-0003gA-QL for 45409@debbugs.gnu.org; Thu, 24 Dec 2020 12:22:27 -0500 Received: from localhost (188.29.98.108.threembb.co.uk [188.29.98.108]) by mira.cbaines.net (Postfix) with ESMTPSA id CF83527BC06 for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:23 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id c26743eb for <45409@debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC) From: Christopher Baines Date: Thu, 24 Dec 2020 17:22:21 +0000 Message-Id: <20201224172221.21057-3-mail@cbaines.net> X-Mailer: git-send-email 2.29.2 In-Reply-To: <20201224172221.21057-1-mail@cbaines.net> References: <20201224172221.21057-1-mail@cbaines.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches This means there's a module for working with substitutes, rather than all the code sitting in the script. The need for this can be seen with the weather and challenge scripts, that now don't have to use code from the substitute script, but can instead use the substitute module. The separation here between the actual functionality of the substitute script and the underlying functionality used both there and elsewhere should make maintenance easier moving forward. This commit just moves code, none of the code should have been changed significantly. --- Makefile.am | 1 + guix/scripts/challenge.scm | 2 +- guix/scripts/substitute.scm | 482 +-------------------------------- guix/scripts/weather.scm | 2 +- guix/substitute.scm | 527 ++++++++++++++++++++++++++++++++++++ 5 files changed, 535 insertions(+), 479 deletions(-) create mode 100644 guix/substitute.scm diff --git a/Makefile.am b/Makefile.am index 8ca837a3ee..5c3b565853 100644 --- a/Makefile.am +++ b/Makefile.am @@ -89,6 +89,7 @@ MODULES = \ guix/memoization.scm \ guix/utils.scm \ guix/sets.scm \ + guix/substitute.scm \ guix/modules.scm \ guix/download.scm \ guix/discovery.scm \ diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index cc9cbe6f27..ea54b1a0a2 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -27,8 +27,8 @@ #:use-module (guix packages) #:use-module ((guix progress) #:hide (dump-port*)) #:use-module (guix serialization) - #:use-module (guix scripts substitute) #:use-module (guix narinfo) + #:use-module (guix substitute) #:use-module (rnrs bytevectors) #:autoload (guix http-client) (http-fetch) #:use-module ((guix build syscalls) #:select (terminal-columns)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index e2d30f1760..d57b83154a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -23,38 +23,30 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix narinfo) + #:use-module (guix substitute) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix combinators) - #:use-module (guix config) - #:use-module (guix records) - #:use-module (guix diagnostics) #:use-module (guix i18n) #:use-module ((guix serialization) #:select (restore-file dump-file)) #:autoload (guix store deduplication) (dump-file/deduplicate) #:autoload (guix scripts discover) (read-substitute-urls) #:use-module (gcrypt hash) #:use-module (guix base32) - #:use-module (guix base64) #:use-module (guix cache) #:use-module (gcrypt pk-crypto) #:use-module (guix pki) - #:use-module ((guix build utils) #:select (mkdir-p dump-port)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix build download) - #:select (uri-abbreviation nar-uri-abbreviation + #:select (nar-uri-abbreviation (open-connection-for-uri - . guix:open-connection-for-uri) - store-path-abbreviation byte-count->string)) + . guix:open-connection-for-uri))) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 ftw) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 vlist) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -68,10 +60,7 @@ #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) - #:export (lookup-narinfos - lookup-narinfos/diverse - - %allow-unauthenticated-substitutes? + #:export (%allow-unauthenticated-substitutes? %error-to-file-descriptor-4? substitute-urls @@ -88,17 +77,6 @@ ;;; ;;; Code: -(define %narinfo-cache-directory - ;; A local cache of narinfos, to avoid going to the network. Most of the - ;; time, 'guix substitute' is called by guix-daemon as root and stores its - ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' - ;; as a user, it stores its cache in ~/.cache. - (if (zero? (getuid)) - (or (and=> (getenv "XDG_CACHE_HOME") - (cut string-append <> "/guix/substitute")) - (string-append %state-directory "/substitute/cache")) - (string-append (cache-directory #:ensure? #f) "/substitute"))) - (define (warn-about-missing-authentication) (warning (G_ "authentication and authorization of substitutes \ disabled!~%")) @@ -111,20 +89,6 @@ disabled!~%")) (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") (cut string-ci=? <> "yes")))) -(define %narinfo-ttl - ;; Number of seconds during which cached narinfo lookups are considered - ;; 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 (404). - (* 1 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)) @@ -212,369 +176,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 (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." - ;; The daemon does not sanitize its input, so PATH could be something like - ;; "/gnu/store/foo". Gracefully handle that. - (match (store-path-hash-part path) - (#f - (leave (G_ "'~a' does not name a store item~%") path)) - ((? string? hash-part) - (string-append %narinfo-cache-directory "/" - (bytevector->base32-string (sha256 (string->utf8 cache-url))) - "/" hash-part)))) - -(define (cached-narinfo cache-url path) - "Check locally if we have valid info about PATH coming from CACHE-URL. -Return two values: a Boolean indicating whether we have valid cached info, and -that info, which may be either #f (when PATH is unavailable) or the narinfo -for PATH." - (define now - (current-time time-monotonic)) - - (define cache-file - (narinfo-cache-file cache-url path)) - - (catch 'system-error - (lambda () - (call-with-input-file cache-file - (lambda (p) - (match (read p) - (('narinfo ('version 2) - ('cache-uri cache-uri) - ('date date) ('ttl ttl) ('value #f)) - ;; A cached negative lookup. - (if (obsolete? date now ttl) - (values #f #f) - (values #t #f))) - (('narinfo ('version 2) - ('cache-uri cache-uri) - ('date date) ('ttl ttl) ('value value)) - ;; A cached positive lookup - (if (obsolete? date now ttl) - (values #f #f) - (values #t (string->narinfo value cache-uri)))) - (('narinfo ('version v) _ ...) - (values #f #f)))))) - (lambda _ - (values #f #f)))) - -(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 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))) - (mkdir-p (dirname file)) - (with-atomic-file-output file - (lambda (out) - (write (cache-entry cache-url narinfo) out)))) - - narinfo) - -(define (narinfo-request cache-url path) - "Return an HTTP request for the narinfo of PATH at CACHE-URL." - (let ((url (string-append cache-url "/" (store-path-hash-part path) - ".narinfo")) - (headers '((User-Agent . "GNU Guile")))) - (build-request (string->uri url) #:method 'GET #:headers headers))) - -(define (at-most max-length lst) - "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 - (() - (values (reverse result) '())) - ((head . tail) - (if (>= len max-length) - (values (reverse result) lst) - (loop (+ 1 len) tail (cons head result))))))) - -(define* (http-multiple-get base-uri proc seed requests - #:key port (verify-certificate? #t) - (open-connection guix:open-connection-for-uri) - (keep-alive? #t) - (batch-size 1000)) - "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. - -When PORT is specified, use it as the initial connection on which HTTP -requests are sent; otherwise call OPEN-CONNECTION to open a new connection for -a URI. When KEEP-ALIVE? is false, close the connection port before -returning." - (let connect ((port port) - (requests requests) - (result seed)) - (define batch - (at-most batch-size requests)) - - ;; (format (current-error-port) "connecting (~a requests left)..." - ;; (length requests)) - (let ((p (or port (open-connection base-uri - #:verify-certificate? - verify-certificate?)))) - ;; For HTTPS, P is not a file port and does not support 'setvbuf'. - (when (file-port? p) - (setvbuf p 'block (expt 2 16))) - - ;; Send BATCH in a row. - ;; XXX: Do our own caching to work around inefficiencies when - ;; communicating over TLS: . - (let-values (((buffer get) (open-bytevector-output-port))) - ;; Inherit the HTTP proxying property from P. - (set-http-proxy-port?! buffer (http-proxy-port? p)) - - (for-each (cut write-request <> buffer) - batch) - (put-bytevector p (get)) - (force-output p)) - - ;; Now start processing responses. - (let loop ((sent batch) - (processed 0) - (result result)) - (match sent - (() - (match (drop requests processed) - (() - (unless keep-alive? - (close-port p)) - (reverse result)) - (remainder - (connect p remainder result)))) - ((head tail ...) - (let* ((resp (read-response p)) - (body (response-body-port resp)) - (result (proc head resp body result))) - ;; The server can choose to stop responding at any time, in which - ;; case we have to try again. Check whether that is the case. - ;; Note that even upon "Connection: close", we can read from BODY. - (match (assq 'connection (response-headers resp)) - (('connection 'close) - (close-port p) - (connect #f ;try again - (drop requests (+ 1 processed)) - result)) - (_ - (loop tail (+ 1 processed) result)))))))))) ;keep going - -(define (read-to-eof port) - "Read from PORT until EOF is reached. The data are discarded." - (dump-port port (%make-void-port "w"))) - -(define (narinfo-from-file file url) - "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f -if file doesn't exist, and the narinfo otherwise." - (catch 'system-error - (lambda () - (call-with-input-file file - (cut read-narinfo <> url))) - (lambda args - (if (= ENOENT (system-error-errno args)) - #f - (apply throw args))))) - -(define %unreachable-hosts - ;; Set of names of unreachable hosts. - (make-hash-table)) - -(define* (open-connection-for-uri/maybe uri - #:key - fresh? - (time %fetch-timeout)) - "Open a connection to URI via 'open-connection-for-uri/cached' and return a -port to it, or, if connection failed, print a warning and return #f. Pass -#:fresh? to 'open-connection-for-uri/cached'." - (define host - (uri-host uri)) - - (catch #t - (lambda () - (open-connection-for-uri/cached uri #:timeout time - #:fresh? fresh?)) - (match-lambda* - (('getaddrinfo-error error) - (unless (hash-ref %unreachable-hosts host) - (hash-set! %unreachable-hosts host #t) ;warn only once - (warning (G_ "~a: host not found: ~a~%") - host (gai-strerror error))) - #f) - (('system-error . args) - (unless (hash-ref %unreachable-hosts host) - (hash-set! %unreachable-hosts host #t) - (warning (G_ "~a: connection failed: ~a~%") host - (strerror - (system-error-errno `(system-error ,@args))))) - #f) - (args - (apply throw args))))) - -(define (fetch-narinfos url paths) - "Retrieve all the narinfos for PATHS from the cache at URL and return them." - (define update-progress! - (let ((done 0) - (total (length paths))) - (lambda () - (display "\r\x1b[K" (current-error-port)) ;erase current line - (force-output (current-error-port)) - (format (current-error-port) - (G_ "updating substitutes from '~a'... ~5,1f%") - url (* 100. (/ done total))) - (set! done (+ 1 done))))) - - (define hash-part->path - (let ((mapping (fold (lambda (path result) - (vhash-cons (store-path-hash-part path) path - result)) - vlist-null - paths))) - (lambda (hash) - (match (vhash-assoc hash mapping) - (#f #f) - ((_ . path) path))))) - - (define (handle-narinfo-response request response port result) - (let* ((code (response-code response)) - (len (response-content-length response)) - (cache (response-cache-control response)) - (ttl (and cache (assoc-ref cache 'max-age)))) - (update-progress!) - - ;; Make sure to read no more than LEN bytes since subsequent bytes may - ;; belong to the next response. - (if (= code 200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (if (string=? (dirname (narinfo-path narinfo)) - (%store-prefix)) - (begin - (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) - (cons narinfo result)) - result)) - (let* ((path (uri-path (request-uri request))) - (hash-part (basename - (string-drop-right path 8)))) ;drop ".narinfo" - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (cache-narinfo! url (hash-part->path hash-part) #f - (if (or (= 404 code) (= 202 code)) - ttl - %narinfo-transient-error-ttl)) - result)))) - - (define (do-fetch uri) - (case (and=> uri uri-scheme) - ((http https) - ;; Note: Do not check HTTPS server certificates to avoid depending - ;; on the X.509 PKI. We can do it because we authenticate - ;; narinfos, which provides a much stronger guarantee. - (let* ((requests (map (cut narinfo-request url <>) paths)) - (result (call-with-cached-connection uri - (lambda (port) - (if port - (begin - (update-progress!) - (http-multiple-get uri - handle-narinfo-response '() - requests - #:open-connection - open-connection-for-uri/cached - #:verify-certificate? #f - #:port port)) - '())) - open-connection-for-uri/maybe))) - (newline (current-error-port)) - result)) - ((file #f) - (let* ((base (string-append (uri-path uri) "/")) - (files (map (compose (cut string-append base <> ".narinfo") - store-path-hash-part) - paths))) - (filter-map (cut narinfo-from-file <> url) files))) - (else - (leave (G_ "~s: unsupported server URI scheme~%") - (if uri (uri-scheme uri) url))))) - - (do-fetch (string->uri url))) - -(define (lookup-narinfos cache paths) - "Return the narinfos for PATHS, invoking the server at CACHE when no -information is available locally." - (let-values (((cached missing) - (fold2 (lambda (path cached missing) - (let-values (((valid? value) - (cached-narinfo cache path))) - (if valid? - (if value - (values (cons value cached) missing) - (values cached missing)) - (values cached (cons path missing))))) - '() - '() - paths))) - (if (null? missing) - cached - (let ((missing (fetch-narinfos cache missing))) - (append cached (or missing '())))))) - -(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 -cache, and so on. - -Return a list of narinfos for PATHS or a subset thereof. The returned -narinfos are either AUTHORIZED?, or they claim a hash that matches an -AUTHORIZED? narinfo." - (define (select-hit result) - (lambda (path) - (match (vhash-fold* cons '() path result) - ((one) - one) - ((several ..1) - (let ((authorized (find authorized? (reverse several)))) - (and authorized - (find (cut equivalent-narinfo? <> authorized) - several))))))) - - (let loop ((caches caches) - (paths paths) - (result vlist-null) ;path->narinfo vhash - (hits '())) ;paths - (match paths - (() ;we're done - ;; Now iterate on all the HITS, and return exactly one match for each - ;; hit: the first narinfo that is authorized, or that has the same hash - ;; as an authorized narinfo, in the order of CACHES. - (filter-map (select-hit result) hits)) - (_ - (match caches - ((cache rest ...) - (let* ((narinfos (lookup-narinfos cache paths)) - (definite (map narinfo-path (filter authorized? narinfos))) - (missing (lset-difference string=? paths definite))) ;XXX: perf - (loop rest missing - (fold vhash-cons result - (map narinfo-path narinfos) narinfos) - (append definite hits)))) - (() ;that's it - (filter-map (select-hit result) hits))))))) - (define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH was found." @@ -718,79 +319,6 @@ authorized substitutes." (wtf (error "unknown `--query' command" wtf)))) -(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? timeout verify-certificate?) - "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. - -When true, TIMEOUT is the maximum number of milliseconds to wait for -connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS -server certificates." - (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? verify-certificate? - #:timeout timeout)) - ((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 #:timeout timeout - #:verify-certificate? - verify-certificate?)) - (begin - ;; Drain input left from the previous use. - (drain-input socket) - socket)))))))) - -(define* (call-with-cached-connection uri proc - #:optional - (open-connection - open-connection-for-uri/cached)) - (let ((port (open-connection 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 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 deduplicate? print-build-trace?) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 97e4a73802..8bb557862d 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -32,8 +32,8 @@ #:use-module (guix gexp) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module ((guix build utils) #:select (every*)) - #:use-module (guix scripts substitute) #:use-module (guix narinfo) + #:use-module (guix substitute) #:use-module (guix http-client) #:use-module (guix ci) #:use-module (guix sets) diff --git a/guix/substitute.scm b/guix/substitute.scm new file mode 100644 index 0000000000..c37b2c398f --- /dev/null +++ b/guix/substitute.scm @@ -0,0 +1,527 @@ +;;; 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 substitute) + #:use-module (guix ui) + #:use-module (guix i18n) + #:use-module (guix cache) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module (guix config) + #:use-module (guix narinfo) + #:use-module (guix combinators) + #:use-module ((guix build utils) #:select (mkdir-p dump-port)) + #:use-module ((guix build download) + #:select ((open-connection-for-uri + . guix:open-connection-for-uri))) + #:use-module (gcrypt hash) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (ice-9 format) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:export (%narinfo-cache-directory + + with-cached-connection + + lookup-narinfos + lookup-narinfos/diverse)) + +(define %narinfo-cache-directory + ;; A local cache of narinfos, to avoid going to the network. Most of the + ;; time, 'guix substitute' is called by guix-daemon as root and stores its + ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' + ;; as a user, it stores its cache in ~/.cache. + (if (zero? (getuid)) + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute")) + (string-append %state-directory "/substitute/cache")) + (string-append (cache-directory #:ensure? #f) "/substitute"))) + +(define %narinfo-ttl + ;; Number of seconds during which cached narinfo lookups are considered + ;; 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 (404). + (* 1 3600)) + +(define %narinfo-transient-error-ttl + ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). + (* 10 60)) + +(define %fetch-timeout + ;; Number of seconds after which networking is considered "slow". + 5) + +(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." + ;; The daemon does not sanitize its input, so PATH could be something like + ;; "/gnu/store/foo". Gracefully handle that. + (match (store-path-hash-part path) + (#f + (leave (G_ "'~a' does not name a store item~%") path)) + ((? string? hash-part) + (string-append %narinfo-cache-directory "/" + (bytevector->base32-string (sha256 (string->utf8 cache-url))) + "/" hash-part)))) + +(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 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))) + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (out) + (write (cache-entry cache-url narinfo) out)))) + + narinfo) + +(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? timeout verify-certificate?) + "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. + +When true, TIMEOUT is the maximum number of milliseconds to wait for +connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS +server certificates." + (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? verify-certificate? + #:timeout timeout)) + ((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 #:timeout timeout + #:verify-certificate? + verify-certificate?)) + (begin + ;; Drain input left from the previous use. + (drain-input socket) + socket)))))))) + +(define* (call-with-cached-connection uri proc + #:optional + (open-connection + open-connection-for-uri/cached)) + (let ((port (open-connection 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 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 (at-most max-length lst) + "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 + (() + (values (reverse result) '())) + ((head . tail) + (if (>= len max-length) + (values (reverse result) lst) + (loop (+ 1 len) tail (cons head result))))))) + +(define* (http-multiple-get base-uri proc seed requests + #:key port (verify-certificate? #t) + (open-connection guix:open-connection-for-uri) + (keep-alive? #t) + (batch-size 1000)) + "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. + +When PORT is specified, use it as the initial connection on which HTTP +requests are sent; otherwise call OPEN-CONNECTION to open a new connection for +a URI. When KEEP-ALIVE? is false, close the connection port before +returning." + (let connect ((port port) + (requests requests) + (result seed)) + (define batch + (at-most batch-size requests)) + + ;; (format (current-error-port) "connecting (~a requests left)..." + ;; (length requests)) + (let ((p (or port (open-connection base-uri + #:verify-certificate? + verify-certificate?)))) + ;; For HTTPS, P is not a file port and does not support 'setvbuf'. + (when (file-port? p) + (setvbuf p 'block (expt 2 16))) + + ;; Send BATCH in a row. + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: . + (let-values (((buffer get) (open-bytevector-output-port))) + ;; Inherit the HTTP proxying property from P. + (set-http-proxy-port?! buffer (http-proxy-port? p)) + + (for-each (cut write-request <> buffer) + batch) + (put-bytevector p (get)) + (force-output p)) + + ;; Now start processing responses. + (let loop ((sent batch) + (processed 0) + (result result)) + (match sent + (() + (match (drop requests processed) + (() + (unless keep-alive? + (close-port p)) + (reverse result)) + (remainder + (connect p remainder result)))) + ((head tail ...) + (let* ((resp (read-response p)) + (body (response-body-port resp)) + (result (proc head resp body result))) + ;; The server can choose to stop responding at any time, in which + ;; case we have to try again. Check whether that is the case. + ;; Note that even upon "Connection: close", we can read from BODY. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (close-port p) + (connect #f ;try again + (drop requests (+ 1 processed)) + result)) + (_ + (loop tail (+ 1 processed) result)))))))))) ;keep going + +(define %unreachable-hosts + ;; Set of names of unreachable hosts. + (make-hash-table)) + +(define* (open-connection-for-uri/maybe uri + #:key + fresh? + (time %fetch-timeout)) + "Open a connection to URI via 'open-connection-for-uri/cached' and return a +port to it, or, if connection failed, print a warning and return #f. Pass +#:fresh? to 'open-connection-for-uri/cached'." + (define host + (uri-host uri)) + + (catch #t + (lambda () + (open-connection-for-uri/cached uri #:timeout time + #:fresh? fresh?)) + (match-lambda* + (('getaddrinfo-error error) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) ;warn only once + (warning (G_ "~a: host not found: ~a~%") + host (gai-strerror error))) + #f) + (('system-error . args) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) + (warning (G_ "~a: connection failed: ~a~%") host + (strerror + (system-error-errno `(system-error ,@args))))) + #f) + (args + (apply throw args))))) + +(define (read-to-eof port) + "Read from PORT until EOF is reached. The data are discarded." + (dump-port port (%make-void-port "w"))) + +(define (narinfo-request cache-url path) + "Return an HTTP request for the narinfo of PATH at CACHE-URL." + (let ((url (string-append cache-url "/" (store-path-hash-part path) + ".narinfo")) + (headers '((User-Agent . "GNU Guile")))) + (build-request (string->uri url) #:method 'GET #:headers headers))) + +(define (narinfo-from-file file url) + "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f +if file doesn't exist, and the narinfo otherwise." + (catch 'system-error + (lambda () + (call-with-input-file file + (cut read-narinfo <> url))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (fetch-narinfos url paths) + "Retrieve all the narinfos for PATHS from the cache at URL and return them." + (define update-progress! + (let ((done 0) + (total (length paths))) + (lambda () + (display "\r\x1b[K" (current-error-port)) ;erase current line + (force-output (current-error-port)) + (format (current-error-port) + (G_ "updating substitutes from '~a'... ~5,1f%") + url (* 100. (/ done total))) + (set! done (+ 1 done))))) + + (define hash-part->path + (let ((mapping (fold (lambda (path result) + (vhash-cons (store-path-hash-part path) path + result)) + vlist-null + paths))) + (lambda (hash) + (match (vhash-assoc hash mapping) + (#f #f) + ((_ . path) path))))) + + (define (handle-narinfo-response request response port result) + (let* ((code (response-code response)) + (len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) + (update-progress!) + + ;; Make sure to read no more than LEN bytes since subsequent bytes may + ;; belong to the next response. + (if (= code 200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (if (string=? (dirname (narinfo-path narinfo)) + (%store-prefix)) + (begin + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) + (cons narinfo result)) + result)) + (let* ((path (uri-path (request-uri request))) + (hash-part (basename + (string-drop-right path 8)))) ;drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! url (hash-part->path hash-part) #f + (if (or (= 404 code) (= 202 code)) + ttl + %narinfo-transient-error-ttl)) + result)))) + + (define (do-fetch uri) + (case (and=> uri uri-scheme) + ((http https) + ;; Note: Do not check HTTPS server certificates to avoid depending + ;; on the X.509 PKI. We can do it because we authenticate + ;; narinfos, which provides a much stronger guarantee. + (let* ((requests (map (cut narinfo-request url <>) paths)) + (result (call-with-cached-connection uri + (lambda (port) + (if port + (begin + (update-progress!) + (http-multiple-get uri + handle-narinfo-response '() + requests + #:open-connection + open-connection-for-uri/cached + #:verify-certificate? #f + #:port port)) + '())) + open-connection-for-uri/maybe))) + (newline (current-error-port)) + result)) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (G_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))) + + (do-fetch (string->uri url))) + +(define (cached-narinfo cache-url path) + "Check locally if we have valid info about PATH coming from CACHE-URL. +Return two values: a Boolean indicating whether we have valid cached info, and +that info, which may be either #f (when PATH is unavailable) or the narinfo +for PATH." + (define now + (current-time time-monotonic)) + + (define cache-file + (narinfo-cache-file cache-url path)) + + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 2) + ('cache-uri cache-uri) + ('date date) ('ttl ttl) ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date now ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 2) + ('cache-uri cache-uri) + ('date date) ('ttl ttl) ('value value)) + ;; A cached positive lookup + (if (obsolete? date now ttl) + (values #f #f) + (values #t (string->narinfo value cache-uri)))) + (('narinfo ('version v) _ ...) + (values #f #f)))))) + (lambda _ + (values #f #f)))) + +(define (lookup-narinfos cache paths) + "Return the narinfos for PATHS, invoking the server at CACHE when no +information is available locally." + (let-values (((cached missing) + (fold2 (lambda (path cached missing) + (let-values (((valid? value) + (cached-narinfo cache path))) + (if valid? + (if value + (values (cons value cached) missing) + (values cached missing)) + (values cached (cons path missing))))) + '() + '() + paths))) + (if (null? missing) + cached + (let ((missing (fetch-narinfos cache missing))) + (append cached (or missing '())))))) + +(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 +cache, and so on. + +Return a list of narinfos for PATHS or a subset thereof. The returned +narinfos are either AUTHORIZED?, or they claim a hash that matches an +AUTHORIZED? narinfo." + (define (select-hit result) + (lambda (path) + (match (vhash-fold* cons '() path result) + ((one) + one) + ((several ..1) + (let ((authorized (find authorized? (reverse several)))) + (and authorized + (find (cut equivalent-narinfo? <> authorized) + several))))))) + + (let loop ((caches caches) + (paths paths) + (result vlist-null) ;path->narinfo vhash + (hits '())) ;paths + (match paths + (() ;we're done + ;; Now iterate on all the HITS, and return exactly one match for each + ;; hit: the first narinfo that is authorized, or that has the same hash + ;; as an authorized narinfo, in the order of CACHES. + (filter-map (select-hit result) hits)) + (_ + (match caches + ((cache rest ...) + (let* ((narinfos (lookup-narinfos cache paths)) + (definite (map narinfo-path (filter authorized? narinfos))) + (missing (lset-difference string=? paths definite))) ;XXX: perf + (loop rest missing + (fold vhash-cons result + (map narinfo-path narinfos) narinfos) + (append definite hits)))) + (() ;that's it + (filter-map (select-hit result) hits))))))) + +;;; Local Variables: +;;; eval: (put 'with-timeout 'scheme-indent-function 1) +;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) +;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1) +;;; End: + +;;; substitute.scm ends here