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