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 ;;;
   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                  `(("locale" ,(operating-system-locale-directory os))))
  57         ;; If network is to be shared with the host, remove network
  58         ;; configuration files from etc-service.
  59         (if shared-network?
  60             (modify-services base
  61               (etc-service-type
  62                files => (remove
  63                          (match-lambda
  64                            ((filename _)
  65                             (member filename
  66                                     (map basename %network-configuration-files))))
  67                          files)))
  68             base)))
  69
  70 (define dummy-networking-service-type
  71   (shepherd-service-type
  72    'dummy-networking
  73    (const (shepherd-service
  74            (documentation "Provide loopback and networking without actually
  75 doing anything.")
  76            (provision '(loopback networking))
  77            (start #~(const #t))))
  78    #f))
  79
  80 (define* (containerized-operating-system os mappings
  81                                          #:key
  82                                          shared-network?
  83                                          (extra-file-systems '()))
  84   "Return an operating system based on OS for use in a Linux container
  85 environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
  86 containerized OS.  EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
  87   (define user-file-systems
  88     (remove (lambda (fs)
  89               (let ((target (file-system-mount-point fs))
  90                     (source (file-system-device fs)))
  91                 (or (string=? target (%store-prefix))
  92                     (string=? target "/")
  93                     (and (string? source)
  94                          (string-prefix? "/dev/" source))
  95                     (string-prefix? "/dev/" target)
  96                     (string-prefix? "/sys/" target))))
  97             (operating-system-file-systems os)))
  98
  99   (define (mapping->fs fs)
 100     (file-system (inherit (file-system-mapping->bind-mount fs))
 101       (needed-for-boot? #t)))
 102
 103   (define useless-services
 104     ;; Services that make no sense in a container.  Those that attempt to
 105     ;; access /dev/tty[0-9] in particular cannot work in a container.
 106     (append (list console-font-service-type
 107                   mingetty-service-type
 108                   agetty-service-type)
 109             ;; Remove nscd service if network is shared with the host.
 110             (if shared-network?
 111                 (list nscd-service-type
 112                       static-networking-service-type
 113                       dhcp-client-service-type
 114                       network-manager-service-type
 115                       connman-service-type
 116                       wicd-service-type)
 117                 (list))))
 118
 119   (operating-system
 120     (inherit os)
 121     (swap-devices '()) ; disable swap
 122     (essential-services (container-essential-services
 123                          this-operating-system
 124                          #:shared-network? shared-network?))
 125     (services (append (remove (lambda (service)
 126                                 (memq (service-kind service)
 127                                       useless-services))
 128                               (operating-system-user-services os))
 129                       ;; Many Guix services depend on a 'networking' shepherd
 130                       ;; service, so make sure to provide a dummy 'networking'
 131                       ;; service when we are sure that networking is already set up
 132                       ;; in the host and can be used.  That prevents double setup.
 133                       (if shared-network?
 134                           (list (service dummy-networking-service-type))
 135                           '())))
 136     (file-systems (append (map mapping->fs
 137                                (if shared-network?
 138                                    (append %network-file-mappings mappings)
 139                                    mappings))
 140                           extra-file-systems
 141                           user-file-systems
 142
 143                           ;; Provide a dummy root file system so we can create
 144                           ;; a 'boot-parameters' file.
 145                           (list (file-system
 146                                   (mount-point "/")
 147                                   (device "nothing")
 148                                   (type "dummy")))))))
 149
 150 (define* (container-script os #:key (mappings '()) shared-network?)
 151   "Return a derivation of a script that runs OS as a Linux container.
 152 MAPPINGS is a list of <file-system> objects that specify the files/directories
 153 that will be shared with the host system."
 154   (define (mountable-file-system? file-system)
 155     ;; Return #t if FILE-SYSTEM should be mounted in the container.
 156     (and (not (string=? "/" (file-system-mount-point file-system)))
 157          (file-system-needed-for-boot? file-system)))
 158
 159   (define (os-file-system-specs os)
 160     (map file-system->spec
 161          (filter mountable-file-system?
 162                  (operating-system-file-systems os))))
 163
 164   (let* ((os (containerized-operating-system
 165               os (cons %store-mapping mappings)
 166               #:shared-network? shared-network?
 167               #:extra-file-systems %container-file-systems))
 168          (specs (os-file-system-specs os)))
 169
 170     (define script
 171       (with-imported-modules (source-module-closure
 172                               '((guix build utils)
 173                                 (gnu build linux-container)
 174                                 (guix i18n)
 175                                 (guix diagnostics)))
 176         #~(begin
 177             (use-modules (gnu build linux-container)
 178                          (gnu system file-systems) ;spec->file-system
 179                          (guix build utils)
 180                          (guix i18n)
 181                          (guix diagnostics)
 182                          (srfi srfi-1))
 183
 184             (define file-systems
 185               (filter-map (lambda (spec)
 186                             (let* ((fs    (spec->file-system spec))
 187                                    (flags (file-system-flags fs)))
 188                               (and (or (not (memq 'bind-mount flags))
 189                                        (file-exists? (file-system-device fs)))
 190                                    fs)))
 191                           '#$specs))
 192
 193             (define (explain pid)
 194               ;; XXX: We can't quite call 'bindtextdomain' so there's actually
 195               ;; no i18n.
 196               ;; XXX: Should we really give both options? 'guix container exec'
 197               ;; is a more verbose command.  Hard to fail to enter the container
 198               ;; when we list two options.
 199               (info (G_ "system container is running as PID ~a~%") pid)
 200               (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
 201                     pid)
 202               (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
 203               (newline (guix-warning-port)))
 204
 205             (call-with-container file-systems
 206               (lambda ()
 207                 (setenv "HOME" "/root")
 208                 (setenv "TMPDIR" "/tmp")
 209                 (setenv "GUIX_NEW_SYSTEM" #$os)
 210                 (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
 211                 (primitive-load (string-append #$os "/boot")))
 212               ;; A range of 65536 uid/gids is used to cover 16 bits worth of
 213               ;; users and groups, which is sufficient for most cases.
 214               ;;
 215               ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
 216               #:host-uids 65536
 217               #:namespaces (if #$shared-network?
 218                                (delq 'net %namespaces)
 219                                %namespaces)
 220               #:process-spawned-hook explain))))
 221
 222     (gexp->script "run-container" script)))
 223
 224 (define* (eval/container exp
 225                          #:key
 226                          (mappings '())
 227                          (namespaces %namespaces))
 228   "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
 229 listed in NAMESPACES.  Add MAPPINGS, a list of <file-system-mapping>, to the
 230 set of directories visible in the process's mount namespace.  Return the
 231 process' exit status as a monadic value.
 232
 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
 241     (define items
 242       (append (append-map derivation-input-output-paths inputs)
 243               (lowered-gexp-sources lowered)))
 244
 245     (mbegin %store-monad
 246       (built-derivations inputs)
 247       (mlet %store-monad ((closure ((store-lift requisites) items)))
 248         (return (call-with-container (map file-system-mapping->bind-mount
 249                                           (append (map (lambda (item)
 250                                                          (file-system-mapping
 251                                                           (source item)
 252                                                           (target source)))
 253                                                        closure)
 254                                                   mappings))
 255                   (lambda ()
 256                     (apply execl
 257                            (string-append (derivation-input-output-path
 258                                            (lowered-gexp-guile lowered))
 259                                           "/bin/guile")
 260                            "guile"
 261                            (append (append-map (lambda (directory)
 262                                                  `("-L" ,directory))
 263                                                (lowered-gexp-load-path lowered))
 264                                    (append-map (lambda (directory)
 265                                                  `("-C" ,directory))
 266                                                (lowered-gexp-load-compiled-path
 267                                                 lowered))
 268                                    (list "-c"
 269                                          (object->string
 270                                           (lowered-gexp-sexp lowered))))))))))))