[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 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; 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
                 (let ((locale (operating-system-locale-directory os)))
                   (with-monad %store-monad
                     (return `(("locale" ,locale))))))
        ;; 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))

(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 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.
    (append (list console-font-service-type
                  mingetty-service-type
                  agetty-service-type)
            ;; Remove nscd service if network is shared with the host.
            (if shared-network?
                (list nscd-service-type
                      static-networking-service-type
                      dhcp-client-service-type
                      network-manager-service-type
                      connman-service-type
                      wicd-service-type)
                (list))))

  (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)
                                      useless-services))
                              (operating-system-user-services os))
                      ;; 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))
                          '())))
    (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.
              (info (G_ "system container is running as PID ~a~%") pid)
              ;; XXX: Should we recommend 'guix container exec'?  It's more
              ;; verbose and doesn't bring much.
              (info (G_ "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>
b94c80ff	3	;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
b33454ae	4	;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
239db054 DT	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)
5e7eaccb	29	#:use-module (guix modules)
239db054	30	#:use-module (gnu build linux-container)
8e5999e0	31	#:use-module (gnu services)
b94c80ff	32	#:use-module (gnu services base)
da966a7a	33	#:use-module (gnu services networking)
b84c4cda	34	#:use-module (gnu services shepherd)
239db054 DT	35	#:use-module (gnu system)
239db054 DT	36	#:use-module (gnu system file-systems)
d2a5e698	37	#:export (system-container
239db054	38	containerized-operating-system
bacfec86 LC	39	container-script
bacfec86 LC	40	eval/container))
239db054	41
b33454ae	42	(define* (container-essential-services os #:key shared-network?)
69cae3d3 LC	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)))
3f9bed04	52	(operating-system-default-essential-services os)))
69cae3d3 LC	53
	54	(cons (service system-service-type
	55	(let ((locale (operating-system-locale-directory os)))
	56	(with-monad %store-monad
	57	(return `(("locale" ,locale))))))
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))))
	79	#f))
	80
6edd5c54 LC	81	(define* (containerized-operating-system os mappings
	82	#:key
	83	shared-network?
	84	(extra-file-systems '()))
239db054 DT	85	"Return an operating system based on OS for use in a Linux container
239db054 DT	86	environment. MAPPINGS is a list of <file-system-mapping> to realize in the
6edd5c54	87	containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
239db054 DT	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 "/")
1f1ff6a0 LC	94	(and (string? source)
1f1ff6a0 LC	95	(string-prefix? "/dev/" source))
76ae10a1 LC	96	(string-prefix? "/dev/" target)
76ae10a1 LC	97	(string-prefix? "/sys/" target))))
239db054 DT	98	(operating-system-file-systems os)))
	99
	100	(define (mapping->fs fs)
d2a5e698	101	(file-system (inherit (file-system-mapping->bind-mount fs))
239db054 DT	102	(needed-for-boot? #t)))
239db054 DT	103
b94c80ff LC	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.
b33454ae AI	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?
b84c4cda	112	(list nscd-service-type
da966a7a LC	113	static-networking-service-type
	114	dhcp-client-service-type
	115	network-manager-service-type
	116	connman-service-type
	117	wicd-service-type)
b33454ae AI	118	(list))))
b33454ae AI	119
69cae3d3 LC	120	(operating-system
69cae3d3 LC	121	(inherit os)
239db054	122	(swap-devices '()) ; disable swap
b33454ae	123	(essential-services (container-essential-services
3f9bed04 LC	124	this-operating-system
3f9bed04 LC	125	#:shared-network? shared-network?))
b84c4cda AI	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	'())))
d2928fa6 AI	137	(file-systems (append (map mapping->fs
	138	(if shared-network?
	139	(append %network-file-mappings mappings)
	140	mappings))
6edd5c54	141	extra-file-systems
3f9bed04 LC	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")))))))
239db054	150
b33454ae	151	(define* (container-script os #:key (mappings '()) shared-network?)
239db054 DT	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."
3f9bed04 LC	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
d2928fa6 AI	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))
5ccec771	169	(specs (os-file-system-specs os)))
239db054	170
69cae3d3 LC	171	(define script
	172	(with-imported-modules (source-module-closure
	173	'((guix build utils)
d236cd16 LC	174	(gnu build linux-container)
	175	(guix i18n)
	176	(guix diagnostics)))
69cae3d3 LC	177	#~(begin
	178	(use-modules (gnu build linux-container)
	179	(gnu system file-systems) ;spec->file-system
5ccec771	180	(guix build utils)
d236cd16 LC	181	(guix i18n)
d236cd16 LC	182	(guix diagnostics)
5ccec771 LC	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
d236cd16 LC	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
5ccec771	204	(call-with-container file-systems
69cae3d3 LC	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=
b33454ae AI	215	#:host-uids 65536
	216	#:namespaces (if #$shared-network?
	217	(delq 'net %namespaces)
d236cd16 LC	218	%namespaces)
d236cd16 LC	219	#:process-spawned-hook explain))))
239db054	220
69cae3d3	221	(gexp->script "run-container" script)))
bacfec86 LC	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"
96b35998 LC	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))
bacfec86 LC	267	(list "-c"
	268	(object->string
	269	(lowered-gexp-sexp lowered))))))))))))