gnu/system/linux-container.scm

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