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.
2014-05-17 17:39:30 +02:00 · 2014-05-17 17:39:30 +02:00 · b4140694ac
commit b4140694ac
parent bf43449ace
7 changed files with 118 additions and 87 deletions
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@ -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))))
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@ -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
--- a/gnu/system.scm
+++ b/gnu/system.scm
@ -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
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@ -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")
--- a/guix/build/activation.scm
+++ b/guix/build/activation.scm
@ -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
--- a/guix/build/install.scm
+++ b/guix/build/install.scm
@ -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,15 +47,44 @@ 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."
-  (match directive
-    (('directory name)
-     (mkdir-p (string-append target name)))
-    (('directory name uid gid)
-     (let ((dir (string-append target name)))
-       (mkdir-p dir)
-       (chown dir uid gid)))
-    ((new '-> old)
-     (symlink old (string-append target new)))))
+  (let loop ((directive directive))
+    (match directive
+      (('directory name)
+       (mkdir-p (string-append target name)))
+      (('directory name uid gid)
+       (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))))))
+
+(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
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@ -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"))