gexp: Add 'references-file'.
* gnu/services/base.scm (references-file): Remove.
* guix/gexp.scm (references-file): New procedure.
* tests/gexp.scm ("references-file"): New test.
master
Ludovic Courtès
parent
6b4124cdcc
commit
774f8804ba
|
|
@ -219,8 +219,6 @@
|
||||||
pam-limits-service-type
|
pam-limits-service-type
|
||||||
pam-limits-service
|
pam-limits-service
|
||||||
|
|
||||||
references-file
|
|
||||||
|
|
||||||
%base-services))
|
%base-services))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
|
@ -1768,26 +1766,6 @@ proxy of 'guix-daemon'...~%")
|
||||||
(substitute-key-authorization authorized-keys guix)
|
(substitute-key-authorization authorized-keys guix)
|
||||||
#~#f))))
|
#~#f))))
|
||||||
|
|
||||||
(define* (references-file item #:optional (name "references"))
|
|
||||||
"Return a file that contains the list of references of ITEM."
|
|
||||||
(if (struct? item) ;lowerable object
|
|
||||||
(computed-file name
|
|
||||||
(with-extensions (list guile-gcrypt) ;for store-copy
|
|
||||||
(with-imported-modules (source-module-closure
|
|
||||||
'((guix build store-copy)))
|
|
||||||
#~(begin
|
|
||||||
(use-modules (guix build store-copy))
|
|
||||||
|
|
||||||
(call-with-output-file #$output
|
|
||||||
(lambda (port)
|
|
||||||
(write (map store-info-item
|
|
||||||
(call-with-input-file "graph"
|
|
||||||
read-reference-graph))
|
|
||||||
port))))))
|
|
||||||
#:options `(#:local-build? #f
|
|
||||||
#:references-graphs (("graph" ,item))))
|
|
||||||
(plain-file name "()")))
|
|
||||||
|
|
||||||
(define guix-service-type
|
(define guix-service-type
|
||||||
(service-type
|
(service-type
|
||||||
(name 'guix)
|
(name 'guix)
|
||||||
|
|
|
||||||
|
|
@ -118,6 +118,7 @@
|
||||||
mixed-text-file
|
mixed-text-file
|
||||||
file-union
|
file-union
|
||||||
directory-union
|
directory-union
|
||||||
|
references-file
|
||||||
|
|
||||||
imported-files
|
imported-files
|
||||||
imported-modules
|
imported-modules
|
||||||
|
|
@ -2173,6 +2174,49 @@ is true, the derivation will not print anything."
|
||||||
#:resolve-collision
|
#:resolve-collision
|
||||||
(ungexp resolve-collision)))))))))
|
(ungexp resolve-collision)))))))))
|
||||||
|
|
||||||
|
(define* (references-file item #:optional (name "references")
|
||||||
|
#:key guile)
|
||||||
|
"Return a file that contains the list of direct and indirect references (the
|
||||||
|
closure) of ITEM."
|
||||||
|
(if (struct? item) ;lowerable object
|
||||||
|
(computed-file name
|
||||||
|
(gexp (begin
|
||||||
|
(use-modules (srfi srfi-1)
|
||||||
|
(ice-9 rdelim)
|
||||||
|
(ice-9 match))
|
||||||
|
|
||||||
|
(define (drop-lines port n)
|
||||||
|
;; Drop N lines read from PORT.
|
||||||
|
(let loop ((n n))
|
||||||
|
(unless (zero? n)
|
||||||
|
(read-line port)
|
||||||
|
(loop (- n 1)))))
|
||||||
|
|
||||||
|
(define (read-graph port)
|
||||||
|
;; Return the list of references read from
|
||||||
|
;; PORT. This is a stripped-down version of
|
||||||
|
;; 'read-reference-graph'.
|
||||||
|
(let loop ((items '()))
|
||||||
|
(match (read-line port)
|
||||||
|
((? eof-object?)
|
||||||
|
(delete-duplicates items))
|
||||||
|
((? string? item)
|
||||||
|
(let ((deriver (read-line port))
|
||||||
|
(count
|
||||||
|
(string->number (read-line port))))
|
||||||
|
(drop-lines port count)
|
||||||
|
(loop (cons item items)))))))
|
||||||
|
|
||||||
|
(call-with-output-file (ungexp output)
|
||||||
|
(lambda (port)
|
||||||
|
(write (call-with-input-file "graph"
|
||||||
|
read-graph)
|
||||||
|
port)))))
|
||||||
|
#:guile guile
|
||||||
|
#:options `(#:local-build? #t
|
||||||
|
#:references-graphs (("graph" ,item))))
|
||||||
|
(plain-file name "()")))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Syntactic sugar.
|
;;; Syntactic sugar.
|
||||||
|
|
|
||||||
|
|
@ -1606,6 +1606,24 @@ importing.* \\(guix config\\) from the host"
|
||||||
(not (member (derivation-file-name native) refs))
|
(not (member (derivation-file-name native) refs))
|
||||||
(member (derivation-file-name cross) refs))))))
|
(member (derivation-file-name cross) refs))))))
|
||||||
|
|
||||||
|
(test-assertm "references-file"
|
||||||
|
(let* ((exp #~(symlink #$%bootstrap-guile #$output))
|
||||||
|
(computed (computed-file "computed" exp
|
||||||
|
#:guile %bootstrap-guile))
|
||||||
|
(refs (references-file computed "refs"
|
||||||
|
#:guile %bootstrap-guile)))
|
||||||
|
(mlet* %store-monad ((drv0 (lower-object %bootstrap-guile))
|
||||||
|
(drv1 (lower-object computed))
|
||||||
|
(drv2 (lower-object refs)))
|
||||||
|
(mbegin %store-monad
|
||||||
|
(built-derivations (list drv2))
|
||||||
|
(mlet %store-monad ((refs ((store-lift requisites)
|
||||||
|
(list (derivation->output-path drv1)))))
|
||||||
|
(return (lset= string=?
|
||||||
|
(call-with-input-file (derivation->output-path drv2)
|
||||||
|
read)
|
||||||
|
refs)))))))
|
||||||
|
|
||||||
(test-assert "lower-object & gexp-input-error?"
|
(test-assert "lower-object & gexp-input-error?"
|
||||||
(guard (c ((gexp-input-error? c)
|
(guard (c ((gexp-input-error? c)
|
||||||
(gexp-error-invalid-input c)))
|
(gexp-error-invalid-input c)))
|
||||||
|
|
|
||||||
Reference in New Issue