Re: `guix pull` over HTTPS

[Marius Bakke <mbakke@fastmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 755 bytes --]

Marius Bakke <mbakke@fastmail.com> writes:

> Marius Bakke <mbakke@fastmail.com> writes:
>
>> @@ -224,8 +225,11 @@ contained therein."
>>    (with-error-handling
>>      (let* ((opts  (parse-options))
>>             (store (open-connection))
>> +           (certs (string-append (package-output store nss-certs)
>> +                                 "/etc/ssl/certs"))
>
> Note: This only works if you have nss-certs in the store already. Not
> sure how to convert this into a gexp.

Wait, this is false. For some reason I assumed package-output just
computed the store path, but it is in fact added to the store.

The attached patch adds a #:certificate-directory parameter and passes
it from (guix-pull) all the way down to (tls-wrap). Feedback wanted!


[-- Attachment #1.2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-pull-Default-to-HTTPS.patch --]
[-- Type: text/x-patch, Size: 9587 bytes --]

From a27448b259b1d2061faabe3c17433e1c660e60c9 Mon Sep 17 00:00:00 2001
From: Marius Bakke <mbakke@fastmail.com>
Date: Tue, 28 Feb 2017 22:34:29 +0100
Subject: [PATCH] pull: Default to HTTPS.

* guix/build/download.scm (tls-wrap): Add CERTIFICATE-DIRECTORY parameter.
(open-connection-for-uri): Adjust parameters to match.
(http-fetch): Likewise.
(url-fetch): Likewise.
* guix/download.scm (download-to-store): Likewise.
* guix/scripts/pull.scm (%snapshot-url): Use HTTPS.
(guix-pull): Verify against the store path of NSS-CERTS.
---
 guix/build/download.scm | 40 ++++++++++++++++++++++++++++------------
 guix/download.scm       | 10 +++++++---
 guix/scripts/pull.scm   |  8 ++++++--
 3 files changed, 41 insertions(+), 17 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 203338b52..2a555506a 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -340,15 +340,20 @@ way."
 (set-exception-printer! 'tls-certificate-error
                         print-tls-certificate-error)
 
-(define* (tls-wrap port server #:key (verify-certificate? #t))
+(define* (tls-wrap port server #:key (verify-certificate? #t)
+                   (certificate-directory #f))
   "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
-host name without trailing dot."
+host name without trailing dot.  If CERTIFICATE-DIRECTORY is set, x509
+certificates will be verified against those found in the specified path
+instead of the default."
   (define (log level str)
     (format (current-error-port)
             "gnutls: [~a|~a] ~a" (getpid) level str))
 
   (let ((session  (make-session connection-end/client))
-        (ca-certs (%x509-certificate-directory)))
+        (ca-certs (if (string? certificate-directory)
+                      certificate-directory
+                      (%x509-certificate-directory))))
 
     ;; Some servers such as 'cloud.github.com' require the client to support
     ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
@@ -459,10 +464,12 @@ ETIMEDOUT error is raised."
 (define* (open-connection-for-uri uri
                                   #:key
                                   timeout
-                                  (verify-certificate? #t))
+                                  (verify-certificate? #t)
+                                  (certificate-directory #f))
   "Like 'open-socket-for-uri', but also handle HTTPS connections.  The
 resulting port must be closed with 'close-connection'.  When
-VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
+VERIFY-CERTIFICATE? is true, verify HTTPS server certificates;
+optionally against those found in CERTIFICATE-DIRECTORY."
   (define https?
     (eq? 'https (uri-scheme uri)))
 
@@ -490,7 +497,8 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
 
        (if https?
            (tls-wrap s (uri-host uri)
-                     #:verify-certificate? verify-certificate?)
+                     #:verify-certificate? verify-certificate?
+                     #:certificate-directory certificate-directory)
            s)))))
 
 (define (close-connection port)
@@ -675,11 +683,13 @@ Return the resulting target URI."
                     #:query    (uri-query    ref)
                     #:fragment (uri-fragment ref)))))
 
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
+(define* (http-fetch uri file #:key timeout (verify-certificate? #t)
+                     (certificate-directory #f))
   "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
 the connection could not be established in less than TIMEOUT seconds.  Return
 FILE on success.  When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
+certificates, optionally against those found in CERTIFICATE-DIRECTORY;
+otherwise simply ignore them."
 
   (define post-2.0.7?
     (or (> (string->number (major-version)) 2)
@@ -709,7 +719,9 @@ certificates; otherwise simply ignore them."
                  (open-connection-for-uri uri
                                           #:timeout timeout
                                           #:verify-certificate?
-                                          verify-certificate?))
+                                          verify-certificate?
+                                          #:certificate-directory
+                                          certificate-directory))
                 ((resp bv-or-port)
                  ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
                  ;; #:streaming? in 2.0.8.  We know we're using it within the
@@ -752,7 +764,8 @@ certificates; otherwise simply ignore them."
          (close connection)
          (http-fetch uri file
                      #:timeout timeout
-                     #:verify-certificate? verify-certificate?)))
+                     #:verify-certificate? verify-certificate?
+                     #:certificate-directory certificate-directory)))
       (else
        (error "download failed" (uri->string uri)
               code (response-reason-phrase resp))))))
@@ -794,7 +807,7 @@ Return a list of URIs."
                     #:key
                     (timeout 10) (verify-certificate? #t)
                     (mirrors '()) (content-addressed-mirrors '())
-                    (hashes '()))
+                    (certificate-directory #f) (hashes '()))
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
 on success.
@@ -809,7 +822,8 @@ algorithm and a hash, return a URL where the specified data can be retrieved
 or #f.
 
 When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates;
-otherwise simply ignore them."
+optionally against those found in CERTIFICATE-DIRECTORY; otherwise
+simply ignore them."
   (define uri
     (append-map (cut maybe-expand-mirrors <> mirrors)
                 (match url
@@ -824,6 +838,8 @@ otherwise simply ignore them."
        (false-if-exception* (http-fetch uri file
                                         #:verify-certificate?
                                         verify-certificate?
+                                        #:certificate-directory
+                                        certificate-directory
                                         #:timeout timeout)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
diff --git a/guix/download.scm b/guix/download.scm
index 86f859881..e4d9fbaab 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -548,11 +548,13 @@ own.  This helper makes it easier to deal with \"zip bombs\"."
 
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)) recursive?
-                            (verify-certificate? #t))
+                            (verify-certificate? #t)
+                            (certificate-directory #f))
   "Download from URL to STORE, either under NAME or URL's basename if
 omitted.  Write progress reports to LOG.  RECURSIVE? has the same effect as
 the same-named parameter of 'add-to-store'.  VERIFY-CERTIFICATE? determines
-whether or not to validate HTTPS server certificates."
+whether or not to validate HTTPS server certificates.  CERTIFICATE-DIRECTORY
+overrides the default search path for TLS certificates if set to a string."
   (define uri
     (string->uri url))
 
@@ -566,7 +568,9 @@ whether or not to validate HTTPS server certificates."
                   (build:url-fetch url temp
                                    #:mirrors %mirrors
                                    #:verify-certificate?
-                                   verify-certificate?))))
+                                   verify-certificate?
+                                   #:certificate-directory
+                                   certificate-directory))))
            (close port)
            (and result
                 (add-to-store store name recursive? "sha256" temp)))))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index a4824e4fd..6d8ac23b5 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -30,6 +30,7 @@
   #:use-module ((guix build utils)
                 #:select (with-directory-excursion delete-file-recursively))
   #:use-module (gnu packages base)
+  #:use-module ((gnu packages certs) #:select (nss-certs))
   #:use-module (gnu packages guile)
   #:use-module ((gnu packages bootstrap)
                 #:select (%bootstrap-guile))
@@ -45,7 +46,7 @@
 
 (define %snapshot-url
   ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
-  "http://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
+  "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
   )
 
 (define-syntax-rule (with-environment-variable variable value body ...)
@@ -224,8 +225,11 @@ contained therein."
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
+           (certs (string-append (package-output store nss-certs)
+                                 "/etc/ssl/certs"))
            (url   (assoc-ref opts 'tarball-url)))
-      (let ((tarball (download-to-store store url "guix-latest.tar.gz")))
+      (let ((tarball (download-to-store store url "guix-latest.tar.gz"
+                                        #:certificate-directory certs)))
         (unless tarball
           (leave (_ "failed to download up-to-date source, exiting\n")))
         (parameterize ((%guile-for-build
-- 
2.12.0