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