gnu/build/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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-boot-config
  26             evaluate-populate-directive
  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-boot-config bootcfg bootcfg-location mount-point)
  42   "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
  43 that the caller must make sure that BOOTCFG is registered as a GC root so
  44 that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  45   (let* ((target (string-append mount-point bootcfg-location))
  46          (pivot  (string-append target ".new")))
  47     (mkdir-p (dirname target))
  48
  49     ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
  50     ;; work when /boot is on a separate partition.  Do that atomically.
  51     (copy-file bootcfg pivot)
  52     (rename-file pivot target)))
  53
  54 (define (evaluate-populate-directive directive target)
  55   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  56 directory TARGET."
  57   (let loop ((directive directive))
  58     (catch 'system-error
  59       (lambda ()
  60         (match directive
  61           (('directory name)
  62            (mkdir-p (string-append target name)))
  63           (('directory name uid gid)
  64            (let ((dir (string-append target name)))
  65              (mkdir-p dir)
  66              (chown dir uid gid)))
  67           (('directory name uid gid mode)
  68            (loop `(directory ,name ,uid ,gid))
  69            (chmod (string-append target name) mode))
  70           ((new '-> old)
  71            (let try ()
  72              (catch 'system-error
  73                (lambda ()
  74                  (symlink old (string-append target new)))
  75                (lambda args
  76                  ;; When doing 'guix system init' on the current '/', some
  77                  ;; symlinks may already exists.  Override them.
  78                  (if (= EEXIST (system-error-errno args))
  79                      (begin
  80                        (delete-file (string-append target new))
  81                        (try))
  82                      (apply throw args))))))))
  83       (lambda args
  84         ;; Usually we can only get here when installing to an existing root,
  85         ;; as with 'guix system init foo.scm /'.
  86         (format (current-error-port)
  87                 "error: failed to evaluate directive: ~s~%"
  88                 directive)
  89         (apply throw args)))))
  90
  91 (define (directives store)
  92   "Return a list of directives to populate the root file system that will host
  93 STORE."
  94   `(;; Note: the store's GID is fixed precisely so we can set it here rather
  95     ;; than at activation time.
  96     (directory ,store 0 30000 #o1775)
  97
  98     (directory "/etc")
  99     (directory "/var/log")                          ; for shepherd
 100     (directory "/var/guix/gcroots")
 101     (directory "/var/empty")                        ; for no-login accounts
 102     (directory "/var/db")                           ; for dhclient, etc.
 103     (directory "/var/run")
 104     (directory "/run")
 105     (directory "/mnt")
 106     (directory "/var/guix/profiles/per-user/root" 0 0)
 107
 108     ;; Link to the initial system generation.
 109     ("/var/guix/profiles/system" -> "system-1-link")
 110
 111     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
 112     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 113
 114     ;; XXX: 'guix-register' creates this symlink with a wrong target, so
 115     ;; create it upfront to be sure.
 116     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 117
 118     (directory "/bin")
 119     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 120     (directory "/var/tmp" 0 0 #o1777)
 121     (directory "/var/lock" 0 0 #o1777)
 122
 123     (directory "/root" 0 0)                       ; an exception
 124     (directory "/home" 0 0)))
 125
 126 (define (populate-root-file-system system target)
 127   "Make the essential non-store files and directories on TARGET.  This
 128 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
 129   (for-each (cut evaluate-populate-directive <> target)
 130             (directives (%store-directory)))
 131
 132   ;; Add system generation 1.
 133   (let ((generation-1 (string-append target
 134                                      "/var/guix/profiles/system-1-link")))
 135     (let try ()
 136       (catch 'system-error
 137         (lambda ()
 138           (symlink system generation-1))
 139         (lambda args
 140           ;; If GENERATION-1 already exists, overwrite it.
 141           (if (= EEXIST (system-error-errno args))
 142               (begin
 143                 (delete-file generation-1)
 144                 (try))
 145               (apply throw args)))))))
 146
 147 (define (reset-timestamps directory)
 148   "Reset the timestamps of all the files under DIRECTORY, so that they appear
 149 as created and modified at the Epoch."
 150   (display "clearing file timestamps...\n")
 151   (for-each (lambda (file)
 152               (let ((s (lstat file)))
 153                 ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
 154                 ;; the timestamp of symlinks cannot be changed, and there are
 155                 ;; symlinks here pointing to /gnu/store, which is the host,
 156                 ;; read-only store.
 157                 (unless (eq? (stat:type s) 'symlink)
 158                   (utime file 0 0 0 0))))
 159             (find-files directory #:directories? #t)))
 160
 161 (define* (register-closure store closure
 162                            #:key (deduplicate? #t))
 163   "Register CLOSURE in STORE, where STORE is the directory name of the target
 164 store and CLOSURE is the name of a file containing a reference graph as used
 165 by 'guix-register'.  As a side effect, this resets timestamps on store files
 166 and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the
 167 rest of STORE."
 168   (let ((status (apply system* "guix-register" "--prefix" store
 169                        (append (if deduplicate? '() '("--no-deduplication"))
 170                                (list closure)))))
 171     (unless (zero? status)
 172       (error "failed to register store items" closure))))
 173
 174 (define* (populate-single-profile-directory directory
 175                                             #:key profile closure
 176                                             deduplicate?
 177                                             register?)
 178   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 179 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 180 is initialized to contain a single profile under /root pointing to PROFILE.
 181 When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
 182 contents of the store; DEDUPLICATE? determines whether to deduplicate files in
 183 the store.
 184
 185 This is used to create the self-contained tarballs with 'guix pack'."
 186   (define (scope file)
 187     (string-append directory "/" file))
 188
 189   (define %root-profile
 190     "/var/guix/profiles/per-user/root")
 191
 192   (define (mkdir-p* dir)
 193     (mkdir-p (scope dir)))
 194
 195   (define (symlink* old new)
 196     (symlink old (scope new)))
 197
 198   ;; Populate the store.
 199   (populate-store (list closure) directory)
 200
 201   (when register?
 202     (register-closure (canonicalize-path directory) closure
 203                       #:deduplicate? deduplicate?)
 204
 205     ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
 206     ;; target uses $TMPDIR.  Fix that.
 207     (delete-file (scope "/var/guix/gcroots/profiles"))
 208     (symlink* "/var/guix/profiles"
 209               "/var/guix/gcroots/profiles"))
 210
 211   ;; Make root's profile, which makes it a GC root.
 212   (mkdir-p* %root-profile)
 213   (symlink* profile
 214             (string-append %root-profile "/guix-profile-1-link"))
 215   (symlink* (string-append %root-profile "/guix-profile-1-link")
 216             (string-append %root-profile "/guix-profile"))
 217
 218   (mkdir-p* "/root")
 219   (symlink* (string-append %root-profile "/guix-profile")
 220             "/root/.guix-profile"))
 221
 222 ;;; install.scm ends here