GNU bug report logs - #45409
[PATCH 0/3] Move some (guix scripts substitute) code to two new modules

Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.

Package: guix-patches; Reported by: Christopher Baines <mail@HIDDEN>; Keywords: patch; dated Thu, 24 Dec 2020 17:19:02 UTC; Maintainer for guix-patches is guix-patches@HIDDEN.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 14:18:50 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 09:18:50 2021
Received: from localhost ([127.0.0.1]:42677 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0mPi-0002Bs-E4
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 09:18:50 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49882)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0mPf-0002Bj-Ik
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 09:18:49 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id B150227BC13;
 Sat, 16 Jan 2021 14:18:46 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 43de36ae;
 Sat, 16 Jan 2021 14:18:44 +0000 (UTC)
References: <20210104211927.14959-1-mail@HIDDEN>
 <20210104211927.14959-3-mail@HIDDEN> <87r1mzrqgk.fsf@HIDDEN>
 <87zh1kidoc.fsf@HIDDEN> <87im83eha5.fsf@HIDDEN>
User-agent: mu4e 1.4.14; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 3/3] guix: Split (guix substitutes) from
 (guix scripts substitute).
In-reply-to: <87im83eha5.fsf@HIDDEN>
Date: Sat, 16 Jan 2021 14:18:41 +0000
Message-ID: <87sg717yny.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


Ludovic Court=C3=A8s <ludo@HIDDEN> writes:

>> I think it's possible to separate it out if some of the error handling
>> is pushed down in to the http procedures, and if when they get an error
>> indicating the connection is unusable, they close the port.
>
> Ideally the (web =E2=80=A6) modules would do that (that=E2=80=99s what yo=
u mean, right?)
> but then we=E2=80=99d have to wait for Guile proper to implement these th=
ings.

Well, I'm unsure, all I'm trying to do at the moment is push the
connection handling down in to http-multiple-get [1].

1: https://issues.guix.info/45409#22

While thinking about this just now, I think there's the possibility of
connection caching causing issues in process-substitution. I'm guessing
the exceptions could occur anywhere from in http-fetch where it calls
http-get, to back in process-substitution where it finishes reading from
the port (I'm unsure where, I loose track of where the port is used).

There was a little bit more error handling previously, as the use of
fetch was wrapped in with-cached-connection, but given that the response
body hasn't been read by this point, I don't think the previous state
was very safe either.

>> I've pushed some rough commits for this to this branch:
>>
>>   https://git.cbaines.net/guix/log/?h=3Dprepare-to-move-guix-scripts-sub=
stitute-code
>>
>> I'm still struggling with the tests, currently make check hangs, I think
>> on the challenge tests, and I don't currently have a plan to work out
>> why the test is hanging.
>
> Overall the approach LGTM.
>
> How about first getting (guix narinfo) in =E2=80=98master=E2=80=99 (the b=
its we agreed
> on), and then tackling the rest so that it=E2=80=99s less daunting?

I've pushed the (guix narinfo) addition now, with the patch that changed
the unauthorized substitute handling.

> Also, I=E2=80=99d like to get the zstd patches in.  :-)

I've rebased on master, tweaked the commit messages, and send a set of
v4 patches and while they don't create the (guix substitutes) module, I
think they unpick the bits I'd like to move out from the code doing the
connection caching.

Thanks,

Chris

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAmAC9cFfFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9XeKxhAAmRPi9iXgECK2YxEsgNNDOpshCJmL2wsv
np37G3S1c0odAic2Pou95legV6D7zQqSgcknLLdb5Xu2EmRYlixcob3SVMoqIShX
kHObumUOBRKsInPX0TU11HDJq1DCeO27IJDYNA0Fs1ZBTWBjR1JIr6VJ8B7qoKLH
YnlYACJQvVZo7LA29vuCjrgXM+QEMgykD7TtUBc4940GwHHFtg1KTr92IRulkgPi
lZsM/dwziNkvJqfZzJzMxVgJrfJOd60F3MG9BPdfkZEe8MlivToOD1uohYbYYnaV
27q1rO2+0WUv/5jwkiPA/N1SKiIpobRbtYSwtvzKVgAV7P0gfhrWTvvjGLP9/ynk
22XzIPn44/EzCl5DiL2hN11aWLNznDvhVbu1/ixZEnhWz3+5OJMcu4SEjvLo1gGu
HXkB6vCNVV/pJPayWup0cG4+zmL6auyUwUolesYSRzdAkMoayClk1Nm3EPlWwgep
p9x0f4OJznLUsIrcdvjxFP0tIjAHMQLIqmPpFK3Zb6Jf4iXYkm6S1MEMmtRvwKyt
iAXyi5w/bhDvTii9gwlA/EPmjCIctPOI6cpv761Z+agFiW3JHc3Cq7tC9wuy4gTC
YX5WTvVRh3KZI14pHddETWUP5WzRfdjpKUTf16At0ZSsSaZK6qmnkesRgkb2Ze/I
5+4JjbesYps=
=2OeU
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:24 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:24 2021
Received: from localhost ([127.0.0.1]:42609 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5w-0005vG-Gj
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:24 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49440)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5i-0005sx-8O
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:12 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 20F5C27BC1F
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:08 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id c1fc769d
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 13/13] substitute: Remove fetch-narinfos use
 open-connection-for-uri/maybe.
Date: Sat, 16 Jan 2021 13:58:03 +0000
Message-Id: <20210116135803.21955-13-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

At least by default.  Instead, make the open-connection procedure a parameter,
and make the default guix:open-connection-for-uri.  Do so similarly for
lookup-narinfos and lookup-narinfos/diverse which work towards calling
fetch-narinfos.

This means this code can be moved to a different module, without having
use/move the connection caching code.

* guix/scripts/substitute.scm (fetch-narinfos): Add #:open-connection
argument, and call http-multiple-get with it.
(lookup-narinfos) Add #:open-connection argument, and call fetch-narinfos with
it.
(lookup-narinfos/diverse): Add #:open-connection argument, and call
lookup-narinfos with it.
(process-query): Call lookup-narinfos/diverse with #:open-connection
open-connection-for-uri/maybe.
---
 guix/scripts/substitute.scm | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 858ce1dcc4..c2a8dd419f 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -314,7 +314,8 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
       (args
        (apply throw args)))))
 
