gnu/build/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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             register-closure
  29             populate-single-profile-directory))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; This module supports the installation of the GNU system on a hard disk.
  34 ;;; It is meant to be used both in a build environment (in derivations that
  35 ;;; build VM images), and on the bare metal (when really installing the
  36 ;;; system.)
  37 ;;;
  38 ;;; Code:
  39
  40 (define (install-boot-config bootcfg bootcfg-location mount-point)
  41   "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
  42 that the caller must make sure that BOOTCFG is registered as a GC root so
  43 that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  44   (let* ((target (string-append mount-point bootcfg-location))
  45          (pivot  (string-append target ".new")))
  46     (mkdir-p (dirname target))
  47
  48     ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
  49     ;; work when /boot is on a separate partition.  Do that atomically.
  50     (copy-file bootcfg pivot)
  51     (rename-file pivot target)))
  52
  53 (define (evaluate-populate-directive directive target)
  54   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  55 directory TARGET."
  56   (let loop ((directive directive))
  57     (catch 'system-error
  58       (lambda ()
  59         (match directive
  60           (('directory name)
  61            (mkdir-p (string-append target name)))
  62           (('directory name uid gid)
  63            (let ((dir (string-append target name)))
  64              (mkdir-p dir)
  65              (chown dir uid gid)))
  66           (('directory name uid gid mode)
  67            (loop `(directory ,name ,uid ,gid))
  68            (chmod (string-append target name) mode))
  69           ((new '-> old)
  70            (let try ()
  71              (catch 'system-error
  72                (lambda ()
  73                  (symlink old (string-append target new)))
  74                (lambda args
  75                  ;; When doing 'guix system init' on the current '/', some
  76                  ;; symlinks may already exists.  Override them.
  77                  (if (= EEXIST (system-error-errno args))
  78                      (begin
  79                        (delete-file (string-append target new))
  80                        (try))
  81                      (apply throw args))))))))
  82       (lambda args
  83         ;; Usually we can only get here when installing to an existing root,
  84         ;; as with 'guix system init foo.scm /'.
  85         (format (current-error-port)
  86                 "error: failed to evaluate directive: ~s~%"
  87                 directive)
  88         (apply throw args)))))
  89
  90 (define (directives store)
  91   "Return a list of directives to populate the root file system that will host
  92 STORE."
  93   `(;; Note: the store's GID is fixed precisely so we can set it here rather
  94     ;; than at activation time.
  95     (directory ,store 0 30000 #o1775)
  96
  97     (directory "/etc")
  98     (directory "/var/log")                          ; for shepherd
  99     (directory "/var/guix/gcroots")
 100     (directory "/var/empty")                        ; for no-login accounts
 101     (directory "/var/db")                           ; for dhclient, etc.
 102     (directory "/var/run")
 103     (directory "/run")
 104     (directory "/mnt")
 105     (directory "/var/guix/profiles/per-user/root" 0 0)
 106
 107     ;; Link to the initial system generation.
 108     ("/var/guix/profiles/system" -> "system-1-link")
 109
 110     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
 111     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 112     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 113
 114     (directory "/bin")
 115     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 116     (directory "/var/tmp" 0 0 #o1777)
 117     (directory "/var/lock" 0 0 #o1777)
 118
 119     (directory "/root" 0 0)                       ; an exception
 120     (directory "/home" 0 0)))
 121
 122 (define (populate-root-file-system system target)
 123   "Make the essential non-store files and directories on TARGET.  This
 124 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
 125   (for-each (cut evaluate-populate-directive <> target)
 126             (directives (%store-directory)))
 127
 128   ;; Add system generation 1.
 129   (let ((generation-1 (string-append target
 130                                      "/var/guix/profiles/system-1-link")))
 131     (let try ()
 132       (catch 'system-error
 133         (lambda ()
 134           (symlink system generation-1))
 135         (lambda args
 136           ;; If GENERATION-1 already exists, overwrite it.
 137           (if (= EEXIST (system-error-errno args))
 138               (begin
 139                 (delete-file generation-1)
 140                 (try))
 141               (apply throw args)))))))
 142
 143 (define* (populate-single-profile-directory directory
 144                                             #:key profile closure
 145                                             (profile-name "guix-profile")
 146                                             database)
 147   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 148 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 149 is initialized to contain a single profile under /root pointing to PROFILE.
 150
 151 When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
 152 DIRECTORY/var/guix/gcroots and friends.
 153
 154 PROFILE-NAME is the name of the profile being created under
 155 /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
 156
 157 This is used to create the self-contained tarballs with 'guix pack'."
 158   (define (scope file)
 159     (string-append directory "/" file))
 160
 161   (define %root-profile
 162     "/var/guix/profiles/per-user/root")
 163
 164   (define (mkdir-p* dir)
 165     (mkdir-p (scope dir)))
 166
 167   (define (symlink* old new)
 168     (symlink old (scope new)))
 169
 170   ;; Populate the store.
 171   (populate-store (list closure) directory)
 172
 173   (when database
 174     (install-file database (scope "/var/guix/db/"))
 175     (chmod (scope "/var/guix/db/db.sqlite") #o644)
 176     (mkdir-p* "/var/guix/profiles")
 177     (mkdir-p* "/var/guix/gcroots")
 178     (symlink* "/var/guix/profiles"
 179               "/var/guix/gcroots/profiles"))
 180
 181   ;; Make root's profile, which makes it a GC root.
 182   (mkdir-p* %root-profile)
 183   (symlink* profile
 184             (string-append %root-profile "/" profile-name "-1-link"))
 185   (symlink* (string-append profile-name "-1-link")
 186             (string-append %root-profile "/" profile-name))
 187
 188   (match profile-name
 189     ("guix-profile"
 190      (mkdir-p* "/root")
 191      (symlink* (string-append %root-profile "/guix-profile")
 192                "/root/.guix-profile"))
 193     ("current-guix"
 194      (mkdir-p* "/root/.config/guix")
 195      (symlink* (string-append %root-profile "/current-guix")
 196                "/root/.config/guix/current"))
 197     (_
 198      #t)))
 199
 200 ;;; install.scm ends here