From cd436bf05a8344acf4462f3602e7d360821a902a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 May 2016 17:37:47 +0200 Subject: download: Support content-addressed mirrors. * guix/download.scm (%content-addressed-mirrors) (%content-addressed-mirror-file): New variables. * guix/download.scm (url-fetch)[builder]: Define 'value-from-environment. Pass #:hashes and #:content-addressed-mirrors to 'url-fetch'. Define "guix download hashes" environment variable. * guix/build/download.scm (url-fetch): Add #:content-addressed-mirrors and #:hashes. [content-addressed-urls]: New variable. Use it. --- guix/build/download.scm | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index fec4cec3e8..824e1c354a 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -605,10 +605,22 @@ Return a list of URIs." (else (list uri)))) -(define* (url-fetch url file #:key (mirrors '())) +(define* (url-fetch url file + #:key + (mirrors '()) (content-addressed-mirrors '()) + (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." +on success. + +When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve +'mirror://' URIs. + +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." (define uri (append-map (cut maybe-expand-mirrors <> mirrors) (match url @@ -628,13 +640,21 @@ on success." uri) #f))) + (define content-addressed-urls + (append-map (lambda (make-url) + (filter-map (match-lambda + ((hash-algo . hash) + (make-url hash-algo hash))) + hashes)) + content-addressed-mirrors)) + ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means ;; '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IOLBF) - (let try ((uri uri)) + (let try ((uri (append uri content-addressed-urls))) (match uri ((uri tail ...) (or (fetch uri file) -- cgit v1.2.3 From 8bfd602bb00ba7bed8f0108f4cea5ac92b772b7e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 29 Apr 2016 22:12:24 +0200 Subject: build: Accept dates with space-padded hour field. * guix/build/download.scm: Replace "parse-rfc-822-date" from the (web http) module. --- guix/build/download.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 824e1c354a..7741726c41 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -426,6 +426,85 @@ port if PORT is a TLS session record port." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) + +;; XXX: Work around , fixed in Guile commit +;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation +;; procedure rejects dates in which the hour is not padded with a zero but +;; with whitespace. +(begin + (define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + + (define (parse-rfc-822-date str space zone-offset) + (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer)) + (parse-month (@@ (web http) parse-month)) + (bad-header (@@ (web http) bad-header))) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + (else + (bad-header 'date str) ; prevent tail call + #f)))) + (module-set! (resolve-module '(web http)) + 'parse-rfc-822-date parse-rfc-822-date)) + ;; XXX: Work around , present in Guile ;; up to 2.0.11. (unless (or (> (string->number (major-version)) 2) -- cgit v1.2.3 From 932f2b70a6a5eee15b1508d7aae7f8a7fdb0e23a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 10 May 2016 15:50:28 +0200 Subject: ant-build-system: Add unpack phase. * guix/build/ant-build-system.scm (unpack): New procedure. (%standard-phases): Use it. --- guix/build/ant-build-system.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'guix/build') diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 27277af34b..6dc19ff2db 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -86,6 +86,17 @@ INPUTS." (find-files dir "\\.*jar$"))) inputs)) ":")) +(define* (unpack #:key source #:allow-other-keys) + "Unpack the jar archive SOURCE. When SOURCE is not a jar archive fall back +to the default GNU unpack strategy." + (if (string-suffix? ".jar" source) + (begin + (mkdir "src") + (with-directory-excursion "src" + (zero? (system* "jar" "-xf" source)))) + ;; Use GNU unpack strategy for things that aren't jar archives. + ((assq-ref gnu:%standard-phases 'unpack) #:source source))) + (define* (configure #:key inputs outputs (jar-name #f) #:allow-other-keys) (when jar-name @@ -151,6 +162,7 @@ repack them. This is necessary to ensure that archives are reproducible." (define %standard-phases (modify-phases gnu:%standard-phases + (replace 'unpack unpack) (replace 'configure configure) (replace 'build build) (replace 'check check) -- cgit v1.2.3 From cf8b312d1872aec1f38a179eeb981d79bf7faa03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 22:11:56 +0200 Subject: grafts: Preserve empty directories when grafting. * guix/build/graft.scm (rewrite-directory)[rewrite-leaf]: Add case for 'directory. Pass #:directories? #t to 'find-files'. --- guix/build/graft.scm | 5 ++++- tests/grafts.scm | 24 ++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b216e6c0d7..e9fce03181 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -115,6 +115,8 @@ file name pairs." (replace-store-references input output mapping store) (chmod output (stat:perms stat)))))))) + ((directory) + (mkdir-p dest)) (else (error "unsupported file type" stat))))) @@ -124,6 +126,7 @@ file name pairs." (umask #o022) (n-par-for-each (parallel-job-count) - rewrite-leaf (find-files directory))) + rewrite-leaf (find-files directory (const #t) + #:directories? #t))) ;;; graft.scm ends here diff --git a/tests/grafts.scm b/tests/grafts.scm index afed704cde..f8c9eced1d 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -127,6 +127,30 @@ (list one two dep) (references %store dep))))))) +(test-assert "graft-derivation, preserve empty directories" + (run-with-store %store + (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) + (graft -> (graft + (origin %bash) + (replacement fake))) + (drv (gexp->derivation + "to-graft" + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output + "/a/b/c/d")) + (symlink #$%bash + (string-append #$output + "/bash"))) + #:modules '((guix build utils)))) + (grafted ((store-lift graft-derivation) drv + (list graft))) + (_ (built-derivations (list grafted))) + (out -> (derivation->output-path grafted))) + (return (and (string=? (readlink (string-append out "/bash")) + fake) + (file-is-directory? (string-append out "/a/b/c/d"))))))) + (test-assert "graft-derivation, no dependencies on grafted output" (run-with-store %store (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) -- cgit v1.2.3 From ece6864bd04fc2f9ff86fd4ac9cb0712dd71c094 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 22:14:46 +0200 Subject: grafts: Rename files whose name matches a graft. Fixes . Reported by Mark H Weaver . * guix/build/graft.scm (rename-matching-files): New procedure. (rewrite-directory): Use it. * tests/grafts.scm ("graft-derivation, renaming"): New test. --- guix/build/graft.scm | 25 ++++++++++++++++++++++++- tests/grafts.scm | 17 +++++++++++++++++ 2 files changed, 41 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index e9fce03181..b61982dd64 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -83,6 +83,28 @@ writing the result to OUTPUT." (put-u8 output (char->integer char)) result))))) +(define (rename-matching-files directory mapping) + "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is +a list of store file name pairs." + (let* ((mapping (map (match-lambda + ((source . target) + (cons (basename source) (basename target)))) + mapping)) + (matches (find-files directory + (lambda (file stat) + (assoc-ref mapping (basename file))) + #:directories? #t))) + + ;; XXX: This is not quite correct: if MAPPING contains "foo", and + ;; DIRECTORY contains "bar/foo/foo", we first rename "bar/foo" and then + ;; "bar/foo/foo" no longer exists so we fail. Oh well, surely that's good + ;; enough! + (for-each (lambda (file) + (let ((target (assoc-ref mapping (basename file)))) + (rename-file file + (string-append (dirname file) "/" target)))) + matches))) + (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -127,6 +149,7 @@ file name pairs." (n-par-for-each (parallel-job-count) rewrite-leaf (find-files directory (const #t) - #:directories? #t))) + #:directories? #t)) + (rename-matching-files output mapping)) ;;; graft.scm ends here diff --git a/tests/grafts.scm b/tests/grafts.scm index f8c9eced1d..8cd048552c 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -182,4 +182,21 @@ (and (string=? (readlink one) repl) (string=? (readlink two) one)))))) +(test-assert "graft-derivation, renaming" ; + (let* ((build `(begin + (use-modules (guix build utils)) + (mkdir-p (string-append (assoc-ref %outputs "out") "/" + (assoc-ref %build-inputs "in"))))) + (orig (build-expression->derivation %store "thing-to-graft" build + #:modules '((guix build utils)) + #:inputs `(("in" ,%bash)))) + (repl (add-text-to-store %store "bash" "fake bash")) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement repl)))))) + (and (build-derivations %store (list grafted)) + (let ((out (derivation->output-path grafted))) + (file-is-directory? (string-append out "/" repl)))))) + (test-end) -- cgit v1.2.3