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         #~(begin
 176             (use-modules (gnu build linux-container)
 177                          (gnu system file-systems) ;spec->file-system
 178                          (guix build utils)
 179                          (srfi srfi-1))
 180
 181             (define file-systems
 182               (filter-map (lambda (spec)
 183                             (let* ((fs    (spec->file-system spec))
 184                                    (flags (file-system-flags fs)))
 185                               (and (or (not (memq 'bind-mount flags))
 186                                        (file-exists? (file-system-device fs)))
 187                                    fs)))
 188                           '#$specs))
 189
 190             (call-with-container file-systems
 191               (lambda ()
 192                 (setenv "HOME" "/root")
 193                 (setenv "TMPDIR" "/tmp")
 194                 (setenv "GUIX_NEW_SYSTEM" #$os)
 195                 (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
 196                 (primitive-load (string-append #$os "/boot")))
 197               ;; A range of 65536 uid/gids is used to cover 16 bits worth of
 198               ;; users and groups, which is sufficient for most cases.
 199               ;;
 200               ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
 201               #:host-uids 65536
 202               #:namespaces (if #$shared-network?
 203                                (delq 'net %namespaces)
 204                                %namespaces)))))
 205
 206     (gexp->script "run-container" script)))
 207
 208 (define* (eval/container exp
 209                          #:key
 210                          (mappings '())
 211                          (namespaces %namespaces))
 212   "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
 213 listed in NAMESPACES.  Add MAPPINGS, a list of <file-system-mapping>, to the
 214 set of directories visible in the process's mount namespace.  Return the
 215 process' exit status as a monadic value.
 216
 217 This is useful to implement processes that, unlike derivations, are not
 218 entirely pure and need to access the outside world or to perform side
 219 effects."
 220   (mlet %store-monad ((lowered (lower-gexp exp)))
 221     (define inputs
 222       (cons (lowered-gexp-guile lowered)
 223             (lowered-gexp-inputs lowered)))
 224
 225     (define items
 226       (append (append-map derivation-input-output-paths inputs)
 227               (lowered-gexp-sources lowered)))
 228
 229     (mbegin %store-monad
 230       (built-derivations inputs)
 231       (mlet %store-monad ((closure ((store-lift requisites) items)))
 232         (return (call-with-container (map file-system-mapping->bind-mount
 233                                           (append (map (lambda (item)
 234                                                          (file-system-mapping
 235                                                           (source item)
 236                                                           (target source)))
 237                                                        closure)
 238                                                   mappings))
 239                   (lambda ()
 240                     (apply execl
 241                            (string-append (derivation-input-output-path
 242                                            (lowered-gexp-guile lowered))
 243                                           "/bin/guile")
 244                            "guile"
 245                            (append (map (lambda (directory) `("-L" ,directory))
 246                                         (lowered-gexp-load-path lowered))
 247                                    (map (lambda (directory) `("-C" ,directory))
 248                                         (lowered-gexp-load-compiled-path
 249                                          lowered))
 250                                    (list "-c"
 251                                          (object->string
 252                                           (lowered-gexp-sexp lowered))))))))))))