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'.
This commit is contained in:
parent
1fafa2f587
commit
e4ecd51e23
@ -107,47 +107,44 @@ BODY..., and restore them."
|
||||
(store-lift topologically-sorted))
|
||||
|
||||
|
||||
(define* (copy-item item target
|
||||
(define* (copy-item item references target
|
||||
#:key (log-port (current-error-port)))
|
||||
"Copy ITEM to the store under root directory TARGET and register it."
|
||||
(mlet* %store-monad ((refs (references* item)))
|
||||
(let ((dest (string-append target item))
|
||||
(state (string-append target "/var/guix")))
|
||||
(format log-port "copying '~a'...~%" item)
|
||||
"Copy ITEM to the store under root directory TARGET and register it with
|
||||
REFERENCES as its set of references."
|
||||
(let ((dest (string-append target item))
|
||||
(state (string-append target "/var/guix")))
|
||||
(format log-port "copying '~a'...~%" item)
|
||||
|
||||
;; 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
|
||||
;; (2) we end up with the right contents.
|
||||
(when (file-exists? dest)
|
||||
(delete-file-recursively dest))
|
||||
;; 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
|
||||
;; (2) we end up with the right contents.
|
||||
(when (file-exists? dest)
|
||||
(delete-file-recursively dest))
|
||||
|
||||
(copy-recursively item dest
|
||||
#:log (%make-void-port "w"))
|
||||
(copy-recursively item dest
|
||||
#:log (%make-void-port "w"))
|
||||
|
||||
;; Register ITEM; as a side-effect, it resets timestamps, etc.
|
||||
;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
|
||||
;; reproducing the user's current settings; see
|
||||
;; <http://bugs.gnu.org/18049>.
|
||||
(unless (register-path item
|
||||
#:prefix target
|
||||
#:state-directory state
|
||||
#:references refs)
|
||||
(leave (G_ "failed to register '~a' under '~a'~%")
|
||||
item target))
|
||||
|
||||
(return #t))))
|
||||
;; Register ITEM; as a side-effect, it resets timestamps, etc.
|
||||
;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
|
||||
;; reproducing the user's current settings; see
|
||||
;; <http://bugs.gnu.org/18049>.
|
||||
(unless (register-path item
|
||||
#:prefix target
|
||||
#:state-directory state
|
||||
#:references references)
|
||||
(leave (G_ "failed to register '~a' under '~a'~%")
|
||||
item target))))
|
||||
|
||||
(define* (copy-closure item target
|
||||
#:key (log-port (current-error-port)))
|
||||
"Copy ITEM and all its dependencies to the store under root directory
|
||||
TARGET, and register them."
|
||||
(mlet* %store-monad ((refs (references* item))
|
||||
(to-copy (topologically-sorted*
|
||||
(delete-duplicates (cons item refs)
|
||||
string=?))))
|
||||
(sequence %store-monad
|
||||
(map (cut copy-item <> target #:log-port log-port)
|
||||
to-copy))))
|
||||
(mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
|
||||
(refs (mapm %store-monad references* to-copy)))
|
||||
(for-each (cut copy-item <> <> target #:log-port log-port)
|
||||
to-copy refs)
|
||||
|
||||
(return *unspecified*)))
|
||||
|
||||
(define* (install-bootloader installer-drv
|
||||
#:key
|
||||
|
Loading…
Reference in New Issue
Block a user