-(define (fetch-narinfos url paths)
+(define* (fetch-narinfos url paths
+                         #:key (open-connection guix:open-connection-for-uri))
   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
   (define update-progress!
     (let ((done 0)
@@ -379,8 +380,7 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
                           (http-multiple-get uri
                                              handle-narinfo-response '()
                                              requests
-                                             #:open-connection
-                                             open-connection-for-uri/maybe
+                                             #:open-connection open-connection
                                              #:verify-certificate? #f))))
          result))
       ((file #f)
@@ -395,7 +395,8 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
 
   (do-fetch (string->uri url)))
 
-(define (lookup-narinfos cache paths)
+(define* (lookup-narinfos cache paths
+                          #:key (open-connection guix:open-connection-for-uri))
   "Return the narinfos for PATHS, invoking the server at CACHE when no
 information is available locally."
   (let-values (((cached missing)
@@ -412,10 +413,13 @@ information is available locally."
                        paths)))
     (if (null? missing)
         cached
-        (let ((missing (fetch-narinfos cache missing)))
+        (let ((missing (fetch-narinfos cache missing
+                                       #:open-connection open-connection)))
           (append cached (or missing '()))))))
 
-(define (lookup-narinfos/diverse caches paths authorized?)
+(define* (lookup-narinfos/diverse caches paths authorized?
+                                  #:key (open-connection
+                                         guix:open-connection-for-uri))
   "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.
@@ -447,7 +451,8 @@ AUTHORIZED? narinfo."
       (_
        (match caches
          ((cache rest ...)
-          (let* ((narinfos (lookup-narinfos cache paths))
+          (let* ((narinfos (lookup-narinfos cache paths
+                                            #:open-connection open-connection))
                  (definite (map narinfo-path (filter authorized? narinfos)))
                  (missing  (lset-difference string=? paths definite))) ;XXX: perf
             (loop rest missing
@@ -587,14 +592,18 @@ authorized substitutes."
   (match (string-tokenize command)
     (("have" paths ..1)
      ;; Return the subset of PATHS available in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+     (let ((substitutable (lookup-narinfos/diverse
+                           cache-urls paths valid?
+                           #:open-connection open-connection-for-uri/maybe)))
        (for-each (lambda (narinfo)
                    (format #t "~a~%" (narinfo-path narinfo)))
                  substitutable)
        (newline)))
     (("info" paths ..1)
      ;; Reply info about PATHS if it's in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+     (let ((substitutable (lookup-narinfos/diverse
+                           cache-urls paths valid?
+                           #:open-connection open-connection-for-uri/maybe)))
        (for-each display-narinfo-data substitutable)
        (newline)))
     (wtf
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:24 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:24 2021
Received: from localhost ([127.0.0.1]:42607 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5w-0005v9-5d
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:24 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49438)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5i-0005sw-8L
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:11 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 0306B27BC1E
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 533ad5a2
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 12/13] substitute: Inline fetch in to process-substitutes.
Date: Sat, 16 Jan 2021 13:58:02 +0000
Message-Id: <20210116135803.21955-12-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

As it's only called in one place, and this should make the code easier to
read.

* guix/scripts/substitute.scm (fetch): Move procedure inside…
(process-substitution): …here.
---
 guix/scripts/substitute.scm | 60 ++++++++++++++++++-------------------
 1 file changed, 29 insertions(+), 31 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b5a4c08325..858ce1dcc4 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -169,37 +169,6 @@ again."
         (sigaction SIGALRM SIG_DFL)
         (apply values result)))))
 
-(define (fetch uri)
-  "Return a binary input port to URI and the number of bytes it's expected to
-provide."
-  (case (uri-scheme uri)
-    ((file)
-     (let ((port (open-file (uri-path uri) "r0b")))
-       (values port (stat:size (stat port)))))
-    ((http https)
-     (guard (c ((http-get-error? c)
-                (leave (G_ "download from '~a' failed: ~a, ~s~%")
-                       (uri->string (http-get-error-uri c))
-                       (http-get-error-code c)
-                       (http-get-error-reason c))))
-       ;; Test this with:
-       ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
-       ;; and then cancel with:
-       ;;   sudo tc qdisc del dev eth0 root
-       (with-timeout %fetch-timeout
-         (begin
-           (warning (G_ "while fetching ~a: server is somewhat slow~%")
-                    (uri->string uri))
-           (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-         (http-fetch uri #:text? #f
-                     #:open-connection open-connection-for-uri/maybe
-                     #:keep-alive? #t
-                     #:buffered? #f
-                     #:verify-certificate? #f))))
-    (else
-     (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."
@@ -705,6 +674,35 @@ the current output port."
     (apply dump-file/deduplicate
            (append args (list #:store (%store-prefix)))))
 
+  (define (fetch uri)
+    (case (uri-scheme uri)
+      ((file)
+       (let ((port (open-file (uri-path uri) "r0b")))
+         (values port (stat:size (stat port)))))
+      ((http https)
+       (guard (c ((http-get-error? c)
+                  (leave (G_ "download from '~a' failed: ~a, ~s~%")
+                         (uri->string (http-get-error-uri c))
+                         (http-get-error-code c)
+                         (http-get-error-reason c))))
+         ;; Test this with:
+         ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
+         ;; and then cancel with:
+         ;;   sudo tc qdisc del dev eth0 root
+         (with-timeout %fetch-timeout
+           (begin
+             (warning (G_ "while fetching ~a: server is somewhat slow~%")
+                      (uri->string uri))
+             (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+           (http-fetch uri #:text? #f
+                       #:open-connection open-connection-for-uri/maybe
+                       #:keep-alive? #t
+                       #:buffered? #f
+                       #:verify-certificate? #f))))
+      (else
+       (leave (G_ "unsupported substitute URI scheme: ~a~%")
+              (uri->string uri)))))
+
   (unless narinfo
     (leave (G_ "no valid substitute for '~a'~%")
            store-item))
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:24 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:24 2021
Received: from localhost ([127.0.0.1]:42605 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5v-0005v2-Qv
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:24 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49436)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5i-0005sr-4F
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:11 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id E0C4D27BC1D
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id afce44bc
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 11/13] substitute: Remove redundant fetch arguments.
Date: Sat, 16 Jan 2021 13:58:01 +0000
Message-Id: <20210116135803.21955-11-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

It's just called in one place, with hardcoded argument values, so just inline
them.

* guix/scripts/substitute.scm (fetch): Remove arguments that don't vary, copy
the values from the call site in process-substitution.
(process-substitution): Remove unnecessary argument values from fetch call.
---
 guix/scripts/substitute.scm | 23 +++++++----------------
 1 file changed, 7 insertions(+), 16 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index d316bdef15..b5a4c08325 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -169,18 +169,12 @@ again."
         (sigaction SIGALRM SIG_DFL)
         (apply values result)))))
 
-(define* (fetch uri #:key (buffered? #t) (timeout? #t)
-                (keep-alive? #f))
+(define (fetch uri)
   "Return a binary input port to URI and the number of bytes it's expected to
-provide.
-
-When PORT is true, use it as the underlying I/O port for HTTP transfers; when
-PORT is false, open a new connection for URI.  When KEEP-ALIVE? is true, the
-connection (typically PORT) is kept open once data has been fetched from URI."
+provide."
   (case (uri-scheme uri)
     ((file)
-     (let ((port (open-file (uri-path uri)
-                            (if buffered? "rb" "r0b"))))
+     (let ((port (open-file (uri-path uri) "r0b")))
        (values port (stat:size (stat port)))))
     ((http https)
      (guard (c ((http-get-error? c)
@@ -192,17 +186,15 @@ connection (typically PORT) is kept open once data has been fetched from URI."
        ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
        ;; and then cancel with:
        ;;   sudo tc qdisc del dev eth0 root
-       (with-timeout (if timeout?
-                         %fetch-timeout
-                         0)
+       (with-timeout %fetch-timeout
          (begin
            (warning (G_ "while fetching ~a: server is somewhat slow~%")
                     (uri->string uri))
            (warning (G_ "try `--no-substitutes' if the problem persists~%")))
          (http-fetch uri #:text? #f
                      #:open-connection open-connection-for-uri/maybe
-                     #:keep-alive? keep-alive?
-                     #:buffered? buffered?
+                     #:keep-alive? #t
+                     #:buffered? #f
                      #:verify-certificate? #f))))
     (else
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
@@ -726,8 +718,7 @@ the current output port."
     (let*-values (((raw download-size)
                    ;; 'guix publish' without '--cache' doesn't specify a
                    ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
-                   (fetch uri #:buffered? #f #:timeout? #f
-                          #:keep-alive? #t))
+                   (fetch uri))
                   ((progress)
                    (let* ((dl-size  (or download-size
                                         (and (equal? compression "none")
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:24 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:23 2021
Received: from localhost ([127.0.0.1]:42603 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5v-0005uv-HF
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:23 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49434)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5i-0005sq-4D
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:11 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id CA43F27BC1C
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 113d4c3d
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 10/13] substitute: Remove now redundant connection caching
 helpers.
Date: Sat, 16 Jan 2021 13:58:00 +0000
Message-Id: <20210116135803.21955-10-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Failures now should be handled where they occur, and if there's a problem
that's symptomatic of an issue with the connection, the port should be closed.

* guix/scripts/substitute.scm (call-with-cached-connection): Remove procedure.
(with-cached-connection): Remove syntax rule.
---
 guix/scripts/substitute.scm | 28 ----------------------------
 1 file changed, 28 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index fc5a19124e..d316bdef15 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -689,32 +689,6 @@ server certificates."
                     (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, or a
-        ;; ERROR/INVALID-SESSION from GnuTLS.
-        (if (or (and (eq? key 'system-error)
-                     (= EPIPE (system-error-errno `(,key ,@args))))
-                (and (eq? key 'gnutls-error)
-                     (eq? (first args) error/invalid-session))
-                (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?)
@@ -1010,8 +984,6 @@ default value."
 
 ;;; 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
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:23 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:23 2021
Received: from localhost ([127.0.0.1]:42601 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5v-0005uo-8d
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:23 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49432)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5h-0005sj-TR
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:10 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id B3DDA27BC1B
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 41331557
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 09/13] substitute: Change connection cache handling in
 process-substitution.
Date: Sat, 16 Jan 2021 13:57:59 +0000
Message-Id: <20210116135803.21955-9-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Just pass open-connection-for-uri/maybe to http-fetch, this removes the need
for with-cached-connection and passing the port in.

* guix/scripts/substitute.scm (fetch): Don't take a port as an argument, and
pass open-connection-for-uri/maybe to http-fetch.
(process-substitution): Don't call fetch with with-cached-connection.
---
 guix/scripts/substitute.scm | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 88219ea7f6..fc5a19124e 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -170,7 +170,7 @@ again."
         (apply values result)))))
 
 (define* (fetch uri #:key (buffered? #t) (timeout? #t)
-                (keep-alive? #f) (port #f))
+                (keep-alive? #f))
   "Return a binary input port to URI and the number of bytes it's expected to
 provide.
 
@@ -199,7 +199,8 @@ connection (typically PORT) is kept open once data has been fetched from URI."
            (warning (G_ "while fetching ~a: server is somewhat slow~%")
                     (uri->string uri))
            (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-         (http-fetch uri #:text? #f #:port port
+         (http-fetch uri #:text? #f
+                     #:open-connection open-connection-for-uri/maybe
                      #:keep-alive? keep-alive?
                      #:buffered? buffered?
                      #:verify-certificate? #f))))
@@ -751,10 +752,8 @@ the current output port."
     (let*-values (((raw download-size)
                    ;; 'guix publish' without '--cache' doesn't specify a
                    ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
-                   (with-cached-connection uri port
-                     (fetch uri #:buffered? #f #:timeout? #f
-                            #:port port
-                            #:keep-alive? #t)))
+                   (fetch uri #:buffered? #f #:timeout? #f
+                          #:keep-alive? #t))
                   ((progress)
                    (let* ((dl-size  (or download-size
                                         (and (equal? compression "none")
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:23 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:23 2021
Received: from localhost ([127.0.0.1]:42599 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5v-0005uh-0Y
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:23 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49428)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5h-0005sY-Hx
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:10 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 7AC6C27BC19
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 171b4850
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 07/13] substitute: Stop using call-with-cached-connection
 in fetch-narinfos.
Date: Sat, 16 Jan 2021 13:57:57 +0000
Message-Id: <20210116135803.21955-7-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Instead, just pass open-connection-for-uri/maybe to http-multiple-get. This
code should be functionaly similar to the previous code. The eventual aim of
this is to make the connection caching not mandatory in fetch-narinfos.

* guix/scripts/substitute.scm (fetch-narinfos): Remove use of
call-with-cached-connection.
---
 guix/scripts/substitute.scm | 22 ++++++++--------------
 1 file changed, 8 insertions(+), 14 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 259b109cc6..88219ea7f6 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -412,20 +412,14 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
        ;; 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)))
+              (result   (begin
+                          (update-progress!)
+                          (http-multiple-get uri
+                                             handle-narinfo-response '()
+                                             requests
+                                             #:open-connection
+                                             open-connection-for-uri/maybe
+                                             #:verify-certificate? #f))))
          result))
       ((file #f)
        (let* ((base  (string-append (uri-path uri) "/"))
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:23 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:23 2021
Received: from localhost ([127.0.0.1]:42597 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5u-0005uZ-MX
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:22 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49430)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5h-0005si-SQ
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:10 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 9134927BC1A
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 27b3d66f
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 08/13] http-client: Accept #:open-connection in http-fetch.
Date: Sat, 16 Jan 2021 13:57:58 +0000
Message-Id: <20210116135803.21955-8-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

So that an alternative procedure can be passed in, perhaps to perform
connection caching.

* guix/http-client.scm (http-fetch): Add an #:open-connection keyword
argument.
---
 guix/http-client.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/guix/http-client.scm b/guix/http-client.scm
index 3aba3b28c1..2d7458a56e 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -75,6 +75,7 @@
 
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
+                     (open-connection guix:open-connection-for-uri)
                      (keep-alive? #f)
                      (verify-certificate? #t)
                      (headers '((user-agent . "GNU Guile")))
@@ -97,10 +98,10 @@ Raise an '&http-get-error' condition if downloading fails."
   (let loop ((uri (if (string? uri)
                       (string->uri uri)
                       uri)))
-    (let ((port (or port (guix:open-connection-for-uri uri
-                                                       #:verify-certificate?
-                                                       verify-certificate?
-                                                       #:timeout timeout)))
+    (let ((port (or port (open-connection uri
+                                          #:verify-certificate?
+                                          verify-certificate?
+                                          #:timeout timeout)))
           (headers (match (uri-userinfo uri)
                      ((? string? str)
                       (cons (cons 'Authorization
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:22 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:22 2021
Received: from localhost ([127.0.0.1]:42595 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5u-0005uW-Cl
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:22 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49426)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5h-0005sZ-Hp
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:10 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 5D6C527BC18
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 19dd725f
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 06/13] substitute: open-connection-for-uri/maybe add
 #:verify-certificate?.
Date: Sat, 16 Jan 2021 13:57:56 +0000
Message-Id: <20210116135803.21955-6-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

As this is used by http-fetch and http-multiple-get when they call the
specified open connection procedure.

* guix/scripts/substitute.scm (open-connection-for-uri/maybe): Support
 #:verify-certificate?.
---
 guix/scripts/substitute.scm | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 64b8ae2a15..259b109cc6 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -322,7 +322,8 @@ if file doesn't exist, and the narinfo otherwise."
 (define* (open-connection-for-uri/maybe uri
                                         #:key
                                         fresh?
-                                        (time %fetch-timeout))
+                                        (time %fetch-timeout)
+                                        verify-certificate?)
   "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'."
@@ -332,7 +333,8 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
   (catch #t
     (lambda ()
       (open-connection-for-uri/cached uri #:timeout time
-                                      #:fresh? fresh?))
+                                      #:fresh? fresh?
+                                      #:verify-certificate? verify-certificate?))
     (match-lambda*
       (('getaddrinfo-error error)
        (unless (hash-ref %unreachable-hosts host)
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:17 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:17 2021
Received: from localhost ([127.0.0.1]:42593 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5o-0005uA-Lb
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:17 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49418)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5g-0005sN-0y
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:10 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 19DA827BC16
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 7a92d3e8
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 04/13] guix: Move http-multiple-get to (guix http-client).
Date: Sat, 16 Jan 2021 13:57:54 +0000
Message-Id: <20210116135803.21955-4-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

From (guix scripts substitute). This will make it easier to reuse this code.

* guix/scripts/substitute.scm (http-multiple-get): Remove, and move to…
* guix/http-client.scm (http-multiple-get): …here.
---
 guix/http-client.scm        | 76 +++++++++++++++++++++++++++++++++++++
 guix/scripts/substitute.scm | 70 ----------------------------------
 2 files changed, 76 insertions(+), 70 deletions(-)

diff --git a/guix/http-client.scm b/guix/http-client.scm
index 553640fe9e..7ead493633 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -21,8 +21,11 @@
 
 (define-module (guix http-client)
   #:use-module (web uri)
+  #:use-module (web http)
   #:use-module ((web client) #:hide (open-socket-for-uri))
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -50,6 +53,7 @@
             http-get-error-reason
 
             http-fetch
+            http-multiple-get
 
             %http-cache-ttl
             http-fetch/cached))
@@ -138,6 +142,78 @@ Raise an '&http-get-error' condition if downloading fails."
                                 (uri->string uri) code
                                 (response-reason-phrase resp))))))))))))
 
+(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
+      (if (>= batch-size (length requests))
+          requests
+          (take requests batch-size)))
+
+    ;; (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: <http://bugs.gnu.org/22966>.
+      (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
+
 
 ;;;
 ;;; Caching.
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index ecc2bd9035..64b8ae2a15 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -299,76 +299,6 @@ return its MAX-LENGTH first elements and its tail."
            (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: <http://bugs.gnu.org/22966>.
-      (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")))
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:16 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:16 2021
Received: from localhost ([127.0.0.1]:42591 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5o-0005u3-Cg
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:16 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49414)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5g-0005sM-3G
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:09 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id ED72427BC15
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:06 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 8f52af8d
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 03/13] substitute: Remove redundant let block from fetch.
Date: Sat, 16 Jan 2021 13:57:53 +0000
Message-Id: <20210116135803.21955-3-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

* guix/scripts/substitute.scm (fetch): Remove redundant let block.
---
 guix/scripts/substitute.scm | 23 +++++++++++------------
 1 file changed, 11 insertions(+), 12 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 74fce15117..ecc2bd9035 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -192,18 +192,17 @@ connection (typically PORT) is kept open once data has been fetched from URI."
        ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
        ;; and then cancel with:
        ;;   sudo tc qdisc del dev eth0 root
-       (let ((port port))
-         (with-timeout (if timeout?
-                           %fetch-timeout
-                           0)
-           (begin
-             (warning (G_ "while fetching ~a: server is somewhat slow~%")
-                      (uri->string uri))
-             (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-           (http-fetch uri #:text? #f #:port port
-                       #:keep-alive? keep-alive?
-                       #:buffered? buffered?
-                       #:verify-certificate? #f)))))
+       (with-timeout (if timeout?
+                         %fetch-timeout
+                         0)
+         (begin
+           (warning (G_ "while fetching ~a: server is somewhat slow~%")
+                    (uri->string uri))
+           (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+         (http-fetch uri #:text? #f #:port port
+                     #:keep-alive? keep-alive?
+                     #:buffered? buffered?
+                     #:verify-certificate? #f))))
     (else
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
             (uri->string uri)))))
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:16 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:16 2021
Received: from localhost ([127.0.0.1]:42589 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5o-0005u1-45
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:16 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49410)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5g-0005sK-3B
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:09 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id A3E3C27BC13
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:06 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 42d2a158
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 01/13] substitute: Remove buffer handling from fetch.
Date: Sat, 16 Jan 2021 13:57:51 +0000
Message-Id: <20210116135803.21955-1-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

http-fetch does this, so just set the right option.

* guix/scripts/substitute.scm (fetch): Remove buffering code, and pass
 #:buffered? to http-fetch.
---
 guix/scripts/substitute.scm | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 2eefdb79d8..aaafb5d605 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -204,10 +204,9 @@ connection (typically PORT) is kept open once data has been fetched from URI."
              (when (or (not port) (port-closed? port))
                (set! port (guix:open-connection-for-uri
                            uri #:verify-certificate? #f)))
-             (unless (or buffered? (not (file-port? port)))
-               (setvbuf port 'none))
              (http-fetch uri #:text? #f #:port port
                          #:keep-alive? keep-alive?
+                         #:buffered? buffered?
                          #:verify-certificate? #f))))))
     (else
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:12 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:12 2021
Received: from localhost ([127.0.0.1]:42587 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5j-0005tV-Hc
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:12 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49412)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5g-0005sL-1G
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:09 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id D0A9327BC14
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:06 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 6a747df8
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 02/13] substitute: Remove connection handling from fetch.
Date: Sat, 16 Jan 2021 13:57:52 +0000
Message-Id: <20210116135803.21955-2-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

http-fetch does this, so just use that code instead.

* guix/scripts/substitute.scm (fetch): Remove connection handling when the
port is closed.
---
 guix/scripts/substitute.scm | 12 ++++--------
 1 file changed, 4 insertions(+), 8 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index aaafb5d605..74fce15117 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -200,14 +200,10 @@ connection (typically PORT) is kept open once data has been fetched from URI."
              (warning (G_ "while fetching ~a: server is somewhat slow~%")
                       (uri->string uri))
              (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-           (begin
-             (when (or (not port) (port-closed? port))
-               (set! port (guix:open-connection-for-uri
-                           uri #:verify-certificate? #f)))
-             (http-fetch uri #:text? #f #:port port
-                         #:keep-alive? keep-alive?
-                         #:buffered? buffered?
-                         #:verify-certificate? #f))))))
+           (http-fetch uri #:text? #f #:port port
+                       #:keep-alive? keep-alive?
+                       #:buffered? buffered?
+                       #:verify-certificate? #f)))))
     (else
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
             (uri->string uri)))))
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 16 Jan 2021 13:58:11 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Jan 16 08:58:11 2021
Received: from localhost ([127.0.0.1]:42581 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1l0m5i-0005sz-6Y
	for submit <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:11 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49420)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1l0m5g-0005sO-1F
 for 45409 <at> debbugs.gnu.org; Sat, 16 Jan 2021 08:58:09 -0500
Received: from localhost (188.29.101.63.threembb.co.uk [188.29.101.63])
 by mira.cbaines.net (Postfix) with ESMTPSA id 3CD5927BC17
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:07 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 78ff9e06
 for <45409 <at> debbugs.gnu.org>; Sat, 16 Jan 2021 13:58:03 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v4 05/13] http-client: Add error handling to http-multiple-get.
Date: Sat, 16 Jan 2021 13:57:55 +0000
Message-Id: <20210116135803.21955-5-mail@HIDDEN>
X-Mailer: git-send-email 2.30.0
In-Reply-To: <20210116135803.21955-1-mail@HIDDEN>
References: <20210116135803.21955-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Making sure to close the port if it looks to be unusable. This closing of the
port will allow for caching connections, without caching broken connections,
as the cache can avoid handing out closed ports.

* guix/http-client.scm (http-multiple-get): Try to catch exceptions that
happen if the port is unusable, this is a adaptation of code within the (guix
scripts substitute) module.
---
 guix/http-client.scm | 74 +++++++++++++++++++++++++++++++++-----------
 1 file changed, 56 insertions(+), 18 deletions(-)

diff --git a/guix/http-client.scm b/guix/http-client.scm
index 7ead493633..3aba3b28c1 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -38,6 +38,7 @@
   #:use-module (guix utils)
   #:use-module (guix base64)
   #:autoload   (gcrypt hash) (sha256)
+  #:autoload   (gnutls) (error/invalid-session)
   #:use-module ((guix build utils)
                 #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
@@ -180,10 +181,25 @@ returning."
         ;; 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))
+        (catch #t
+          (lambda ()
+            (for-each (cut write-request <> buffer)
+                      batch)
+            (put-bytevector p (get))
+            (force-output p))
+          (lambda (key . args)
+            ;; If PORT becomes unusable, open a fresh connection and
+            ;; retry.
+            (if (or (and (eq? key 'system-error)
+                         (= EPIPE (system-error-errno `(,key ,@args))))
+                    (and (eq? key 'gnutls-error)
+                         (eq? (first args) error/invalid-session)))
+                (begin
+                  (close-port p)    ; close the broken port
+                  (connect #f
+                           requests
+                           result))
+                (apply throw key args)))))
 
       ;; Now start processing responses.
       (let loop ((sent      batch)
@@ -199,20 +215,42 @@ returning."
              (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
+           (catch #t
+             (lambda ()
+               (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
+             (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, or a
+               ;; ERROR/INVALID-SESSION from GnuTLS.
+               (if (or (and (eq? key 'system-error)
+                            (= EPIPE (system-error-errno `(,key ,@args))))
+                       (and (eq? key 'gnutls-error)
+                            (eq? (first args) error/invalid-session))
+                       (memq key
+                             '(bad-response bad-header bad-header-component)))
+                   (begin
+                     (close-port p)
+                     (connect #f      ; try again
+                              (drop requests (+ 1 processed))
+                              result))
+                   (apply throw key args))))))))))
 
 
 ;;;
-- 
2.30.0





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 11 Jan 2021 13:26:35 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jan 11 08:26:35 2021
Received: from localhost ([127.0.0.1]:56100 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kyxDP-0005pw-GQ
	for submit <at> debbugs.gnu.org; Mon, 11 Jan 2021 08:26:35 -0500
Received: from eggs.gnu.org ([209.51.188.92]:55054)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kyxDN-0005pe-VM
 for 45409 <at> debbugs.gnu.org; Mon, 11 Jan 2021 08:26:34 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:36668)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kyxDI-0005sZ-Ku; Mon, 11 Jan 2021 08:26:28 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=57936 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kyxDH-0006eK-A8; Mon, 11 Jan 2021 08:26:27 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 3/3] guix: Split (guix substitutes) from
 (guix scripts substitute).
References: <20210104211927.14959-1-mail@HIDDEN>
 <20210104211927.14959-3-mail@HIDDEN> <87r1mzrqgk.fsf@HIDDEN>
 <87zh1kidoc.fsf@HIDDEN>
X-URL: http://www.fdn.fr/~lcourtes/
X-Revolutionary-Date: 22 =?utf-8?Q?Niv=C3=B4se?= an 229 de la =?utf-8?Q?R?=
 =?utf-8?Q?=C3=A9volution?=
X-PGP-Key-ID: 0x090B11993D9AEBB5
X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc
X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4  0CFB 090B 1199 3D9A EBB5
X-OS: x86_64-pc-linux-gnu
Date: Mon, 11 Jan 2021 14:26:26 +0100
In-Reply-To: <87zh1kidoc.fsf@HIDDEN> (Christopher Baines's message of
 "Thu, 07 Jan 2021 22:29:23 +0000")
Message-ID: <87im83eha5.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Hi,

Christopher Baines <mail@HIDDEN> skribis:

>> I=E2=80=99m reluctant starting this new module while it still contains
>> single-short-lived-process assumptions (connection caching & co.).
>>
>> How about proceeding like this:
>>
>>   1. Move =E2=80=98http-multiple-get=E2=80=99 to (guix http-client).
>>
>>   2. Postpone the (guix substitute) bit to a separate patch series to
>>      leave us the time to polish things a bit and removes the
>>      single-process assumptions, or just move fewer things to (guix
>>      substitutes).
>>
>> You could push (guix narinfo) in the meantime since I think that one is
>> almost ready.
>>
>> How does that sound?  Am I being too cautious?
>
> Well, separating out the connection caching might be helpful for
> cleaning things up in the Guix Build Coordinator, I had to add a mutex
> currently as I'm guessing the caching isn't thread safe.

Precisely, that=E2=80=99s the kind of reason why it=E2=80=99s currently bur=
ied in (guix
scripts substitute) rather than exposed as a reusable library.  :-)

> I think it's possible to separate it out if some of the error handling
> is pushed down in to the http procedures, and if when they get an error
> indicating the connection is unusable, they close the port.

Ideally the (web =E2=80=A6) modules would do that (that=E2=80=99s what you =
mean, right?)
but then we=E2=80=99d have to wait for Guile proper to implement these thin=
gs.

> I've pushed some rough commits for this to this branch:
>
>   https://git.cbaines.net/guix/log/?h=3Dprepare-to-move-guix-scripts-subs=
titute-code
>
> I'm still struggling with the tests, currently make check hangs, I think
> on the challenge tests, and I don't currently have a plan to work out
> why the test is hanging.

Overall the approach LGTM.

How about first getting (guix narinfo) in =E2=80=98master=E2=80=99 (the bit=
s we agreed
on), and then tackling the rest so that it=E2=80=99s less daunting?

Also, I=E2=80=99d like to get the zstd patches in.  :-)

Thanks,
Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 7 Jan 2021 22:29:34 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Jan 07 17:29:33 2021
Received: from localhost ([127.0.0.1]:48849 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kxdmf-0005hI-I9
	for submit <at> debbugs.gnu.org; Thu, 07 Jan 2021 17:29:33 -0500
Received: from mira.cbaines.net ([212.71.252.8]:49244)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kxdmc-0005h8-34
 for 45409 <at> debbugs.gnu.org; Thu, 07 Jan 2021 17:29:32 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id D1EF127BC0E;
 Thu,  7 Jan 2021 22:29:28 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 2953f32b;
 Thu, 7 Jan 2021 22:29:26 +0000 (UTC)
References: <20210104211927.14959-1-mail@HIDDEN>
 <20210104211927.14959-3-mail@HIDDEN> <87r1mzrqgk.fsf@HIDDEN>
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 3/3] guix: Split (guix substitutes) from
 (guix scripts substitute).
In-reply-to: <87r1mzrqgk.fsf@HIDDEN>
Date: Thu, 07 Jan 2021 22:29:23 +0000
Message-ID: <87zh1kidoc.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


Ludovic Court=C3=A8s <ludo@HIDDEN> writes:

> Christopher Baines <mail@HIDDEN> skribis:
>
>> This means there's a module for working with substitutes, rather than al=
l the
>> code sitting in the script. The need for this can be seen with the weath=
er and
>> challenge scripts, that now don't have to use code from the substitute s=
cript,
>> but can instead use the substitute module.
>>
>> The separation here between the actual functionality of the substitute s=
cript
>> and the underlying functionality used both there and elsewhere should ma=
ke
>> maintenance easier moving forward.
>>
>> This commit just moves code, none of the code should have been changed
>> significantly.
>>
>> * guix/scripts/substitute.scm (%narinfo-cache-directory, %narinfo-ttl,
>> %narinfo-negative-ttl, %narinfo-transient-error-ttl, %unreachable-hosts,
>> %max-cached-connections): Move variables to (guix substitutes).
>> (narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request, at=
-most,
>> http-multiple-get, read-to-eof, narinfo-from-file,
>> open-connection-for-uri/maybe, fetch-narinfos, lookup-narinfos,
>> lookup-narinfos/diverse, open-connection-for-uri/cached,
>> call-with-cached-connection): Move procedures to (guix substitutes).
>> (with-cached-connection): Move syntax rule to (guix substitutes).
>> * guix/substitutes.scm: New file.
>> * Makefile.am (MODULES): Add it.
>> * po/guix/POTFILES.in: Add 'guix/substitutes.scm'.
>
> I=E2=80=99m reluctant starting this new module while it still contains
> single-short-lived-process assumptions (connection caching & co.).
>
> How about proceeding like this:
>
>   1. Move =E2=80=98http-multiple-get=E2=80=99 to (guix http-client).
>
>   2. Postpone the (guix substitute) bit to a separate patch series to
>      leave us the time to polish things a bit and removes the
>      single-process assumptions, or just move fewer things to (guix
>      substitutes).
>
> You could push (guix narinfo) in the meantime since I think that one is
> almost ready.
>
> How does that sound?  Am I being too cautious?

Well, separating out the connection caching might be helpful for
cleaning things up in the Guix Build Coordinator, I had to add a mutex
currently as I'm guessing the caching isn't thread safe.

I think it's possible to separate it out if some of the error handling
is pushed down in to the http procedures, and if when they get an error
indicating the connection is unusable, they close the port.

I've pushed some rough commits for this to this branch:

  https://git.cbaines.net/guix/log/?h=3Dprepare-to-move-guix-scripts-substi=
tute-code

I'm still struggling with the tests, currently make check hangs, I think
on the challenge tests, and I don't currently have a plan to work out
why the test is hanging.

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/3i0NfFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9XfBUg//QCsNw8UNJ92v+orRrmNP71sDfmC4gAe8
BBvwWOuJLKe2mVchYTL4AN5B6Qvmhcob00W3mEdXVet9tb9aW6zdSUI0y0vTcfiJ
A5MkjI5guOQm2rG/zCrju4pkCPxkxFk/qSju1Q07vR4eAMU4EBCmpiXT06/e0ceT
BHvGVY9b7oClCHRMRh3DzMdG3SU978KyVBJxZXD8+q/LwqQ/SAH1cP47Ku/3koHq
T9vUq303/f0zPfpU2WE3sky19Sbm710tiiFC2rzW8zM+5pzPr4Pzl1SyRtSCo55E
l27YaxOAYVW1Jvj2n7eFLdsV5msoUlU2jSg57XdZIKSbDgK3Bs2u+GW6FOwP4mGy
SysR8ZqQ8RIiQh0cZFmoADhk4FGYIuJevwGgIig5v+mtH1FlpTxbtq90kjhrmdKH
4Wdcr2mh5Syvo/saF7eHqKguV48Z9tNN5XC00mWQ2GANv65EPFP3f/eilshiIeFo
ZR91773aFQ113A6EQvz2Yh2zroODgLjgeXXB7qJAmnl7xy09G9VncXMIBgr52K0s
4u4WvOKw2uDvdXPsmeGLR2yDrwG9irHo835bfDFndylsVScdVlgJW+y48co9/yka
flWG4Onh5FThsIWd66rIzoICHrXGNxqW8FjW4fSA7NDhjbK+YV6uEOVQI6LhBlXf
rI5LHQrdU7M=
=gxvx
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 6 Jan 2021 08:37:25 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Jan 06 03:37:25 2021
Received: from localhost ([127.0.0.1]:43360 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kx4Jp-0008LB-2A
	for submit <at> debbugs.gnu.org; Wed, 06 Jan 2021 03:37:25 -0500
Received: from eggs.gnu.org ([209.51.188.92]:39820)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kx4Jn-0008Ky-4r
 for 45409 <at> debbugs.gnu.org; Wed, 06 Jan 2021 03:37:23 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:55321)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kx4Jh-0004a2-RU; Wed, 06 Jan 2021 03:37:17 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=41264 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kx4Jh-0004a7-EK; Wed, 06 Jan 2021 03:37:17 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 1/3] substitute: Untangle skipping
 authentication from valid-narinfo?.
References: <87y2hn9l8j.fsf@HIDDEN>
 <20210104211927.14959-1-mail@HIDDEN> <871rezt5cd.fsf@HIDDEN>
 <878s97j8ja.fsf@HIDDEN>
X-URL: http://www.fdn.fr/~lcourtes/
X-Revolutionary-Date: 17 =?utf-8?Q?Niv=C3=B4se?= an 229 de la =?utf-8?Q?R?=
 =?utf-8?Q?=C3=A9volution?=
X-PGP-Key-ID: 0x090B11993D9AEBB5
X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc
X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4  0CFB 090B 1199 3D9A EBB5
X-OS: x86_64-pc-linux-gnu
Date: Wed, 06 Jan 2021 09:37:16 +0100
In-Reply-To: <878s97j8ja.fsf@HIDDEN> (Christopher Baines's message of
 "Tue, 05 Jan 2021 22:58:17 +0000")
Message-ID: <87im8asbpf.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Hi,

Christopher Baines <mail@HIDDEN> skribis:

> Ludovic Court=C3=A8s <ludo@HIDDEN> writes:
>
>> Hi,
>>
>> Christopher Baines <mail@HIDDEN> skribis:
>>
>>> Rather than having valid-narinfo? evaluate to #t if
>>> %allow-unauthenticated-substitutes? is set to #t, just use (const #t) f=
or
>>> valid-narinfo? when %allow-unauthenticated-substitutes? is set to #t.  =
This
>>> will allow moving valid-narinfo? in to a (guix substitutes) module.
>>>
>>> * guix/scripts/substitute.scm (process-query, process-substitution): Ch=
ange
>>> the authorized? argument to lookup-narinfo and lookup-narinfos/diverse =
based
>>> on %allow-unauthenticated-substitutes?.
>>> (valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?.
>>
>> Bummer that there are two call sites.
>>
>> What about doing away with =E2=80=98%allow-unauthenticated-substitutes?=
=E2=80=99 and
>> instead changing its only user, =E2=80=98tests/substitute.scm=E2=80=99, =
like so:

My bad, I missed that =E2=80=98test-env=E2=80=99 does:

  GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES=3Dyes

So what I proposed won=E2=80=99t work.

All in all, let=E2=80=99s just take the patch you proposed.  Sorry for the
confusion!

> I don't know what's up with these tests in particular, adding peek in
> places makes tests fail... not using Guile debugging helpers and
> outputting to (current-error-port) seems to not change the result
> though.

Yeah that=E2=80=99s because (current-output-port) is used to communicate wi=
th
the daemon, so if you inadvertently write things there, it breaks.

> I didn't really understand this code, but looking at it more, I'm
> thinking now that what it actually does is affects all the tests, and
> for some tests in the (tests substitute) module, the
> %allow-unauthenticated-substitutes? behaviour is turned off.

Yeah, I got the logic wrong.

> Commenting out the relevant code in the script seems to support this,
> the substitute tests still pass, but tests in the store, derivation and
> guix-daemon modules fail. The substitute tests are actually fine, and
> break if you disable substitute authentication. The mock approach is
> probably feasible, but it would need to be done in those
> modules/tests. I haven't looked at the details, but I'd be a little
> concerned that it might require mocking in each of the individual 15
> failing tests, maybe that's good for being explicit though?
>
> Back to the use of %allow-unauthenticated-substitutes? in the code,
> there are two call sites, for the two separate code paths, but it would
> be pretty easy to move to one call site. Both process-query and
> process-substitution take an acl, but they could instead take some
> (valid? obj) procedure. That would either call (valid-narinfo? obj acl)
> or just evaluate to #t in the allow unauthorized case. This effectively
> moves the logic and call site to the command.

Yeah but the patch you proposed is fine.

Thanks and apologies for the back-and-forth!

Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 5 Jan 2021 22:58:25 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue Jan 05 17:58:25 2021
Received: from localhost ([127.0.0.1]:42912 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwvHV-0001JC-8Y
	for submit <at> debbugs.gnu.org; Tue, 05 Jan 2021 17:58:25 -0500
Received: from mira.cbaines.net ([212.71.252.8]:59558)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kwvHU-0001J4-0f
 for 45409 <at> debbugs.gnu.org; Tue, 05 Jan 2021 17:58:24 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id BCECB27BC0C;
 Tue,  5 Jan 2021 22:58:22 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 052057ac;
 Tue, 5 Jan 2021 22:58:20 +0000 (UTC)
References: <87y2hn9l8j.fsf@HIDDEN>
 <20210104211927.14959-1-mail@HIDDEN> <871rezt5cd.fsf@HIDDEN>
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 1/3] substitute: Untangle skipping
 authentication from valid-narinfo?.
In-reply-to: <871rezt5cd.fsf@HIDDEN>
Date: Tue, 05 Jan 2021 22:58:17 +0000
Message-ID: <878s97j8ja.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


Ludovic Court=C3=A8s <ludo@HIDDEN> writes:

> Hi,
>
> Christopher Baines <mail@HIDDEN> skribis:
>
>> Rather than having valid-narinfo? evaluate to #t if
>> %allow-unauthenticated-substitutes? is set to #t, just use (const #t) for
>> valid-narinfo? when %allow-unauthenticated-substitutes? is set to #t.  T=
his
>> will allow moving valid-narinfo? in to a (guix substitutes) module.
>>
>> * guix/scripts/substitute.scm (process-query, process-substitution): Cha=
nge
>> the authorized? argument to lookup-narinfo and lookup-narinfos/diverse b=
ased
>> on %allow-unauthenticated-substitutes?.
>> (valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?.
>
> Bummer that there are two call sites.
>
> What about doing away with =E2=80=98%allow-unauthenticated-substitutes?=
=E2=80=99 and
> instead changing its only user, =E2=80=98tests/substitute.scm=E2=80=99, l=
ike so:
>
> diff --git a/tests/substitute.scm b/tests/substitute.scm
> index 542aaf603f..1827ffe8d4 100644
> --- a/tests/substitute.scm
> +++ b/tests/substitute.scm
> @@ -178,10 +178,10 @@ a file for NARINFO."
>          (call-with-output-file
>              (string-append narinfo-directory "/example.nar")
>            (cute write-file
> -                (string-append narinfo-directory "/example.out") <>))
> -
> -        (%allow-unauthenticated-substitutes? #f))
> -      thunk
> +                (string-append narinfo-directory "/example.out") <>)))
> +      (lambda ()
> +        (mock ((guix narinfo) valid-narinfo?) (const #t)
> +              (thunk)))
>        (lambda ()
>          (when (file-exists? cache-directory)
>            (delete-file-recursively cache-directory))))))
>
> That change would have to be made in the patch that creates (guix
> narinfo).
>
> WDYT?

I don't know what's up with these tests in particular, adding peek in
places makes tests fail... not using Guile debugging helpers and
outputting to (current-error-port) seems to not change the result
though.

I didn't really understand this code, but looking at it more, I'm
thinking now that what it actually does is affects all the tests, and
for some tests in the (tests substitute) module, the
%allow-unauthenticated-substitutes? behaviour is turned off.

Commenting out the relevant code in the script seems to support this,
the substitute tests still pass, but tests in the store, derivation and
guix-daemon modules fail. The substitute tests are actually fine, and
break if you disable substitute authentication. The mock approach is
probably feasible, but it would need to be done in those
modules/tests. I haven't looked at the details, but I'd be a little
concerned that it might require mocking in each of the individual 15
failing tests, maybe that's good for being explicit though?

Back to the use of %allow-unauthenticated-substitutes? in the code,
there are two call sites, for the two separate code paths, but it would
be pretty easy to move to one call site. Both process-query and
process-substitution take an acl, but they could instead take some
(valid? obj) procedure. That would either call (valid-narinfo? obj acl)
or just evaluate to #t in the allow unauthorized case. This effectively
moves the logic and call site to the command.

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/07wlfFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9Xf64RAAqQ6xADmqmC1avTCo5hHpSLtLqPInecDx
Q4v75eLD2uHXZfCnGbpvdvdIujVdtnBqQjfWSPK432zOAw2o0x+o6KBo3ogtKQ4n
CGhx+aKpnUC0MjptbA+bWlXnKnwn/+n5OX4U+WxPjkg5zxiuWVvc9nz6GFdd15EZ
jzoRz+9Hq/+YfyxPN+rjiw7l48w6T7PgWwpgoprwZZw5u3prLZqXhPWLMYSianf0
iYIC5pxqKEhKCKGFoVZOL6ZXjXQT7r73R6GN2t5TsjuaVafhYImetoWPiK5HAyRq
sMKu2q7L+VMrOEtUndmjqYukBRw+yUzWYilfqqCKWoy33WuHbj+CP6VD2EUHQ9S4
LpIrdJKwdQ7a7tiYYw5O1UWeOvsN8lAMaW+yrUvhK1j79yKrxo0tpq51Qda43kdt
+QmTSP3cUVrmyY19UVqNa3QrwDI9h2zzgUV8kD5+g7kAkxZmGe2l16mkhPK+Fg4U
uaM6YPY+sod73nc//iaiySQ5orz8Dokza7BnELur2IJnqBh6G6qyfanbRBGoXyIE
G4Ne46OZuObFvN2qmSt9r8MQYqOYXFmmnpN0XIvkCsX7ErsCfNGHhEzavdJHqel6
y2y5c/CnkLzMnf3jaV+VGWJVDl1+9njPPMX3n9v7uJhCE4zGMWk2ol356JOCb9cj
FHKGWJv2trU=
=wM9k
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 5 Jan 2021 22:04:04 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue Jan 05 17:04:04 2021
Received: from localhost ([127.0.0.1]:42885 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwuQt-0008Sf-Pw
	for submit <at> debbugs.gnu.org; Tue, 05 Jan 2021 17:04:04 -0500
Received: from eggs.gnu.org ([209.51.188.92]:44920)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kwuQs-0008SC-26
 for 45409 <at> debbugs.gnu.org; Tue, 05 Jan 2021 17:04:02 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:45999)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kwuQm-0007ex-U9; Tue, 05 Jan 2021 17:03:56 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=41116 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kwuQm-00025v-E9; Tue, 05 Jan 2021 17:03:56 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 3/3] guix: Split (guix substitutes) from
 (guix scripts substitute).
References: <20210104211927.14959-1-mail@HIDDEN>
 <20210104211927.14959-3-mail@HIDDEN>
Date: Tue, 05 Jan 2021 23:03:55 +0100
In-Reply-To: <20210104211927.14959-3-mail@HIDDEN> (Christopher Baines's
 message of "Mon, 4 Jan 2021 21:19:27 +0000")
Message-ID: <87r1mzrqgk.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Christopher Baines <mail@HIDDEN> skribis:

> 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 weathe=
r and
> challenge scripts, that now don't have to use code from the substitute sc=
ript,
> but can instead use the substitute module.
>
> The separation here between the actual functionality of the substitute sc=
ript
> 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.
>
> * guix/scripts/substitute.scm (%narinfo-cache-directory, %narinfo-ttl,
> %narinfo-negative-ttl, %narinfo-transient-error-ttl, %unreachable-hosts,
> %max-cached-connections): Move variables to (guix substitutes).
> (narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request, at-=
most,
> http-multiple-get, read-to-eof, narinfo-from-file,
> open-connection-for-uri/maybe, fetch-narinfos, lookup-narinfos,
> lookup-narinfos/diverse, open-connection-for-uri/cached,
> call-with-cached-connection): Move procedures to (guix substitutes).
> (with-cached-connection): Move syntax rule to (guix substitutes).
> * guix/substitutes.scm: New file.
> * Makefile.am (MODULES): Add it.
> * po/guix/POTFILES.in: Add 'guix/substitutes.scm'.

I=E2=80=99m reluctant starting this new module while it still contains
single-short-lived-process assumptions (connection caching & co.).

How about proceeding like this:

  1. Move =E2=80=98http-multiple-get=E2=80=99 to (guix http-client).

  2. Postpone the (guix substitute) bit to a separate patch series to
     leave us the time to polish things a bit and removes the
     single-process assumptions, or just move fewer things to (guix
     substitutes).

You could push (guix narinfo) in the meantime since I think that one is
almost ready.

How does that sound?  Am I being too cautious?

Thanks again! :-)

Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 5 Jan 2021 21:58:48 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue Jan 05 16:58:48 2021
Received: from localhost ([127.0.0.1]:42869 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwuLn-0008IQ-O5
	for submit <at> debbugs.gnu.org; Tue, 05 Jan 2021 16:58:48 -0500
Received: from eggs.gnu.org ([209.51.188.92]:43176)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kwuLm-0008IF-Qr
 for 45409 <at> debbugs.gnu.org; Tue, 05 Jan 2021 16:58:47 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:45889)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kwuLh-0005hD-IE; Tue, 05 Jan 2021 16:58:41 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=41114 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kwuLZ-0002qY-JW; Tue, 05 Jan 2021 16:58:38 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 2/3] guix: Move narinfo code from
 substitute script to module.
References: <20210104211927.14959-1-mail@HIDDEN>
 <20210104211927.14959-2-mail@HIDDEN>
Date: Tue, 05 Jan 2021 22:58:32 +0100
In-Reply-To: <20210104211927.14959-2-mail@HIDDEN> (Christopher Baines's
 message of "Mon, 4 Jan 2021 21:19:26 +0000")
Message-ID: <87wnwrrqpj.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Christopher Baines <mail@HIDDEN> skribis:

> This separation between the code for dealing with narinfos from the code =
doing
> that for a purpose should make things clearer, and better support compone=
nts
> other that the substitute script in using this code.
>
> This is just moving the code around, no code should have been significant=
ly
> changed.
>
> * guix/scripts/substitute.scm (<narinfo>): Move record type to (guix nari=
nfo).
> (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.
> * po/guix/POTFILES.in: Add 'guix/narinfo.scm'.

[...]

> +(define-module (guix narinfo)

[...]

> +  #:use-module (guix scripts substitute)

This one should be removed.

Otherwise LGTM!

Thanks,
Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 5 Jan 2021 21:57:18 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue Jan 05 16:57:18 2021
Received: from localhost ([127.0.0.1]:42861 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwuKM-0008Fa-A8
	for submit <at> debbugs.gnu.org; Tue, 05 Jan 2021 16:57:18 -0500
Received: from eggs.gnu.org ([209.51.188.92]:42618)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kwuKK-0008FB-0G
 for 45409 <at> debbugs.gnu.org; Tue, 05 Jan 2021 16:57:16 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:45858)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kwuKE-00059v-L8; Tue, 05 Jan 2021 16:57:10 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=41112 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kwuKC-0000lJ-0l; Tue, 05 Jan 2021 16:57:08 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH v3 1/3] substitute: Untangle skipping
 authentication from valid-narinfo?.
References: <87y2hn9l8j.fsf@HIDDEN>
 <20210104211927.14959-1-mail@HIDDEN>
Date: Tue, 05 Jan 2021 22:57:06 +0100
In-Reply-To: <20210104211927.14959-1-mail@HIDDEN> (Christopher Baines's
 message of "Mon, 4 Jan 2021 21:19:25 +0000")
Message-ID: <871rezt5cd.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="=-=-="
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable

Hi,

Christopher Baines <mail@HIDDEN> skribis:

> Rather than having valid-narinfo? evaluate to #t if
> %allow-unauthenticated-substitutes? is set to #t, just use (const #t) for
> valid-narinfo? when %allow-unauthenticated-substitutes? is set to #t.  Th=
is
> will allow moving valid-narinfo? in to a (guix substitutes) module.
>
> * guix/scripts/substitute.scm (process-query, process-substitution): Chan=
ge
> the authorized? argument to lookup-narinfo and lookup-narinfos/diverse ba=
sed
> on %allow-unauthenticated-substitutes?.
> (valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?.

Bummer that there are two call sites.

What about doing away with =E2=80=98%allow-unauthenticated-substitutes?=E2=
=80=99 and
instead changing its only user, =E2=80=98tests/substitute.scm=E2=80=99, lik=
e so:


--=-=-=
Content-Type: text/x-patch
Content-Disposition: inline

diff --git a/tests/substitute.scm b/tests/substitute.scm
index 542aaf603f..1827ffe8d4 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -178,10 +178,10 @@ a file for NARINFO."
         (call-with-output-file
             (string-append narinfo-directory "/example.nar")
           (cute write-file
-                (string-append narinfo-directory "/example.out") <>))
-
-        (%allow-unauthenticated-substitutes? #f))
-      thunk
+                (string-append narinfo-directory "/example.out") <>)))
+      (lambda ()
+        (mock ((guix narinfo) valid-narinfo?) (const #t)
+              (thunk)))
       (lambda ()
         (when (file-exists? cache-directory)
           (delete-file-recursively cache-directory))))))

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


That change would have to be made in the patch that creates (guix
narinfo).

WDYT?

Ludo=E2=80=99.

--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 4 Jan 2021 21:24:06 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jan 04 16:24:06 2021
Received: from localhost ([127.0.0.1]:60454 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwXKf-0006Oa-Q3
	for submit <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:24:05 -0500
Received: from mira.cbaines.net ([212.71.252.8]:34464)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kwXKe-0006OT-SR
 for 45409 <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:24:05 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id 2F58227BC0B;
 Mon,  4 Jan 2021 21:24:04 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 449f5e74;
 Mon, 4 Jan 2021 21:24:01 +0000 (UTC)
References: <87y2hn9l8j.fsf@HIDDEN>
 <20201224172221.21057-1-mail@HIDDEN> <87pn2m12s4.fsf@HIDDEN>
 <87turx998y.fsf@HIDDEN>
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute
 script to module.
In-reply-to: <87turx998y.fsf@HIDDEN>
Date: Mon, 04 Jan 2021 21:24:01 +0000
Message-ID: <87k0ssjszy.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain


I've sent a v3 now that fixes some conflicts and should apply once more
upon master.

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/zh3FfFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9Xc++BAAl2/jjzbTcEXRq2eJjWUGIrhq18+b5vC7
hKkhx+FLYK8WzMH99wHDkPV1QBv98LFaCSF8WSr/jcufvi4PJlDQQZRRKsK/XH2O
JneQIeOOElspDFDjpJqCErmjTYmMfXifkputuDGCnA565Nhf9yc/DNlkUPje628J
JS9hCrMV1wq1d8zFBx1eK5xRtFk3xCQcwwrNWGZ0ciM9TKhqdSrLxs57vGrdfz46
Sj4ce1kdRCwjz9wWmq9lvGFv/sTFcze6G8qaRZo5e+mNGXBIm97+trlnaMVbrP7x
XRUXzVuDMO8jrTAJbct6hrsFUaQQR6fFltKSWsG1ZAcl1FX5lpr8JiAueq82bU9H
MYGaDlyGt75iogMSAKpTjSZiSjgEPsTRq1/7MreEyos0cy3vYO1KosutPkrpoNX+
XsLqtSa/I1KdC/SswH35bP5zHdy+aNTwketfdE827BAFK3RzfPLXmZzWJofQ3sly
6UKgCbW6os5U4kLis54uSCJjvTnyFrgygsaq82jRlac5YtBUaGY9fUIK3ziVt3V2
lUVm9o6xYKP4WIHJZFInNUNG36gDXhxh4iK+1xYlLJjChry0is1RKUzqWIKd22VF
8n6/a0Yr3iYmez+KS7hPfzLRQuXFrM2gEAXi9+8vwINqsneSfYEB+h5H5MTveI1X
wy0zL6jh9WE=
=dVAY
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 4 Jan 2021 21:19:41 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jan 04 16:19:41 2021
Received: from localhost ([127.0.0.1]:60448 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwXGL-0006HY-Vq
	for submit <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:41 -0500
Received: from mira.cbaines.net ([212.71.252.8]:34166)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kwXGE-0006H0-O1
 for 45409 <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:35 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id 1529A27BC0D
 for <45409 <at> debbugs.gnu.org>; Mon,  4 Jan 2021 21:19:30 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 9b3c8acf
 for <45409 <at> debbugs.gnu.org>; Mon, 4 Jan 2021 21:19:27 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v3 3/3] guix: Split (guix substitutes) from (guix scripts
 substitute).
Date: Mon,  4 Jan 2021 21:19:27 +0000
Message-Id: <20210104211927.14959-3-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20210104211927.14959-1-mail@HIDDEN>
References: <20210104211927.14959-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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.

* guix/scripts/substitute.scm (%narinfo-cache-directory, %narinfo-ttl,
%narinfo-negative-ttl, %narinfo-transient-error-ttl, %unreachable-hosts,
%max-cached-connections): Move variables to (guix substitutes).
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request, at-most,
http-multiple-get, read-to-eof, narinfo-from-file,
open-connection-for-uri/maybe, fetch-narinfos, lookup-narinfos,
lookup-narinfos/diverse, open-connection-for-uri/cached,
call-with-cached-connection): Move procedures to (guix substitutes).
(with-cached-connection): Move syntax rule to (guix substitutes).
* guix/substitutes.scm: New file.
* Makefile.am (MODULES): Add it.
* po/guix/POTFILES.in: Add 'guix/substitutes.scm'.
---
 Makefile.am                 |   1 +
 guix/scripts/challenge.scm  |   2 +-
 guix/scripts/substitute.scm | 486 +--------------------------------
 guix/scripts/weather.scm    |   2 +-
 guix/substitutes.scm        | 531 ++++++++++++++++++++++++++++++++++++
 po/guix/POTFILES.in         |   1 +
 6 files changed, 540 insertions(+), 483 deletions(-)
 create mode 100644 guix/substitutes.scm

diff --git a/Makefile.am b/Makefile.am
index 69166a2ea1..fe39eae53c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,7 @@ MODULES =					\
   guix/memoization.scm				\
   guix/utils.scm				\
   guix/sets.scm					\
+  guix/substitutes.scm				\
   guix/modules.scm				\
   guix/download.scm				\
   guix/discovery.scm				\
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index cc9cbe6f27..74cf163937 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 substitutes)
   #: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 f9bcead045..45c07b1038 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -23,39 +23,30 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix narinfo)
+  #:use-module (guix substitutes)
   #: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))
-  #:autoload   (gnutls) (error/invalid-session)
+                           . 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)
@@ -69,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
@@ -89,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!~%"))
@@ -112,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))
@@ -213,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: <http://bugs.gnu.org/22966>.
-      (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."
@@ -719,82 +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, or a
-        ;; ERROR/INVALID-SESSION from GnuTLS.
-        (if (or (and (eq? key 'system-error)
-                     (= EPIPE (system-error-errno `(,key ,@args))))
-                (and (eq? key 'gnutls-error)
-                     (eq? (first args) error/invalid-session))
-                (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..527a63560d 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 substitutes)
   #:use-module (guix http-client)
   #:use-module (guix ci)
   #:use-module (guix sets)
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
new file mode 100644
index 0000000000..7c2012d307
--- /dev/null
+++ b/guix/substitutes.scm
@@ -0,0 +1,531 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix substitutes)
+  #: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 diagnostics)
+  #: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)))
+  #:autoload   (gnutls) (error/invalid-session)
+  #: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, or a
+        ;; ERROR/INVALID-SESSION from GnuTLS.
+        (if (or (and (eq? key 'system-error)
+                     (= EPIPE (system-error-errno `(,key ,@args))))
+                (and (eq? key 'gnutls-error)
+                     (eq? (first args) error/invalid-session))
+                (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: <http://bugs.gnu.org/22966>.
+      (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:
+
+;;; substitutes.scm ends here
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 666e630adf..fa397d7969 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -88,6 +88,7 @@ guix/status.scm
 guix/http-client.scm
 guix/nar.scm
 guix/narinfo.scm
+guix/substitutes.scm
 guix/channels.scm
 guix/profiles.scm
 guix/git.scm
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 4 Jan 2021 21:19:38 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jan 04 16:19:38 2021
Received: from localhost ([127.0.0.1]:60446 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwXGH-0006HH-Az
	for submit <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:37 -0500
Received: from mira.cbaines.net ([212.71.252.8]:34164)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kwXGE-0006Gz-Li
 for 45409 <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:32 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id E3D5B27BC0C
 for <45409 <at> debbugs.gnu.org>; Mon,  4 Jan 2021 21:19:29 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 124654a8
 for <45409 <at> debbugs.gnu.org>; Mon, 4 Jan 2021 21:19:27 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v3 2/3] guix: Move narinfo code from substitute script to
 module.
Date: Mon,  4 Jan 2021 21:19:26 +0000
Message-Id: <20210104211927.14959-2-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20210104211927.14959-1-mail@HIDDEN>
References: <20210104211927.14959-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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 (<narinfo>): 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.
* po/guix/POTFILES.in: Add 'guix/narinfo.scm'.
---
 Makefile.am                 |   1 +
 guix/narinfo.scm            | 324 ++++++++++++++++++++++++++++++++++++
 guix/scripts/challenge.scm  |   1 +
 guix/scripts/substitute.scm | 281 +------------------------------
 guix/scripts/weather.scm    |   1 +
 po/guix/POTFILES.in         |   1 +
 tests/challenge.scm         |   2 +-
 tests/substitute.scm        |   1 +
 8 files changed, 332 insertions(+), 280 deletions(-)
 create mode 100644 guix/narinfo.scm

diff --git a/Makefile.am b/Makefile.am
index aec2bb1474..69166a2ea1 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..5965758bff
--- /dev/null
+++ b/guix/narinfo.scm
@@ -0,0 +1,324 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <narinfo>
+  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
+                 nar-hash nar-size references deriver system
+                 signature contents)
+  narinfo?
+  (path         narinfo-path)
+  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
+  (uris         narinfo-uris)            ;list of strings
+  (compressions narinfo-compressions)    ;list of strings
+  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
+  (file-hashes  narinfo-file-hashes)
+  (nar-hash     narinfo-hash)
+  (nar-size     narinfo-size)
+  (references   narinfo-references)
+  (deriver      narinfo-deriver)
+  (system       narinfo-system)
+  (signature    narinfo-signature)      ; canonical sexp
+  ;; The original contents of a narinfo file.  This field is needed because we
+  ;; want to preserve the exact textual representation for verification purposes.
+  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
+  ;; for more information.
+  (contents     narinfo-contents))
+
+(define (narinfo-hash-algorithm+value narinfo)
+  "Return two values: the hash algorithm used by NARINFO and its value as a
+bytevector."
+  (match (string-tokenize (narinfo-hash narinfo)
+                          (char-set-complement (char-set #\:)))
+    ((algorithm base32)
+     (values (lookup-hash-algorithm (string->symbol algorithm))
+             (nix-base32-string->bytevector base32)))
+    (_
+     (raise (formatted-message
+             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
+
+(define (narinfo-hash->sha256 hash)
+  "If the string HASH denotes a sha256 hash, return it as a bytevector.
+Otherwise return #f."
+  (and (string-prefix? "sha256:" hash)
+       (nix-base32-string->bytevector (string-drop hash 7))))
+
+(define (narinfo-signature->canonical-sexp str)
+  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
+  (match (string-split str #\;)
+    ((version host-name sig)
+     (let ((maybe-number (string->number version)))
+       (cond ((not (number? maybe-number))
+              (leave (G_ "signature version must be a number: ~s~%")
+                     version))
+             ;; Currently, there are no other versions.
+             ((not (= 1 maybe-number))
+              (leave (G_ "unsupported signature version: ~a~%")
+                     maybe-number))
+             (else
+              (let ((signature (utf8->string (base64-decode sig))))
+                (catch 'gcry-error
+                  (lambda ()
+                    (string->canonical-sexp signature))
+                  (lambda (key proc err)
+                    (leave (G_ "signature is not a valid \
+s-expression: ~s~%")
+                           signature))))))))
+    (x
+     (leave (G_ "invalid format of the signature field: ~a~%") x))))
+
+(define (narinfo-maker str cache-url)
+  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
+must contain the original contents of a narinfo file."
+  (lambda (path urls compressions file-hashes file-sizes
+                nar-hash nar-size references deriver system
+                signature)
+    "Return a new <narinfo> object."
+    (define len (length urls))
+    (%make-narinfo path cache-url
+                   ;; Handle the case where URL is a relative URL.
+                   (map (lambda (url)
+                          (or (string->uri url)
+                              (string->uri
+                               (string-append cache-url "/" url))))
+                        urls)
+                   compressions
+                   (match file-sizes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   (match file-hashes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   nar-hash
+                   (and=> nar-size string->number)
+                   (string-tokenize references)
+                   (match deriver
+                     ((or #f "") #f)
+                     (_ deriver))
+                   system
+                   (false-if-exception
+                    (and=> signature narinfo-signature->canonical-sexp))
+                   str)))
+
+(define 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))
+    ("xz"    . ,(const #t))
+    ("bzip2" . ,(const #t))
+    ("none"  . ,(const #t))))
+
+(define (supported-compression? compression)
+  "Return true if COMPRESSION, a string, denotes a supported compression
+method."
+  (match (assoc-ref %compression-methods compression)
+    (#f         #f)
+    (supported? (supported?))))
+
+(define (compresses-better? compression1 compression2)
+  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
+this is a rough approximation."
+  (match compression1
+    ("none" #f)
+    ("gzip" (string=? compression2 "none"))
+    (_      (or (string=? compression2 "none")
+                (string=? compression2 "gzip")))))
+
+(define (narinfo-best-uri narinfo)
+  "Select the \"best\" URI to download NARINFO's nar, and return three values:
+the URI, its compression method (a string), and the compressed file size."
+  (define choices
+    (filter (match-lambda
+              ((uri compression file-size)
+               (supported-compression? compression)))
+            (zip (narinfo-uris narinfo)
+                 (narinfo-compressions narinfo)
+                 (narinfo-file-sizes narinfo))))
+
+  (define (file-size<? c1 c2)
+    (match c1
+      ((uri1 compression1 (? integer? file-size1))
+       (match c2
+         ((uri2 compression2 (? integer? file-size2))
+          (< file-size1 file-size2))
+         (_ #t)))
+      ((uri compression1 #f)
+       (match c2
+         ((uri2 compression2 _)
+          (compresses-better? compression1 compression2))))
+      (_ #f)))                                    ;we can't tell
+
+  (match (sort choices file-size<?)
+    (((uri compression file-size) _ ...)
+     (values uri compression file-size))))
+
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index d0a456ac1d..cc9cbe6f27 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -28,6 +28,7 @@
   #:use-module ((guix progress) #:hide (dump-port*))
   #:use-module (guix serialization)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #: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 14fb848880..f9bcead045 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -22,6 +22,7 @@
 (define-module (guix scripts substitute)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module (guix narinfo)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix combinators)
@@ -68,29 +69,8 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (guix http-client)
-  #:export (narinfo-signature->canonical-sexp
-
-            narinfo?
-            narinfo-path
-            narinfo-uris
-            narinfo-uri-base
-            narinfo-compressions
-            narinfo-file-hashes
-            narinfo-file-sizes
-            narinfo-hash
-            narinfo-size
-            narinfo-references
-            narinfo-deriver
-            narinfo-system
-            narinfo-signature
-
-            narinfo-hash->sha256
-            narinfo-best-uri
-
-            lookup-narinfos
+  #:export (lookup-narinfos
             lookup-narinfos/diverse
-            read-narinfo
-            write-narinfo
 
             %allow-unauthenticated-substitutes?
             %error-to-file-descriptor-4?
@@ -150,10 +130,6 @@ disabled!~%"))
   ;; How often we want to remove files corresponding to expired cache entries.
   (* 7 24 3600))
 
-(define fields->alist
-  ;; The narinfo format is really just like recutils.
-  recutils->alist)
-
 (define %fetch-timeout
   ;; Number of seconds after which networking is considered "slow".
   5)
@@ -237,190 +213,6 @@ connection (typically PORT) is kept open once data has been fetched from URI."
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
             (uri->string uri)))))
 
-
-(define-record-type <narinfo>
-  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
-                 nar-hash nar-size references deriver system
-                 signature contents)
-  narinfo?
-  (path         narinfo-path)
-  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
-  (uris         narinfo-uris)            ;list of strings
-  (compressions narinfo-compressions)    ;list of strings
-  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
-  (file-hashes  narinfo-file-hashes)
-  (nar-hash     narinfo-hash)
-  (nar-size     narinfo-size)
-  (references   narinfo-references)
-  (deriver      narinfo-deriver)
-  (system       narinfo-system)
-  (signature    narinfo-signature)      ; canonical sexp
-  ;; The original contents of a narinfo file.  This field is needed because we
-  ;; want to preserve the exact textual representation for verification purposes.
-  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
-  ;; for more information.
-  (contents     narinfo-contents))
-
-(define (narinfo-hash-algorithm+value narinfo)
-  "Return two values: the hash algorithm used by NARINFO and its value as a
-bytevector."
-  (match (string-tokenize (narinfo-hash narinfo)
-                          (char-set-complement (char-set #\:)))
-    ((algorithm base32)
-     (values (lookup-hash-algorithm (string->symbol algorithm))
-             (nix-base32-string->bytevector base32)))
-    (_
-     (raise (formatted-message
-             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
-
-(define (narinfo-hash->sha256 hash)
-  "If the string HASH denotes a sha256 hash, return it as a bytevector.
-Otherwise return #f."
-  (and (string-prefix? "sha256:" hash)
-       (nix-base32-string->bytevector (string-drop hash 7))))
-
-(define (narinfo-signature->canonical-sexp str)
-  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
-  (match (string-split str #\;)
-    ((version host-name sig)
-     (let ((maybe-number (string->number version)))
-       (cond ((not (number? maybe-number))
-              (leave (G_ "signature version must be a number: ~s~%")
-                     version))
-             ;; Currently, there are no other versions.
-             ((not (= 1 maybe-number))
-              (leave (G_ "unsupported signature version: ~a~%")
-                     maybe-number))
-             (else
-              (let ((signature (utf8->string (base64-decode sig))))
-                (catch 'gcry-error
-                  (lambda ()
-                    (string->canonical-sexp signature))
-                  (lambda (key proc err)
-                    (leave (G_ "signature is not a valid \
-s-expression: ~s~%")
-                           signature))))))))
-    (x
-     (leave (G_ "invalid format of the signature field: ~a~%") x))))
-
-(define (narinfo-maker str cache-url)
-  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
-must contain the original contents of a narinfo file."
-  (lambda (path urls compressions file-hashes file-sizes
-                nar-hash nar-size references deriver system
-                signature)
-    "Return a new <narinfo> object."
-    (define len (length urls))
-    (%make-narinfo path cache-url
-                   ;; Handle the case where URL is a relative URL.
-                   (map (lambda (url)
-                          (or (string->uri url)
-                              (string->uri
-                               (string-append cache-url "/" url))))
-                        urls)
-                   compressions
-                   (match file-sizes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   (match file-hashes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   nar-hash
-                   (and=> nar-size string->number)
-                   (string-tokenize references)
-                   (match deriver
-                     ((or #f "") #f)
-                     (_ deriver))
-                   system
-                   (false-if-exception
-                    (and=> signature narinfo-signature->canonical-sexp))
-                   str)))
-
-(define* (read-narinfo port #:optional url
-                       #:key size)
-  "Read a narinfo from PORT.  If URL is true, it must be a string used to
-build full URIs from relative URIs found while reading PORT.  When SIZE is
-true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
-
-No authentication and authorization checks are performed here!"
-  (let ((str (utf8->string (if size
-                               (get-bytevector-n port size)
-                               (get-bytevector-all port)))))
-    (alist->record (call-with-input-string str fields->alist)
-                   (narinfo-maker str url)
-                   '("StorePath" "URL" "Compression"
-                     "FileHash" "FileSize" "NarHash" "NarSize"
-                     "References" "Deriver" "System"
-                     "Signature")
-                   '("URL" "Compression" "FileSize" "FileHash"))))
-
-(define (narinfo-sha256 narinfo)
-  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
-'Signature' field."
-  (define %mandatory-fields
-    ;; List of fields that must be signed.  If they are not signed, the
-    ;; narinfo is considered unsigned.
-    '("StorePath" "NarHash" "References"))
-
-  (let ((contents (narinfo-contents narinfo)))
-    (match (string-contains contents "Signature:")
-      (#f #f)
-      (index
-       (let* ((above-signature (string-take contents index))
-              (signed-fields (match (call-with-input-string above-signature
-                                      fields->alist)
-                               (((fields . values) ...) fields))))
-         (and (every (cut member <> signed-fields) %mandatory-fields)
-              (sha256 (string->utf8 above-signature))))))))
-
-(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
-                         #:key verbose?)
-  "Return #t if NARINFO's signature is not valid."
-  (let ((hash      (narinfo-sha256 narinfo))
-        (signature (narinfo-signature narinfo))
-        (uri       (uri->string (first (narinfo-uris narinfo)))))
-    (and hash signature
-         (signature-case (signature hash acl)
-           (valid-signature #t)
-           (invalid-signature
-            (when verbose?
-              (format (current-error-port)
-                      "invalid signature for substitute at '~a'~%"
-                      uri))
-            #f)
-           (hash-mismatch
-            (when verbose?
-              (format (current-error-port)
-                      "hash mismatch for substitute at '~a'~%"
-                      uri))
-            #f)
-           (unauthorized-key
-            (when verbose?
-              (format (current-error-port)
-                      "substitute at '~a' is signed by an \
-unauthorized party~%"
-                      uri))
-            #f)
-           (corrupt-signature
-            (when verbose?
-              (format (current-error-port)
-                      "corrupt signature for substitute at '~a'~%"
-                      uri))
-            #f)))))
-
-(define (write-narinfo narinfo port)
-  "Write NARINFO to PORT."
-  (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
-
-(define (narinfo->string narinfo)
-  "Return the external representation of NARINFO."
-  (call-with-output-string (cut write-narinfo narinfo <>)))
-
-(define (string->narinfo str cache-uri)
-  "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
-the cache STR originates form."
-  (call-with-input-string str (cut read-narinfo <> cache-uri)))
-
 (define (narinfo-cache-file cache-url path)
   "Return the name of the local file that contains an entry for PATH.  The
 entry is stored in a sub-directory specific to CACHE-URL."
@@ -742,22 +534,6 @@ information is available locally."
         (let ((missing (fetch-narinfos cache missing)))
           (append cached (or missing '()))))))
 
-(define (equivalent-narinfo? narinfo1 narinfo2)
-  "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe
-the same store item.  This ignores unnecessary metadata such as the Nar URL."
-  (and (string=? (narinfo-hash narinfo1)
-                 (narinfo-hash narinfo2))
-
-       ;; The following is not needed if all we want is to download a valid
-       ;; nar, but it's necessary if we want valid narinfo.
-       (string=? (narinfo-path narinfo1)
-                 (narinfo-path narinfo2))
-       (equal? (narinfo-references narinfo1)
-               (narinfo-references narinfo2))
-
-       (= (narinfo-size narinfo1)
-          (narinfo-size narinfo2))))
-
 (define (lookup-narinfos/diverse caches paths authorized?)
   "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
 That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
@@ -943,59 +719,6 @@ authorized substitutes."
     (wtf
      (error "unknown `--query' command" wtf))))
 
-(define %compression-methods
-  ;; Known compression methods and a thunk to determine whether they're
-  ;; supported.  See 'decompressed-port' in (guix utils).
-  `(("gzip"  . ,(const #t))
-    ("lzip"  . ,(const #t))
-    ("xz"    . ,(const #t))
-    ("bzip2" . ,(const #t))
-    ("none"  . ,(const #t))))
-
-(define (supported-compression? compression)
-  "Return true if COMPRESSION, a string, denotes a supported compression
-method."
-  (match (assoc-ref %compression-methods compression)
-    (#f         #f)
-    (supported? (supported?))))
-
-(define (compresses-better? compression1 compression2)
-  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
-this is a rough approximation."
-  (match compression1
-    ("none" #f)
-    ("gzip" (string=? compression2 "none"))
-    (_      (or (string=? compression2 "none")
-                (string=? compression2 "gzip")))))
-
-(define (narinfo-best-uri narinfo)
-  "Select the \"best\" URI to download NARINFO's nar, and return three values:
-the URI, its compression method (a string), and the compressed file size."
-  (define choices
-    (filter (match-lambda
-              ((uri compression file-size)
-               (supported-compression? compression)))
-            (zip (narinfo-uris narinfo)
-                 (narinfo-compressions narinfo)
-                 (narinfo-file-sizes narinfo))))
-
-  (define (file-size<? c1 c2)
-    (match c1
-      ((uri1 compression1 (? integer? file-size1))
-       (match c2
-         ((uri2 compression2 (? integer? file-size2))
-          (< file-size1 file-size2))
-         (_ #t)))
-      ((uri compression1 #f)
-       (match c2
-         ((uri2 compression2 _)
-          (compresses-better? compression1 compression2))))
-      (_ #f)))                                    ;we can't tell
-
-  (match (sort choices file-size<?)
-    (((uri compression file-size) _ ...)
-     (values uri compression file-size))))
-
 (define %max-cached-connections
   ;; Maximum number of connections kept in cache by
   ;; 'open-connection-for-uri/cached'.
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index f28070ddc4..97e4a73802 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -33,6 +33,7 @@
   #: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 http-client)
   #:use-module (guix ci)
   #:use-module (guix sets)
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 1aec3bef3c..666e630adf 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -87,6 +87,7 @@ guix/ui.scm
 guix/status.scm
 guix/http-client.scm
 guix/nar.scm
+guix/narinfo.scm
 guix/channels.scm
 guix/profiles.scm
 guix/git.scm
diff --git a/tests/challenge.scm b/tests/challenge.scm
index 9c6d6e0d58..fdd5fd238e 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -27,8 +27,8 @@
   #:use-module (guix packages)
   #:use-module (guix gexp)
   #:use-module (guix base32)
+  #:use-module (guix narinfo)
   #:use-module (guix scripts challenge)
-  #:use-module (guix scripts substitute)
   #:use-module ((guix build utils) #:select (find-files))
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 542aaf603f..697abc4684 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -19,6 +19,7 @@
 
 (define-module (test-substitute)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #:use-module (guix base64)
   #:use-module (gcrypt hash)
   #:use-module (guix serialization)
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 4 Jan 2021 21:19:33 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jan 04 16:19:33 2021
Received: from localhost ([127.0.0.1]:60444 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kwXGG-0006HE-TS
	for submit <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:33 -0500
Received: from mira.cbaines.net ([212.71.252.8]:34162)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kwXGE-0006Gy-Lr
 for 45409 <at> debbugs.gnu.org; Mon, 04 Jan 2021 16:19:31 -0500
Received: from localhost (188.28.108.198.threembb.co.uk [188.28.108.198])
 by mira.cbaines.net (Postfix) with ESMTPSA id C05D127BC0B
 for <45409 <at> debbugs.gnu.org>; Mon,  4 Jan 2021 21:19:29 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id f7664b32
 for <45409 <at> debbugs.gnu.org>; Mon, 4 Jan 2021 21:19:27 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v3 1/3] substitute: Untangle skipping authentication from
 valid-narinfo?.
Date: Mon,  4 Jan 2021 21:19:25 +0000
Message-Id: <20210104211927.14959-1-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Rather than having valid-narinfo? evaluate to #t if
%allow-unauthenticated-substitutes? is set to #t, just use (const #t) for
valid-narinfo? when %allow-unauthenticated-substitutes? is set to #t.  This
will allow moving valid-narinfo? in to a (guix substitutes) 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?.
(valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?.
---
 guix/scripts/substitute.scm | 77 ++++++++++++++++++++-----------------
 1 file changed, 41 insertions(+), 36 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index e53de8c304..14fb848880 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
 ;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;; Copyright © 2020 Christopher Baines <mail@HIDDEN>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -375,38 +376,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."
@@ -918,11 +918,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)
@@ -1079,7 +1082,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) "/")
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 18:19:32 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 13:19:32 2021
Received: from localhost ([127.0.0.1]:38587 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw7yW-0000Jl-7c
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 13:19:32 -0500
Received: from mira.cbaines.net ([212.71.252.8]:40472)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kw7yU-0000Jd-8q
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 13:19:31 -0500
Received: from localhost (92.41.186.20.threembb.co.uk [92.41.186.20])
 by mira.cbaines.net (Postfix) with ESMTPSA id BE55527BC0D;
 Sun,  3 Jan 2021 18:19:29 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 74372971;
 Sun, 3 Jan 2021 18:19:27 +0000 (UTC)
References: <20201224172221.21057-1-mail@HIDDEN>
 <20201224172221.21057-3-mail@HIDDEN> <87czym12j1.fsf@HIDDEN>
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH 3/3] guix: Split (guix substitute) from
 (guix scripts substitute).
In-reply-to: <87czym12j1.fsf@HIDDEN>
Date: Sun, 03 Jan 2021 18:19:26 +0000
Message-ID: <87r1n1993l.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


Ludovic Court=C3=A8s <ludo@HIDDEN> writes:

> Hi,
>
> Christopher Baines <mail@HIDDEN> skribis:
>
>> This means there's a module for working with substitutes, rather than al=
l the
>> code sitting in the script. The need for this can be seen with the weath=
er and
>> challenge scripts, that now don't have to use code from the substitute s=
cript,
>> but can instead use the substitute module.
>>
>> The separation here between the actual functionality of the substitute s=
cript
>> and the underlying functionality used both there and elsewhere should ma=
ke
>> maintenance easier moving forward.
>>
>> This commit just moves code, none of the code should have been changed
>> significantly.
>
> It would still be nice to list the identifiers that were moved in the
> commit log, it=E2=80=99s boring :-) but it can be helpful when browsing t=
he
> history.

Sure, I've done that now, I'd got bored by this point before.

> As for the split, I wouldn=E2=80=99t put as much into (guix substitutes) =
(I=E2=80=99d
> use =E2=80=9Csubstitutes=E2=80=9D, plural, for consistency with most othe=
r modules.)

Done.

> As a rule of thumb, I would keep in (guix scripts substitute) anything
> that=E2=80=99s very much biased towards a single short-lived process: con=
nection
> cache, host name resolution failure cache, etc.  These things are a bit
> hacky and not designed for use as a library.  They=E2=80=99re also very m=
uch
> policy rather than mechanism, and as such they don=E2=80=99t belong in a =
proper
> library IMO.

I think that's fine, but it's harder said than done. I think the
connection caching and host name resolution failure caching code would
need unpicking from the general substitute fetching code, and I haven't
attempted to do that yet.

>> -(define* (http-multiple-get base-uri proc seed requests
>> -                            #:key port (verify-certificate? #t)
>> -                            (open-connection guix:open-connection-for-u=
ri)
>> -                            (keep-alive? #t)
>> -                            (batch-size 1000))
>
> How about moving this one to (guix http-client), as a separate patch?
> I think it=E2=80=99s a better fit and could be useful elsewhere.

Sure, that sounds good, I'll look at it later with a separate patch.

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/yCq5fFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9Xfoig//S4ZjMTWa03WY4nJMp7mDcZyARD4fFm4c
kv68rqYN5Ye011fQYZdTl3gGzUOc2/cR0da95OnRcM7j5P/8C6LBssMEVgJdiodu
e6QYA8fo6GSBsg73AZ2PjnivQy5HTPwUOIJfsUQAWIYZPb1xpgQFN2CBO2EnjphO
DEdwAHBpLua2Y63euLoteuLK1/pMA6yqMxXxz5BlYRNKsdVsfWkkBXOE8oFU339/
zlBh30AMYfXDhd+ty2988JaoCXYj1jiLfBH4yohV33v79UbLEoNQxKGbTGWQcG/l
qWDNJy9sJDBlhqPOT70eSxm0/4VBbLaBOcRk1eG4zSMm/aikCB1MUnHfz9aZcwsV
GIFwRo+vk7WJ3ZLpFQVHW9QoH3p4oXIKrL/SEkYabya50zLZqW8cPqQC9amvnruX
JWImOtwQ1qikTufyVOp92970atxUGkID6P/kqDm+yNOVYHc6vI1p/xwpAaFIrv0L
xZQmt13flLbt/ECFDTnEDFJBhjIxYAPCbwsgByEymEgngBTVWvLuum48x+74oI+I
Th+v8+q3/AFg1744PS8cebY3Ao+xEz806kgqqT9B6dkKRdSM860znHQNF7ls/ugR
aG2Otl6qj3aLDhqIH+4mrP0uhMGFAoPIv+ED3giJNWsmlv9R2rsYI/0cth+NP2FM
CEKtZD/upj8=
=TZRo
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 18:16:19 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 13:16:19 2021
Received: from localhost ([127.0.0.1]:38583 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw7vO-0000FB-Hk
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 13:16:18 -0500
Received: from mira.cbaines.net ([212.71.252.8]:40424)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kw7vM-0000F3-Oi
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 13:16:17 -0500
Received: from localhost (92.41.186.20.threembb.co.uk [92.41.186.20])
 by mira.cbaines.net (Postfix) with ESMTPSA id 0830427BC09;
 Sun,  3 Jan 2021 18:16:15 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 2d7a6d26;
 Sun, 3 Jan 2021 18:16:13 +0000 (UTC)
References: <87y2hn9l8j.fsf@HIDDEN>
 <20201224172221.21057-1-mail@HIDDEN> <87pn2m12s4.fsf@HIDDEN>
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: Ludovic =?utf-8?Q?Court=C3=A8s?= <ludo@HIDDEN>
Subject: Re: [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute
 script to module.
In-reply-to: <87pn2m12s4.fsf@HIDDEN>
Date: Sun, 03 Jan 2021 18:16:13 +0000
Message-ID: <87turx998y.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable


Ludovic Court=C3=A8s <ludo@HIDDEN> writes:

> Christopher Baines <mail@HIDDEN> skribis:
>
>> This separation between the code for dealing with narinfos from the code=
 doing
>> that for a purpose should make things clearer, and better support compon=
ents
>> other that the substitute script in using this code.
>>
>> This is just moving the code around, no code should have been significan=
tly
>> changed.
>>
>> * guix/scripts/substitute.scm (<narinfo>): Move record type to (guix nar=
info).
>> (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.
>
> That=E2=80=99s a good idea!
>
> Please add guix/narinfo.scm to po/guix/POTFILES.in so it can be
> translated.

I've sent some updated patches now, and I've fixed this in them.

>> +(define-module (guix narinfo)
>> +  #:use-module (guix ui)
>
> We should try and avoid (guix ui); is (guix diagnostics) enough?

Yep, that seems to work fine.

>> +  #:use-module (guix scripts substitute)
>
> (guix =E2=80=A6) modules must not depend on (guix scripts =E2=80=A6).
>
> Perhaps that=E2=80=99s just for =E2=80=98%allow-unauthenticated-substitut=
es?=E2=80=99, no?  If
> so, let=E2=80=99s just not refer to =E2=80=98%allow-unauthenticated-subst=
itutes?=E2=80=99 here.
> It=E2=80=99s a hack to allow for tests, so better keep it local to (guix =
scripts
> substitute).

I've moved the commit where I fix this to be the first one, so this
should be clearer now.

>> +(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
>> +                         #:key verbose?)
>> +  "Return #t if NARINFO's signature is not valid."
>> +  (or (%allow-unauthenticated-substitutes?)
>
> Yeah, let=E2=80=99s remove it from here.  At worst, we can always use =E2=
=80=98mock=E2=80=99 in
> tests to make =E2=80=98valid-narinfo?=E2=80=99 return #t unconditionally.
>
> OK with these changes.
>
> After the change, please make sure =E2=80=9Cmake check=E2=80=9D and =E2=
=80=9Cmake as-derivation=E2=80=9D
> still pass.  For =E2=80=9Cmake as-derivation=E2=80=9D, we should also mak=
e sure
> =E2=80=98guix-core=E2=80=99 doesn=E2=80=99t pull in everything via (guix =
scripts substitute).

Both seem to work for me.

> (The zstd patches will conflict with this series but I=E2=80=99ll take ca=
re of
> it once it=E2=80=99s applied.)

Sounds good.

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/yCe1fFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9XdFeBAAgOEpwej4smaUvF8TdgtTLG1W90vw0FON
xGsSRoznjwaFwiSeaT/RhJ7Fzq2T9Kn1ypt+Uz+KVDamYzxF++pjszkbS4YkNORL
S6Tm2vmTktSZ71/dssEwmW+X+a+VvOkExvv0AKif+5zFELn4Tu9vZ5I9gz6JB0yu
SGvD2VeNYuKIrnOOKFiNaoLuxhRMLcz3MpqUkSdgGm1mnqKAuzmHB3alROICSVNA
PaYys23uumiFSWqbYh/i2EPC1yhL/+mkm5sivctDoTPyNJX6sl15zDdnbPiuGEEo
MhSIPw/RK6iHz2Q0IiF4kvf7yK3UQq9WTBDZngX2u4zUe8UzmdN2xB3/y7JA0efV
TBvYsfuqFwL0Iq2vp57MqmgNlf5Pv7PWDAqJ151cl80+oMNMvJcGethJj0ZwhXcx
nYHzTBenJQ3JyBoN3AOoweVmGF1ES3zXDRnlGN/V4jON+wZn7EloHkvL24uN0lSu
/1Smpe7cBMXc0CfEjC0NX5KNriKUX0+0lEB0v6Y5uDZfOocGYloMlMIjWDzubrFY
b5O2I90OSZxu1/U62eciz1rDmx3m2GpK9bIS0Nh3CeQMulKI6D53jw5a4TmBJoIi
rYL+PO4Vq+taC3UmlDcWXWsrREAvCyJwjs30iE6flEkrlSX2LMRA+umTsRGL9xtk
Ysh0xm/ugXs=
=banI
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 17:59:30 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 12:59:30 2021
Received: from localhost ([127.0.0.1]:38561 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw7f6-0008GE-84
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:30 -0500
Received: from mira.cbaines.net ([212.71.252.8]:40360)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kw7ey-0008Fc-MP
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:26 -0500
Received: from localhost (92.41.186.20.threembb.co.uk [92.41.186.20])
 by mira.cbaines.net (Postfix) with ESMTPSA id 094B527BC0B
 for <45409 <at> debbugs.gnu.org>; Sun,  3 Jan 2021 17:59:20 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 402e1a54
 for <45409 <at> debbugs.gnu.org>; Sun, 3 Jan 2021 17:59:17 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v2 3/3] guix: Split (guix substitutes) from (guix scripts
 substitute).
Date: Sun,  3 Jan 2021 17:59:17 +0000
Message-Id: <20210103175917.15992-3-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20210103175917.15992-1-mail@HIDDEN>
References: <20210103175917.15992-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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.

* guix/scripts/substitute.scm (%narinfo-cache-directory, %narinfo-ttl,
%narinfo-negative-ttl, %narinfo-transient-error-ttl, %unreachable-hosts,
%max-cached-connections): Move variables to (guix substitutes).
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request, at-most,
http-multiple-get, read-to-eof, narinfo-from-file,
open-connection-for-uri/maybe, fetch-narinfos, lookup-narinfos,
lookup-narinfos/diverse, open-connection-for-uri/cached,
call-with-cached-connection): Move procedures to (guix substitutes).
(with-cached-connection): Move syntax rule to (guix substitutes).
* guix/substitutes.scm: New file.
* Makefile.am (MODULES): Add it.
* po/guix/POTFILES.in: Add 'guix/substitutes.scm'.
---
 Makefile.am                 |   1 +
 guix/scripts/challenge.scm  |   2 +-
 guix/scripts/substitute.scm | 482 +--------------------------------
 guix/scripts/weather.scm    |   2 +-
 guix/substitutes.scm        | 527 ++++++++++++++++++++++++++++++++++++
 po/guix/POTFILES.in         |   1 +
 6 files changed, 536 insertions(+), 479 deletions(-)
 create mode 100644 guix/substitutes.scm

diff --git a/Makefile.am b/Makefile.am
index 69166a2ea1..fe39eae53c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,7 @@ MODULES =					\
   guix/memoization.scm				\
   guix/utils.scm				\
   guix/sets.scm					\
+  guix/substitutes.scm				\
   guix/modules.scm				\
   guix/download.scm				\
   guix/discovery.scm				\
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index cc9cbe6f27..74cf163937 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 substitutes)
   #: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..45c07b1038 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 substitutes)
   #: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: <http://bugs.gnu.org/22966>.
-      (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..527a63560d 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 substitutes)
   #:use-module (guix http-client)
   #:use-module (guix ci)
   #:use-module (guix sets)
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
new file mode 100644
index 0000000000..80942185e6
--- /dev/null
+++ b/guix/substitutes.scm
@@ -0,0 +1,527 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix substitutes)
+  #: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 diagnostics)
+  #: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: <http://bugs.gnu.org/22966>.
+      (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:
+
+;;; substitutes.scm ends here
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 666e630adf..fa397d7969 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -88,6 +88,7 @@ guix/status.scm
 guix/http-client.scm
 guix/nar.scm
 guix/narinfo.scm
+guix/substitutes.scm
 guix/channels.scm
 guix/profiles.scm
 guix/git.scm
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 17:59:28 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 12:59:28 2021
Received: from localhost ([127.0.0.1]:38555 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw7f1-0008Fy-UK
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:28 -0500
Received: from mira.cbaines.net ([212.71.252.8]:40358)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kw7ey-0008Fb-MK
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:22 -0500
Received: from localhost (92.41.186.20.threembb.co.uk [92.41.186.20])
 by mira.cbaines.net (Postfix) with ESMTPSA id D6A9C27BC0A
 for <45409 <at> debbugs.gnu.org>; Sun,  3 Jan 2021 17:59:19 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 5d8c4515
 for <45409 <at> debbugs.gnu.org>; Sun, 3 Jan 2021 17:59:17 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v2 2/3] guix: Move narinfo code from substitute script to
 module.
Date: Sun,  3 Jan 2021 17:59:16 +0000
Message-Id: <20210103175917.15992-2-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20210103175917.15992-1-mail@HIDDEN>
References: <20210103175917.15992-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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 (<narinfo>): 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.
* po/guix/POTFILES.in: Add 'guix/narinfo.scm'.
---
 Makefile.am                 |   1 +
 guix/narinfo.scm            | 324 ++++++++++++++++++++++++++++++++++++
 guix/scripts/challenge.scm  |   1 +
 guix/scripts/substitute.scm | 281 +------------------------------
 guix/scripts/weather.scm    |   1 +
 po/guix/POTFILES.in         |   1 +
 tests/challenge.scm         |   2 +-
 tests/substitute.scm        |   1 +
 8 files changed, 332 insertions(+), 280 deletions(-)
 create mode 100644 guix/narinfo.scm

diff --git a/Makefile.am b/Makefile.am
index aec2bb1474..69166a2ea1 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..5965758bff
--- /dev/null
+++ b/guix/narinfo.scm
@@ -0,0 +1,324 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <narinfo>
+  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
+                 nar-hash nar-size references deriver system
+                 signature contents)
+  narinfo?
+  (path         narinfo-path)
+  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
+  (uris         narinfo-uris)            ;list of strings
+  (compressions narinfo-compressions)    ;list of strings
+  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
+  (file-hashes  narinfo-file-hashes)
+  (nar-hash     narinfo-hash)
+  (nar-size     narinfo-size)
+  (references   narinfo-references)
+  (deriver      narinfo-deriver)
+  (system       narinfo-system)
+  (signature    narinfo-signature)      ; canonical sexp
+  ;; The original contents of a narinfo file.  This field is needed because we
+  ;; want to preserve the exact textual representation for verification purposes.
+  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
+  ;; for more information.
+  (contents     narinfo-contents))
+
+(define (narinfo-hash-algorithm+value narinfo)
+  "Return two values: the hash algorithm used by NARINFO and its value as a
+bytevector."
+  (match (string-tokenize (narinfo-hash narinfo)
+                          (char-set-complement (char-set #\:)))
+    ((algorithm base32)
+     (values (lookup-hash-algorithm (string->symbol algorithm))
+             (nix-base32-string->bytevector base32)))
+    (_
+     (raise (formatted-message
+             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
+
+(define (narinfo-hash->sha256 hash)
+  "If the string HASH denotes a sha256 hash, return it as a bytevector.
+Otherwise return #f."
+  (and (string-prefix? "sha256:" hash)
+       (nix-base32-string->bytevector (string-drop hash 7))))
+
+(define (narinfo-signature->canonical-sexp str)
+  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
+  (match (string-split str #\;)
+    ((version host-name sig)
+     (let ((maybe-number (string->number version)))
+       (cond ((not (number? maybe-number))
+              (leave (G_ "signature version must be a number: ~s~%")
+                     version))
+             ;; Currently, there are no other versions.
+             ((not (= 1 maybe-number))
+              (leave (G_ "unsupported signature version: ~a~%")
+                     maybe-number))
+             (else
+              (let ((signature (utf8->string (base64-decode sig))))
+                (catch 'gcry-error
+                  (lambda ()
+                    (string->canonical-sexp signature))
+                  (lambda (key proc err)
+                    (leave (G_ "signature is not a valid \
+s-expression: ~s~%")
+                           signature))))))))
+    (x
+     (leave (G_ "invalid format of the signature field: ~a~%") x))))
+
+(define (narinfo-maker str cache-url)
+  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
+must contain the original contents of a narinfo file."
+  (lambda (path urls compressions file-hashes file-sizes
+                nar-hash nar-size references deriver system
+                signature)
+    "Return a new <narinfo> object."
+    (define len (length urls))
+    (%make-narinfo path cache-url
+                   ;; Handle the case where URL is a relative URL.
+                   (map (lambda (url)
+                          (or (string->uri url)
+                              (string->uri
+                               (string-append cache-url "/" url))))
+                        urls)
+                   compressions
+                   (match file-sizes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   (match file-hashes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   nar-hash
+                   (and=> nar-size string->number)
+                   (string-tokenize references)
+                   (match deriver
+                     ((or #f "") #f)
+                     (_ deriver))
+                   system
+                   (false-if-exception
+                    (and=> signature narinfo-signature->canonical-sexp))
+                   str)))
+
+(define 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))
+    ("xz"    . ,(const #t))
+    ("bzip2" . ,(const #t))
+    ("none"  . ,(const #t))))
+
+(define (supported-compression? compression)
+  "Return true if COMPRESSION, a string, denotes a supported compression
+method."
+  (match (assoc-ref %compression-methods compression)
+    (#f         #f)
+    (supported? (supported?))))
+
+(define (compresses-better? compression1 compression2)
+  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
+this is a rough approximation."
+  (match compression1
+    ("none" #f)
+    ("gzip" (string=? compression2 "none"))
+    (_      (or (string=? compression2 "none")
+                (string=? compression2 "gzip")))))
+
+(define (narinfo-best-uri narinfo)
+  "Select the \"best\" URI to download NARINFO's nar, and return three values:
+the URI, its compression method (a string), and the compressed file size."
+  (define choices
+    (filter (match-lambda
+              ((uri compression file-size)
+               (supported-compression? compression)))
+            (zip (narinfo-uris narinfo)
+                 (narinfo-compressions narinfo)
+                 (narinfo-file-sizes narinfo))))
+
+  (define (file-size<? c1 c2)
+    (match c1
+      ((uri1 compression1 (? integer? file-size1))
+       (match c2
+         ((uri2 compression2 (? integer? file-size2))
+          (< file-size1 file-size2))
+         (_ #t)))
+      ((uri compression1 #f)
+       (match c2
+         ((uri2 compression2 _)
+          (compresses-better? compression1 compression2))))
+      (_ #f)))                                    ;we can't tell
+
+  (match (sort choices file-size<?)
+    (((uri compression file-size) _ ...)
+     (values uri compression file-size))))
+
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index d0a456ac1d..cc9cbe6f27 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -28,6 +28,7 @@
   #:use-module ((guix progress) #:hide (dump-port*))
   #:use-module (guix serialization)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #: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 d66f73e75a..e2d30f1760 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -22,6 +22,7 @@
 (define-module (guix scripts substitute)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module (guix narinfo)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix combinators)
@@ -67,29 +68,8 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (guix http-client)
-  #:export (narinfo-signature->canonical-sexp
-
-            narinfo?
-            narinfo-path
-            narinfo-uris
-            narinfo-uri-base
-            narinfo-compressions
-            narinfo-file-hashes
-            narinfo-file-sizes
-            narinfo-hash
-            narinfo-size
-            narinfo-references
-            narinfo-deriver
-            narinfo-system
-            narinfo-signature
-
-            narinfo-hash->sha256
-            narinfo-best-uri
-
-            lookup-narinfos
+  #:export (lookup-narinfos
             lookup-narinfos/diverse
-            read-narinfo
-            write-narinfo
 
             %allow-unauthenticated-substitutes?
             %error-to-file-descriptor-4?
@@ -149,10 +129,6 @@ disabled!~%"))
   ;; How often we want to remove files corresponding to expired cache entries.
   (* 7 24 3600))
 
-(define fields->alist
-  ;; The narinfo format is really just like recutils.
-  recutils->alist)
-
 (define %fetch-timeout
   ;; Number of seconds after which networking is considered "slow".
   5)
@@ -236,190 +212,6 @@ connection (typically PORT) is kept open once data has been fetched from URI."
      (leave (G_ "unsupported substitute URI scheme: ~a~%")
             (uri->string uri)))))
 
-
-(define-record-type <narinfo>
-  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
-                 nar-hash nar-size references deriver system
-                 signature contents)
-  narinfo?
-  (path         narinfo-path)
-  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
-  (uris         narinfo-uris)            ;list of strings
-  (compressions narinfo-compressions)    ;list of strings
-  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
-  (file-hashes  narinfo-file-hashes)
-  (nar-hash     narinfo-hash)
-  (nar-size     narinfo-size)
-  (references   narinfo-references)
-  (deriver      narinfo-deriver)
-  (system       narinfo-system)
-  (signature    narinfo-signature)      ; canonical sexp
-  ;; The original contents of a narinfo file.  This field is needed because we
-  ;; want to preserve the exact textual representation for verification purposes.
-  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
-  ;; for more information.
-  (contents     narinfo-contents))
-
-(define (narinfo-hash-algorithm+value narinfo)
-  "Return two values: the hash algorithm used by NARINFO and its value as a
-bytevector."
-  (match (string-tokenize (narinfo-hash narinfo)
-                          (char-set-complement (char-set #\:)))
-    ((algorithm base32)
-     (values (lookup-hash-algorithm (string->symbol algorithm))
-             (nix-base32-string->bytevector base32)))
-    (_
-     (raise (formatted-message
-             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
-
-(define (narinfo-hash->sha256 hash)
-  "If the string HASH denotes a sha256 hash, return it as a bytevector.
-Otherwise return #f."
-  (and (string-prefix? "sha256:" hash)
-       (nix-base32-string->bytevector (string-drop hash 7))))
-
-(define (narinfo-signature->canonical-sexp str)
-  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
-  (match (string-split str #\;)
-    ((version host-name sig)
-     (let ((maybe-number (string->number version)))
-       (cond ((not (number? maybe-number))
-              (leave (G_ "signature version must be a number: ~s~%")
-                     version))
-             ;; Currently, there are no other versions.
-             ((not (= 1 maybe-number))
-              (leave (G_ "unsupported signature version: ~a~%")
-                     maybe-number))
-             (else
-              (let ((signature (utf8->string (base64-decode sig))))
-                (catch 'gcry-error
-                  (lambda ()
-                    (string->canonical-sexp signature))
-                  (lambda (key proc err)
-                    (leave (G_ "signature is not a valid \
-s-expression: ~s~%")
-                           signature))))))))
-    (x
-     (leave (G_ "invalid format of the signature field: ~a~%") x))))
-
-(define (narinfo-maker str cache-url)
-  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
-must contain the original contents of a narinfo file."
-  (lambda (path urls compressions file-hashes file-sizes
-                nar-hash nar-size references deriver system
-                signature)
-    "Return a new <narinfo> object."
-    (define len (length urls))
-    (%make-narinfo path cache-url
-                   ;; Handle the case where URL is a relative URL.
-                   (map (lambda (url)
-                          (or (string->uri url)
-                              (string->uri
-                               (string-append cache-url "/" url))))
-                        urls)
-                   compressions
-                   (match file-sizes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   (match file-hashes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   nar-hash
-                   (and=> nar-size string->number)
-                   (string-tokenize references)
-                   (match deriver
-                     ((or #f "") #f)
-                     (_ deriver))
-                   system
-                   (false-if-exception
-                    (and=> signature narinfo-signature->canonical-sexp))
-                   str)))
-
-(define* (read-narinfo port #:optional url
-                       #:key size)
-  "Read a narinfo from PORT.  If URL is true, it must be a string used to
-build full URIs from relative URIs found while reading PORT.  When SIZE is
-true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
-
-No authentication and authorization checks are performed here!"
-  (let ((str (utf8->string (if size
-                               (get-bytevector-n port size)
-                               (get-bytevector-all port)))))
-    (alist->record (call-with-input-string str fields->alist)
-                   (narinfo-maker str url)
-                   '("StorePath" "URL" "Compression"
-                     "FileHash" "FileSize" "NarHash" "NarSize"
-                     "References" "Deriver" "System"
-                     "Signature")
-                   '("URL" "Compression" "FileSize" "FileHash"))))
-
-(define (narinfo-sha256 narinfo)
-  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
-'Signature' field."
-  (define %mandatory-fields
-    ;; List of fields that must be signed.  If they are not signed, the
-    ;; narinfo is considered unsigned.
-    '("StorePath" "NarHash" "References"))
-
-  (let ((contents (narinfo-contents narinfo)))
-    (match (string-contains contents "Signature:")
-      (#f #f)
-      (index
-       (let* ((above-signature (string-take contents index))
-              (signed-fields (match (call-with-input-string above-signature
-                                      fields->alist)
-                               (((fields . values) ...) fields))))
-         (and (every (cut member <> signed-fields) %mandatory-fields)
-              (sha256 (string->utf8 above-signature))))))))
-
-(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
-                         #:key verbose?)
-  "Return #t if NARINFO's signature is not valid."
-  (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 @@ 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
@@ -942,59 +718,6 @@ authorized substitutes."
     (wtf
      (error "unknown `--query' command" wtf))))
 
-(define %compression-methods
-  ;; Known compression methods and a thunk to determine whether they're
-  ;; supported.  See 'decompressed-port' in (guix utils).
-  `(("gzip"  . ,(const #t))
-    ("lzip"  . ,(const #t))
-    ("xz"    . ,(const #t))
-    ("bzip2" . ,(const #t))
-    ("none"  . ,(const #t))))
-
-(define (supported-compression? compression)
-  "Return true if COMPRESSION, a string, denotes a supported compression
-method."
-  (match (assoc-ref %compression-methods compression)
-    (#f         #f)
-    (supported? (supported?))))
-
-(define (compresses-better? compression1 compression2)
-  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
-this is a rough approximation."
-  (match compression1
-    ("none" #f)
-    ("gzip" (string=? compression2 "none"))
-    (_      (or (string=? compression2 "none")
-                (string=? compression2 "gzip")))))
-
-(define (narinfo-best-uri narinfo)
-  "Select the \"best\" URI to download NARINFO's nar, and return three values:
-the URI, its compression method (a string), and the compressed file size."
-  (define choices
-    (filter (match-lambda
-              ((uri compression file-size)
-               (supported-compression? compression)))
-            (zip (narinfo-uris narinfo)
-                 (narinfo-compressions narinfo)
-                 (narinfo-file-sizes narinfo))))
-
-  (define (file-size<? c1 c2)
-    (match c1
-      ((uri1 compression1 (? integer? file-size1))
-       (match c2
-         ((uri2 compression2 (? integer? file-size2))
-          (< file-size1 file-size2))
-         (_ #t)))
-      ((uri compression1 #f)
-       (match c2
-         ((uri2 compression2 _)
-          (compresses-better? compression1 compression2))))
-      (_ #f)))                                    ;we can't tell
-
-  (match (sort choices file-size<?)
-    (((uri compression file-size) _ ...)
-     (values uri compression file-size))))
-
 (define %max-cached-connections
   ;; Maximum number of connections kept in cache by
   ;; 'open-connection-for-uri/cached'.
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index f28070ddc4..97e4a73802 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -33,6 +33,7 @@
   #: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 http-client)
   #:use-module (guix ci)
   #:use-module (guix sets)
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 1aec3bef3c..666e630adf 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -87,6 +87,7 @@ guix/ui.scm
 guix/status.scm
 guix/http-client.scm
 guix/nar.scm
+guix/narinfo.scm
 guix/channels.scm
 guix/profiles.scm
 guix/git.scm
diff --git a/tests/challenge.scm b/tests/challenge.scm
index 9c6d6e0d58..fdd5fd238e 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -27,8 +27,8 @@
   #:use-module (guix packages)
   #:use-module (guix gexp)
   #:use-module (guix base32)
+  #:use-module (guix narinfo)
   #:use-module (guix scripts challenge)
-  #:use-module (guix scripts substitute)
   #:use-module ((guix build utils) #:select (find-files))
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 542aaf603f..697abc4684 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -19,6 +19,7 @@
 
 (define-module (test-substitute)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #:use-module (guix base64)
   #:use-module (gcrypt hash)
   #:use-module (guix serialization)
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 17:59:23 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 12:59:22 2021
Received: from localhost ([127.0.0.1]:38553 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw7f0-0008Fq-D7
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:22 -0500
Received: from mira.cbaines.net ([212.71.252.8]:40356)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1kw7ey-0008Fa-MI
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 12:59:21 -0500
Received: from localhost (92.41.186.20.threembb.co.uk [92.41.186.20])
 by mira.cbaines.net (Postfix) with ESMTPSA id BCDD027BC09
 for <45409 <at> debbugs.gnu.org>; Sun,  3 Jan 2021 17:59:19 +0000 (GMT)
Received: from localhost (localhost [local])
 by localhost (OpenSMTPD) with ESMTPA id 65825e2d
 for <45409 <at> debbugs.gnu.org>; Sun, 3 Jan 2021 17:59:17 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH v2 1/3] substitute: Untangle skipping authentication from
 valid-narinfo?.
Date: Sun,  3 Jan 2021 17:59:15 +0000
Message-Id: <20210103175917.15992-1-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

Rather than having valid-narinfo? evaluate to #t if
%allow-unauthenticated-substitutes? is set to #t, just use (const #t) for
valid-narinfo? when %allow-unauthenticated-substitutes? is set to #t.  This
will allow moving valid-narinfo? in to a (guix substitutes) 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?.
(valid-narinfo?): Remove use of %allow-unauthenticated-substitutes?.
---
 guix/scripts/substitute.scm | 77 ++++++++++++++++++++-----------------
 1 file changed, 41 insertions(+), 36 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8084c89ae5..d66f73e75a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@HIDDEN>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
 ;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;; Copyright © 2020 Christopher Baines <mail@HIDDEN>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -374,38 +375,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."
@@ -917,11 +917,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)
@@ -1075,7 +1078,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) "/")
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 15:08:43 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 10:08:42 2021
Received: from localhost ([127.0.0.1]:38330 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw4zq-000415-MP
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 10:08:42 -0500
Received: from eggs.gnu.org ([209.51.188.92]:60052)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kw4zp-00040t-MK
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 10:08:41 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:43472)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kw4zk-0001PE-Gu; Sun, 03 Jan 2021 10:08:36 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33262 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kw4zk-0002Qt-2s; Sun, 03 Jan 2021 10:08:36 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH 3/3] guix: Split (guix substitute) from
 (guix scripts substitute).
References: <20201224172221.21057-1-mail@HIDDEN>
 <20201224172221.21057-3-mail@HIDDEN>
Date: Sun, 03 Jan 2021 16:08:34 +0100
In-Reply-To: <20201224172221.21057-3-mail@HIDDEN> (Christopher Baines's
 message of "Thu, 24 Dec 2020 17:22:21 +0000")
Message-ID: <87czym12j1.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Hi,

Christopher Baines <mail@HIDDEN> skribis:

> 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 weathe=
r and
> challenge scripts, that now don't have to use code from the substitute sc=
ript,
> but can instead use the substitute module.
>
> The separation here between the actual functionality of the substitute sc=
ript
> 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.

It would still be nice to list the identifiers that were moved in the
commit log, it=E2=80=99s boring :-) but it can be helpful when browsing the
history.

As for the split, I wouldn=E2=80=99t put as much into (guix substitutes) (I=
=E2=80=99d
use =E2=80=9Csubstitutes=E2=80=9D, plural, for consistency with most other =
modules.)

As a rule of thumb, I would keep in (guix scripts substitute) anything
that=E2=80=99s very much biased towards a single short-lived process: conne=
ction
cache, host name resolution failure cache, etc.  These things are a bit
hacky and not designed for use as a library.  They=E2=80=99re also very much
policy rather than mechanism, and as such they don=E2=80=99t belong in a pr=
oper
library IMO.

> -(define* (http-multiple-get base-uri proc seed requests
> -                            #:key port (verify-certificate? #t)
> -                            (open-connection guix:open-connection-for-ur=
i)
> -                            (keep-alive? #t)
> -                            (batch-size 1000))

How about moving this one to (guix http-client), as a separate patch?
I think it=E2=80=99s a better fit and could be useful elsewhere.

Thanks!

Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 3 Jan 2021 15:03:16 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Jan 03 10:03:16 2021
Received: from localhost ([127.0.0.1]:38315 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1kw4ua-0003so-Gv
	for submit <at> debbugs.gnu.org; Sun, 03 Jan 2021 10:03:16 -0500
Received: from eggs.gnu.org ([209.51.188.92]:59154)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1kw4uY-0003sa-GM
 for 45409 <at> debbugs.gnu.org; Sun, 03 Jan 2021 10:03:15 -0500
Received: from fencepost.gnu.org ([2001:470:142:3::e]:43359)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <ludo@HIDDEN>)
 id 1kw4uT-0007wa-Al; Sun, 03 Jan 2021 10:03:09 -0500
Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33260 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1kw4uS-0000wW-Qk; Sun, 03 Jan 2021 10:03:09 -0500
From: =?utf-8?Q?Ludovic_Court=C3=A8s?= <ludo@HIDDEN>
To: Christopher Baines <mail@HIDDEN>
Subject: Re: [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute
 script to module.
References: <87y2hn9l8j.fsf@HIDDEN>
 <20201224172221.21057-1-mail@HIDDEN>
Date: Sun, 03 Jan 2021 16:03:07 +0100
In-Reply-To: <20201224172221.21057-1-mail@HIDDEN> (Christopher Baines's
 message of "Thu, 24 Dec 2020 17:22:19 +0000")
Message-ID: <87pn2m12s4.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 45409
Cc: 45409 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

Hi!

Christopher Baines <mail@HIDDEN> skribis:

> This separation between the code for dealing with narinfos from the code =
doing
> that for a purpose should make things clearer, and better support compone=
nts
> other that the substitute script in using this code.
>
> This is just moving the code around, no code should have been significant=
ly
> changed.
>
> * guix/scripts/substitute.scm (<narinfo>): Move record type to (guix nari=
nfo).
> (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.

That=E2=80=99s a good idea!

Please add guix/narinfo.scm to po/guix/POTFILES.in so it can be
translated.

> +(define-module (guix narinfo)
> +  #:use-module (guix ui)

We should try and avoid (guix ui); is (guix diagnostics) enough?

> +  #:use-module (guix scripts substitute)

(guix =E2=80=A6) modules must not depend on (guix scripts =E2=80=A6).

Perhaps that=E2=80=99s just for =E2=80=98%allow-unauthenticated-substitutes=
?=E2=80=99, no?  If
so, let=E2=80=99s just not refer to =E2=80=98%allow-unauthenticated-substit=
utes?=E2=80=99 here.
It=E2=80=99s a hack to allow for tests, so better keep it local to (guix sc=
ripts
substitute).

> +(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
> +                         #:key verbose?)
> +  "Return #t if NARINFO's signature is not valid."
> +  (or (%allow-unauthenticated-substitutes?)

Yeah, let=E2=80=99s remove it from here.  At worst, we can always use =E2=
=80=98mock=E2=80=99 in
tests to make =E2=80=98valid-narinfo?=E2=80=99 return #t unconditionally.

OK with these changes.

After the change, please make sure =E2=80=9Cmake check=E2=80=9D and =E2=80=
=9Cmake as-derivation=E2=80=9D
still pass.  For =E2=80=9Cmake as-derivation=E2=80=9D, we should also make =
sure
=E2=80=98guix-core=E2=80=99 doesn=E2=80=99t pull in everything via (guix sc=
ripts substitute).

(The zstd patches will conflict with this series but I=E2=80=99ll take care=
 of
it once it=E2=80=99s applied.)

Thanks,
Ludo=E2=80=99.




Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:42 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Dec 24 12:22:42 2020
Received: from localhost ([127.0.0.1]:55965 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1ksUJr-0003gh-Bp
	for submit <at> 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 <mail@HIDDEN>) id 1ksUJk-0003gA-QL
 for 45409 <at> 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 <at> 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 <at> debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH 3/3] guix: Split (guix substitute) from (guix scripts
 substitute).
Date: Thu, 24 Dec 2020 17:22:21 +0000
Message-Id: <20201224172221.21057-3-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20201224172221.21057-1-mail@HIDDEN>
References: <20201224172221.21057-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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: <http://bugs.gnu.org/22966>.
-      (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 <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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: <http://bugs.gnu.org/22966>.
+      (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
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:31 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Dec 24 12:22:31 2020
Received: from localhost ([127.0.0.1]:55963 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1ksUJq-0003ge-5a
	for submit <at> 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 <mail@HIDDEN>) id 1ksUJk-0003g8-Q4
 for 45409 <at> 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 <at> 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 <at> debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH 1/3] guix: Move narinfo code from substitute script to module.
Date: Thu, 24 Dec 2020 17:22:19 +0000
Message-Id: <20201224172221.21057-1-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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 (<narinfo>): 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 <ludo@HIDDEN>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
+;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <narinfo>
+  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
+                 nar-hash nar-size references deriver system
+                 signature contents)
+  narinfo?
+  (path         narinfo-path)
+  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
+  (uris         narinfo-uris)            ;list of strings
+  (compressions narinfo-compressions)    ;list of strings
+  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
+  (file-hashes  narinfo-file-hashes)
+  (nar-hash     narinfo-hash)
+  (nar-size     narinfo-size)
+  (references   narinfo-references)
+  (deriver      narinfo-deriver)
+  (system       narinfo-system)
+  (signature    narinfo-signature)      ; canonical sexp
+  ;; The original contents of a narinfo file.  This field is needed because we
+  ;; want to preserve the exact textual representation for verification purposes.
+  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
+  ;; for more information.
+  (contents     narinfo-contents))
+
+(define (narinfo-hash-algorithm+value narinfo)
+  "Return two values: the hash algorithm used by NARINFO and its value as a
+bytevector."
+  (match (string-tokenize (narinfo-hash narinfo)
+                          (char-set-complement (char-set #\:)))
+    ((algorithm base32)
+     (values (lookup-hash-algorithm (string->symbol algorithm))
+             (nix-base32-string->bytevector base32)))
+    (_
+     (raise (formatted-message
+             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
+
+(define (narinfo-hash->sha256 hash)
+  "If the string HASH denotes a sha256 hash, return it as a bytevector.
+Otherwise return #f."
+  (and (string-prefix? "sha256:" hash)
+       (nix-base32-string->bytevector (string-drop hash 7))))
+
+(define (narinfo-signature->canonical-sexp str)
+  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
+  (match (string-split str #\;)
+    ((version host-name sig)
+     (let ((maybe-number (string->number version)))
+       (cond ((not (number? maybe-number))
+              (leave (G_ "signature version must be a number: ~s~%")
+                     version))
+             ;; Currently, there are no other versions.
+             ((not (= 1 maybe-number))
+              (leave (G_ "unsupported signature version: ~a~%")
+                     maybe-number))
+             (else
+              (let ((signature (utf8->string (base64-decode sig))))
+                (catch 'gcry-error
+                  (lambda ()
+                    (string->canonical-sexp signature))
+                  (lambda (key proc err)
+                    (leave (G_ "signature is not a valid \
+s-expression: ~s~%")
+                           signature))))))))
+    (x
+     (leave (G_ "invalid format of the signature field: ~a~%") x))))
+
+(define (narinfo-maker str cache-url)
+  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
+must contain the original contents of a narinfo file."
+  (lambda (path urls compressions file-hashes file-sizes
+                nar-hash nar-size references deriver system
+                signature)
+    "Return a new <narinfo> object."
+    (define len (length urls))
+    (%make-narinfo path cache-url
+                   ;; Handle the case where URL is a relative URL.
+                   (map (lambda (url)
+                          (or (string->uri url)
+                              (string->uri
+                               (string-append cache-url "/" url))))
+                        urls)
+                   compressions
+                   (match file-sizes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   (match file-hashes
+                     (()        (make-list len #f))
+                     ((lst ...) (map string->number lst)))
+                   nar-hash
+                   (and=> nar-size string->number)
+                   (string-tokenize references)
+                   (match deriver
+                     ((or #f "") #f)
+                     (_ deriver))
+                   system
+                   (false-if-exception
+                    (and=> signature narinfo-signature->canonical-sexp))
+                   str)))
+
+(define 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-size<? c1 c2)
+    (match c1
+      ((uri1 compression1 (? integer? file-size1))
+       (match c2
+         ((uri2 compression2 (? integer? file-size2))
+          (< file-size1 file-size2))
+         (_ #t)))
+      ((uri compression1 #f)
+       (match c2
+         ((uri2 compression2 _)
+          (compresses-better? compression1 compression2))))
+      (_ #f)))                                    ;we can't tell
+
+  (match (sort choices file-size<?)
+    (((uri compression file-size) _ ...)
+     (values uri compression file-size))))
+
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index d0a456ac1d..cc9cbe6f27 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -28,6 +28,7 @@
   #:use-module ((guix progress) #:hide (dump-port*))
   #:use-module (guix serialization)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #: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 8084c89ae5..72242b73f1 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -21,6 +21,7 @@
 (define-module (guix scripts substitute)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module (guix narinfo)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix combinators)
@@ -66,29 +67,8 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (guix http-client)
-  #:export (narinfo-signature->canonical-sexp
-
-            narinfo?
-            narinfo-path
-            narinfo-uris
-            narinfo-uri-base
-            narinfo-compressions
-            narinfo-file-hashes
-            narinfo-file-sizes
-            narinfo-hash
-            narinfo-size
-            narinfo-references
-            narinfo-deriver
-            narinfo-system
-            narinfo-signature
-
-            narinfo-hash->sha256
-            narinfo-best-uri
-
-            lookup-narinfos
+  #:export (lookup-narinfos
             lookup-narinfos/diverse
-            read-narinfo
-            write-narinfo
 
             %allow-unauthenticated-substitutes?
             %error-to-file-descriptor-4?
@@ -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 <narinfo>
-  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
-                 nar-hash nar-size references deriver system
-                 signature contents)
-  narinfo?
-  (path         narinfo-path)
-  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
-  (uris         narinfo-uris)            ;list of strings
-  (compressions narinfo-compressions)    ;list of strings
-  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
-  (file-hashes  narinfo-file-hashes)
-  (nar-hash     narinfo-hash)
-  (nar-size     narinfo-size)
-  (references   narinfo-references)
-  (deriver      narinfo-deriver)
-  (system       narinfo-system)
-  (signature    narinfo-signature)      ; canonical sexp
-  ;; The original contents of a narinfo file.  This field is needed because we
-  ;; want to preserve the exact textual representation for verification purposes.
-  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
-  ;; for more information.
-  (contents     narinfo-contents))
-
-(define (narinfo-hash-algorithm+value narinfo)
-  "Return two values: the hash algorithm used by NARINFO and its value as a
-bytevector."
-  (match (string-tokenize (narinfo-hash narinfo)
-                          (char-set-complement (char-set #\:)))
-    ((algorithm base32)
-     (values (lookup-hash-algorithm (string->symbol algorithm))
-             (nix-base32-string->bytevector base32)))
-    (_
-     (raise (formatted-message
-             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
-
-(define (narinfo-hash->sha256 hash)
-  "If the string HASH denotes a sha256 hash, return it as a bytevector.
-Otherwise return #f."
-  (and (string-prefix? "sha256:" hash)
-       (nix-base32-string->bytevector (string-drop hash 7))))
-
-(define (narinfo-signature->canonical-sexp str)
-  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
-  (match (string-split str #\;)
-    ((version host-name sig)
-     (let ((maybe-number (string->number version)))
-       (cond ((not (number? maybe-number))
-              (leave (G_ "signature version must be a number: ~s~%")
-                     version))
-             ;; Currently, there are no other versions.
-             ((not (= 1 maybe-number))
-              (leave (G_ "unsupported signature version: ~a~%")
-                     maybe-number))
-             (else
-              (let ((signature (utf8->string (base64-decode sig))))
-                (catch 'gcry-error
-                  (lambda ()
-                    (string->canonical-sexp signature))
-                  (lambda (key proc err)
-                    (leave (G_ "signature is not a valid \
-s-expression: ~s~%")
-                           signature))))))))
-    (x
-     (leave (G_ "invalid format of the signature field: ~a~%") x))))
-
-(define (narinfo-maker str cache-url)
-  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
-must contain the original contents of a narinfo file."
-  (lambda (path urls compressions file-hashes file-sizes
-                nar-hash nar-size references deriver system
-                signature)
-    "Return a new <narinfo> object."
-    (define len (length urls))
-    (%make-narinfo path cache-url
-                   ;; Handle the case where URL is a relative URL.
-                   (map (lambda (url)
-                          (or (string->uri url)
-                              (string->uri
-                               (string-append cache-url "/" url))))
-                        urls)
-                   compressions
-                   (match file-sizes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   (match file-hashes
-                     (()        (make-list len #f))
-                     ((lst ...) (map string->number lst)))
-                   nar-hash
-                   (and=> nar-size string->number)
-                   (string-tokenize references)
-                   (match deriver
-                     ((or #f "") #f)
-                     (_ deriver))
-                   system
-                   (false-if-exception
-                    (and=> signature narinfo-signature->canonical-sexp))
-                   str)))
-
-(define* (read-narinfo port #:optional url
-                       #:key size)
-  "Read a narinfo from PORT.  If URL is true, it must be a string used to
-build full URIs from relative URIs found while reading PORT.  When SIZE is
-true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
-
-No authentication and authorization checks are performed here!"
-  (let ((str (utf8->string (if size
-                               (get-bytevector-n port size)
-                               (get-bytevector-all port)))))
-    (alist->record (call-with-input-string str fields->alist)
-                   (narinfo-maker str url)
-                   '("StorePath" "URL" "Compression"
-                     "FileHash" "FileSize" "NarHash" "NarSize"
-                     "References" "Deriver" "System"
-                     "Signature")
-                   '("URL" "Compression" "FileSize" "FileHash"))))
-
-(define (narinfo-sha256 narinfo)
-  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
-'Signature' field."
-  (define %mandatory-fields
-    ;; List of fields that must be signed.  If they are not signed, the
-    ;; narinfo is considered unsigned.
-    '("StorePath" "NarHash" "References"))
-
-  (let ((contents (narinfo-contents narinfo)))
-    (match (string-contains contents "Signature:")
-      (#f #f)
-      (index
-       (let* ((above-signature (string-take contents index))
-              (signed-fields (match (call-with-input-string above-signature
-                                      fields->alist)
-                               (((fields . values) ...) fields))))
-         (and (every (cut member <> signed-fields) %mandatory-fields)
-              (sha256 (string->utf8 above-signature))))))))
-
-(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
-                         #:key verbose?)
-  "Return #t if NARINFO's signature is not valid."
-  (or (%allow-unauthenticated-substitutes?)
-      (let ((hash      (narinfo-sha256 narinfo))
-            (signature (narinfo-signature narinfo))
-            (uri       (uri->string (first (narinfo-uris narinfo)))))
-        (and hash signature
-             (signature-case (signature hash acl)
-               (valid-signature #t)
-               (invalid-signature
-                (when verbose?
-                  (format (current-error-port)
-                          "invalid signature for substitute at '~a'~%"
-                          uri))
-                #f)
-               (hash-mismatch
-                (when verbose?
-                  (format (current-error-port)
-                          "hash mismatch for substitute at '~a'~%"
-                          uri))
-                #f)
-               (unauthorized-key
-                (when verbose?
-                  (format (current-error-port)
-                          "substitute at '~a' is signed by an \
-unauthorized party~%"
-                          uri))
-                #f)
-               (corrupt-signature
-                (when verbose?
-                  (format (current-error-port)
-                          "corrupt signature for substitute at '~a'~%"
-                          uri))
-                #f))))))
-
-(define (write-narinfo narinfo port)
-  "Write NARINFO to PORT."
-  (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
-
-(define (narinfo->string narinfo)
-  "Return the external representation of NARINFO."
-  (call-with-output-string (cut write-narinfo narinfo <>)))
-
-(define (string->narinfo str cache-uri)
-  "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
-the cache STR originates form."
-  (call-with-input-string str (cut read-narinfo <> cache-uri)))
-
 (define (narinfo-cache-file cache-url path)
   "Return the name of the local file that contains an entry for PATH.  The
 entry is stored in a sub-directory specific to CACHE-URL."
@@ -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<? c1 c2)
-    (match c1
-      ((uri1 compression1 (? integer? file-size1))
-       (match c2
-         ((uri2 compression2 (? integer? file-size2))
-          (< file-size1 file-size2))
-         (_ #t)))
-      ((uri compression1 #f)
-       (match c2
-         ((uri2 compression2 _)
-          (compresses-better? compression1 compression2))))
-      (_ #f)))                                    ;we can't tell
-
-  (match (sort choices file-size<?)
-    (((uri compression file-size) _ ...)
-     (values uri compression file-size))))
-
 (define %max-cached-connections
   ;; Maximum number of connections kept in cache by
   ;; 'open-connection-for-uri/cached'.
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index f28070ddc4..97e4a73802 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -33,6 +33,7 @@
   #: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 http-client)
   #:use-module (guix ci)
   #:use-module (guix sets)
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at 45409 <at> debbugs.gnu.org:


Received: (at 45409) by debbugs.gnu.org; 24 Dec 2020 17:22:27 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Dec 24 12:22:27 2020
Received: from localhost ([127.0.0.1]:55961 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1ksUJm-0003gJ-5J
	for submit <at> 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 <mail@HIDDEN>) id 1ksUJk-0003g9-O2
 for 45409 <at> 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 <at> 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 <at> debbugs.gnu.org>; Thu, 24 Dec 2020 17:22:21 +0000 (UTC)
From: Christopher Baines <mail@HIDDEN>
To: 45409 <at> debbugs.gnu.org
Subject: [PATCH 2/3] guix: Untangle (guix narinfo) from (guix scripts
 substitute).
Date: Thu, 24 Dec 2020 17:22:20 +0000
Message-Id: <20201224172221.21057-2-mail@HIDDEN>
X-Mailer: git-send-email 2.29.2
In-Reply-To: <20201224172221.21057-1-mail@HIDDEN>
References: <20201224172221.21057-1-mail@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 45409
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

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 <ludo@HIDDEN>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
 ;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;; Copyright © 2020 Christopher Baines <mail@HIDDEN>
 ;;;
 ;;; 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 <ludo@HIDDEN>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@HIDDEN>
 ;;; Copyright © 2018 Kyle Meyer <kyle@HIDDEN>
+;;; Copyright © 2020 Christopher Baines <mail@HIDDEN>
 ;;;
 ;;; 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) "/")
-- 
2.29.2





Information forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.

Message received at submit <at> debbugs.gnu.org:


Received: (at submit) by debbugs.gnu.org; 24 Dec 2020 17:18:01 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Dec 24 12:18:01 2020
Received: from localhost ([127.0.0.1]:55950 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1ksUFV-0003Ys-G2
	for submit <at> debbugs.gnu.org; Thu, 24 Dec 2020 12:18:01 -0500
Received: from lists.gnu.org ([209.51.188.17]:55370)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <mail@HIDDEN>) id 1ksUFQ-0003Yi-P5
 for submit <at> debbugs.gnu.org; Thu, 24 Dec 2020 12:18:00 -0500
Received: from eggs.gnu.org ([2001:470:142:3::10]:45178)
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <mail@HIDDEN>) id 1ksUFQ-0003Kn-IR
 for guix-patches@HIDDEN; Thu, 24 Dec 2020 12:17:56 -0500
Received: from mira.cbaines.net ([212.71.252.8]:58712)
 by eggs.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <mail@HIDDEN>) id 1ksUFO-000711-NH
 for guix-patches@HIDDEN; Thu, 24 Dec 2020 12:17:56 -0500
Received: from localhost (188.29.98.108.threembb.co.uk [188.29.98.108])
 by mira.cbaines.net (Postfix) with ESMTPSA id 5059D27BC05
 for <guix-patches@HIDDEN>; Thu, 24 Dec 2020 17:17:53 +0000 (GMT)
Received: from capella (localhost [127.0.0.1])
 by localhost (OpenSMTPD) with ESMTP id 526cb6d5
 for <guix-patches@HIDDEN>; Thu, 24 Dec 2020 17:17:51 +0000 (UTC)
User-agent: mu4e 1.4.13; emacs 27.1
From: Christopher Baines <mail@HIDDEN>
To: guix-patches@HIDDEN
Subject: [PATCH 0/3] Move some (guix scripts substitute) code to two new
 modules
Date: Thu, 24 Dec 2020 17:17:48 +0000
Message-ID: <87y2hn9l8j.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha512; protocol="application/pgp-signature"
Received-SPF: pass client-ip=212.71.252.8; envelope-from=mail@HIDDEN;
 helo=mira.cbaines.net
X-Spam_score_int: -18
X-Spam_score: -1.9
X-Spam_bar: -
X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, SPF_HELO_PASS=-0.001,
 SPF_PASS=-0.001 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-Spam-Score: -1.3 (-)
X-Debbugs-Envelope-To: submit
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -2.3 (--)

--=-=-=
Content-Type: text/plain


These commits are still a work in progress, but I think the changes look
pretty positive.



Christopher Baines (3):
  guix: Move narinfo code from substitute script to module.
  guix: Untangle (guix narinfo) from (guix scripts substitute).
  guix: Split (guix substitute) from (guix scripts substitute).

 Makefile.am                 |   2 +
 guix/narinfo.scm            | 325 +++++++++++++++
 guix/scripts/challenge.scm  |   3 +-
 guix/scripts/substitute.scm | 778 +-----------------------------------
 guix/scripts/weather.scm    |   3 +-
 guix/substitute.scm         | 527 ++++++++++++++++++++++++
 6 files changed, 875 insertions(+), 763 deletions(-)
 create mode 100644 guix/narinfo.scm
 create mode 100644 guix/substitute.scm

--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQKlBAEBCgCPFiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl/kzTxfFIAAAAAALgAo
aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF
ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcRHG1haWxAY2Jh
aW5lcy5uZXQACgkQXiijOwuE9XcIhQ//Yx9AKeXICHeFkqSh5peBN5Zcv9DtL4Mj
RN3uxZAm9JDDz2JKyqoXDaqWx6Qp/YNCmdEYCitrTfm5waSsQYcvzCn1s0S44zzc
3lY2OhBPcp4o3V9Rtm6aIyP30CbjaQ16bf8wDizgTAdmJ467dwRd0eCu+nhOcvlb
+0bzUuCkwX15X2wNtoyGb3+XVuJC/0A9ITlCkVoThIDYkdOxbQdVIASc0J5ZzJpd
/fbqqtcB/tEoAy9dAm2LVSSIcOBIqrUOw49KsmwYWSv7pq8xhcjidOAyn7p3uRif
LDocE34q2a6NRcF5bmrv4yj/ZbQvHnu/6pwi7v2j/61AAD51vZWgBuUjuFg0BhBo
C4gfIa1wk4xHWryCBkZPmoA+c+sidY2xlOWwVqF4Ush5+b8BpQlH1rTDQDqgHdBX
E0BMSIJdatLFf0wqaEyscOWmAHoEzAu/B+mJAlf/rIQAnA7rcATesWBTbla0+UTB
RRm3w+sCDaHcU49O0yGR1cJRbNqF/9urNbr6mEjBFqsRQGBZCoxZkJnCm9eWBGlt
pk465Aztm5nCCIlFUY2ax2syeoVcq0C6D1J5owxKAanuiBP1xDxqxn/a7LoelAJd
Up2OHH/uYXDUVPxmDd11Gs+LeUJZFMLwydd1O8qBunbFx/Rc04shCrIzJ8+pBcnX
UUjRt4n4w5M=
=rgD0
-----END PGP SIGNATURE-----
--=-=-=--




Acknowledgement sent to Christopher Baines <mail@HIDDEN>:
New bug report received and forwarded. Copy sent to guix-patches@HIDDEN. Full text available.
Report forwarded to guix-patches@HIDDEN:
bug#45409; Package guix-patches. Full text available.
Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.
Last modified: Sat, 16 Jan 2021 14:30:02 UTC

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997 nCipher Corporation Ltd, 1994-97 Ian Jackson.