summaryrefslogtreecommitdiff
path: root/gnu/system/linux-container.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/linux-container.scm')
-rw-r--r--gnu/system/linux-container.scm69
1 files changed, 43 insertions, 26 deletions
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 3fe3482d7f..37a053cdc3 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -29,12 +29,31 @@
#:use-module (gnu build linux-container)
#:use-module (gnu services)
#:use-module (gnu services base)
+ #:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:export (system-container
containerized-operating-system
container-script))
+(define (container-essential-services os)
+ "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-essential-services os)))
+
+ (cons (service system-service-type
+ (let ((locale (operating-system-locale-directory os)))
+ (with-monad %store-monad
+ (return `(("locale" ,locale))))))
+ (append base (list %containerized-shepherd-service))))
+
(define (containerized-operating-system os mappings)
"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
@@ -62,8 +81,10 @@ containerized OS."
mingetty-service-type
agetty-service-type))
- (operating-system (inherit os)
+ (operating-system
+ (inherit os)
(swap-devices '()) ; disable swap
+ (essential-services (container-essential-services os))
(services (remove (lambda (service)
(memq (service-kind service)
useless-services))
@@ -81,30 +102,26 @@ that will be shared with the host system."
(operating-system-file-systems os)))
(specs (map file-system->spec file-systems)))
- (mlet* %store-monad ((os-drv (operating-system-derivation
- os
- #:container? #t)))
-
- (define script
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (gnu build linux-container)))
- #~(begin
- (use-modules (gnu build linux-container)
- (gnu system file-systems) ;spec->file-system
- (guix build utils))
+ (define script
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (gnu build linux-container)))
+ #~(begin
+ (use-modules (gnu build linux-container)
+ (gnu system file-systems) ;spec->file-system
+ (guix build utils))
- (call-with-container (map spec->file-system '#$specs)
- (lambda ()
- (setenv "HOME" "/root")
- (setenv "TMPDIR" "/tmp")
- (setenv "GUIX_NEW_SYSTEM" #$os-drv)
- (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
- (primitive-load (string-append #$os-drv "/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))))
+ (call-with-container (map spec->file-system '#$specs)
+ (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))))
- (gexp->script "run-container" script))))
+ (gexp->script "run-container" script)))