diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 125 | ||||
| -rw-r--r-- | guix/download.scm | 17 | ||||
| -rw-r--r-- | guix/http-client.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 34 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 4 |
8 files changed, 187 insertions, 36 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 4259f52b7a..8e32b3d7ff 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -273,14 +274,78 @@ out if the connection could not be established in less than TIMEOUT seconds." session record port using PORT as its underlying communication port." (hashq-set! %tls-ports record-port port)) -(define (tls-wrap port server) +(define %x509-certificate-directory + ;; The directory where X.509 authority PEM certificates are stored. + (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY") + (getenv "SSL_CERT_DIR")))) ;like OpenSSL + +(define (make-credendials-with-ca-trust-files directory) + "Return certificate credentials with X.509 authority certificates read from +DIRECTORY. Those authority certificates are checked when +'peer-certificate-status' is later called." + (let ((cred (make-certificate-credentials)) + (files (or (scandir directory + (lambda (file) + (string-suffix? ".pem" file))) + '()))) + (for-each (lambda (file) + (set-certificate-credentials-x509-trust-file! + cred (string-append directory "/" file) + x509-certificate-format/pem)) + (or files '())) + cred)) + +(define (peer-certificate session) + "Return the certificate of the remote peer in SESSION." + (match (session-peer-certificate-chain session) + ((first _ ...) + (import-x509-certificate first x509-certificate-format/der)))) + +(define (assert-valid-server-certificate session server) + "Return #t if the certificate of the remote peer for SESSION is a valid +certificate for SERVER, where SERVER is the expected host name of peer." + (define cert + (peer-certificate session)) + + ;; First check whether the server's certificate matches SERVER. + (unless (x509-certificate-matches-hostname? cert server) + (throw 'tls-certificate-error 'host-mismatch cert server)) + + ;; Second check its validity and reachability from the set of authority + ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'. + (match (peer-certificate-status session) + (() ;certificate is valid + #t) + ((statuses ...) + (throw 'tls-certificate-error 'invalid-certificate cert server + statuses)))) + +(define (print-tls-certificate-error port key args default-printer) + "Print the TLS certificate error represented by ARGS in an intelligible +way." + (match args + (('host-mismatch cert server) + (format port + "X.509 server certificate for '~a' does not match: ~a~%" + server (x509-certificate-dn cert))) + (('invalid-certificate cert server statuses) + (format port + "X.509 certificate of '~a' could not be verified:~%~{ ~a~%~}" + server + (map certificate-status->string statuses))))) + +(set-exception-printer! 'tls-certificate-error + print-tls-certificate-error) + +(define* (tls-wrap port server #:key (verify-certificate? #t)) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS host name without trailing dot." (define (log level str) (format (current-error-port) "gnutls: [~a|~a] ~a" (getpid) level str)) - (let ((session (make-session connection-end/client))) + (let ((session (make-session connection-end/client)) + (ca-certs (%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 @@ -301,13 +366,27 @@ host name without trailing dot." ;; <https://tools.ietf.org/html/rfc7568>. (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0") - (set-session-credentials! session (make-certificate-credentials)) + (set-session-credentials! session + (if (and verify-certificate? ca-certs) + (make-credendials-with-ca-trust-files + ca-certs) + (make-certificate-credentials))) ;; Uncomment the following lines in case of debugging emergency. ;;(set-log-level! 10) ;;(set-log-procedure! log) (handshake session) + + ;; Verify the server's certificate if needed. + (when verify-certificate? + (catch 'tls-certificate-error + (lambda () + (assert-valid-server-certificate session server)) + (lambda args + (close-port port) + (apply throw args)))) + (let ((record (session-record-port session))) ;; Since we use `fileno' above, the file descriptor behind PORT would be ;; closed when PORT is GC'd. If we used `port->fdes', it would instead @@ -374,9 +453,13 @@ ETIMEDOUT error is raised." (apply throw args) (loop (cdr addresses)))))))) -(define* (open-connection-for-uri uri #:key timeout) +(define* (open-connection-for-uri uri + #:key + timeout + (verify-certificate? #t)) "Like 'open-socket-for-uri', but also handle HTTPS connections. The -resulting port must be closed with 'close-connection'." +resulting port must be closed with 'close-connection'. When +VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define https? (eq? 'https (uri-scheme uri))) @@ -403,7 +486,8 @@ resulting port must be closed with 'close-connection'." (setvbuf s _IOFBF %http-receive-buffer-size) (if https? - (tls-wrap s (uri-host uri)) + (tls-wrap s (uri-host uri) + #:verify-certificate? verify-certificate?) s))))) (define (close-connection port) @@ -588,10 +672,11 @@ Return the resulting target URI." #:query (uri-query ref) #:fragment (uri-fragment ref))))) -(define* (http-fetch uri file #:key timeout) +(define* (http-fetch uri file #:key timeout (verify-certificate? #t)) "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." +FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS +certificates; otherwise simply ignore them." (define post-2.0.7? (or (> (string->number (major-version)) 2) @@ -618,7 +703,10 @@ FILE on success." (_ '())))) (let*-values (((connection) - (open-connection-for-uri uri #:timeout timeout)) + (open-connection-for-uri uri + #:timeout timeout + #:verify-certificate? + verify-certificate?)) ((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 @@ -659,7 +747,9 @@ FILE on success." (format #t "following redirection to `~a'...~%" (uri->string uri)) (close connection) - (http-fetch uri file #:timeout timeout))) + (http-fetch uri file + #:timeout timeout + #:verify-certificate? verify-certificate?))) (else (error "download failed" (uri->string uri) code (response-reason-phrase resp)))))) @@ -699,7 +789,7 @@ Return a list of URIs." (define* (url-fetch url file #:key - (timeout 10) + (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) (hashes '())) "Fetch FILE from URL; URL may be either a single string, or a list of @@ -713,7 +803,10 @@ HASHES must be a list of algorithm/hash pairs, where each algorithm is a symbol such as 'sha256 and each hash is a bytevector. CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash algorithm and a hash, return a URL where the specified data can be retrieved -or #f." +or #f. + +When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates; +otherwise simply ignore them." (define uri (append-map (cut maybe-expand-mirrors <> mirrors) (match url @@ -725,9 +818,13 @@ or #f." file (uri->string uri)) (case (uri-scheme uri) ((http https) - (false-if-exception* (http-fetch uri file #:timeout timeout))) + (false-if-exception* (http-fetch uri file + #:verify-certificate? + verify-certificate? + #:timeout timeout))) ((ftp) - (false-if-exception* (ftp-fetch uri file #:timeout timeout))) + (false-if-exception* (ftp-fetch uri file + #:timeout timeout))) (else (format #t "skipping URI with unsupported scheme: ~s~%" uri) diff --git a/guix/download.scm b/guix/download.scm index 80507f952a..0c275053c5 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -372,7 +372,11 @@ in the store." #:hashes (value-from-environment "guix download hashes") #:content-addressed-mirrors - (primitive-load #$%content-addressed-mirror-file)))))) + (primitive-load #$%content-addressed-mirror-file) + + ;; No need to validate certificates since we know the + ;; hash of the expected result. + #:verify-certificate? #f))))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) @@ -430,10 +434,12 @@ own. This helper makes it easier to deal with \"tar bombs\"." #:local-build? #t))) (define* (download-to-store store url #:optional (name (basename url)) - #:key (log (current-error-port)) recursive?) + #:key (log (current-error-port)) recursive? + (verify-certificate? #t)) "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'." +the same-named parameter of 'add-to-store'. VERIFY-CERTIFICATE? determines +whether or not to validate HTTPS server certificates." (define uri (string->uri url)) @@ -444,7 +450,10 @@ the same-named parameter of 'add-to-store'." (lambda (temp port) (let ((result (parameterize ((current-output-port log)) - (build:url-fetch url temp #:mirrors %mirrors)))) + (build:url-fetch url temp + #:mirrors %mirrors + #:verify-certificate? + verify-certificate?)))) (close port) (and result (add-to-store store name recursive? "sha256" temp))))))) diff --git a/guix/http-client.scm b/guix/http-client.scm index a8324be09f..cc3acc9587 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -223,7 +223,7 @@ or if EOF is reached." 'shutdown (const #f)) (define* (http-fetch uri #:key port (text? #f) (buffered? #t) - keep-alive?) + keep-alive? (verify-certificate? #t)) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an @@ -231,11 +231,15 @@ unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be reused for future HTTP requests. +When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. + Raise an '&http-get-error' condition if downloading fails." (let loop ((uri (if (string? uri) (string->uri uri) uri))) - (let ((port (or port (open-connection-for-uri uri))) + (let ((port (or port (open-connection-for-uri uri + #:verify-certificate? + verify-certificate?))) (auth-header (match (uri-userinfo uri) ((? string? str) (list (cons 'Authorization diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index bcb4eaa043..ec30b05ac0 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -41,7 +41,8 @@ (define %default-options ;; Alist of default option values. - `((format . ,bytevector->nix-base32-string))) + `((format . ,bytevector->nix-base32-string) + (verify-certificate? . #t))) (define (show-help) (display (_ "Usage: guix download [OPTION] URL @@ -52,6 +53,9 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (_ " -f, --format=FMT write the hash in the given format")) + (format #t (_ " + --no-check-certificate + do not validate the certificate of HTTPS servers ")) (newline) (display (_ " -h, --help display this help and exit")) @@ -77,6 +81,9 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (alist-cons 'format fmt-proc (alist-delete 'format result)))) + (option '("no-check-certificate") #f #f + (lambda (opt name arg result) + (alist-cons 'verify-certificate? #f result))) (option '(#\h "help") #f #f (lambda args @@ -120,7 +127,10 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (parameterize ((current-terminal-columns (terminal-columns))) (download-to-store store (uri->string uri) - (basename (uri-path uri))))))) + (basename (uri-path uri)) + #:verify-certificate? + (assoc-ref opts + 'verify-certificate?)))))) (hash (call-with-input-file (or path (leave (_ "~a: download failed~%") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0c69bfc9d3..6dea67ca22 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -427,7 +427,7 @@ host file systems to mount inside the container." (file-systems (append %container-file-systems (map mapping->file-system mappings)))) (exit/status - (call-with-container (map file-system->spec file-systems) + (call-with-container file-systems (lambda () ;; Setup global shell. (mkdir-p "/bin") diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index d6281eae64..6e6f550941 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -369,7 +369,8 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." ;; This can happen if the server returns an invalid HTTP header, ;; as is the case with the 'Date' header at sqlite.org. (values 'invalid-http-response #f)) - ((getaddrinfo-error system-error gnutls-error) + ((getaddrinfo-error system-error + gnutls-error tls-certificate-error) (values key args)) (else (apply throw key args)))))) @@ -397,6 +398,13 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (_ (values 'unknown-protocol #f))))) +(define (tls-certificate-error-string args) + "Return a string explaining the 'tls-certificate-error' arguments ARGS." + (call-with-output-string + (lambda (port) + (print-exception port #f + 'tls-certificate-error args)))) + (define (validate-uri uri package field) "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." @@ -457,6 +465,10 @@ suspiciously small file (~a bytes)") (cons status argument)))) field) #f) + ((tls-certificate-error) + (emit-warning package + (format #f (_ "TLS certificate error: ~a") + (tls-certificate-error-string argument)))) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. #f) @@ -672,14 +684,22 @@ from ~s: ~a (~s)~%") (http-get-error-reason c)) (warning (_ "assuming no CVE vulnerabilities~%")) '())) - (catch 'getaddrinfo-error + (catch #t (lambda () (current-vulnerabilities)) - (lambda (key errcode) - (warning (_ "failed to lookup NIST host: ~a~%") - (gai-strerror errcode)) - (warning (_ "assuming no CVE vulnerabilities~%")) - '())))) + (match-lambda* + (('getaddrinfo-error errcode) + (warning (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '()) + (('tls-certificate-error args ...) + (warning (_ "TLS certificate error: ~a") + (tls-certificate-error-string args)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '()) + (args + (apply throw args)))))) (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 3d6fde0188..524b019a31 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -210,10 +210,12 @@ provide." (close-connection port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-connection-for-uri uri)) + (set! port (open-connection-for-uri uri + #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) - (http-fetch uri #:text? #f #:port port)))))) + (http-fetch uri #:text? #f #:port port + #:verify-certificate? #f)))))) (else (leave (_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) @@ -246,6 +248,7 @@ failure, return #f and #f." #f)) ((http https) (let ((port (open-connection-for-uri uri + #:verify-certificate? #f #:timeout %fetch-timeout))) (guard (c ((http-get-error? c) (warning (_ "while fetching '~a': ~a (~s)~%") @@ -256,6 +259,7 @@ failure, return #f and #f." (warning (_ "ignoring substitute server at '~s'~%") url) (values #f #f))) (values (read-cache-info (http-fetch uri + #:verify-certificate? #f #:port port #:keep-alive? #t)) port)))))) @@ -518,7 +522,7 @@ indicates that PATH is unavailable at CACHE-URL." (build-request (string->uri url) #:method 'GET))) (define* (http-multiple-get base-uri proc seed requests - #:key port) + #:key port (verify-certificate? #t)) "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 @@ -529,7 +533,9 @@ initial connection on which HTTP requests are sent." (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (or port (open-connection-for-uri base-uri)))) + (let ((p (or port (open-connection-for-uri base-uri + #:verify-certificate? + verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p _IOFBF (expt 2 16))) @@ -627,9 +633,14 @@ if file doesn't exist, and the narinfo otherwise." ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) + + ;; Note: Do not check HTTPS server certificates to avoid depending on + ;; the X.509 PKI. We can do it because we authenticate narinfos, + ;; which provides a much stronger guarantee. (let ((result (http-multiple-get uri handle-narinfo-response '() requests + #:verify-certificate? #f #:port port))) (close-connection port) (newline (current-error-port)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index df9b37d544..71ddccfa61 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -44,7 +44,6 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services herd) - #:use-module (gnu packages grub) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -617,7 +616,8 @@ building anything." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (grub (package->derivation grub)) + (grub (package->derivation (grub-configuration-grub + (operating-system-bootloader os)))) (grub.cfg (if (eq? 'container action) (return #f) (operating-system-grub.cfg os |