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             install-database-and-gc-roots
  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     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 114
 115     (directory "/bin")
 116     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 117     (directory "/var/tmp" 0 0 #o1777)
 118     (directory "/var/lock" 0 0 #o1777)
 119
 120     (directory "/root" 0 0)                       ; an exception
 121     (directory "/home" 0 0)))
 122
 123 (define (populate-root-file-system system target)
 124   "Make the essential non-store files and directories on TARGET.  This
 125 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
 126   (for-each (cut evaluate-populate-directive <> target)
 127             (directives (%store-directory)))
 128
 129   ;; Add system generation 1.
 130   (let ((generation-1 (string-append target
 131                                      "/var/guix/profiles/system-1-link")))
 132     (let try ()
 133       (catch 'system-error
 134         (lambda ()
 135           (symlink system generation-1))
 136         (lambda args
 137           ;; If GENERATION-1 already exists, overwrite it.
 138           (if (= EEXIST (system-error-errno args))
 139               (begin
 140                 (delete-file generation-1)
 141                 (try))
 142               (apply throw args)))))))
 143
 144 (define %root-profile
 145   "/var/guix/profiles/per-user/root")
 146
 147 (define* (install-database-and-gc-roots root database profile
 148                                         #:key (profile-name "guix-profile"))
 149   "Install DATABASE, the store database, under directory ROOT.  Create
 150 PROFILE-NAME and have it link to PROFILE, a store item."
 151   (define (scope file)
 152     (string-append root "/" file))
 153
 154   (define (mkdir-p* dir)
 155     (mkdir-p (scope dir)))
 156
 157   (define (symlink* old new)
 158     (symlink old (scope new)))
 159
 160   (install-file database (scope "/var/guix/db/"))
 161   (chmod (scope "/var/guix/db/db.sqlite") #o644)
 162   (mkdir-p* "/var/guix/profiles")
 163   (mkdir-p* "/var/guix/gcroots")
 164   (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
 165
 166   ;; Make root's profile, which makes it a GC root.
 167   (mkdir-p* %root-profile)
 168   (symlink* profile
 169             (string-append %root-profile "/" profile-name "-1-link"))
 170   (symlink* (string-append profile-name "-1-link")
 171             (string-append %root-profile "/" profile-name)))
 172
 173 (define* (populate-single-profile-directory directory
 174                                             #:key profile closure
 175                                             (profile-name "guix-profile")
 176                                             database)
 177   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 178 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 179 is initialized to contain a single profile under /root pointing to PROFILE.
 180
 181 When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
 182 DIRECTORY/var/guix/gcroots and friends.
 183
 184 PROFILE-NAME is the name of the profile being created under
 185 /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
 186
 187 This is used to create the self-contained tarballs with 'guix pack'."
 188   (define (scope file)
 189     (string-append directory "/" file))
 190
 191   (define (mkdir-p* dir)
 192     (mkdir-p (scope dir)))
 193
 194   (define (symlink* old new)
 195     (symlink old (scope new)))
 196
 197   ;; Populate the store.
 198   (populate-store (list closure) directory)
 199
 200   (when database
 201     (install-database-and-gc-roots directory database profile
 202                                    #:profile-name profile-name))
 203
 204   (match profile-name
 205     ("guix-profile"
 206      (mkdir-p* "/root")
 207      (symlink* (string-append %root-profile "/guix-profile")
 208                "/root/.guix-profile"))
 209     ("current-guix"
 210      (mkdir-p* "/root/.config/guix")
 211      (symlink* (string-append %root-profile "/current-guix")
 212                "/root/.config/guix/current"))
 213     (_
 214      #t)))
 215
 216 ;;; install.scm ends here