Commit | Line | Data |
---|---|---|
239db054 DT |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> | |
b94c80ff | 3 | ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> |
b33454ae | 4 | ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> |
239db054 DT |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (gnu system linux-container) | |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (srfi srfi-1) | |
24 | #:use-module (guix config) | |
25 | #:use-module (guix store) | |
26 | #:use-module (guix gexp) | |
27 | #:use-module (guix derivations) | |
28 | #:use-module (guix monads) | |
5e7eaccb | 29 | #:use-module (guix modules) |
239db054 | 30 | #:use-module (gnu build linux-container) |
8e5999e0 | 31 | #:use-module (gnu services) |
b94c80ff | 32 | #:use-module (gnu services base) |
b84c4cda | 33 | #:use-module (gnu services shepherd) |
239db054 DT |
34 | #:use-module (gnu system) |
35 | #:use-module (gnu system file-systems) | |
d2a5e698 | 36 | #:export (system-container |
239db054 DT |
37 | containerized-operating-system |
38 | container-script)) | |
39 | ||
b33454ae | 40 | (define* (container-essential-services os #:key shared-network?) |
69cae3d3 LC |
41 | "Return a list of essential services corresponding to OS, a |
42 | non-containerized OS. This procedure essentially strips essential services | |
43 | from OS that are needed on the bare metal and not in a container." | |
44 | (define base | |
45 | (remove (lambda (service) | |
46 | (memq (service-kind service) | |
47 | (list (service-kind %linux-bare-metal-service) | |
48 | firmware-service-type | |
49 | system-service-type))) | |
3f9bed04 | 50 | (operating-system-default-essential-services os))) |
69cae3d3 LC |
51 | |
52 | (cons (service system-service-type | |
53 | (let ((locale (operating-system-locale-directory os))) | |
54 | (with-monad %store-monad | |
55 | (return `(("locale" ,locale)))))) | |
b33454ae AI |
56 | ;; If network is to be shared with the host, remove network |
57 | ;; configuration files from etc-service. | |
58 | (if shared-network? | |
59 | (modify-services base | |
60 | (etc-service-type | |
61 | files => (remove | |
62 | (match-lambda | |
63 | ((filename _) | |
64 | (member filename | |
65 | (map basename %network-configuration-files)))) | |
66 | files))) | |
67 | base))) | |
69cae3d3 | 68 | |
b84c4cda AI |
69 | (define dummy-networking-service-type |
70 | (shepherd-service-type | |
71 | 'dummy-networking | |
72 | (const (shepherd-service | |
73 | (documentation "Provide loopback and networking without actually | |
74 | doing anything.") | |
75 | (provision '(loopback networking)) | |
76 | (start #~(const #t)))) | |
77 | #f)) | |
78 | ||
6edd5c54 LC |
79 | (define* (containerized-operating-system os mappings |
80 | #:key | |
81 | shared-network? | |
82 | (extra-file-systems '())) | |
239db054 DT |
83 | "Return an operating system based on OS for use in a Linux container |
84 | environment. MAPPINGS is a list of <file-system-mapping> to realize in the | |
6edd5c54 | 85 | containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." |
239db054 DT |
86 | (define user-file-systems |
87 | (remove (lambda (fs) | |
88 | (let ((target (file-system-mount-point fs)) | |
89 | (source (file-system-device fs))) | |
90 | (or (string=? target (%store-prefix)) | |
91 | (string=? target "/") | |
1f1ff6a0 LC |
92 | (and (string? source) |
93 | (string-prefix? "/dev/" source)) | |
76ae10a1 LC |
94 | (string-prefix? "/dev/" target) |
95 | (string-prefix? "/sys/" target)))) | |
239db054 DT |
96 | (operating-system-file-systems os))) |
97 | ||
98 | (define (mapping->fs fs) | |
d2a5e698 | 99 | (file-system (inherit (file-system-mapping->bind-mount fs)) |
239db054 DT |
100 | (needed-for-boot? #t))) |
101 | ||
b94c80ff LC |
102 | (define useless-services |
103 | ;; Services that make no sense in a container. Those that attempt to | |
104 | ;; access /dev/tty[0-9] in particular cannot work in a container. | |
b33454ae AI |
105 | (append (list console-font-service-type |
106 | mingetty-service-type | |
107 | agetty-service-type) | |
108 | ;; Remove nscd service if network is shared with the host. | |
109 | (if shared-network? | |
b84c4cda AI |
110 | (list nscd-service-type |
111 | static-networking-service-type) | |
b33454ae AI |
112 | (list)))) |
113 | ||
69cae3d3 LC |
114 | (operating-system |
115 | (inherit os) | |
239db054 | 116 | (swap-devices '()) ; disable swap |
b33454ae | 117 | (essential-services (container-essential-services |
3f9bed04 LC |
118 | this-operating-system |
119 | #:shared-network? shared-network?)) | |
b84c4cda AI |
120 | (services (append (remove (lambda (service) |
121 | (memq (service-kind service) | |
122 | useless-services)) | |
123 | (operating-system-user-services os)) | |
124 | ;; Many Guix services depend on a 'networking' shepherd | |
125 | ;; service, so make sure to provide a dummy 'networking' | |
126 | ;; service when we are sure that networking is already set up | |
127 | ;; in the host and can be used. That prevents double setup. | |
128 | (if shared-network? | |
129 | (list (service dummy-networking-service-type)) | |
130 | '()))) | |
d2928fa6 AI |
131 | (file-systems (append (map mapping->fs |
132 | (if shared-network? | |
133 | (append %network-file-mappings mappings) | |
134 | mappings)) | |
6edd5c54 | 135 | extra-file-systems |
3f9bed04 LC |
136 | user-file-systems |
137 | ||
138 | ;; Provide a dummy root file system so we can create | |
139 | ;; a 'boot-parameters' file. | |
140 | (list (file-system | |
141 | (mount-point "/") | |
142 | (device "nothing") | |
143 | (type "dummy"))))))) | |
239db054 | 144 | |
b33454ae | 145 | (define* (container-script os #:key (mappings '()) shared-network?) |
239db054 DT |
146 | "Return a derivation of a script that runs OS as a Linux container. |
147 | MAPPINGS is a list of <file-system> objects that specify the files/directories | |
148 | that will be shared with the host system." | |
d2928fa6 AI |
149 | (define nscd-run-directory "/var/run/nscd") |
150 | ||
151 | (define nscd-mapping | |
152 | (file-system-mapping | |
153 | (source nscd-run-directory) | |
154 | (target nscd-run-directory))) | |
6edd5c54 | 155 | |
3f9bed04 LC |
156 | (define (mountable-file-system? file-system) |
157 | ;; Return #t if FILE-SYSTEM should be mounted in the container. | |
158 | (and (not (string=? "/" (file-system-mount-point file-system))) | |
159 | (file-system-needed-for-boot? file-system))) | |
160 | ||
d2928fa6 AI |
161 | (define (os-file-system-specs os) |
162 | (map file-system->spec | |
163 | (filter mountable-file-system? | |
164 | (operating-system-file-systems os)))) | |
165 | ||
166 | (let* ((os (containerized-operating-system | |
167 | os (cons %store-mapping mappings) | |
168 | #:shared-network? shared-network? | |
169 | #:extra-file-systems %container-file-systems)) | |
170 | (nscd-os (containerized-operating-system | |
171 | os (cons* nscd-mapping %store-mapping mappings) | |
172 | #:shared-network? shared-network? | |
173 | #:extra-file-systems %container-file-systems)) | |
174 | (specs (os-file-system-specs os)) | |
175 | (nscd-specs (os-file-system-specs nscd-os))) | |
239db054 | 176 | |
69cae3d3 LC |
177 | (define script |
178 | (with-imported-modules (source-module-closure | |
179 | '((guix build utils) | |
180 | (gnu build linux-container))) | |
181 | #~(begin | |
182 | (use-modules (gnu build linux-container) | |
183 | (gnu system file-systems) ;spec->file-system | |
184 | (guix build utils)) | |
239db054 | 185 | |
d2928fa6 AI |
186 | (call-with-container |
187 | (map spec->file-system | |
188 | (if (and #$shared-network? | |
189 | (file-exists? #$nscd-run-directory)) | |
190 | '#$nscd-specs | |
191 | '#$specs)) | |
69cae3d3 LC |
192 | (lambda () |
193 | (setenv "HOME" "/root") | |
194 | (setenv "TMPDIR" "/tmp") | |
195 | (setenv "GUIX_NEW_SYSTEM" #$os) | |
196 | (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) | |
197 | (primitive-load (string-append #$os "/boot"))) | |
198 | ;; A range of 65536 uid/gids is used to cover 16 bits worth of | |
199 | ;; users and groups, which is sufficient for most cases. | |
200 | ;; | |
201 | ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= | |
b33454ae AI |
202 | #:host-uids 65536 |
203 | #:namespaces (if #$shared-network? | |
204 | (delq 'net %namespaces) | |
205 | %namespaces))))) | |
239db054 | 206 | |
69cae3d3 | 207 | (gexp->script "run-container" script))) |