~droyo/guix-channel

ref: 3bfc628072a3ea8dda59cde303edd7869e30c3d9 guix-channel/aqwari/namespace.scm -rw-r--r-- 11.5 KiB
3bfc6280David Arroyo Add module and syntax for declaring mount namespaces 15 days ago
                                                                                
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
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
;; Declare and combine linux mount_namespaces(7).
;; Builds a self-contained executable that constructs an
;; anonymous namespace according to the macro's input.
(define-module (aqwari namespace)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)

  #:use-module (guix gexp)
  #:use-module (guix packages)

  #:use-module (gnu packages base)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages musl)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages commencement)

  #:export
    (namespace
     namespace?
     tmpfs))

(define-record-type <namespace>
  (make-namespace mounts)
  namespace?
  (mounts namespace-mounts))

;; A bind mount (e.g. mount --bind)
(define-record-type <bind-mount>
  (make-bind-mount target source)
  bind-mount?
  (target bind-mount-target)
  (source bind-mount-source))

;; An overlayfs union mount
(define-record-type <overlay-mount>
  (make-overlay-mount target lowerdir upperdir workdir)
  overlay-mount?
  (target   overlay-mount-target)   ;; dir to mount on
  (lowerdir overlay-mount-lowerdir) ;; ordered list of read-only dirs
  (upperdir overlay-mount-upperdir) ;; single writable directory
  (workdir  overlay-mount-workdir)) ;; writable merge dir, same fs as upperdir

;; A tmpfs mount
(define-record-type <tmpfs-mount>
  (make-tmpfs-mount target option)
  tmpfs-mount?
  (target tmpfs-mount-target)  ;; dir to mount on
  (option tmpfs-mount-option)) ;; "size=10M", etc

