From mboxrd@z Thu Jan 1 00:00:00 1970 From: Marius Bakke Subject: Re: `guix pull` over HTTPS Date: Wed, 01 Mar 2017 03:36:11 +0100 Message-ID: <8760jt206c.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> References: <20170209155512.GA11291@jasmine> <20170210003054.GA12412@jasmine> <87fujmcb6w.fsf@gnu.org> <87lgte10eu.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <87inoh660r.fsf@gnu.org> <874m011xb2.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <871sv44x97.fsf@gnu.org> <20170228054616.GA28504@jasmine> <87shmy1hup.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <20170228162919.GA10253@jasmine> <87mvd61cxv.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <87k28a11wt.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <87h93e0z4a.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> <87efyi0ynv.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:56257) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ciu7l-0004CO-Eu for guix-devel@gnu.org; Tue, 28 Feb 2017 21:36:19 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ciu7i-0000sI-8K for guix-devel@gnu.org; Tue, 28 Feb 2017 21:36:17 -0500 In-Reply-To: <87efyi0ynv.fsf@kirby.i-did-not-set--mail-host-address--so-tickle-me> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: Leo Famulari Cc: guix-devel@gnu.org --=-=-= Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" --==-=-= Content-Type: text/plain Marius Bakke writes: > Marius Bakke 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! --==-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQEzBAEBCgAdFiEEu7At3yzq9qgNHeZDoqBt8qM6VPoFAli2M5sACgkQoqBt8qM6 VPr3bAf/W6E0GYmwzPdYsAXLJLg9ilWv648BdRukXtuvDIKyKSPfEzgZEEN7x/B7 Fqfsb1nzC8+A054YHiRkfhPGqnqOxg/THWyRTwIyLGq9NN4PMC28a4wtjuLeQkGV sQDjlNjEcjiwBCUsgcA9nCKrAbM/pBz4fMJqJkkadraUUZqVVPuFB1WqzU/BHAIz IIyrHAWmeriVg/utxEZVBuW/WQV/uvsEjf867h9K7GxGYF2pEzkLTw7pgnyNj6ix WvvaMJQqUZ6c/k+BWga6Aog76Lip1Z1TlYtfXdvhGngghtBEI7pSEIXnrVz0Tz3V FnQhP8W1tf2LurD9ELlRy2Dk5wlv/A== =nJ/9 -----END PGP SIGNATURE----- --==-=-=-- --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-pull-Default-to-HTTPS.patch >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 --=-=-=--