ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-17 04:07:10 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix system: Factorize out closure copy.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

30
guix/scripts/system.scm
View file

@ -70,6 +70,22 @@ (define (read-operating-system file)
(leave (_ "failed to load machine file '~a': ~s~%")
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
#:key (log-port (current-output-port))
grub? grub.cfg device)
@ -83,19 +99,7 @@ (define to-copy
(topologically-sorted store lst)))
;; Copy items to the new store.
(for-each (lambda (item)
(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))))
(for-each (cut copy-closure store <> target #:log-port log-port)
to-copy)
;; Create a bunch of additional files.