(define (tmpfs options)
  "Create a template for a tmpfs mount. Re-using the result in multiple binds
creates multiple distinct tmpfs file systems. OPTIONS is a comma-separated
string of key=value parameters for tmpfs(5)"
  (make-tmpfs-mount #nil options))

(define mount-file
  (match-lambda
    (($ <bind-mount>    target) target)
    (($ <overlay-mount> target) target)
    (($ <tmpfs-mount>   target) target)))

(define mount-spec
  (match-lambda
    (($ <bind-mount> _ source) source)
    (($ <overlay-mount>) "overlay")
    (($ <tmpfs-mount>) "tmpfs")))

(define mount-type
  (match-lambda
    (($ <bind-mount>) "none")
    (($ <overlay-mount>) "overlay")
    (($ <tmpfs-mount>) "tmpfs")))

(define mount-opts
  (match-lambda
    (($ <bind-mount>) "defaults,bind")
    (($ <tmpfs-mount> _ opts) opts)

    ;; upper, work, and any element of lower may be a G-expression, whose
    ;; location is not known until build-time. So we don't build the option
    ;; string yet and ship the parameters to the build-side code instead.
    (($ <overlay-mount> _ lower upper work)
     (list lower upper work))))

(define bind->mount
  ;; Parses the inputs of the (bind ...) macro in (namespace ...)
  ;; and produces the appropriate mount (tmpfs, overlay, bind, etc)
  (match-lambda*
    (((? string? target) (? string? source))
     (make-bind-mount target source))

    (((? string? target) (? gexp? source))
     (make-bind-mount target source))

    ;; This is for convenience, so users don't have to wrap each package
    ;; in a gexp. We also mount any propagated inputs, so they are present
    ;; in the resulting namespace.
    (((? string? target) (? package? pkg))
     (apply values
       (cons
         (make-bind-mount target (gexp (ungexp pkg)))
         (map
           (lambda (dep) (bind->mount target dep))
           (package-propagated-inputs pkg)))))

    ;; Matching the various formats for describing inputs
    (((? string? target) ((? string? pkgname) (? package? pkg)))
     (bind->mount target pkg))

    (((? string? target) ((? string? pkgname) (? package? pkg) (? string? output)))
     (make-bind-mount target (gexp (ungexp pkg output))))

    (((? string? target) ($ <tmpfs-mount> _ options))
     (make-tmpfs-mount target options))

    (((? string? target))
     (make-bind-mount target target))

    (((? list? targets))
     (apply values (map bind->mount targets)))

    (((? string? target) (? list? sources))
     (apply values
       (map (lambda (source) (bind->mount target source)) sources)))))

(define-syntax namespace-args
  (syntax-rules (bind include)
    ((namespace-args ()) '())

    ((namespace-args ((include ns) . rest))
     (append
       (namespace-mounts ns)
       (namespace-args rest)))

    ((namespace-args ((bind args ...) . rest))
     (append
       (call-with-values (lambda () (bind->mount args ...)) list)
       (namespace-args rest)))))

(define-syntax-rule (namespace . args)
  (make-namespace (namespace-args args)))

(define-public %namespace-minimal
  (namespace
    (bind '("/dev/" "/proc/"))
    (bind "/" (list tzdata nss-certs))))

(define (compare-mounts a b)
  ;; Push tmpfs for a directory to the head of a sequence of mounts for
  ;; the same mountpoint, because it must be mounted first if it is to
  ;; be used for an overlay mount.
  (if (tmpfs-mount? a)
      (string<= (mount-file a) (mount-file b))
      (string<  (mount-file a) (mount-file b))))

(define (collapse-mounts mounts)
  "Create union mounts for multiple binds to the same location, if possible."
  ;; The order of bindings to the same mountpoint is significant,
  ;; so stable sort is a requirement.
  (let loop ((args (stable-sort mounts compare-mounts)))
    (match args
      ('() '())

      ;; overlayfs is kind of a PITA. For writable unions, it requires
      ;; a writable dir to use as the "upperdir", where writes will go,
      ;; *AND* an empty "workdir" for temporary storage, on the same
      ;; file system as upperdir. The semantics we're supporting here is
      ;; that if a tmpfs is part of a union mount, it is used as the
      ;; upperdir and the union is made writable. To avoid polluting the
      ;; new namespace, it is mounted *outside* the namespace root, and
      ;; the `exec` helper populates it with a "work" and "upper" dir.
      ;;
      ;; Compare to the simple semantics of Plan 9's bind(1); additions to
      ;; a union directory go to the first member of the union. That's it.
      ((($ <tmpfs-mount>   mnt opts)
        ($ <bind-mount>    mnt source) . rest)
       (let* ((tmnt (string-append "/tmpfs" mnt))
              (upper (string-append (string-trim-right tmnt #\/) "/upper"))
              (work (string-append (string-trim-right tmnt #\/)  "/work"))
              (lower (list source)))
         (cons
           (make-tmpfs-mount tmnt opts)
           (loop (cons (make-overlay-mount mnt lower upper work) rest)))))

      ;; A side effect of the above is that whether or not a tmpfs is
      ;; mounted in the new namespace is determined by whether or not
      ;; it is a member of a union mount. So the build-side code must
      ;; be told explicitly whether to mount it under "root" or "tmpfs"
      ((($ <tmpfs-mount> mnt opts) . rest)
       (cons
         (make-tmpfs-mount (string-append "/root" mnt) opts)
         (loop rest)))

      ((($ <overlay-mount> mnt lower upper work)
        ($ <bind-mount>    mnt source) . rest)
       (let ((stack (append lower (list source))))
         (loop
           (cons
             (make-overlay-mount mnt stack upper work)
             rest))))

      ((($ <bind-mount> mnt dir1)
        ($ <bind-mount> mnt dir2) . rest)
       (loop
         (cons
           (make-overlay-mount mnt (list dir1 dir2) #f #f)
           rest)))

      (((= mount-file mnt) (= mount-file mnt) . rest)
       (error "don't know how to combine ~a" (take args 2)))

      ((fs . rest) (cons fs (loop rest))))))

(define-gexp-compiler
  (namespace-compiler (ns <namespace>) system target)

  (define mounts (collapse-mounts (namespace-mounts ns)))

  (define builder
    (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules
          (ice-9 popen)
          (ice-9 match)
          (srfi srfi-1)
          (srfi srfi-13)
          (guix build utils))

        (define (clean path) (string-trim-right path #\/))

        (define (overlay-opts file lowerdir . rest)
          (let ((lowerdir (append lowerdir (list (string-append #$output "/root" file)))))
            (string-join
              (map
                string-append
                (list "lowerdir=" "upperdir=" "workdir=")
                (cons
                  (string-join lowerdir ":")
                  (map
                    (lambda (dir) (string-append #$output dir))
                    (remove not rest)))) ",")))

        (define (write-exec-c-header port)
          "Write C header describing the mount namespace to PORT"
          (format port "struct fstab { ~a};~%"
            (string-join
              (cons "int upper"
                (map
                  (lambda (field) (format #f "char *~a" field))
                  '("spec" "file" "type" "opts"))) "; " 'suffix))
          (format port "const char *root = ~s;~%"
            (string-append #$output "/root"))
          (format port "const char *gnustore = ~s;~%"
            (string-append #$output "/root/gnu/store"))
          (format port "struct fstab fstab[] = {~%~a~%};~%"
            (string-join
              (map
                (match-lambda*
                  (("tmpfs" file "tmpfs" opts)
                   (format #f "	{~a, ~s, ~s, ~s, ~s}"
                     (if (string-prefix? "/root" file) 0 1)
                     "tmpfs" (string-append #$output (clean file))
                     "tmpfs" opts))

                  (("overlay" file "overlay" (lower upper work))
                   (let ((opts (overlay-opts file lower upper work)))
                     (format #f "	{0, ~s, ~s, ~s, ~s}"
                       "overlay"
                       (string-append #$output "/root" (clean file))
                       "overlay" opts)))

                  ((spec file type opts)
                   (format #f "	{0, ~s, ~s, ~s, ~s}"
                      (clean spec)
                      (string-append #$output "/root" (clean file))
                      type opts)))
                '#$(map mount-spec mounts)
                '#$(map mount-file mounts)
                '#$(map mount-type mounts)
                '#$(map mount-opts mounts)) ",\n" 'infix)))

        (define (build-exec dst)
          "Compile the `exec` binary which constructs a namespace"
          (define cc (string-append #+gcc-toolchain "/bin/gcc"))
          (define pipe
            (open-pipe* OPEN_WRITE
              cc "-mmusl" "-static"
                 "-include" "/dev/stdin"
                 (string-append "-B" #$musl "/lib")
                 (string-append "-I" #$musl "/include")
                 (string-append "-I" #$linux-libre-headers "/include")
                 (string-append "-L" #$musl "/lib")
                 (string-append "-B" #$gcc-toolchain "/bin")
                 "-o" dst
                 #$(local-file "./ns-helper.c")))

          (write-exec-c-header pipe)
          (match (status:exit-val (close-pipe pipe))
            (0 #t)
            (#f (error "cc exec failed"))
            (rc (error "cc ext status ~a" rc))))

        (define (trailing-slash? path)
          (string-suffix? "/" path))

        (define (create-empty file)
          (with-output-to-file file noop))

        (mkdir-p (string-append #$output "/root"))
        (mkdir-p (string-append #$output "/root/gnu/store"))

        (for-each
          (lambda (dir) (mkdir-p (string-append #$output dir)))
          '#$(map mount-file (filter tmpfs-mount? mounts)))

        (for-each
          (match-lambda
            ((? trailing-slash? dir)
             (mkdir-p (string-append #$output "/root" dir)))
            (file
             (mkdir-p (string-append #$output "/root" (dirname file)))
             (create-empty (string-append #$output "/root" file))))
          '#$(map mount-file (remove tmpfs-mount? mounts)))

        (build-exec (string-append #$output "/exec")))))

  (gexp->derivation "namespace" builder))