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