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-2022 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 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu system linux-container)
  25   #:use-module (ice-9 match)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (guix config)
  28   #:use-module (guix store)
  29   #:use-module (guix gexp)
  30   #:use-module (guix derivations)
  31   #:use-module (guix monads)
  32   #:use-module (guix modules)
  33   #:use-module (gnu build linux-container)
  34   #:use-module (gnu services)
  35   #:use-module (gnu services base)
  36   #:use-module (gnu services networking)
  37   #:use-module (gnu services shepherd)
  38   #:use-module (gnu system)
  39   #:use-module (gnu system file-systems)
  40   #:export (system-container
  41             containerized-operating-system
  42             container-script
  43             eval/container))
  44
  45 (define* (container-essential-services os #:key shared-network?)
  46   "Return a list of essential services corresponding to OS, a
  47 non-containerized OS.  This procedure essentially strips essential services
  48 from OS that are needed on the bare metal and not in a container."
  49   (define base
  50     (remove (lambda (service)
  51               (memq (service-kind service)
  52                     (list (service-kind %linux-bare-metal-service)
  53                           firmware-service-type
  54                           system-service-type)))
  55             (operating-system-default-essential-services os)))
  56
  57   (cons (service system-service-type
  58                  `(("locale" ,(operating-system-locale-directory os))))
  59         ;; If network is to be shared with the host, remove network
  60         ;; configuration files from etc-service.
  61         (if shared-network?
  62             (modify-services base
  63               (etc-service-type
  64                files => (remove
  65                          (match-lambda
  66                            ((filename _)
  67                             (member filename
  68                                     (map basename %network-configuration-files))))
  69                          files)))
  70             base)))
  71
  72 (define dummy-networking-service-type
  73   (shepherd-service-type
  74    'dummy-networking
  75    (const (shepherd-service
  76            (documentation "Provide loopback and networking without actually
  77 doing anything.")
  78            (provision '(loopback networking))
  79            (start #~(const #t))))
  80    #f
  81    (description "Provide loopback and networking without actually doing
  82 anything.  This service is used by guest systems running in containers, where
  83 networking support is provided by the host.")))
  84
  85 (define %nscd-container-caches
  86   ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
  87   ;; many containers to coexist on the same machine without exhausting RAM.
  88   (map (lambda (cache)
  89          (nscd-cache
  90           (inherit cache)
  91           (max-database-size (expt 2 18)))) ;256KiB
  92        %nscd-default-caches))
  93
  94 (define* (containerized-operating-system os mappings
  95                                          #:key
  96                                          shared-network?
  97                                          (extra-file-systems '()))
  98   "Return an operating system based on OS for use in a Linux container
  99 environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
 100 containerized OS.  EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
 101   (define user-file-systems
 102     (remove (lambda (fs)
 103               (let ((target (file-system-mount-point fs))
 104                     (source (file-system-device fs)))
 105                 (or (string=? target (%store-prefix))
 106                     (string=? target "/")
 107                     (and (string? source)
 108                          (string-prefix? "/dev/" source))
 109                     (string-prefix? "/dev/" target)
 110                     (string-prefix? "/sys/" target))))
 111             (operating-system-file-systems os)))
 112
 113   (define (mapping->fs fs)
 114     (file-system (inherit (file-system-mapping->bind-mount fs))
 115       (needed-for-boot? #t)))
 116
 117   (define services-to-drop
 118     ;; Service types to filter from the original operating-system. Some of
 119     ;; these make no sense in a container (e.g., those that access
 120     ;; /dev/tty[0-9]), while others just need to be reinstantiated with
 121     ;; different configs that are better suited to containers.
 122     (append (list console-font-service-type
 123                   mingetty-service-type
 124                   agetty-service-type
 125                   ;; Reinstantiated below with smaller caches.
 126                   nscd-service-type)
 127             (if shared-network?
 128                 ;; Replace these with dummy-networking-service-type below.
 129                 (list
 130                  static-networking-service-type
 131                  dhcp-client-service-type
 132                  network-manager-service-type
 133                  connman-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                          (srfi srfi-37)
 208                          (ice-9 match))
 209
 210             (define (show-help)
 211               (display (G_ "Usage: run-container [OPTION ...]
 212 Run the container with the given options."))
 213               (newline)
 214               (display (G_ "
 215       --share=SPEC       share host file system with read/write access
 216                          according to SPEC"))
 217               (display (G_ "
 218       --expose=SPEC      expose host file system directory as read-only
 219                          according to SPEC"))
 220               (newline)
 221               (display (G_ "
 222   -h, --help             display this help and exit"))
 223               (newline))
 224
 225             (define %options
 226               ;; Specifications of the command-line options.
 227               (list (option '(#\h "help") #f #f
 228                             (lambda args
 229                               (show-help)
 230                               (exit 0)))
 231                     (option '("share") #t #f
 232                             (lambda (opt name arg result)
 233                               (alist-cons 'file-system-mapping
 234                                           (specification->file-system-mapping arg #t)
 235                                           result)))
 236                     (option '("expose") #t #f
 237                             (lambda (opt name arg result)
 238                               (alist-cons 'file-system-mapping
 239                                           (specification->file-system-mapping arg #f)
 240                                           result)))))
 241
 242             (define (parse-options args options)
 243               (args-fold args options
 244                          (lambda (opt name arg . rest)
 245                            (report-error (G_ "~A: unrecognized option~%") name)
 246                            (exit 1))
 247                          (lambda (op res) (cons op res))
 248                          '()))
 249
 250             (define (explain pid)
 251               ;; XXX: We can't quite call 'bindtextdomain' so there's actually
 252               ;; no i18n.
 253               ;; XXX: Should we really give both options? 'guix container exec'
 254               ;; is a more verbose command.  Hard to fail to enter the container
 255               ;; when we list two options.
 256               (info (G_ "system container is running as PID ~a~%") pid)
 257               (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
 258                     pid)
 259               (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
 260               (newline (guix-warning-port)))
 261
 262             (let* ((opts (parse-options (cdr (command-line)) %options))
 263                    (mappings (filter-map (match-lambda
 264                                            (('file-system-mapping . mapping) mapping)
 265                                            (_ #f))
 266                                          opts))
 267                    (file-systems
 268                     (filter-map (lambda (fs)
 269                                   (let ((flags (file-system-flags fs)))
 270                                     (and (or (not (memq 'bind-mount flags))
 271                                              (file-exists? (file-system-device fs)))
 272                                          fs)))
 273                                 (append (map file-system-mapping->bind-mount mappings)
 274                                         (map spec->file-system '#$specs)))))
 275               (call-with-container file-systems
 276                 (lambda ()
 277                   (setenv "HOME" "/root")
 278                   (setenv "TMPDIR" "/tmp")
 279                   (setenv "GUIX_NEW_SYSTEM" #$os)
 280                   (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
 281                   (primitive-load (string-append #$os "/boot")))
 282                 ;; A range of 65536 uid/gids is used to cover 16 bits worth of
 283                 ;; users and groups, which is sufficient for most cases.
 284                 ;;
 285                 ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
 286                 #:host-uids 65536
 287                 #:namespaces (if #$shared-network?
 288                                  (delq 'net %namespaces)
 289                                  %namespaces)
 290                 #:process-spawned-hook explain)))))
 291
 292     (gexp->script "run-container" script)))
 293
 294 (define* (eval/container exp
 295                          #:key
 296                          (mappings '())
 297                          (namespaces %namespaces)
 298                          (guest-uid 0) (guest-gid 0))
 299   "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
 300 listed in NAMESPACES.  Add MAPPINGS, a list of <file-system-mapping>, to the
 301 set of directories visible in the process's mount namespace.  Inside the
 302 namespaces, run code as GUEST-UID and GUEST-GID.  Return the process' exit
 303 status as a monadic value.
 304
 305 This is useful to implement processes that, unlike derivations, are not
 306 entirely pure and need to access the outside world or to perform side
 307 effects."
 308   (mlet %store-monad ((lowered (lower-gexp exp)))
 309     (define inputs
 310       (cons (lowered-gexp-guile lowered)
 311             (lowered-gexp-inputs lowered)))
 312
 313     (define items
 314       (append (append-map derivation-input-output-paths inputs)
 315               (lowered-gexp-sources lowered)))
 316
 317     (mbegin %store-monad
 318       (built-derivations inputs)
 319       (mlet %store-monad ((closure ((store-lift requisites) items)))
 320         (return (call-with-container (map file-system-mapping->bind-mount
 321                                           (append (map (lambda (item)
 322                                                          (file-system-mapping
 323                                                           (source item)
 324                                                           (target source)))
 325                                                        closure)
 326                                                   mappings))
 327                   (lambda ()
 328                     (apply execl
 329                            (string-append (derivation-input-output-path
 330                                            (lowered-gexp-guile lowered))
 331                                           "/bin/guile")
 332                            "guile"
 333                            (append (append-map (lambda (directory)
 334                                                  `("-L" ,directory))
 335                                                (lowered-gexp-load-path lowered))
 336                                    (append-map (lambda (directory)
 337                                                  `("-C" ,directory))
 338                                                (lowered-gexp-load-compiled-path
 339                                                 lowered))
 340                                    (list "-c"
 341                                          (object->string
 342                                           (lowered-gexp-sexp lowered))))))
 343                   #:namespaces namespaces
 344                   #:guest-uid guest-uid
 345                   #:guest-gid guest-gid))))))