nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

system: Make /run/current-system at activation time. 

* gnu/system.scm (etc-directory): Change default value of #:profile.
  Change contents of SHELLS.  Use /run/current-system/profile/{s,}bin in
  BASHRC.
  (operating-system-boot-script)[%modules]: Add (guix build
  linux-initrd).  Add call to 'activate-current-system' in gexp.
  (operating-system-initrd-file, operating-system-grub.cfg): New
  procedures.
  (operating-system-derivation): Don't build grub.cfg here and remove it
  from the file union.
* gnu/system/vm.scm (qemu-image): Remove #:populate.
  (operating-system-build-gid, operating-system-default-contents):
  Remove.
  (system-qemu-image): Remove call to
  'operating-system-default-contents'.  Use 'operating-system-grub.cfg'
  to get grub.cfg.  Add GRUB.CFG to #:inputs.
  (system-qemu-image/shared-store): Likewise, but don't add GRUB.CFG to
  #:inputs.
  (system-qemu-image/shared-store-script): Pass --system kernel option.
* guix/build/activation.scm (%booted-system, %current-system): New
  variables.
  (boot-time-system, activate-current-system): New procedures.
* guix/build/install.scm (evaluate-populate-directive): Add case
  for ('directory name uid gid mode).
  (directives, populate-root-file-system): New procedures.
* guix/build/vm.scm (initialize-hard-disk): Replace calls to
  'evaluate-populate-directive' by a call to
  'populate-root-file-system'.
* gnu/services/dmd.scm (dmd-configuration-file): Use
  /run/current-system/profile/bin.
* gnu/services/xorg.scm (slim-service): Likewise.
This commit is contained in:
Ludovic Courtès 2014-05-17 17:39:30 +02:00
parent bf43449ace
commit b4140694ac
7 changed files with 118 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gnu/services/dmd.scm
View File

@ -64,7 +64,7 @@
services))
;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
(setenv "PATH" "/run/current-system/bin")
(setenv "PATH" "/run/current-system/profile/bin")
(format #t "starting services...~%")
(for-each start '#$(append-map service-provision services))))

2
gnu/services/xorg.scm
View File

@ -139,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER."
(mlet %store-monad ((startx (or startx (xorg-start-command)))
(xinitrc (xinitrc)))
(text-file* "slim.cfg" "
default_path /run/current-system/bin
default_path /run/current-system/profile/bin
default_xserver " startx "
xserver_arguments :0 vt7
xauth_path " xauth "/bin/xauth

56
gnu/system.scm
View File

@ -55,6 +55,7 @@
operating-system-derivation
operating-system-profile
operating-system-grub.cfg
<file-system>
file-system
@ -263,7 +264,7 @@ explicitly appear in OS."
(locale "C") (timezone "Europe/Paris")
(skeletons '())
(pam-services '())
(profile "/var/run/current-system/profile")
(profile "/run/current-system/profile")
(sudoers ""))
"Return a derivation that builds the static part of the /etc directory."
(mlet* %store-monad
@ -273,8 +274,8 @@ explicitly appear in OS."
(shells (text-file "shells" ; used by xterm and others
"\
/bin/sh
/run/current-system/bin/sh
/run/current-system/bin/bash\n"))
/run/current-system/profile/bin/sh
/run/current-system/profile/bin/bash\n"))
(issue (text-file "issue" "
This is an alpha preview of the GNU system. Welcome.
@ -293,8 +294,8 @@ export LC_ALL=\"" locale "\"
export TZ=\"" timezone "\"
export TZDIR=\"" tzdata "/share/zoneinfo\"
export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
export PATH=/run/setuid-programs:$PATH
export PATH=/run/setuid-programs:/run/current-system/profile/sbin
export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH
export CPATH=$HOME/.guix-profile/include:" profile "/include
export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
alias ls='ls -p --color'
@ -402,7 +403,8 @@ alias ll='ls -l'
we're running in the final root."
(define %modules
'((guix build activation)
(guix build utils)))
(guix build utils)
(guix build linux-initrd)))
(mlet* %store-monad ((services (operating-system-services os))
(etc (operating-system-etc-directory os))
@ -446,6 +448,9 @@ we're running in the final root."
;; Activate setuid programs.
(activate-setuid-programs (list #$@setuid-progs))
;; Set up /run/current-system.
(activate-current-system #:boot? #t)
;; Close any remaining open file descriptors to be on the
;; safe side. This must be the very last thing we do,
;; because Guile has internal FDs such as 'sleep_pipe'
@ -466,8 +471,8 @@ we're running in the final root."
(_ #f))
(operating-system-file-systems os)))
(define (operating-system-derivation os)
"Return a derivation that builds OS."
(define (operating-system-initrd-file os)
"Return a gexp denoting the initrd file of OS."
(define boot-file-systems
(filter (match-lambda
(($ <file-system> device "/")
@ -476,15 +481,16 @@ we're running in the final root."
boot?))
(operating-system-file-systems os)))
(mlet %store-monad
((initrd ((operating-system-initrd os) boot-file-systems)))
(return #~(string-append #$initrd "/initrd"))))
(define (operating-system-grub.cfg os)
"Return the GRUB configuration file for OS."
(mlet* %store-monad
((profile (operating-system-profile os))
(etc (operating-system-etc-directory os))
(services (operating-system-services os))
(boot (operating-system-boot-script os))
(kernel -> (operating-system-kernel os))
(initrd ((operating-system-initrd os) boot-file-systems))
(initrd-file -> #~(string-append #$initrd "/initrd"))
((system (operating-system-derivation os))
(root-fs -> (operating-system-root-file-system os))
(kernel -> (operating-system-kernel os))
(entries -> (list (menu-entry
(label (string-append
"GNU system with "
@ -494,15 +500,25 @@ we're running in the final root."
(linux-arguments
(list (string-append "--root="
(file-system-device root-fs))
#~(string-append "--load=" #$boot)))
(initrd initrd-file))))
(grub.cfg (grub-configuration-file entries)))
#~(string-append "--system=" #$system)
#~(string-append "--load=" #$system
"/boot")))
(initrd #~(string-append #$system "/initrd"))))))
(grub-configuration-file entries)))
(define (operating-system-derivation os)
"Return a derivation that builds OS."
(mlet* %store-monad
((profile (operating-system-profile os))
(etc (operating-system-etc-directory os))
(boot (operating-system-boot-script os))
(kernel -> (operating-system-kernel os))
(initrd (operating-system-initrd-file os)))
(file-union "system"
`(("boot" ,#~#$boot)
("kernel" ,#~#$kernel)
("initrd" ,initrd-file)
("initrd" ,initrd)
("profile" ,#~#$profile)
("grub.cfg" ,#~#$grub.cfg)
("etc" ,#~#$etc)))))
;;; system.scm ends here

59
gnu/system/vm.scm
View File

@ -192,7 +192,6 @@ made available under the /xchg CIFS share."
(file-system-type "ext4")
grub-configuration
(register-closures? #t)
(populate #f)
(inputs '())
copy-inputs?)
"Return a bootable, stand-alone QEMU image, with a root partition of type
@ -203,12 +202,7 @@ 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,
register INPUTS in the store database of the image so that Guix can be used in
the image.
POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition. It is evaluated once the image has been
populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files."
the image."
(mlet %store-monad
((graph (sequence %store-monad (map input->name+output inputs))))
(expression->derivation-in-linux-vm
@ -241,8 +235,7 @@ such as /etc files."
#:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures?
#:disk-image-size #$disk-image-size
#:file-system-type #$file-system-type
#:directives '#$populate)
#:file-system-type #$file-system-type)
(reboot))))
#:system system
#:make-disk-image? #t
@ -254,39 +247,6 @@ such as /etc files."
;;; Stand-alone VM image.
;;;
(define (operating-system-build-gid os)
"Return as a monadic value the group id for build users of OS, or #f."
(mlet %store-monad ((services (operating-system-services os)))
(return (any (lambda (service)
(and (equal? '(guix-daemon)
(service-provision service))
(match (service-user-groups service)
((group)
(user-group-id group)))))
services))))
(define (operating-system-default-contents os)
"Return a list of directives suitable for 'system-qemu-image' describing the
basic contents of the root file system of OS."
(mlet* %store-monad ((os-drv (operating-system-derivation os))
(build-gid (operating-system-build-gid os))
(profile (operating-system-profile os)))
(return #~((directory #$(%store-prefix) 0 #$(or build-gid 0))
(directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/run/nscd")
(directory "/var/guix/gcroots")
("/var/guix/gcroots/system" -> #$os-drv)
(directory "/run")
("/run/current-system" -> #$profile)
(directory "/bin")
("/bin/sh" -> "/run/current-system/bin/bash")
(directory "/tmp")
(directory "/var/guix/profiles/per-user/root" 0 0)
(directory "/root" 0 0) ; an exception
(directory "/home" 0 0)))))
(define* (system-qemu-image os
#:key
(file-system-type "ext4")
@ -312,14 +272,12 @@ of the GNU system as described by OS."
file-systems-to-keep)))))
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(os-dir -> (derivation->output-path os-drv))
(grub.cfg -> (string-append os-dir "/grub.cfg"))
(populate (operating-system-default-contents os)))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg
#:populate populate
#:disk-image-size disk-image-size
#:file-system-type file-system-type
#:inputs `(("system" ,os-drv))
#:inputs `(("system" ,os-drv)
("grub.cfg" ,grub.cfg))
#:copy-inputs? #t))))
(define (virtualized-operating-system os)
@ -356,11 +314,8 @@ environment with the store shared with the host."
with the host."
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(os-dir -> (derivation->output-path os-drv))
(grub.cfg -> (string-append os-dir "/grub.cfg"))
(populate (operating-system-default-contents os)))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg
#:populate populate
#:disk-image-size disk-image-size
#:inputs `(("system" ,os-drv))
@ -390,7 +345,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir
-kernel " #$(operating-system-kernel os) "/bzImage \
-initrd " #$os-drv "/initrd \
-append \"" #$(if graphic? "" "console=ttyS0 ")
"--load=" #$os-drv "/boot --root=/dev/vda1\" \
"--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \
-serial stdio \
-drive file=" #$image
",if=virtio,cache=writeback,werror=report,readonly\n")

33
guix/build/activation.scm
View File

@ -18,13 +18,15 @@
(define-module (guix build activation)
#:use-module (guix build utils)
#:use-module (guix build linux-initrd)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (activate-users+groups
activate-etc
activate-setuid-programs))
activate-setuid-programs
activate-current-system))
;;; Commentary:
;;;
@ -195,4 +197,33 @@ numeric gid or #f."
(for-each make-setuid-program programs))
(define %booted-system
;; The system we booted in (a symlink.)
"/run/booted-system")
(define %current-system
;; The system that is current (a symlink.) This is not necessarily the same
;; as %BOOTED-SYSTEM, for instance because we can re-build a new system
;; configuration and activate it, without rebooting.
"/run/current-system")
(define (boot-time-system)
"Return the '--system' argument passed on the kernel command line."
(find-long-option "--system" (linux-command-line)))
(define* (activate-current-system #:optional (system (boot-time-system))
#:key boot?)
"Atomically make SYSTEM the current system. When BOOT? is true, also make
it the booted system."
(format #t "making '~a' the current system...~%" system)
(when boot?
(when (file-exists? %booted-system)
(delete-file %booted-system))
(symlink system %booted-system))
;; Atomically make SYSTEM current.
(let ((new (string-append %current-system ".new")))
(symlink system new)
(rename-file new %current-system)))
;;; activation.scm ends here

34
guix/build/install.scm
View File

@ -19,9 +19,10 @@
(define-module (guix build install)
#:use-module (guix build utils)
#:use-module (guix build install)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (install-grub
evaluate-populate-directive
populate-root-file-system
reset-timestamps
register-closure))
@ -46,6 +47,7 @@ MOUNT-POINT. Return #t on success."
(define (evaluate-populate-directive directive target)
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET."
(let loop ((directive directive))
(match directive
(('directory name)
(mkdir-p (string-append target name)))
@ -53,8 +55,36 @@ directory TARGET."
(let ((dir (string-append target name)))
(mkdir-p dir)
(chown dir uid gid)))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
(chmod (string-append target name) mode))
((new '-> old)
(symlink old (string-append target new)))))
(symlink old (string-append target new))))))
(define (directives store)
"Return a list of directives to populate the root file system that will host
STORE."
`((directory ,store 0 0)
(directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/run/nscd")
(directory "/var/guix/gcroots")
(directory "/run")
("/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)
"Make the essential non-store files and directories on TARGET. This
includes /etc, /var, /run, /bin/sh, etc."
(for-each (cut evaluate-populate-directive <> target)
(directives (%store-directory))))
(define (reset-timestamps directory)
"Reset the timestamps of all the files under DIRECTORY, so that they appear

3
guix/build/vm.scm
View File

@ -206,8 +206,7 @@ further populate the partition."
;; Evaluate the POPULATE directives.
(display "populating...\n")
(for-each (cut evaluate-populate-directive <> target-directory)
directives)
(populate-root-file-system target-directory)
(unless (install-grub grub.cfg "/dev/sda" target-directory)
(error "failed to install GRUB"))