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
Ludovic Courtès 2017-11-30 14:17:24 +01:00
parent 1fafa2f587
commit e4ecd51e23
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 29 additions and 32 deletions

View File

@ -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