Marius Bakke <mba...@fastmail.com> writes: > Marius Bakke <mba...@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!
signature.asc
Description: PGP signature
>From a27448b259b1d2061faabe3c17433e1c660e60c9 Mon Sep 17 00:00:00 2001
From: Marius Bakke <mba...@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
