gnu/build/install.scm

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