From 57bdd79e485801ccf405ca7389bd099809fe5d67 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Oct 2016 23:02:46 +0200 Subject: grafts: Allow the replacement to have a different name. * guix/build/graft.scm (replace-store-references): REPLACEMENT is now the full string, not just the hash. (rewrite-directory)[hash-mapping](valid-suffix?): Remove. (hash+suffix): Rename to... (hash+rest): ... this. Change to return the whole string as the second element of the list. Adjust 'match-lambda' expression accordingly; check whether the string length of the origin and replacement match. * tests/grafts.scm ("graft-derivation, grafted item uses a different name"): New test. * doc/guix.texi (Security Updates): Update sentence on the name/version restriction. --- guix/build/graft.scm | 43 ++++++++++++++++++++++++++----------------- 1 file changed, 26 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index f85d485554..b08b65b7cf 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -20,7 +20,6 @@ (define-module (guix build graft) #:use-module (guix build utils) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 threads) @@ -58,7 +57,9 @@ #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to REPLACEMENT-TABLE, and writing the result to OUTPUT. REPLACEMENT-TABLE is a -vhash that maps strings (original hashes) to bytevectors (replacement hashes). +vhash that maps strings (original hashes) to bytevectors (replacement strings +comprising the replacement hash, a dash, and a string). + Note: We use string keys to work around the fact that guile-2.0 hashes all bytevectors to the same value." @@ -130,16 +131,18 @@ bytevectors to the same value." ;; that have not yet been written. (put-bytevector output buffer written (- i hash-length written)) - ;; Now write the replacement hash. + ;; Now write the replacement string. (put-bytevector output replacement) ;; Since the byte at position 'i' is a dash, ;; which is not a nix-base32 char, the earliest ;; position where the next hash might start is ;; i+1, and the earliest position where the ;; following dash might start is (+ i 1 - ;; hash-length). Also, we have now written up to - ;; position 'i' in the buffer. - (scan-from (+ i 1 hash-length) i))) + ;; hash-length). Also, increase the write + ;; position to account for REPLACEMENT. + (let ((len (bytevector-length replacement))) + (scan-from (+ i 1 len) + (+ i (- len hash-length)))))) ;; If the byte at position 'i' is a nix-base32 char, ;; then the dash we're looking for might be as early as ;; the following byte, so we can only advance by 1. @@ -213,26 +216,32 @@ an exception is caught." file name pairs." (define hash-mapping + ;; List of hash/replacement pairs, where the hash is a nix-base32 string + ;; and the replacement is a string that includes the replacement's name, + ;; like "r837zajjc1q8z9hph4b6860a9c05blyy-openssl-1.0.2j". (let* ((prefix (string-append store "/")) (start (string-length prefix)) (end (+ start hash-length))) (define (valid-hash? h) (every nix-base32-char? (string->list h))) - (define (valid-suffix? s) - (string-prefix? "-" s)) - (define (hash+suffix s) + (define (hash+rest s) (and (< end (string-length s)) - (let ((hash (substring s start end)) - (suffix (substring s end))) + (let ((hash (substring s start end)) + (all (substring s start))) (and (string-prefix? prefix s) - (valid-hash? hash) - (valid-suffix? suffix) - (list hash suffix))))) + (valid-hash? hash) + (eqv? #\- (string-ref s end)) + (list hash all))))) + (map (match-lambda - (((= hash+suffix (origin-hash suffix)) + (((= hash+rest (origin-hash origin-string)) . - (= hash+suffix (replacement-hash suffix))) - (cons origin-hash (string->utf8 replacement-hash))) + (= hash+rest (replacement-hash replacement-string))) + (unless (= (string-length origin-string) + (string-length replacement-string)) + (error "replacement length differs from the original length" + origin-string replacement-string)) + (cons origin-hash (string->utf8 replacement-string))) ((origin . replacement) (error "invalid replacement" origin replacement))) mapping))) -- cgit v1.2.3 From 9bee2bd1b02c7ef91cc7232e8647bd07525d3382 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Oct 2016 23:30:49 +0200 Subject: lint: 'cve' checker reports the replacement's vulnerabilities. Before, 'guix lint -c cve' would report the vulnerabilities of the original package while pretending they are the vulnerabilities of the replacement. * guix/scripts/lint.scm (check-vulnerabilities): Consider the package replacement before calling 'package-vulnerabilities'. * tests/lint.scm ("cve: vulnerability fixed in replacement version"): New test. --- guix/scripts/lint.scm | 38 +++++++++++++++++++------------------- tests/lint.scm | 23 +++++++++++++++++++++++ 2 files changed, 42 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index eac3214bbf..b3ec6d628e 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -683,25 +683,25 @@ from ~s: ~a (~s)~%") (define (check-vulnerabilities package) "Check for known vulnerabilities for PACKAGE." - (match (package-vulnerabilities package) - (() - #t) - ((vulnerabilities ...) - (let* ((package (or (package-replacement package) package)) - (patches (filter-map patch-file-name - (or (and=> (package-source package) - origin-patches) - '()))) - (unpatched (remove (lambda (vuln) - (find (cute string-contains - <> (vulnerability-id vuln)) - patches)) - vulnerabilities))) - (unless (null? unpatched) - (emit-warning package - (format #f (_ "probably vulnerable to ~a") - (string-join (map vulnerability-id unpatched) - ", ")))))))) + (let ((package (or (package-replacement package) package))) + (match (package-vulnerabilities package) + (() + #t) + ((vulnerabilities ...) + (let* ((patches (filter-map patch-file-name + (or (and=> (package-source package) + origin-patches) + '()))) + (unpatched (remove (lambda (vuln) + (find (cute string-contains + <> (vulnerability-id vuln)) + patches)) + vulnerabilities))) + (unless (null? unpatched) + (emit-warning package + (format #f (_ "probably vulnerable to ~a") + (string-join (map vulnerability-id unpatched) + ", "))))))))) ;;; diff --git a/tests/lint.scm b/tests/lint.scm index df69d2b4b1..d692b42f93 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -36,6 +36,7 @@ #:use-module (web server) #:use-module (web server http) #:use-module (web response) + #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-64)) @@ -613,6 +614,28 @@ string) on HTTP requests." (patches (list "/a/b/pi-CVE-2015-1234.patch")))))))))) +(test-assert "cve: vulnerability fixed in replacement version" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (match (package-version package) + ("0" + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package)))))) + ("1" + '())))) + (and (not (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package "foo" (version "0")))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package + "foo" (version "0") + (replacement (dummy-package "foo" (version "1")))))))))) + (test-assert "cve: patched vulnerability in replacement" (mock ((guix scripts lint) package-vulnerabilities (lambda (package) -- cgit v1.2.3