[jackhill/guix/guix.git] / gnu / system / linux-container.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Google LLC
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system linux-container)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #: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
            eval/container))

(define* (container-essential-services os #:key shared-network?)
  "Return a list of essential services corresponding to OS, a
non-containerized OS.  This procedure essentially strips essential services
from OS that are needed on the bare metal and not in a container."
  (define base
    (remove (lambda (service)
              (memq (service-kind service)
                    (list (service-kind %linux-bare-metal-service)
                          firmware-service-type
                          system-service-type)))
            (operating-system-default-essential-services os)))

  (cons (service system-service-type
                 `(("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?
            (modify-services base
              (etc-service-type
               files => (remove
                         (match-lambda
                           ((filename _)
                            (member filename
                                    (map basename %network-configuration-files))))
                         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?
                                         (extra-file-systems '()))
  "Return an operating system based on OS for use in a Linux container
environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
containerized OS.  EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
  (define user-file-systems
    (remove (lambda (fs)
              (let ((target (file-system-mount-point fs))
                    (source (file-system-device fs)))
                (or (string=? target (%store-prefix))
                    (string=? target "/")
                    (and (string? source)
                         (string-prefix? "/dev/" source))
                    (string-prefix? "/dev/" target)
                    (string-prefix? "/sys/" target))))
            (operating-system-file-systems os)))

  (define (mapping->fs fs)
    (file-system (inherit (file-system-mapping->bind-mount fs))
      (needed-for-boot? #t)))

  (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
                  ;; Reinstantiated below with smaller caches.
                  nscd-service-type)
            (if shared-network?
                ;; 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 (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)
                                   mappings))
                          extra-file-systems
                          user-file-systems

                          ;; Provide a dummy root file system so we can create
                          ;; a 'boot-parameters' file.
                          (list (file-system
                                  (mount-point "/")
                                  (device "nothing")
                                  (type "dummy")))))))

(define* (container-script os #:key (mappings '()) shared-network?)
  "Return a derivation of a script that runs OS as a Linux container.
MAPPINGS is a list of <file-system> objects that specify the files/directories
that will be shared with the host system."
  (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)))
         (file-system-needed-for-boot? file-system)))

  (define (os-file-system-specs os)
    (map file-system->spec
         (filter mountable-file-system?
                 (operating-system-file-systems os))))

  (let* ((os (containerized-operating-system
              os (cons %store-mapping mappings)
              #:shared-network? shared-network?
              #:extra-file-systems %container-file-systems))
         (specs (os-file-system-specs os)))

    (define script
      (with-imported-modules (source-module-closure
                              '((guix build utils)
                                (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)
                         (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")
                (setenv "GUIX_NEW_SYSTEM" #$os)
                (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                (primitive-load (string-append #$os "/boot")))
              ;; A range of 65536 uid/gids is used to cover 16 bits worth of
              ;; users and groups, which is sufficient for most cases.
              ;;
              ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
              #:host-uids 65536
              #:namespaces (if #$shared-network?
                               (delq 'net %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 <file-system-mapping>, 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))))))))))))
Commit	Line	Data
239db054 DT	1	;;; GNU Guix --- Functional package management for GNU
239db054 DT	2	;;; Copyright © 2015 David Thompson <davet@gnu.org>
0d22fc8d	3	;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
b33454ae	4	;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
c2771085	5	;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
5627bfe4	6	;;; Copyright © 2020 Google LLC
239db054 DT	7	;;;
	8	;;; This file is part of GNU Guix.
	9	;;;
	10	;;; GNU Guix is free software; you can redistribute it and/or modify it
	11	;;; under the terms of the GNU General Public License as published by
	12	;;; the Free Software Foundation; either version 3 of the License, or (at
	13	;;; your option) any later version.
	14	;;;
	15	;;; GNU Guix is distributed in the hope that it will be useful, but
	16	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;;; GNU General Public License for more details.
	19	;;;
	20	;;; You should have received a copy of the GNU General Public License
	21	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	22
	23	(define-module (gnu system linux-container)
	24	#:use-module (ice-9 match)
	25	#:use-module (srfi srfi-1)
	26	#:use-module (guix config)
	27	#:use-module (guix store)
	28	#:use-module (guix gexp)
	29	#:use-module (guix derivations)
	30	#:use-module (guix monads)
5e7eaccb	31	#:use-module (guix modules)
239db054	32	#:use-module (gnu build linux-container)
8e5999e0	33	#:use-module (gnu services)
b94c80ff	34	#:use-module (gnu services base)
da966a7a	35	#:use-module (gnu services networking)
b84c4cda	36	#:use-module (gnu services shepherd)
239db054 DT	37	#:use-module (gnu system)
239db054 DT	38	#:use-module (gnu system file-systems)
d2a5e698	39	#:export (system-container
239db054	40	containerized-operating-system
bacfec86 LC	41	container-script
bacfec86 LC	42	eval/container))
239db054	43
b33454ae	44	(define* (container-essential-services os #:key shared-network?)
69cae3d3 LC	45	"Return a list of essential services corresponding to OS, a
	46	non-containerized OS. This procedure essentially strips essential services
	47	from OS that are needed on the bare metal and not in a container."
	48	(define base
	49	(remove (lambda (service)
	50	(memq (service-kind service)
	51	(list (service-kind %linux-bare-metal-service)
	52	firmware-service-type
	53	system-service-type)))
3f9bed04	54	(operating-system-default-essential-services os)))
69cae3d3 LC	55
69cae3d3 LC	56	(cons (service system-service-type
0e5c2d5e	57	`(("locale" ,(operating-system-locale-directory os))))
b33454ae AI	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)))
69cae3d3	70
b84c4cda AI	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))))
0d22fc8d LC	79	#f
	80	(description "Provide loopback and networking without actually doing
	81	anything. This service is used by guest systems running in containers, where
	82	networking support is provided by the host.")))
b84c4cda	83
5627bfe4 JC	84	(define %nscd-container-caches
	85	;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
	86	;; many containers to coexist on the same machine without exhausting RAM.
	87	(map (lambda (cache)
	88	(nscd-cache
	89	(inherit cache)
	90	(max-database-size (expt 2 18)))) ;256KiB
	91	%nscd-default-caches))
	92
6edd5c54 LC	93	(define* (containerized-operating-system os mappings
	94	#:key
	95	shared-network?
	96	(extra-file-systems '()))
239db054 DT	97	"Return an operating system based on OS for use in a Linux container
239db054 DT	98	environment. MAPPINGS is a list of <file-system-mapping> to realize in the
6edd5c54	99	containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
239db054 DT	100	(define user-file-systems
	101	(remove (lambda (fs)
	102	(let ((target (file-system-mount-point fs))
	103	(source (file-system-device fs)))
	104	(or (string=? target (%store-prefix))
	105	(string=? target "/")
1f1ff6a0 LC	106	(and (string? source)
1f1ff6a0 LC	107	(string-prefix? "/dev/" source))
76ae10a1 LC	108	(string-prefix? "/dev/" target)
76ae10a1 LC	109	(string-prefix? "/sys/" target))))
239db054 DT	110	(operating-system-file-systems os)))
	111
	112	(define (mapping->fs fs)
d2a5e698	113	(file-system (inherit (file-system-mapping->bind-mount fs))
239db054 DT	114	(needed-for-boot? #t)))
239db054 DT	115
5627bfe4 JC	116	(define services-to-drop
	117	;; Service types to filter from the original operating-system. Some of
	118	;; these make no sense in a container (e.g., those that access
	119	;; /dev/tty[0-9]), while others just need to be reinstantiated with
	120	;; different configs that are better suited to containers.
b33454ae AI	121	(append (list console-font-service-type
b33454ae AI	122	mingetty-service-type
5627bfe4 JC	123	agetty-service-type
	124	;; Reinstantiated below with smaller caches.
	125	nscd-service-type)
b33454ae	126	(if shared-network?
5627bfe4 JC	127	;; Replace these with dummy-networking-service-type below.
	128	(list
	129	static-networking-service-type
	130	dhcp-client-service-type
	131	network-manager-service-type
	132	connman-service-type
	133	wicd-service-type)
b33454ae AI	134	(list))))
b33454ae AI	135
5627bfe4 JC	136	(define services-to-add
	137	(append
	138	;; Many Guix services depend on a 'networking' shepherd
	139	;; service, so make sure to provide a dummy 'networking'
	140	;; service when we are sure that networking is already set up
	141	;; in the host and can be used. That prevents double setup.
	142	(if shared-network?
	143	(list (service dummy-networking-service-type))
	144	'())
	145	(list
	146	(nscd-service (nscd-configuration
	147	(caches %nscd-container-caches))))))
	148
69cae3d3 LC	149	(operating-system
69cae3d3 LC	150	(inherit os)
239db054	151	(swap-devices '()) ; disable swap
b33454ae	152	(essential-services (container-essential-services
3f9bed04 LC	153	this-operating-system
3f9bed04 LC	154	#:shared-network? shared-network?))
b84c4cda AI	155	(services (append (remove (lambda (service)
b84c4cda AI	156	(memq (service-kind service)
5627bfe4	157	services-to-drop))
b84c4cda	158	(operating-system-user-services os))
5627bfe4	159	services-to-add))
d2928fa6 AI	160	(file-systems (append (map mapping->fs
	161	(if shared-network?
	162	(append %network-file-mappings mappings)
	163	mappings))
6edd5c54	164	extra-file-systems
3f9bed04 LC	165	user-file-systems
	166
	167	;; Provide a dummy root file system so we can create
	168	;; a 'boot-parameters' file.
	169	(list (file-system
	170	(mount-point "/")
	171	(device "nothing")
	172	(type "dummy")))))))
239db054	173
b33454ae	174	(define* (container-script os #:key (mappings '()) shared-network?)
239db054 DT	175	"Return a derivation of a script that runs OS as a Linux container.
	176	MAPPINGS is a list of <file-system> objects that specify the files/directories
	177	that will be shared with the host system."
3f9bed04 LC	178	(define (mountable-file-system? file-system)
	179	;; Return #t if FILE-SYSTEM should be mounted in the container.
	180	(and (not (string=? "/" (file-system-mount-point file-system)))
	181	(file-system-needed-for-boot? file-system)))
	182
d2928fa6 AI	183	(define (os-file-system-specs os)
	184	(map file-system->spec
	185	(filter mountable-file-system?
	186	(operating-system-file-systems os))))
	187
	188	(let* ((os (containerized-operating-system
	189	os (cons %store-mapping mappings)
	190	#:shared-network? shared-network?
	191	#:extra-file-systems %container-file-systems))
5ccec771	192	(specs (os-file-system-specs os)))
239db054	193
69cae3d3 LC	194	(define script
	195	(with-imported-modules (source-module-closure
	196	'((guix build utils)
d236cd16 LC	197	(gnu build linux-container)
	198	(guix i18n)
	199	(guix diagnostics)))
69cae3d3 LC	200	#~(begin
	201	(use-modules (gnu build linux-container)
	202	(gnu system file-systems) ;spec->file-system
5ccec771	203	(guix build utils)
d236cd16 LC	204	(guix i18n)
d236cd16 LC	205	(guix diagnostics)
5ccec771 LC	206	(srfi srfi-1))
	207
	208	(define file-systems
	209	(filter-map (lambda (spec)
	210	(let* ((fs (spec->file-system spec))
	211	(flags (file-system-flags fs)))
	212	(and (or (not (memq 'bind-mount flags))
	213	(file-exists? (file-system-device fs)))
	214	fs)))
	215	'#$specs))
	216
d236cd16 LC	217	(define (explain pid)
	218	;; XXX: We can't quite call 'bindtextdomain' so there's actually
	219	;; no i18n.
c2771085 EF	220	;; XXX: Should we really give both options? 'guix container exec'
	221	;; is a more verbose command. Hard to fail to enter the container
	222	;; when we list two options.
d236cd16	223	(info (G_ "system container is running as PID ~a~%") pid)
c2771085	224	(info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
d236cd16	225	pid)
c2771085	226	(info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
d236cd16 LC	227	(newline (guix-warning-port)))
d236cd16 LC	228
5ccec771	229	(call-with-container file-systems
69cae3d3 LC	230	(lambda ()
	231	(setenv "HOME" "/root")
	232	(setenv "TMPDIR" "/tmp")
	233	(setenv "GUIX_NEW_SYSTEM" #$os)
	234	(for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
	235	(primitive-load (string-append #$os "/boot")))
	236	;; A range of 65536 uid/gids is used to cover 16 bits worth of
	237	;; users and groups, which is sufficient for most cases.
	238	;;
	239	;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
b33454ae AI	240	#:host-uids 65536
	241	#:namespaces (if #$shared-network?
	242	(delq 'net %namespaces)
d236cd16 LC	243	%namespaces)
d236cd16 LC	244	#:process-spawned-hook explain))))
239db054	245
69cae3d3	246	(gexp->script "run-container" script)))
bacfec86 LC	247
	248	(define* (eval/container exp
	249	#:key
	250	(mappings '())
	251	(namespaces %namespaces))
	252	"Evaluate EXP, a gexp, in a new process executing in separate namespaces as
	253	listed in NAMESPACES. Add MAPPINGS, a list of <file-system-mapping>, to the
	254	set of directories visible in the process's mount namespace. Return the
	255	process' exit status as a monadic value.
	256
	257	This is useful to implement processes that, unlike derivations, are not
	258	entirely pure and need to access the outside world or to perform side
	259	effects."
	260	(mlet %store-monad ((lowered (lower-gexp exp)))
	261	(define inputs
	262	(cons (lowered-gexp-guile lowered)
	263	(lowered-gexp-inputs lowered)))
	264
	265	(define items
	266	(append (append-map derivation-input-output-paths inputs)
	267	(lowered-gexp-sources lowered)))
	268
	269	(mbegin %store-monad
	270	(built-derivations inputs)
	271	(mlet %store-monad ((closure ((store-lift requisites) items)))
	272	(return (call-with-container (map file-system-mapping->bind-mount
	273	(append (map (lambda (item)
	274	(file-system-mapping
	275	(source item)
	276	(target source)))
	277	closure)
	278	mappings))
	279	(lambda ()
	280	(apply execl
	281	(string-append (derivation-input-output-path
	282	(lowered-gexp-guile lowered))
	283	"/bin/guile")
	284	"guile"
96b35998 LC	285	(append (append-map (lambda (directory)
	286	`("-L" ,directory))
	287	(lowered-gexp-load-path lowered))
	288	(append-map (lambda (directory)
	289	`("-C" ,directory))
	290	(lowered-gexp-load-compiled-path
	291	lowered))
bacfec86 LC	292	(list "-c"
	293	(object->string
	294	(lowered-gexp-sexp lowered))))))))))))