mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-23 21:17:11 -05:00
Add `imported-files'.
* guix/derivations.scm (imported-files): New procedure. (build-expression->derivation): Correctly handle inputs that are sources and not derivation paths. * tests/derivations.scm ("imported-files"): New test.
This commit is contained in:
parent
0e383c76ce
commit
99634e3ff4
2 changed files with 70 additions and 4 deletions
|
@ -52,7 +52,8 @@ (define-module (guix derivations)
|
|||
derivation
|
||||
|
||||
%guile-for-build
|
||||
build-expression->derivation))
|
||||
build-expression->derivation
|
||||
imported-files))
|
||||
|
||||
;;;
|
||||
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
|
||||
|
@ -372,6 +373,51 @@ (define %guile-for-build
|
|||
;; when using `build-expression->derivation'.
|
||||
(make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
|
||||
|
||||
(define* (imported-files store files
|
||||
#:key (name "file-import") (system (%current-system)))
|
||||
"Return a derivation that imports FILES into STORE. FILES must be a list
|
||||
of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
|
||||
system, imported, and appears under FINAL-PATH in the resulting store path."
|
||||
(define (parent-dirs file-name)
|
||||
;; Return the list of parent dirs of FILE-NAME, in the order in which an
|
||||
;; `mkdir -p' implementation would make them.
|
||||
(let ((not-slash (char-set-complement (char-set #\/))))
|
||||
(reverse
|
||||
(fold (lambda (dir result)
|
||||
(match result
|
||||
(()
|
||||
(list dir))
|
||||
((prev _ ...)
|
||||
(cons (string-append prev "/" dir)
|
||||
result))))
|
||||
'()
|
||||
(remove (cut string=? <> ".")
|
||||
(string-tokenize (dirname file-name) not-slash))))))
|
||||
|
||||
(let* ((files (map (match-lambda
|
||||
((final-path . file-name)
|
||||
(cons final-path
|
||||
(add-to-store store (basename final-path) #t #f
|
||||
"sha256" file-name))))
|
||||
files))
|
||||
(builder
|
||||
`(begin
|
||||
(mkdir %output) (chdir %output)
|
||||
,@(append-map (match-lambda
|
||||
((final-path . store-path)
|
||||
(append (match (parent-dirs final-path)
|
||||
(() '())
|
||||
((head ... tail)
|
||||
(append (map (lambda (d)
|
||||
`(false-if-exception
|
||||
(mkdir ,d)))
|
||||
head)
|
||||
`((mkdir ,tail)))))
|
||||
`((symlink ,store-path ,final-path)))))
|
||||
files))))
|
||||
(build-expression->derivation store name (%current-system)
|
||||
builder files)))
|
||||
|
||||
(define* (build-expression->derivation store name system exp inputs
|
||||
#:key (outputs '("out"))
|
||||
hash hash-algo)
|
||||
|
@ -395,7 +441,9 @@ (define %build-inputs
|
|||
',(map (match-lambda
|
||||
((name . drv)
|
||||
(cons name
|
||||
(derivation-path->output-path drv))))
|
||||
(if (derivation-path? drv)
|
||||
(derivation-path->output-path drv)
|
||||
drv))))
|
||||
inputs))) )
|
||||
(builder (add-text-to-store store
|
||||
(string-append name "-guile-builder")
|
||||
|
|
|
@ -24,11 +24,13 @@ (define-module (test-derivations)
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 ftw))
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
(define %store
|
||||
(false-if-exception (open-connection)))
|
||||
|
@ -156,7 +158,7 @@ (define %coreutils
|
|||
(let ((p (derivation-path->output-path drv-path)))
|
||||
(file-exists? (string-append p "/good"))))))
|
||||
|
||||
(test-skip (if (%guile-for-build) 0 2))
|
||||
(test-skip (if (%guile-for-build) 0 4))
|
||||
|
||||
(test-assert "build-expression->derivation without inputs"
|
||||
(let* ((builder '(begin
|
||||
|
@ -208,6 +210,22 @@ (define %coreutils
|
|||
(let ((p (derivation-path->output-path drv-path)))
|
||||
(string-contains (call-with-input-file p read-line) "GNU")))))
|
||||
|
||||
(test-assert "imported-files"
|
||||
(let* ((files `(("x" . ,(search-path %load-path "ice-9/q.scm"))
|
||||
("a/b/c" . ,(search-path %load-path
|
||||
"guix/derivations.scm"))
|
||||
("p/q" . ,(search-path %load-path "guix.scm"))))
|
||||
(drv-path (imported-files %store files)))
|
||||
(and (build-derivations %store (list drv-path))
|
||||
(let ((dir (derivation-path->output-path drv-path)))
|
||||
(every (match-lambda
|
||||
((path . source)
|
||||
(equal? (call-with-input-file (string-append dir "/" path)
|
||||
get-bytevector-all)
|
||||
(call-with-input-file source
|
||||
get-bytevector-all))))
|
||||
files)))))
|
||||
|
||||
(test-skip (if (false-if-exception (getaddrinfo "ftp.gnu.org" "http"))
|
||||
0
|
||||
1))
|
||||
|
|
Loading…
Reference in a new issue