diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/cve.scm | 66 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 43 | ||||
| -rw-r--r-- | guix/ui.scm | 10 |
3 files changed, 88 insertions, 31 deletions
diff --git a/guix/cve.scm b/guix/cve.scm index a7b0bde6dc..8e76f42f0d 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,29 +49,45 @@ (id vulnerability-id) (packages vulnerability-packages)) -(define %cve-feed-uri +(define %now + (current-date)) +(define %current-year + (date-year %now)) +(define %past-year + (- %current-year 1)) + +(define (yearly-feed-uri year) + "Return the URI for the CVE feed for YEAR." (string->uri - "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-Modified.xml.gz")) + (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" + (number->string year) ".xml.gz"))) -(define %ttl +(define %current-year-ttl ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are ;; updated "approximately every two hours." (* 3600 3)) -(define (call-with-cve-port proc) +(define %past-year-ttl + ;; Update the previous year's database more and more infrequently. + (* 3600 24 2 (date-month %now))) + +(define (call-with-cve-port uri ttl proc) "Pass PROC an input port from which to read the CVE stream." - (let ((port (http-fetch/cached %cve-feed-uri #:ttl %ttl))) + (let ((port (http-fetch/cached uri #:ttl ttl))) (dynamic-wind (const #t) (lambda () (call-with-decompressed-port 'gzip port - proc)) + (lambda (port) + (setvbuf port _IOFBF 65536) + (proc port)))) (lambda () (close-port port))))) (define %cpe-package-rx - ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION". - (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)")) + ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes + ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL". + (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)")) (define (cpe->package-name cpe) "Converts the Common Platform Enumeration (CPE) string CPE to a package @@ -80,7 +96,13 @@ CPE string." (and=> (regexp-exec %cpe-package-rx (string-trim-both cpe)) (lambda (matches) (cons (match:substring matches 2) - (match:substring matches 3))))) + (string-append (match:substring matches 3) + (match (match:substring matches 4) + ("" "") + (patch-level + ;; Drop the colon from things like + ;; "cpe:/a:openbsd:openssh:6.8:p1". + (string-drop patch-level 1)))))))) (define %parse-vulnerability-feed ;; Parse the XML vulnerability feed from @@ -135,12 +157,19 @@ vulnerability objects." (define (current-vulnerabilities) "Return the current list of Common Vulnerabilities and Exposures (CVE) as published by the US NIST." - (call-with-cve-port - (lambda (port) - ;; XXX: The SSAX "error port" is used to send pointless warnings such as - ;; "warning: Skipping PI". Turn that off. - (parameterize ((current-ssax-error-port (%make-void-port "w"))) - (xml->vulnerabilities port))))) + (define (read-vulnerabilities uri ttl) + (call-with-cve-port uri ttl + (lambda (port) + ;; XXX: The SSAX "error port" is used to send pointless warnings such as + ;; "warning: Skipping PI". Turn that off. + (parameterize ((current-ssax-error-port (%make-void-port "w"))) + (xml->vulnerabilities port))))) + + (append-map read-vulnerabilities + (list (yearly-feed-uri %past-year) + (yearly-feed-uri %current-year)) + (list %past-year-ttl + %current-year-ttl))) (define (vulnerabilities->lookup-proc vulnerabilities) "Return a lookup procedure built from VULNERABILITIES that takes a package @@ -174,4 +203,9 @@ a list of vulnerabilities affection the given package version." '() package table))) + +;;; Local Variables: +;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2) +;;; End: + ;;; cve.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 01cc3f129e..b057e9b12a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -32,6 +32,7 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation + open-connection-for-uri store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -49,6 +50,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) + #:use-module (web http) #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) @@ -171,7 +173,7 @@ to the caller without emitting an error message." (let ((port (open-file (uri-path uri) (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) - ((http) + ((http https) (guard (c ((http-get-error? c) (let ((code (http-get-error-code c))) (if (and (= code 404) quiet-404?) @@ -201,10 +203,13 @@ to the caller without emitting an error message." (close-port port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri)) - (unless buffered? + (set! port (open-connection-for-uri uri)) + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) - (http-fetch uri #:text? #f #:port port)))))))) + (http-fetch uri #:text? #f #:port port)))))) + (else + (leave (_ "unsupported substitute URI scheme: ~a~%") + (uri->string uri))))) (define-record-type <cache-info> (%make-cache-info url store-directory wants-mass-query?) @@ -475,8 +480,8 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url proc seed requests) - "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +(define (http-multiple-get base-uri proc seed requests) + "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 'fold'. Return the final result." @@ -484,11 +489,23 @@ read the response body, and the previous result, starting with SEED, à la (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-socket-for-uri base-url))) + (let ((p (open-connection-for-uri base-uri))) + ;; For HTTPS, P is not a file port and does not support 'setvbuf'. + (when (file-port? p) + (setvbuf p _IOFBF (expt 2 16))) + ;; Send all of REQUESTS in a row. - (setvbuf p _IOFBF (expt 2 16)) - (for-each (cut write-request <> p) requests) - (force-output p) + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: <http://bugs.gnu.org/22966>. + (let-values (((buffer get) (open-bytevector-output-port))) + ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. + (when (module-variable (resolve-interface '(web http)) + 'http-proxy-port?) + (set-http-proxy-port?! buffer (http-proxy-port? p))) + + (for-each (cut write-request <> buffer) requests) + (put-bytevector p (get)) + (force-output p)) ;; Now start processing responses. (let loop ((requests requests) @@ -567,10 +584,10 @@ if file doesn't exist, and the narinfo otherwise." (define (do-fetch uri) (case (and=> uri uri-scheme) - ((http) + ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) - (let ((result (http-multiple-get url + (let ((result (http-multiple-get uri handle-narinfo-response '() requests))) (newline (current-error-port)) diff --git a/guix/ui.scm b/guix/ui.scm index a3ec6834b6..7b7bee0ac8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -410,6 +410,12 @@ interpreted." (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." + (define (port-filename* port) + ;; 'port-filename' returns #f for non-file ports, but it raises an + ;; exception for file ports that are closed. Work around that. + (and (not (port-closed? port)) + (port-filename port))) + (guard (c ((package-input-error? c) (let* ((package (package-error-package c)) (input (package-error-invalid-input c)) @@ -440,9 +446,9 @@ interpreted." (port (nar-error-port c))) (if file (leave (_ "corrupt input while restoring '~a' from ~s~%") - file (or (port-filename port) port)) + file (or (port-filename* port) port)) (leave (_ "corrupt input while restoring archive from ~s~%") - (or (port-filename port) port))))) + (or (port-filename* port) port))))) ((nix-connection-error? c) (leave (_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) |