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 syscalls)
  22   #:use-module (guix build utils)
  23   #:use-module (guix build store-copy)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (ice-9 match)
  26   #:export (install-boot-config
  27             evaluate-populate-directive
  28             populate-root-file-system
  29             install-database-and-gc-roots
  30             populate-single-profile-directory
  31             mount-cow-store
  32             unmount-cow-store))
  33
  34 ;;; Commentary:
  35 ;;;
  36 ;;; This module supports the installation of the GNU system on a hard disk.
  37 ;;; It is meant to be used both in a build environment (in derivations that
  38 ;;; build VM images), and on the bare metal (when really installing the
  39 ;;; system.)
  40 ;;;
  41 ;;; Code:
  42
  43 (define (install-boot-config bootcfg bootcfg-location mount-point)
  44   "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
  45 that the caller must make sure that BOOTCFG is registered as a GC root so
  46 that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  47   (let* ((target (string-append mount-point bootcfg-location))
  48          (pivot  (string-append target ".new")))
  49     (mkdir-p (dirname target))
  50
  51     ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
  52     ;; work when /boot is on a separate partition.  Do that atomically.
  53     (copy-file bootcfg pivot)
  54     (rename-file pivot target)))
  55
  56 (define* (evaluate-populate-directive directive target
  57                                       #:key
  58                                       (default-gid 0)
  59                                       (default-uid 0))
  60   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  61 directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
  62 the context of the caller.  If the directive matches those defaults then,
  63 'chown' won't be run."
  64   (let loop ((directive directive))
  65     (catch 'system-error
  66       (lambda ()
  67         (match directive
  68           (('directory name)
  69            (mkdir-p (string-append target name)))
  70           (('directory name uid gid)
  71            (let ((dir (string-append target name)))
  72              (mkdir-p dir)
  73              ;; If called from a context without "root" permissions, "chown"
  74              ;; to root will fail.  In that case, do not try to run "chown"
  75              ;; and assume that the file will be chowned elsewhere (when
  76              ;; interned in the store for instance).
  77              (or (and (= uid default-uid) (= gid default-gid))
  78                  (chown dir uid gid))))
  79           (('directory name uid gid mode)
  80            (loop `(directory ,name ,uid ,gid))
  81            (chmod (string-append target name) mode))
  82           (('file name)
  83            (call-with-output-file (string-append target name)
  84              (const #t)))
  85           (('file name (? string? content))
  86            (call-with-output-file (string-append target name)
  87              (lambda (port)
  88                (display content port))))
  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   `((directory ,store 0 0 #o1775)
 114
 115     (directory "/etc")
 116     (directory "/var/log")                          ; for shepherd
 117     (directory "/var/guix/gcroots")
 118     (directory "/var/empty")                        ; for no-login accounts
 119     (directory "/var/db")                           ; for dhclient, etc.
 120     (directory "/var/run")
 121     (directory "/run")
 122     (directory "/mnt")
 123     (directory "/var/guix/profiles/per-user/root" 0 0)
 124
 125     ;; Link to the initial system generation.
 126     ("/var/guix/profiles/system" -> "system-1-link")
 127
 128     ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
 129     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 130     ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
 131
 132     (directory "/bin")
 133     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 134     (directory "/var/tmp" 0 0 #o1777)
 135     (directory "/var/lock" 0 0 #o1777)
 136
 137     (directory "/home" 0 0)))
 138
 139 (define* (populate-root-file-system system target
 140                                     #:key (extras '()))
 141   "Make the essential non-store files and directories on TARGET.  This
 142 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
 143 EXTRAS is a list of directives appended to the built-in directives to populate
 144 TARGET."
 145   (for-each (cut evaluate-populate-directive <> target)
 146             (append (directives (%store-directory)) extras))
 147
 148   ;; Add system generation 1.
 149   (let ((generation-1 (string-append target
 150                                      "/var/guix/profiles/system-1-link")))
 151     (let try ()
 152       (catch 'system-error
 153         (lambda ()
 154           (symlink system generation-1))
 155         (lambda args
 156           ;; If GENERATION-1 already exists, overwrite it.
 157           (if (= EEXIST (system-error-errno args))
 158               (begin
 159                 (delete-file generation-1)
 160                 (try))
 161               (apply throw args)))))))
 162
 163 (define %root-profile
 164   "/var/guix/profiles/per-user/root")
 165
 166 (define* (install-database-and-gc-roots root database profile
 167                                         #:key (profile-name "guix-profile"))
 168   "Install DATABASE, the store database, under directory ROOT.  Create
 169 PROFILE-NAME and have it link to PROFILE, a store item."
 170   (define (scope file)
 171     (string-append root "/" file))
 172
 173   (define (mkdir-p* dir)
 174     (mkdir-p (scope dir)))
 175
 176   (define (symlink* old new)
 177     (symlink old (scope new)))
 178
 179   (install-file database (scope "/var/guix/db/"))
 180   (chmod (scope "/var/guix/db/db.sqlite") #o644)
 181   (mkdir-p* "/var/guix/profiles")
 182   (mkdir-p* "/var/guix/gcroots")
 183   (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
 184
 185   ;; Make root's profile, which makes it a GC root.
 186   (mkdir-p* %root-profile)
 187   (symlink* profile
 188             (string-append %root-profile "/" profile-name "-1-link"))
 189   (symlink* (string-append profile-name "-1-link")
 190             (string-append %root-profile "/" profile-name)))
 191
 192 (define* (populate-single-profile-directory directory
 193                                             #:key profile closure
 194                                             (profile-name "guix-profile")
 195                                             database)
 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
 200 When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
 201 DIRECTORY/var/guix/gcroots and friends.
 202
 203 PROFILE-NAME is the name of the profile being created under
 204 /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
 205
 206 This is used to create the self-contained tarballs with 'guix pack'."
 207   (define (scope file)
 208     (string-append directory "/" file))
 209
 210   (define (mkdir-p* dir)
 211     (mkdir-p (scope dir)))
 212
 213   (define (symlink* old new)
 214     (symlink old (scope new)))
 215
 216   ;; Populate the store.
 217   (populate-store (list closure) directory
 218                   #:deduplicate? #f)
 219
 220   (when database
 221     (install-database-and-gc-roots directory database profile
 222                                    #:profile-name profile-name))
 223
 224   (match profile-name
 225     ("guix-profile"
 226      (mkdir-p* "/root")
 227      (symlink* (string-append %root-profile "/guix-profile")
 228                "/root/.guix-profile"))
 229     ("current-guix"
 230      (mkdir-p* "/root/.config/guix")
 231      (symlink* (string-append %root-profile "/current-guix")
 232                "/root/.config/guix/current"))
 233     (_
 234      #t)))
 235
 236 (define (mount-cow-store target backing-directory)
 237   "Make the store copy-on-write, using TARGET as the backing store.  This is
 238 useful when TARGET is on a hard disk, whereas the current store is on a RAM
 239 disk."
 240   (define (set-store-permissions directory)
 241     "Set the right perms on DIRECTORY to use it as the store."
 242     (chown directory 0 30000)      ;use the fixed 'guixbuild' GID
 243     (chmod directory #o1775))
 244
 245   (let ((tmpdir (string-append target "/tmp")))
 246     (mkdir-p tmpdir)
 247     (mount tmpdir "/tmp" "none" MS_BIND))
 248
 249   (let* ((rw-dir (string-append target backing-directory))
 250          (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
 251     (mkdir-p rw-dir)
 252     (mkdir-p work-dir)
 253     (mkdir-p "/.rw-store")
 254     (set-store-permissions rw-dir)
 255     (set-store-permissions "/.rw-store")
 256
 257     ;; Mount the overlay, then atomically make it the store.
 258     (mount "none" "/.rw-store" "overlay" 0
 259            (string-append "lowerdir=" (%store-directory) ","
 260                           "upperdir=" rw-dir ","
 261                           "workdir=" work-dir))
 262     (mount "/.rw-store" (%store-directory) "" MS_MOVE)
 263     (rmdir "/.rw-store")))
 264
 265 (define (unmount-cow-store target backing-directory)
 266   "Unmount copy-on-write store."
 267   (let ((tmp-dir "/remove"))
 268     (mkdir-p tmp-dir)
 269     (mount (%store-directory) tmp-dir "" MS_MOVE)
 270     (umount tmp-dir)
 271     (rmdir tmp-dir)
 272     (delete-file-recursively
 273      (string-append target backing-directory))))
 274
 275 ;;; install.scm ends here