gnu/build/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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             install-database-and-gc-roots
  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                                       #:key
  55                                       (default-gid 0)
  56                                       (default-uid 0))
  57   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  58 directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
  59 the context of the caller.  If the directive matches those defaults then,
  60 'chown' won't be run."
  61   (let loop ((directive directive))
  62     (catch 'system-error
  63       (lambda ()
  64         (match directive
  65           (('directory name)
  66            (mkdir-p (string-append target name)))
  67           (('directory name uid gid)
  68            (let ((dir (string-append target name)))
  69              (mkdir-p dir)
  70              ;; If called from a context without "root" permissions, "chown"
  71              ;; to root will fail.  In that case, do not try to run "chown"
  72              ;; and assume that the file will be chowned elsewhere (when
  73              ;; interned in the store for instance).
  74              (or (and (= uid default-uid) (= gid default-gid))
  75                  (chown dir uid gid))))
  76           (('directory name uid gid mode)
  77            (loop `(directory ,name ,uid ,gid))
  78            (chmod (string-append target name) mode))
  79           (('file name)
  80            (call-with-output-file (string-append target name)
  81              (const #t)))
  82           (('file name (? string? content))
  83            (call-with-output-file (string-append target name)
  84              (lambda (port)
  85                (display content port))))
  86           ((new '-> old)
  87            (let try ()
  88              (catch 'system-error
  89                (lambda ()
  90                  (symlink old (string-append target new)))
  91                (lambda args
  92                  ;; When doing 'guix system init' on the current '/', some
  93                  ;; symlinks may already exists.  Override them.
  94                  (if (= EEXIST (system-error-errno args))
  95                      (begin
  96                        (delete-file (string-append target new))
  97                        (try))
  98                      (apply throw args))))))))
  99       (lambda args
 100         ;; Usually we can only get here when installing to an existing root,
 101         ;; as with 'guix system init foo.scm /'.
 102         (format (current-error-port)
 103                 "error: failed to evaluate directive: ~s~%"
 104                 directive)
 105         (apply throw args)))))
 106
 107 (define (directives store)
 108   "Return a list of directives to populate the root file system that will host
 109 STORE."
 110   `((directory ,store 0 0 #o1775)
 111
 112     (directory "/etc")
 113     (directory "/var/log")                          ; for shepherd
 114     (directory "/var/guix/gcroots")
 115     (directory "/var/empty")                        ; for no-login accounts
 116     (directory "/var/db")                           ; for dhclient, etc.
 117     (directory "/var/run")
 118     (directory "/run")
 119     (directory "/mnt")
 120     (directory "/var/guix/profiles/per-user/root" 0 0)
 121
 122     ;; Link to the initial system generation.
 123     ("/var/guix/profiles/system" -> "system-1-link")
 124
 125     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
 126     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 127     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 128
 129     (directory "/bin")
 130     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 131     (directory "/var/tmp" 0 0 #o1777)
 132     (directory "/var/lock" 0 0 #o1777)
 133
 134     (directory "/home" 0 0)))
 135
 136 (define* (populate-root-file-system system target
 137                                     #:key (extras '()))
 138   "Make the essential non-store files and directories on TARGET.  This
 139 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
 140 EXTRAS is a list of directives appended to the built-in directives to populate
 141 TARGET."
 142   (for-each (cut evaluate-populate-directive <> target)
 143             (append (directives (%store-directory)) extras))
 144
 145   ;; Add system generation 1.
 146   (let ((generation-1 (string-append target
 147                                      "/var/guix/profiles/system-1-link")))
 148     (let try ()
 149       (catch 'system-error
 150         (lambda ()
 151           (symlink system generation-1))
 152         (lambda args
 153           ;; If GENERATION-1 already exists, overwrite it.
 154           (if (= EEXIST (system-error-errno args))
 155               (begin
 156                 (delete-file generation-1)
 157                 (try))
 158               (apply throw args)))))))
 159
 160 (define %root-profile
 161   "/var/guix/profiles/per-user/root")
 162
 163 (define* (install-database-and-gc-roots root database profile
 164                                         #:key (profile-name "guix-profile"))
 165   "Install DATABASE, the store database, under directory ROOT.  Create
 166 PROFILE-NAME and have it link to PROFILE, a store item."
 167   (define (scope file)
 168     (string-append root "/" file))
 169
 170   (define (mkdir-p* dir)
 171     (mkdir-p (scope dir)))
 172
 173   (define (symlink* old new)
 174     (symlink old (scope new)))
 175
 176   (install-file database (scope "/var/guix/db/"))
 177   (chmod (scope "/var/guix/db/db.sqlite") #o644)
 178   (mkdir-p* "/var/guix/profiles")
 179   (mkdir-p* "/var/guix/gcroots")
 180   (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
 181
 182   ;; Make root's profile, which makes it a GC root.
 183   (mkdir-p* %root-profile)
 184   (symlink* profile
 185             (string-append %root-profile "/" profile-name "-1-link"))
 186   (symlink* (string-append profile-name "-1-link")
 187             (string-append %root-profile "/" profile-name)))
 188
 189 (define* (populate-single-profile-directory directory
 190                                             #:key profile closure
 191                                             (profile-name "guix-profile")
 192                                             database)
 193   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 194 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 195 is initialized to contain a single profile under /root pointing to PROFILE.
 196
 197 When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
 198 DIRECTORY/var/guix/gcroots and friends.
 199
 200 PROFILE-NAME is the name of the profile being created under
 201 /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
 202
 203 This is used to create the self-contained tarballs with 'guix pack'."
 204   (define (scope file)
 205     (string-append directory "/" file))
 206
 207   (define (mkdir-p* dir)
 208     (mkdir-p (scope dir)))
 209
 210   (define (symlink* old new)
 211     (symlink old (scope new)))
 212
 213   ;; Populate the store.
 214   (populate-store (list closure) directory)
 215
 216   (when database
 217     (install-database-and-gc-roots directory database profile
 218                                    #:profile-name profile-name))
 219
 220   (match profile-name
 221     ("guix-profile"
 222      (mkdir-p* "/root")
 223      (symlink* (string-append %root-profile "/guix-profile")
 224                "/root/.guix-profile"))
 225     ("current-guix"
 226      (mkdir-p* "/root/.config/guix")
 227      (symlink* (string-append %root-profile "/current-guix")
 228                "/root/.config/guix/current"))
 229     (_
 230      #t)))
 231
 232 ;;; install.scm ends here