system: Install /var/guix/profiles/system-1-link on new systems.

* guix/build/install.scm (directives): Add /var/guix/profiles/system.
  (populate-root-file-system): Add 'system' parameter.  Create
  /var/guix/profiles/system-1-link.
* guix/scripts/system.scm (install): Pass OS-DIR to
  'populate-root-file-system'.
* guix/build/vm.scm (initialize-root-partition): Add #:system-directory
  parameter, and pass it to 'populate-root-file-system'.
  (initialize-hard-disk): Add #:system-directory parameter, and pass it
  to 'initialize-root-partition'.
* gnu/system/vm.scm (qemu-image): Add #:os-derivation parameter and pass
  it to 'initialize-hard-disk'.
  (system-disk-image, system-qemu-image,
  system-qemu-image/shared-store): Pass #:os-derivation to 'qemu-image.
This commit is contained in:
Ludovic Courtès 2014-06-27 17:54:29 +02:00
parent dff624230a
commit f2c403eab6
4 changed files with 30 additions and 13 deletions

View file

@ -197,6 +197,7 @@ (define* (qemu-image #:key
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
os-derivation
grub-configuration
(register-closures? #t)
(inputs '())
@ -204,9 +205,9 @@ (define* (qemu-image #:key
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
partition. The returned image is a full disk image, with a GRUB installation
that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
must be the name of a file in the VM.)
partition. The returned image is a full disk image that runs OS-DERIVATION,
with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
file (GRUB-CONFIGURATION must be the name of a file in the VM.)
INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
@ -240,6 +241,7 @@ (define* (qemu-image #:key
(((names . _) ...)
names))))
(initialize-hard-disk "/dev/vda"
#:system-directory #$os-derivation
#:grub.cfg #$grub-configuration
#:closures graphs
#:copy-closures? #$copy-inputs?
@ -298,6 +300,7 @@ (define file-systems-to-keep
(mlet* %store-monad ((os-drv (operating-system-derivation os))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:name name
#:os-derivation os-drv
#:grub-configuration grub.cfg
#:disk-image-size disk-image-size
#:disk-image-format "raw"
@ -334,7 +337,8 @@ (define file-systems-to-keep
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg
(qemu-image #:os-derivation os-drv
#:grub-configuration grub.cfg
#:disk-image-size disk-image-size
#:file-system-type file-system-type
#:inputs `(("system" ,os-drv)
@ -376,7 +380,8 @@ (define* (system-qemu-image/shared-store
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg
(qemu-image #:os-derivation os-drv
#:grub-configuration grub.cfg
#:disk-image-size disk-image-size
#:inputs `(("system" ,os-drv))

View file

@ -83,21 +83,30 @@ (define (directives store)
(directory "/var/empty") ; for no-login accounts
(directory "/var/run")
(directory "/run")
(directory "/var/guix/profiles/per-user/root" 0 0)
;; Link to the initial system generation.
("/var/guix/profiles/system" -> "system-1-link")
("/var/guix/gcroots/booted-system" -> "/run/booted-system")
("/var/guix/gcroots/current-system" -> "/run/current-system")
(directory "/bin")
("/bin/sh" -> "/run/current-system/profile/bin/bash")
(directory "/tmp" 0 0 #o1777) ; sticky bit
(directory "/var/guix/profiles/per-user/root" 0 0)
(directory "/root" 0 0) ; an exception
(directory "/home" 0 0)))
(define (populate-root-file-system target)
(define (populate-root-file-system system target)
"Make the essential non-store files and directories on TARGET. This
includes /etc, /var, /run, /bin/sh, etc."
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
(for-each (cut evaluate-populate-directive <> target)
(directives (%store-directory))))
(directives (%store-directory)))
;; Add system generation 1.
(symlink system
(string-append target "/var/guix/profiles/system-1-link")))
(define (reset-timestamps directory)
"Reset the timestamps of all the files under DIRECTORY, so that they appear

View file

@ -172,7 +172,7 @@ (define* (format-partition partition type
(define* (initialize-root-partition target-directory
#:key copy-closures? register-closures?
closures)
closures system-directory)
"Initialize the root partition mounted at TARGET-DIRECTORY."
(define target-store
(string-append target-directory (%store-directory)))
@ -203,10 +203,11 @@ (define target-store
;; Add the non-store directories and files.
(display "populating...\n")
(populate-root-file-system target-directory))
(populate-root-file-system system-directory target-directory))
(define* (initialize-hard-disk device
#:key
system-directory
grub.cfg
disk-image-size
(file-system-type "ext4")
@ -218,7 +219,8 @@ (define* (initialize-hard-disk device
partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is
the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the
partition."
partition. SYSTEM-DIRECTORY is the name of the directory of the 'system'
derivation."
(define target-directory
"/fs")
@ -236,6 +238,7 @@ (define partition
(mount partition target-directory file-system-type)
(initialize-root-partition target-directory
#:system-directory system-directory
#:copy-closures? copy-closures?
#:register-closures? register-closures?
#:closures closures)

View file

@ -116,7 +116,7 @@ (define to-copy
;; Create a bunch of additional files.
(format log-port "populating '~a'...~%" target)
(populate-root-file-system target)
(populate-root-file-system os-dir target)
(when grub?
(unless (false-if-exception (install-grub grub.cfg device target))