guix system: Factorize out closure copy.

* guix/scripts/system.scm (copy-closure): New procedure.
  (install): Use it.
This commit is contained in:
Ludovic Courtès 2014-05-19 22:42:34 +02:00
parent d467e640aa
commit c56d19fb11
1 changed files with 17 additions and 13 deletions

View File

@ -70,6 +70,22 @@
(leave (_ "failed to load machine file '~a': ~s~%") (leave (_ "failed to load machine file '~a': ~s~%")
file args)))))) file args))))))
(define* (copy-closure store item target
#:key (log-port (current-error-port)))
"Copy ITEM to the store under root directory TARGET and register it."
(let ((dest (string-append target item))
(refs (references store item)))
(format log-port "copying '~a'...~%" item)
(copy-recursively item dest
#:log (%make-void-port "w"))
;; Register ITEM; as a side-effect, it resets timestamps, etc.
(unless (register-path item
#:prefix target
#:references refs)
(leave (_ "failed to register '~a' under '~a'~%")
item target))))
(define* (install store os-dir target (define* (install store os-dir target
#:key (log-port (current-output-port)) #:key (log-port (current-output-port))
grub? grub.cfg device) grub? grub.cfg device)
@ -83,19 +99,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
(topologically-sorted store lst))) (topologically-sorted store lst)))
;; Copy items to the new store. ;; Copy items to the new store.
(for-each (lambda (item) (for-each (cut copy-closure store <> target #:log-port log-port)
(let ((dest (string-append target item))
(refs (references store item)))
(format log-port "copying '~a'...~%" item)
(copy-recursively item dest
#:log (%make-void-port "w"))
;; Register ITEM; as a side-effect, it resets timestamps, etc.
(unless (register-path item
#:prefix target
#:references refs)
(leave (_ "failed to register '~a' under '~a'~%")
item target))))
to-copy) to-copy)
;; Create a bunch of additional files. ;; Create a bunch of additional files.