linux-container.scm 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015 David Thompson <davet@gnu.org>
  3. ;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  4. ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
  5. ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
  6. ;;; Copyright © 2020 Google LLC
  7. ;;;
  8. ;;; This file is part of GNU Guix.
  9. ;;;
  10. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11. ;;; under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 3 of the License, or (at
  13. ;;; your option) any later version.
  14. ;;;
  15. ;;; GNU Guix is distributed in the hope that it will be useful, but
  16. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;;; GNU General Public License for more details.
  19. ;;;
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  22. (define-module (gnu system linux-container)
  23. #:use-module (ice-9 match)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (guix config)
  26. #:use-module (guix store)
  27. #:use-module (guix gexp)
  28. #:use-module (guix derivations)
  29. #:use-module (guix monads)
  30. #:use-module (guix modules)
  31. #:use-module (gnu build linux-container)
  32. #:use-module (gnu services)
  33. #:use-module (gnu services base)
  34. #:use-module (gnu services networking)
  35. #:use-module (gnu services shepherd)
  36. #:use-module (gnu system)
  37. #:use-module (gnu system file-systems)
  38. #:export (system-container
  39. containerized-operating-system
  40. container-script
  41. eval/container))
  42. (define* (container-essential-services os #:key shared-network?)
  43. "Return a list of essential services corresponding to OS, a
  44. non-containerized OS. This procedure essentially strips essential services
  45. from OS that are needed on the bare metal and not in a container."
  46. (define base
  47. (remove (lambda (service)
  48. (memq (service-kind service)
  49. (list (service-kind %linux-bare-metal-service)
  50. firmware-service-type
  51. system-service-type)))
  52. (operating-system-default-essential-services os)))
  53. (cons (service system-service-type
  54. `(("locale" ,(operating-system-locale-directory os))))
  55. ;; If network is to be shared with the host, remove network
  56. ;; configuration files from etc-service.
  57. (if shared-network?
  58. (modify-services base
  59. (etc-service-type
  60. files => (remove
  61. (match-lambda
  62. ((filename _)
  63. (member filename
  64. (map basename %network-configuration-files))))
  65. files)))
  66. base)))
  67. (define dummy-networking-service-type
  68. (shepherd-service-type
  69. 'dummy-networking
  70. (const (shepherd-service
  71. (documentation "Provide loopback and networking without actually
  72. doing anything.")
  73. (provision '(loopback networking))
  74. (start #~(const #t))))
  75. #f))
  76. (define %nscd-container-caches
  77. ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
  78. ;; many containers to coexist on the same machine without exhausting RAM.
  79. (map (lambda (cache)
  80. (nscd-cache
  81. (inherit cache)
  82. (max-database-size (expt 2 18)))) ;256KiB
  83. %nscd-default-caches))
  84. (define* (containerized-operating-system os mappings
  85. #:key
  86. shared-network?
  87. (extra-file-systems '()))
  88. "Return an operating system based on OS for use in a Linux container
  89. environment. MAPPINGS is a list of <file-system-mapping> to realize in the
  90. containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
  91. (define user-file-systems
  92. (remove (lambda (fs)
  93. (let ((target (file-system-mount-point fs))
  94. (source (file-system-device fs)))
  95. (or (string=? target (%store-prefix))
  96. (string=? target "/")
  97. (and (string? source)
  98. (string-prefix? "/dev/" source))
  99. (string-prefix? "/dev/" target)
  100. (string-prefix? "/sys/" target))))
  101. (operating-system-file-systems os)))
  102. (define (mapping->fs fs)
  103. (file-system (inherit (file-system-mapping->bind-mount fs))
  104. (needed-for-boot? #t)))
  105. (define services-to-drop
  106. ;; Service types to filter from the original operating-system. Some of
  107. ;; these make no sense in a container (e.g., those that access
  108. ;; /dev/tty[0-9]), while others just need to be reinstantiated with
  109. ;; different configs that are better suited to containers.
  110. (append (list console-font-service-type
  111. mingetty-service-type
  112. agetty-service-type
  113. ;; Reinstantiated below with smaller caches.
  114. nscd-service-type)
  115. (if shared-network?
  116. ;; Replace these with dummy-networking-service-type below.
  117. (list
  118. static-networking-service-type
  119. dhcp-client-service-type
  120. network-manager-service-type
  121. connman-service-type
  122. wicd-service-type)
  123. (list))))
  124. (define services-to-add
  125. (append
  126. ;; Many Guix services depend on a 'networking' shepherd
  127. ;; service, so make sure to provide a dummy 'networking'
  128. ;; service when we are sure that networking is already set up
  129. ;; in the host and can be used. That prevents double setup.
  130. (if shared-network?
  131. (list (service dummy-networking-service-type))
  132. '())
  133. (list
  134. (nscd-service (nscd-configuration
  135. (caches %nscd-container-caches))))))
  136. (operating-system
  137. (inherit os)
  138. (swap-devices '()) ; disable swap
  139. (essential-services (container-essential-services
  140. this-operating-system
  141. #:shared-network? shared-network?))
  142. (services (append (remove (lambda (service)
  143. (memq (service-kind service)
  144. services-to-drop))
  145. (operating-system-user-services os))
  146. services-to-add))
  147. (file-systems (append (map mapping->fs
  148. (if shared-network?
  149. (append %network-file-mappings mappings)
  150. mappings))
  151. extra-file-systems
  152. user-file-systems
  153. ;; Provide a dummy root file system so we can create
  154. ;; a 'boot-parameters' file.
  155. (list (file-system
  156. (mount-point "/")
  157. (device "nothing")
  158. (type "dummy")))))))
  159. (define* (container-script os #:key (mappings '()) shared-network?)
  160. "Return a derivation of a script that runs OS as a Linux container.
  161. MAPPINGS is a list of <file-system> objects that specify the files/directories
  162. that will be shared with the host system."
  163. (define (mountable-file-system? file-system)
  164. ;; Return #t if FILE-SYSTEM should be mounted in the container.
  165. (and (not (string=? "/" (file-system-mount-point file-system)))
  166. (file-system-needed-for-boot? file-system)))
  167. (define (os-file-system-specs os)
  168. (map file-system->spec
  169. (filter mountable-file-system?
  170. (operating-system-file-systems os))))
  171. (let* ((os (containerized-operating-system
  172. os (cons %store-mapping mappings)
  173. #:shared-network? shared-network?
  174. #:extra-file-systems %container-file-systems))
  175. (specs (os-file-system-specs os)))
  176. (define script
  177. (with-imported-modules (source-module-closure
  178. '((guix build utils)
  179. (gnu build linux-container)
  180. (guix i18n)
  181. (guix diagnostics)))
  182. #~(begin
  183. (use-modules (gnu build linux-container)
  184. (gnu system file-systems) ;spec->file-system
  185. (guix build utils)
  186. (guix i18n)
  187. (guix diagnostics)
  188. (srfi srfi-1))
  189. (define file-systems
  190. (filter-map (lambda (spec)
  191. (let* ((fs (spec->file-system spec))
  192. (flags (file-system-flags fs)))
  193. (and (or (not (memq 'bind-mount flags))
  194. (file-exists? (file-system-device fs)))
  195. fs)))
  196. '#$specs))
  197. (define (explain pid)
  198. ;; XXX: We can't quite call 'bindtextdomain' so there's actually
  199. ;; no i18n.
  200. ;; XXX: Should we really give both options? 'guix container exec'
  201. ;; is a more verbose command. Hard to fail to enter the container
  202. ;; when we list two options.
  203. (info (G_ "system container is running as PID ~a~%") pid)
  204. (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
  205. pid)
  206. (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
  207. (newline (guix-warning-port)))
  208. (call-with-container file-systems
  209. (lambda ()
  210. (setenv "HOME" "/root")
  211. (setenv "TMPDIR" "/tmp")
  212. (setenv "GUIX_NEW_SYSTEM" #$os)
  213. (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
  214. (primitive-load (string-append #$os "/boot")))
  215. ;; A range of 65536 uid/gids is used to cover 16 bits worth of
  216. ;; users and groups, which is sufficient for most cases.
  217. ;;
  218. ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
  219. #:host-uids 65536
  220. #:namespaces (if #$shared-network?
  221. (delq 'net %namespaces)
  222. %namespaces)
  223. #:process-spawned-hook explain))))
  224. (gexp->script "run-container" script)))
  225. (define* (eval/container exp
  226. #:key
  227. (mappings '())
  228. (namespaces %namespaces))
  229. "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
  230. listed in NAMESPACES. Add MAPPINGS, a list of <file-system-mapping>, to the
  231. set of directories visible in the process's mount namespace. Return the
  232. process' exit status as a monadic value.
  233. This is useful to implement processes that, unlike derivations, are not
  234. entirely pure and need to access the outside world or to perform side
  235. effects."
  236. (mlet %store-monad ((lowered (lower-gexp exp)))
  237. (define inputs
  238. (cons (lowered-gexp-guile lowered)
  239. (lowered-gexp-inputs lowered)))
  240. (define items
  241. (append (append-map derivation-input-output-paths inputs)
  242. (lowered-gexp-sources lowered)))
  243. (mbegin %store-monad
  244. (built-derivations inputs)
  245. (mlet %store-monad ((closure ((store-lift requisites) items)))
  246. (return (call-with-container (map file-system-mapping->bind-mount
  247. (append (map (lambda (item)
  248. (file-system-mapping
  249. (source item)
  250. (target source)))
  251. closure)
  252. mappings))
  253. (lambda ()
  254. (apply execl
  255. (string-append (derivation-input-output-path
  256. (lowered-gexp-guile lowered))
  257. "/bin/guile")
  258. "guile"
  259. (append (append-map (lambda (directory)
  260. `("-L" ,directory))
  261. (lowered-gexp-load-path lowered))
  262. (append-map (lambda (directory)
  263. `("-C" ,directory))
  264. (lowered-gexp-load-compiled-path
  265. lowered))
  266. (list "-c"
  267. (object->string
  268. (lowered-gexp-sexp lowered))))))))))))