gnu/build/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu build install)
  20   #:use-module (guix build utils)
  21   #:use-module (guix build store-copy)
  22   #:use-module (srfi srfi-26)
  23   #:use-module (ice-9 match)
  24   #:export (install-grub
  25             populate-root-file-system
  26             reset-timestamps
  27             register-closure
  28             populate-single-profile-directory))
  29
  30 ;;; Commentary:
  31 ;;;
  32 ;;; This module supports the installation of the GNU system on a hard disk.
  33 ;;; It is meant to be used both in a build environment (in derivations that
  34 ;;; build VM images), and on the bare metal (when really installing the
  35 ;;; system.)
  36 ;;;
  37 ;;; Code:
  38
  39 (define* (install-grub grub.cfg device mount-point)
  40   "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
  41 MOUNT-POINT.
  42
  43 Note that the caller must make sure that GRUB.CFG is registered as a GC root
  44 so that the fonts, background images, etc. referred to by GRUB.CFG are not
  45 GC'd."
  46   (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
  47          (pivot  (string-append target ".new")))
  48     (mkdir-p (dirname target))
  49
  50     ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
  51     ;; work when /boot is on a separate partition.  Do that atomically.
  52     (copy-file grub.cfg pivot)
  53     (rename-file pivot target)
  54
  55     (unless (zero? (system* "grub-install" "--no-floppy"
  56                             "--boot-directory"
  57                             (string-append mount-point "/boot")
  58                             device))
  59       (error "failed to install GRUB"))))
  60
  61 (define (evaluate-populate-directive directive target)
  62   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  63 directory TARGET."
  64   (let loop ((directive directive))
  65     (catch 'system-error
  66       (lambda ()
  67         (match directive
  68           (('directory name)
  69            (mkdir-p (string-append target name)))
  70           (('directory name uid gid)
  71            (let ((dir (string-append target name)))
  72              (mkdir-p dir)
  73              (chown dir uid gid)))
  74           (('directory name uid gid mode)
  75            (loop `(directory ,name ,uid ,gid))
  76            (chmod (string-append target name) mode))
  77           ((new '-> old)
  78            (let try ()
  79              (catch 'system-error
  80                (lambda ()
  81                  (symlink old (string-append target new)))
  82                (lambda args
  83                  ;; When doing 'guix system init' on the current '/', some
  84                  ;; symlinks may already exists.  Override them.
  85                  (if (= EEXIST (system-error-errno args))
  86                      (begin
  87                        (delete-file (string-append target new))
  88                        (try))
  89                      (apply throw args))))))))
  90       (lambda args
  91         ;; Usually we can only get here when installing to an existing root,
  92         ;; as with 'guix system init foo.scm /'.
  93         (format (current-error-port)
  94                 "error: failed to evaluate directive: ~s~%"
  95                 directive)
  96         (apply throw args)))))
  97
  98 (define (directives store)
  99   "Return a list of directives to populate the root file system that will host
 100 STORE."
 101   `(;; Note: the store's GID is fixed precisely so we can set it here rather
 102     ;; than at activation time.
 103     (directory ,store 0 30000 #o1775)
 104
 105     (directory "/etc")
 106     (directory "/var/log")                          ; for dmd
 107     (directory "/var/guix/gcroots")
 108     (directory "/var/empty")                        ; for no-login accounts
 109     (directory "/var/db")                           ; for dhclient, etc.
 110     (directory "/var/run")
 111     (directory "/run")
 112     (directory "/mnt")
 113     (directory "/var/guix/profiles/per-user/root" 0 0)
 114
 115     ;; Link to the initial system generation.
 116     ("/var/guix/profiles/system" -> "system-1-link")
 117
 118     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
 119     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 120
 121     (directory "/bin")
 122     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 123     (directory "/var/tmp" 0 0 #o1777)
 124
 125     (directory "/root" 0 0)                       ; an exception
 126     (directory "/home" 0 0)))
 127
 128 (define (populate-root-file-system system target)
 129   "Make the essential non-store files and directories on TARGET.  This
 130 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
 131   (for-each (cut evaluate-populate-directive <> target)
 132             (directives (%store-directory)))
 133
 134   ;; Add system generation 1.
 135   (false-if-exception (delete-file "/var/guix/profiles/system-1-link"))
 136   (symlink system
 137            (string-append target "/var/guix/profiles/system-1-link")))
 138
 139 (define (reset-timestamps directory)
 140   "Reset the timestamps of all the files under DIRECTORY, so that they appear
 141 as created and modified at the Epoch."
 142   (display "clearing file timestamps...\n")
 143   (for-each (lambda (file)
 144               (let ((s (lstat file)))
 145                 ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
 146                 ;; the timestamp of symlinks cannot be changed, and there are
 147                 ;; symlinks here pointing to /gnu/store, which is the host,
 148                 ;; read-only store.
 149                 (unless (eq? (stat:type s) 'symlink)
 150                   (utime file 0 0 0 0))))
 151             (find-files directory "")))
 152
 153 (define (register-closure store closure)
 154   "Register CLOSURE in STORE, where STORE is the directory name of the target
 155 store and CLOSURE is the name of a file containing a reference graph as used
 156 by 'guix-register'.  As a side effect, this resets timestamps on store files."
 157   (let ((status (system* "guix-register" "--prefix" store
 158                          closure)))
 159     (unless (zero? status)
 160       (error "failed to register store items" closure))))
 161
 162 (define* (populate-single-profile-directory directory
 163                                             #:key profile closure)
 164   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 165 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 166 is initialized to contain a single profile under /root pointing to PROFILE.
 167 This is used to create the self-contained Guix tarball."
 168   (define (scope file)
 169     (string-append directory "/" file))
 170
 171   (define %root-profile
 172     "/var/guix/profiles/per-user/root")
 173
 174   (define (mkdir-p* dir)
 175     (mkdir-p (scope dir)))
 176
 177   (define (symlink* old new)
 178     (symlink old (scope new)))
 179
 180   ;; Populate the store.
 181   (populate-store (list closure) directory)
 182   (register-closure (canonicalize-path directory) closure)
 183
 184   ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
 185   ;; target uses $TMPDIR.  Fix that.
 186   (delete-file (scope "/var/guix/gcroots/profiles"))
 187   (symlink* "/var/guix/profiles"
 188             "/var/guix/gcroots/profiles")
 189
 190   ;; Make root's profile, which makes it a GC root.
 191   (mkdir-p* %root-profile)
 192   (symlink* profile
 193             (string-append %root-profile "/guix-profile-1-link"))
 194   (symlink* (string-append %root-profile "/guix-profile-1-link")
 195             (string-append %root-profile "/guix-profile"))
 196
 197   (mkdir-p* "/root")
 198   (symlink* (string-append %root-profile "/guix-profile")
 199             "/root/.guix-profile"))
 200
 201 ;;; install.scm ends here