guix system: Simplify closure copy.
* guix/scripts/system.scm (copy-item): Add 'references' argument and remove 'references*' call. Turn into a non-monadic procedure. (copy-closure): Remove initial call to 'references*'. Only pass ITEM to 'topologically-sorted*' since that's equivalent. Compute the list of references corresponding to TO-COPY and pass it to 'copy-item'.master
parent
1fafa2f587
commit
e4ecd51e23
|
@ -107,47 +107,44 @@ BODY..., and restore them."
|
||||||
(store-lift topologically-sorted))
|
(store-lift topologically-sorted))
|
||||||
|
|
||||||
|
|
||||||
(define* (copy-item item target
|
(define* (copy-item item references target
|
||||||
#:key (log-port (current-error-port)))
|
#:key (log-port (current-error-port)))
|
||||||
"Copy ITEM to the store under root directory TARGET and register it."
|
"Copy ITEM to the store under root directory TARGET and register it with
|
||||||
(mlet* %store-monad ((refs (references* item)))
|
REFERENCES as its set of references."
|
||||||
(let ((dest (string-append target item))
|
(let ((dest (string-append target item))
|
||||||
(state (string-append target "/var/guix")))
|
(state (string-append target "/var/guix")))
|
||||||
(format log-port "copying '~a'...~%" item)
|
(format log-port "copying '~a'...~%" item)
|
||||||
|
|
||||||
;; Remove DEST if it exists to make sure that (1) we do not fail badly
|
;; Remove DEST if it exists to make sure that (1) we do not fail badly
|
||||||
;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
|
;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
|
||||||
;; (2) we end up with the right contents.
|
;; (2) we end up with the right contents.
|
||||||
(when (file-exists? dest)
|
(when (file-exists? dest)
|
||||||
(delete-file-recursively dest))
|
(delete-file-recursively dest))
|
||||||
|
|
||||||
(copy-recursively item dest
|
(copy-recursively item dest
|
||||||
#:log (%make-void-port "w"))
|
#:log (%make-void-port "w"))
|
||||||
|
|
||||||
;; Register ITEM; as a side-effect, it resets timestamps, etc.
|
;; Register ITEM; as a side-effect, it resets timestamps, etc.
|
||||||
;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
|
;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
|
||||||
;; reproducing the user's current settings; see
|
;; reproducing the user's current settings; see
|
||||||
;; <http://bugs.gnu.org/18049>.
|
;; <http://bugs.gnu.org/18049>.
|
||||||
(unless (register-path item
|
(unless (register-path item
|
||||||
#:prefix target
|
#:prefix target
|
||||||
#:state-directory state
|
#:state-directory state
|
||||||
#:references refs)
|
#:references references)
|
||||||
(leave (G_ "failed to register '~a' under '~a'~%")
|
(leave (G_ "failed to register '~a' under '~a'~%")
|
||||||
item target))
|
item target))))
|
||||||
|
|
||||||
(return #t))))
|
|
||||||
|
|
||||||
(define* (copy-closure item target
|
(define* (copy-closure item target
|
||||||
#:key (log-port (current-error-port)))
|
#:key (log-port (current-error-port)))
|
||||||
"Copy ITEM and all its dependencies to the store under root directory
|
"Copy ITEM and all its dependencies to the store under root directory
|
||||||
TARGET, and register them."
|
TARGET, and register them."
|
||||||
(mlet* %store-monad ((refs (references* item))
|
(mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
|
||||||
(to-copy (topologically-sorted*
|
(refs (mapm %store-monad references* to-copy)))
|
||||||
(delete-duplicates (cons item refs)
|
(for-each (cut copy-item <> <> target #:log-port log-port)
|
||||||
string=?))))
|
to-copy refs)
|
||||||
(sequence %store-monad
|
|
||||||
(map (cut copy-item <> target #:log-port log-port)
|
(return *unspecified*)))
|
||||||
to-copy))))
|
|
||||||
|
|
||||||
(define* (install-bootloader installer-drv
|
(define* (install-bootloader installer-drv
|
||||||
#:key
|
#:key
|
||||||
|
|
Loading…
Reference in New Issue