diff options
Diffstat (limited to 'guix/scripts')
| -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 |
5 files changed, 57 insertions, 16 deletions
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 |