X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/30e12b9664d774aca3948b1fa2e0aee6af09ca40..9f2da0a0613f864aed9002950f4eaac59ae89d77:/gnu/system/linux-container.scm diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index c1e963d047..e6fd0f1315 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -1,7 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2016, 2017, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2019 Arun Isaac +;;; Copyright © 2020 Efraim Flashner +;;; Copyright © 2020 Google LLC ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,11 +32,14 @@ #:use-module (gnu build linux-container) #:use-module (gnu services) #:use-module (gnu services base) + #:use-module (gnu services networking) + #:use-module (gnu services shepherd) #:use-module (gnu system) #:use-module (gnu system file-systems) #:export (system-container containerized-operating-system - container-script)) + container-script + eval/container)) (define* (container-essential-services os #:key shared-network?) "Return a list of essential services corresponding to OS, a @@ -49,9 +54,7 @@ from OS that are needed on the bare metal and not in a container." (operating-system-default-essential-services os))) (cons (service system-service-type - (let ((locale (operating-system-locale-directory os))) - (with-monad %store-monad - (return `(("locale" ,locale)))))) + `(("locale" ,(operating-system-locale-directory os)))) ;; If network is to be shared with the host, remove network ;; configuration files from etc-service. (if shared-network? @@ -65,6 +68,28 @@ from OS that are needed on the bare metal and not in a container." files))) base))) +(define dummy-networking-service-type + (shepherd-service-type + 'dummy-networking + (const (shepherd-service + (documentation "Provide loopback and networking without actually +doing anything.") + (provision '(loopback networking)) + (start #~(const #t)))) + #f + (description "Provide loopback and networking without actually doing +anything. This service is used by guest systems running in containers, where +networking support is provided by the host."))) + +(define %nscd-container-caches + ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows + ;; many containers to coexist on the same machine without exhausting RAM. + (map (lambda (cache) + (nscd-cache + (inherit cache) + (max-database-size (expt 2 18)))) ;256KiB + %nscd-default-caches)) + (define* (containerized-operating-system os mappings #:key shared-network? @@ -88,27 +113,50 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." (file-system (inherit (file-system-mapping->bind-mount fs)) (needed-for-boot? #t))) - (define useless-services - ;; Services that make no sense in a container. Those that attempt to - ;; access /dev/tty[0-9] in particular cannot work in a container. + (define services-to-drop + ;; Service types to filter from the original operating-system. Some of + ;; these make no sense in a container (e.g., those that access + ;; /dev/tty[0-9]), while others just need to be reinstantiated with + ;; different configs that are better suited to containers. (append (list console-font-service-type mingetty-service-type - agetty-service-type) - ;; Remove nscd service if network is shared with the host. + agetty-service-type + ;; Reinstantiated below with smaller caches. + nscd-service-type) (if shared-network? - (list nscd-service-type) + ;; Replace these with dummy-networking-service-type below. + (list + static-networking-service-type + dhcp-client-service-type + network-manager-service-type + connman-service-type + wicd-service-type) (list)))) + (define services-to-add + (append + ;; Many Guix services depend on a 'networking' shepherd + ;; service, so make sure to provide a dummy 'networking' + ;; service when we are sure that networking is already set up + ;; in the host and can be used. That prevents double setup. + (if shared-network? + (list (service dummy-networking-service-type)) + '()) + (list + (nscd-service (nscd-configuration + (caches %nscd-container-caches)))))) + (operating-system (inherit os) (swap-devices '()) ; disable swap (essential-services (container-essential-services this-operating-system #:shared-network? shared-network?)) - (services (remove (lambda (service) - (memq (service-kind service) - useless-services)) - (operating-system-user-services os))) + (services (append (remove (lambda (service) + (memq (service-kind service) + services-to-drop)) + (operating-system-user-services os)) + services-to-add)) (file-systems (append (map mapping->fs (if shared-network? (append %network-file-mappings mappings) @@ -127,13 +175,6 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of objects that specify the files/directories that will be shared with the host system." - (define nscd-run-directory "/var/run/nscd") - - (define nscd-mapping - (file-system-mapping - (source nscd-run-directory) - (target nscd-run-directory))) - (define (mountable-file-system? file-system) ;; Return #t if FILE-SYSTEM should be mounted in the container. (and (not (string=? "/" (file-system-mount-point file-system))) @@ -148,28 +189,44 @@ that will be shared with the host system." os (cons %store-mapping mappings) #:shared-network? shared-network? #:extra-file-systems %container-file-systems)) - (nscd-os (containerized-operating-system - os (cons* nscd-mapping %store-mapping mappings) - #:shared-network? shared-network? - #:extra-file-systems %container-file-systems)) - (specs (os-file-system-specs os)) - (nscd-specs (os-file-system-specs nscd-os))) + (specs (os-file-system-specs os))) (define script (with-imported-modules (source-module-closure '((guix build utils) - (gnu build linux-container))) + (gnu build linux-container) + (guix i18n) + (guix diagnostics))) #~(begin (use-modules (gnu build linux-container) (gnu system file-systems) ;spec->file-system - (guix build utils)) - - (call-with-container - (map spec->file-system - (if (and #$shared-network? - (file-exists? #$nscd-run-directory)) - '#$nscd-specs - '#$specs)) + (guix build utils) + (guix i18n) + (guix diagnostics) + (srfi srfi-1)) + + (define file-systems + (filter-map (lambda (spec) + (let* ((fs (spec->file-system spec)) + (flags (file-system-flags fs))) + (and (or (not (memq 'bind-mount flags)) + (file-exists? (file-system-device fs))) + fs))) + '#$specs)) + + (define (explain pid) + ;; XXX: We can't quite call 'bindtextdomain' so there's actually + ;; no i18n. + ;; XXX: Should we really give both options? 'guix container exec' + ;; is a more verbose command. Hard to fail to enter the container + ;; when we list two options. + (info (G_ "system container is running as PID ~a~%") pid) + (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n") + pid) + (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid) + (newline (guix-warning-port))) + + (call-with-container file-systems (lambda () (setenv "HOME" "/root") (setenv "TMPDIR" "/tmp") @@ -183,6 +240,55 @@ that will be shared with the host system." #:host-uids 65536 #:namespaces (if #$shared-network? (delq 'net %namespaces) - %namespaces))))) + %namespaces) + #:process-spawned-hook explain)))) (gexp->script "run-container" script))) + +(define* (eval/container exp + #:key + (mappings '()) + (namespaces %namespaces)) + "Evaluate EXP, a gexp, in a new process executing in separate namespaces as +listed in NAMESPACES. Add MAPPINGS, a list of , to the +set of directories visible in the process's mount namespace. Return the +process' exit status as a monadic value. + +This is useful to implement processes that, unlike derivations, are not +entirely pure and need to access the outside world or to perform side +effects." + (mlet %store-monad ((lowered (lower-gexp exp))) + (define inputs + (cons (lowered-gexp-guile lowered) + (lowered-gexp-inputs lowered))) + + (define items + (append (append-map derivation-input-output-paths inputs) + (lowered-gexp-sources lowered))) + + (mbegin %store-monad + (built-derivations inputs) + (mlet %store-monad ((closure ((store-lift requisites) items))) + (return (call-with-container (map file-system-mapping->bind-mount + (append (map (lambda (item) + (file-system-mapping + (source item) + (target source))) + closure) + mappings)) + (lambda () + (apply execl + (string-append (derivation-input-output-path + (lowered-gexp-guile lowered)) + "/bin/guile") + "guile" + (append (append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + (append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-compiled-path + lowered)) + (list "-c" + (object->string + (lowered-gexp-sexp lowered))))))))))))