bug#22937: guix package fails when --substitute-urls specifies an HTTPS endpoint

[Ludovic Courtès]

First, the graceless error handling is fixed in
204d34ff961d6dabf18b255decc29712e03afef0.

Second, here’s a preliminary patch that almost works with
<https://hydra-mirror.marusich.info>.

The problem is that sometimes the server closes the connection
unexpectedly, leading to an obscure backtrace like this:

--8<---------------cut here---------------start------------->8---
substitute:  629: 6 [lookup-narinfos "https://hydra-mirror.marusich.info"; #]
substitute:  585: 5 [fetch-narinfos "https://hydra-mirror.marusich.info"; #]
substitute:  510: 4 [http-multiple-get # ...]
substitute: In web/response.scm:
substitute:  197: 3 [read-response #<input-output: gnutls-session-port 38f59c0>]
substitute: In web/http.scm:
substitute: 1157: 2 [read-response-line #<input-output: gnutls-session-port 
38f59c0>]
substitute:  151: 1 [read-header-line #<input-output: gnutls-session-port 
38f59c0>]
substitute: In unknown file:
substitute:    ?: 0 [%read-line #<input-output: gnutls-session-port 38f59c0>]
substitute: 
substitute: ERROR: In procedure %read-line:
substitute: ERROR: Throw to key `gnutls-error' with args `(#<gnutls-error-enum 
Error in the pull function.> fill_session_record_port_input)'.
--8<---------------cut here---------------end--------------->8---

The “error in the pull function” is because ‘gnutls_record_recv’ got
ECONNRESET while reading.

I wonder whether this could be due to the particular configuration of
nginx at Cloudfront, so I’ll try with another server (I’ve set up Let’s
Encrypt on that server but it’s not accessible yet via port 443.)

To be continued!

Ludo’.

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b82fc17..df95de0 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -32,6 +32,7 @@
   #:use-module ((guix build utils) #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
                 #:select (progress-proc uri-abbreviation
+                          open-connection-for-uri
                           store-path-abbreviation byte-count->string))
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
@@ -171,7 +172,7 @@ to the caller without emitting an error message."
      (let ((port (open-file (uri-path uri)
                             (if buffered? "rb" "r0b"))))
        (values port (stat:size (stat port)))))
-    ((http)
+    ((http https)
      (guard (c ((http-get-error? c)
                 (let ((code (http-get-error-code c)))
                   (if (and (= code 404) quiet-404?)
@@ -201,10 +202,10 @@ to the caller without emitting an error message."
                  (close-port port))))
            (begin
              (when (or (not port) (port-closed? port))
-               (set! port (open-socket-for-uri uri))
+               (set! port (open-connection-for-uri uri))
                (unless buffered?
                  (setvbuf port _IONBF)))
-             (http-fetch uri #:text? #f #:port port))))))))
+             (http-fetch uri #:text? #f #:port port))))))
     (else
      (leave (_ "unsupported substitute URI scheme: ~a~%")
             (uri->string uri)))))
@@ -478,20 +479,26 @@ may be #f, in which case it indicates that PATH is 
unavailable at CACHE-URL."
                             ".narinfo")))
     (build-request (string->uri url) #:method 'GET)))
 
-(define (http-multiple-get base-url proc seed requests)
-  "Send all of REQUESTS to the server at BASE-URL.  Call PROC for each
+(define (http-multiple-get base-uri proc seed requests)
+  "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."
   (let connect ((requests requests)
                 (result   seed))
-    ;; (format (current-error-port) "connecting (~a requests left)..."
-    ;;         (length requests))
-    (let ((p (open-socket-for-uri base-url)))
+    (format (current-error-port) "connecting (~a requests left)..."
+            (length requests))
+    (let ((p (open-connection-for-uri base-uri)))
+      ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
+      (when (file-port? p)
+        (setvbuf p _IOFBF (expt 2 16)))
+
       ;; Send all of REQUESTS in a row.
-      (setvbuf p _IOFBF (expt 2 16))
-      (for-each (cut write-request <> p) requests)
-      (force-output p)
+      ;; XXX: Do our own caching to work around <http://bugs.gnu.org/22966>.
+      (let-values (((buffer get) (open-bytevector-output-port)))
+        (for-each (cut write-request <> buffer) requests)
+        (put-bytevector p (get))
+        (force-output p))
 
       ;; Now start processing responses.
       (let loop ((requests requests)
@@ -501,6 +508,8 @@ read the response body, and the previous result, starting 
with SEED, à la
            (reverse result))
           ((head tail ...)
            (let* ((resp   (read-response p))
+                  ;; (xxx    (format (current-error-port)
+                  ;;                 "http response: ~s~%" resp))
                   (body   (response-body-port resp))
                   (result (proc head resp body result)))
              ;; The server can choose to stop responding at any time, in which
@@ -570,10 +579,10 @@ if file doesn't exist, and the narinfo otherwise."
 
   (define (do-fetch uri)
     (case (and=> uri uri-scheme)
-      ((http)
+      ((http https)
        (let ((requests (map (cut narinfo-request url <>) paths)))
          (update-progress!)
-         (let ((result (http-multiple-get url
+         (let ((result (http-multiple-get uri
                                           handle-narinfo-response '()
                                           requests)))
            (newline (current-error-port))