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