gnu/build/install.scm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build install)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (guix build store-copy)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (install-boot-config
            evaluate-populate-directive
            populate-root-file-system
            install-database-and-gc-roots
            populate-single-profile-directory
            mount-cow-store
            unmount-cow-store))

;;; Commentary:
;;;
;;; This module supports the installation of the GNU system on a hard disk.
;;; It is meant to be used both in a build environment (in derivations that
;;; build VM images), and on the bare metal (when really installing the
;;; system.)
;;;
;;; Code:

(define (install-boot-config bootcfg bootcfg-location mount-point)
  "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
that the caller must make sure that BOOTCFG is registered as a GC root so
that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  (let* ((target (string-append mount-point bootcfg-location))
         (pivot  (string-append target ".new")))
    (mkdir-p (dirname target))

    ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
    ;; work when /boot is on a separate partition.  Do that atomically.
    (copy-file bootcfg pivot)
    (rename-file pivot target)))

(define* (evaluate-populate-directive directive target
                                      #:key
                                      (default-gid 0)
                                      (default-uid 0))
  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller.  If the directive matches those defaults then,
'chown' won't be run."
  (let loop ((directive directive))
    (catch 'system-error
      (lambda ()
        (match directive
          (('directory name)
           (mkdir-p (string-append target name)))
          (('directory name uid gid)
           (let ((dir (string-append target name)))
             (mkdir-p dir)
             ;; If called from a context without "root" permissions, "chown"
             ;; to root will fail.  In that case, do not try to run "chown"
             ;; and assume that the file will be chowned elsewhere (when
             ;; interned in the store for instance).
             (or (and (= uid default-uid) (= gid default-gid))
                 (chown dir uid gid))))
          (('directory name uid gid mode)
           (loop `(directory ,name ,uid ,gid))
           (chmod (string-append target name) mode))
          (('file name)
           (call-with-output-file (string-append target name)
             (const #t)))
          (('file name (? string? content))
           (call-with-output-file (string-append target name)
             (lambda (port)
               (display content port))))
          ((new '-> old)
           (let try ()
             (catch 'system-error
               (lambda ()
                 (symlink old (string-append target new)))
               (lambda args
                 ;; When doing 'guix system init' on the current '/', some
                 ;; symlinks may already exists.  Override them.
                 (if (= EEXIST (system-error-errno args))
                     (begin
                       (delete-file (string-append target new))
                       (try))
                     (apply throw args))))))))
      (lambda args
        ;; Usually we can only get here when installing to an existing root,
        ;; as with 'guix system init foo.scm /'.
        (format (current-error-port)
                "error: failed to evaluate directive: ~s~%"
                directive)
        (apply throw args)))))

(define (directives store)
  "Return a list of directives to populate the root file system that will host
STORE."
  `((directory ,store 0 0 #o1775)

    (directory "/etc")
    (directory "/var/log")                          ; for shepherd
    (directory "/var/guix/gcroots")
    (directory "/var/empty")                        ; for no-login accounts
    (directory "/var/db")                           ; for dhclient, etc.
    (directory "/var/run")
    (directory "/run")
    (directory "/mnt")
    (directory "/var/guix/profiles/per-user/root" 0 0)

    ;; Link to the initial system generation.
    ("/var/guix/profiles/system" -> "system-1-link")

    ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
    ("/var/guix/gcroots/current-system" -> "/run/current-system")
    ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")

    (directory "/bin")
    (directory "/tmp" 0 0 #o1777)                 ; sticky bit
    (directory "/var/tmp" 0 0 #o1777)
    (directory "/var/lock" 0 0 #o1777)

    (directory "/home" 0 0)))

(define* (populate-root-file-system system target
                                    #:key (extras '()))
  "Make the essential non-store files and directories on TARGET.  This
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate
TARGET."
  (for-each (cut evaluate-populate-directive <> target)
            (append (directives (%store-directory)) extras))

  ;; Add system generation 1.
  (let ((generation-1 (string-append target
                                     "/var/guix/profiles/system-1-link")))
    (let try ()
      (catch 'system-error
        (lambda ()
          (symlink system generation-1))
        (lambda args
          ;; If GENERATION-1 already exists, overwrite it.
          (if (= EEXIST (system-error-errno args))
              (begin
                (delete-file generation-1)
                (try))
              (apply throw args)))))))

(define %root-profile
  "/var/guix/profiles/per-user/root")

(define* (install-database-and-gc-roots root database profile
                                        #:key (profile-name "guix-profile"))
  "Install DATABASE, the store database, under directory ROOT.  Create
PROFILE-NAME and have it link to PROFILE, a store item."
  (define (scope file)
    (string-append root "/" file))

  (define (mkdir-p* dir)
    (mkdir-p (scope dir)))

  (define (symlink* old new)
    (symlink old (scope new)))

  (install-file database (scope "/var/guix/db/"))
  (chmod (scope "/var/guix/db/db.sqlite") #o644)
  (mkdir-p* "/var/guix/profiles")
  (mkdir-p* "/var/guix/gcroots")
  (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")

  ;; Make root's profile, which makes it a GC root.
  (mkdir-p* %root-profile)
  (symlink* profile
            (string-append %root-profile "/" profile-name "-1-link"))
  (symlink* (string-append profile-name "-1-link")
            (string-append %root-profile "/" profile-name)))

(define* (populate-single-profile-directory directory
                                            #:key profile closure
                                            (profile-name "guix-profile")
                                            database)
  "Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE.

When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
DIRECTORY/var/guix/gcroots and friends.

PROFILE-NAME is the name of the profile being created under
/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".

This is used to create the self-contained tarballs with 'guix pack'."
  (define (scope file)
    (string-append directory "/" file))

  (define (mkdir-p* dir)
    (mkdir-p (scope dir)))

  (define (symlink* old new)
    (symlink old (scope new)))

  ;; Populate the store.
  (populate-store (list closure) directory
                  #:deduplicate? #f)

  (when database
    (install-database-and-gc-roots directory database profile
                                   #:profile-name profile-name))

  (match profile-name
    ("guix-profile"
     (mkdir-p* "/root")
     (symlink* (string-append %root-profile "/guix-profile")
               "/root/.guix-profile"))
    ("current-guix"
     (mkdir-p* "/root/.config/guix")
     (symlink* (string-append %root-profile "/current-guix")
               "/root/.config/guix/current"))
    (_
     #t)))

(define (mount-cow-store target backing-directory)
  "Make the store copy-on-write, using TARGET as the backing store.  This is
useful when TARGET is on a hard disk, whereas the current store is on a RAM
disk."
  (define (set-store-permissions directory)
    "Set the right perms on DIRECTORY to use it as the store."
    (chown directory 0 30000)      ;use the fixed 'guixbuild' GID
    (chmod directory #o1775))

  (let ((tmpdir (string-append target "/tmp")))
    (mkdir-p tmpdir)
    (mount tmpdir "/tmp" "none" MS_BIND))

  (let* ((rw-dir (string-append target backing-directory))
         (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
    (mkdir-p rw-dir)
    (mkdir-p work-dir)
    (mkdir-p "/.rw-store")
    (set-store-permissions rw-dir)
    (set-store-permissions "/.rw-store")

    ;; Mount the overlay, then atomically make it the store.
    (mount "none" "/.rw-store" "overlay" 0
           (string-append "lowerdir=" (%store-directory) ","
                          "upperdir=" rw-dir ","
                          "workdir=" work-dir))
    (mount "/.rw-store" (%store-directory) "" MS_MOVE)
    (rmdir "/.rw-store")))

(define (unmount-cow-store target backing-directory)
  "Unmount copy-on-write store."
  (let ((tmp-dir "/remove"))
    (mkdir-p tmp-dir)
    (mount (%store-directory) tmp-dir "" MS_MOVE)
    (umount tmp-dir)
    (rmdir tmp-dir)
    (delete-file-recursively
     (string-append target backing-directory))))

;;; install.scm ends here