summaryrefslogtreecommitdiff
path: root/guix/scripts/system.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-05-18 21:32:57 +0200
committerLudovic Courtès <ludo@gnu.org>2014-05-18 22:27:23 +0200
commit72b9d60df4723541e1a65f7a3d14abb757fbed97 (patch)
treeb2f4a29ef26d14f940f4df28a10af9f5c22b79d8 /guix/scripts/system.scm
parentbb31e0a3ee2ba23fa7a57471b0aa2363404f4c27 (diff)
guix system: Add 'init' sub-command.
* guix/scripts/system.scm (install): New procedure. (guix-system)[parse-option]: Remove check for extraneous arguments. [match-pair, option-arguments]: New procedures. Use 'option-arguments'. Honor 'init'. (show-help): Document 'init'. * doc/guix.texi (Invoking guix system): Document 'init'.
Diffstat (limited to 'guix/scripts/system.scm')
-rw-r--r--guix/scripts/system.scm87
1 files changed, 78 insertions, 9 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 0739534b57..ee5df6e951 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -19,14 +19,18 @@
(define-module (guix scripts system)
#:use-module (guix ui)
#:use-module (guix store)
+ #:use-module (guix gexp)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (guix monads)
#:use-module (guix scripts build)
+ #:use-module (guix build utils)
+ #:use-module (guix build install)
#:use-module (gnu system)
#:use-module (gnu system vm)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (guix-system
@@ -64,6 +68,38 @@
(leave (_ "failed to load machine file '~a': ~s~%")
file args))))))
+(define* (install store os-dir target
+ #:key (log-port (current-output-port)))
+ "Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an
+absolute directory name since that's what 'guix-register' expects."
+ (define to-copy
+ (let ((lst (delete-duplicates (cons os-dir (references store os-dir))
+ string=?)))
+ (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))))
+ to-copy)
+
+ ;; Create a bunch of additional files.
+ (format log-port "populating '~a'...~%" target)
+ (populate-root-file-system target)
+
+ ;; TODO: Install GRUB.
+ )
+
;;;
;;; Options.
@@ -79,7 +115,9 @@ Build the operating system declared in FILE according to ACTION.\n"))
(display (_ "\
- 'vm', build a virtual machine image that shares the host's store\n"))
(display (_ "\
- - 'vm-image', build a freestanding virtual machine image.\n"))
+ - 'vm-image', build a freestanding virtual machine image\n"))
+ (display (_ "\
+ - 'init', initialize a root file system to run GNU.\n"))
(show-build-options-help)
(display (_ "
@@ -132,27 +170,50 @@ Build the operating system declared in FILE according to ACTION.\n"))
(leave (_ "~A: unrecognized option~%") name))
(lambda (arg result)
(if (assoc-ref result 'action)
- (let ((previous (assoc-ref result 'argument)))
- (if previous
- (leave (_ "~a: extraneous argument~%") previous)
- (alist-cons 'argument arg result)))
+ (alist-cons 'argument arg result)
(let ((action (string->symbol arg)))
(case action
- ((build vm vm-image)
+ ((build vm vm-image init)
(alist-cons 'action action result))
(else (leave (_ "~a: unknown action~%")
action))))))
%default-options))
+ (define (match-pair car)
+ ;; Return a procedure that matches a pair with CAR.
+ (match-lambda
+ ((head . tail)
+ (and (eq? car head) tail))
+ (_ #f)))
+
+ (define (option-arguments opts)
+ ;; Extract the plain arguments from OPTS.
+ (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
+ (count (length args))
+ (action (assoc-ref opts 'action)))
+ (define (fail)
+ (leave (_ "wrong number of arguments for action '~a'~%")
+ action))
+
+ (case action
+ ((build vm vm-image)
+ (unless (= count 1)
+ (fail)))
+ ((init)
+ (unless (= count 2)
+ (fail))))
+ args))
+
(with-error-handling
(let* ((opts (parse-options))
- (file (assoc-ref opts 'argument))
+ (args (option-arguments opts))
+ (file (first args))
(action (assoc-ref opts 'action))
(os (if file
(read-operating-system file)
(leave (_ "no configuration file specified~%"))))
(mdrv (case action
- ((build)
+ ((build init)
(operating-system-derivation os))
((vm-image)
(let ((size (assoc-ref opts 'image-size)))
@@ -171,4 +232,12 @@ Build the operating system declared in FILE according to ACTION.\n"))
(unless dry?
(build-derivations store (list drv))
(display (derivation->output-path drv))
- (newline)))))
+ (newline)
+
+ (when (eq? action 'init)
+ (let ((target (second args)))
+ (format #t (_ "initializing operating system under '~a'...~%")
+ target)
+
+ (install store (derivation->output-path drv)
+ (canonicalize-path target))))))))