>From a27448b259b1d2061faabe3c17433e1c660e60c9 Mon Sep 17 00:00:00 2001 From: Marius Bakke 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