summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/guix.texi7
-rw-r--r--gnu/system.scm73
-rw-r--r--gnu/system/linux-container.scm69
-rw-r--r--gnu/system/vm.scm13
4 files changed, 90 insertions, 72 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 37fef40522..7d80c00530 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10531,6 +10531,13 @@ details.
@item @code{services} (default: @var{%base-services})
A list of service objects denoting system services. @xref{Services}.
+@cindex essential services
+@item @code{essential-services} (default: ...)
+The list of ``essential services''---i.e., things like instances of
+@code{system-service-type} and @code{host-name-service-type} (@pxref{Service
+Reference}), which are derived from the operating system definition itself.
+As a user you should @emph{never} need to touch this field.
+
@item @code{pam-services} (default: @code{(base-pam-services)})
@cindex PAM
@cindex pluggable authentication modules
diff --git a/gnu/system.scm b/gnu/system.scm
index 035bbd82a1..9887d72c41 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -69,6 +69,7 @@
operating-system-bootloader
operating-system-services
+ operating-system-essential-services
operating-system-user-services
operating-system-packages
operating-system-host-name
@@ -201,6 +202,9 @@
(name-service-switch operating-system-name-service-switch ; <name-service-switch>
(default %default-nss))
+ (essential-services operating-system-essential-services ; list of services
+ (thunked)
+ (default (essential-services this-record)))
(services operating-system-user-services ; list of services
(default %base-services))
@@ -438,27 +442,22 @@ OS."
(file-append (operating-system-kernel os)
"/" (system-linux-image-file-name os)))
-(define* (operating-system-directory-base-entries os #:key container?)
+(define* (operating-system-directory-base-entries os)
"Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
(let ((locale (operating-system-locale-directory os)))
- (with-monad %store-monad
- (if container?
- (return `(("locale" ,locale)))
- (mlet %store-monad
- ((kernel -> (operating-system-kernel os))
- (initrd -> (operating-system-initrd-file os))
- (params (operating-system-boot-parameters-file os)))
- (return `(("kernel" ,kernel)
- ("parameters" ,params)
- ("initrd" ,initrd)
- ("locale" ,locale)))))))) ;used by libc
-
-(define* (essential-services os #:key container?)
+ (mlet %store-monad ((kernel -> (operating-system-kernel os))
+ (initrd -> (operating-system-initrd-file os))
+ (params (operating-system-boot-parameters-file os)))
+ (return `(("kernel" ,kernel)
+ ("parameters" ,params)
+ ("initrd" ,initrd)
+ ("locale" ,locale)))))) ;used by libc
+
+(define* (essential-services os)
"Return the list of essential services for OS. These are special services
that implement part of what's declared in OS are responsible for low-level
-bookkeeping. CONTAINER? determines whether to return the list of services for
-a container or that of a \"bare metal\" system."
+bookkeeping."
(define known-fs
(map file-system-mount-point (operating-system-file-systems os)))
@@ -468,8 +467,7 @@ a container or that of a \"bare metal\" system."
(swaps (swap-services os))
(procs (service user-processes-service-type))
(host-name (host-name-service (operating-system-host-name os)))
- (entries (operating-system-directory-base-entries
- os #:container? container?)))
+ (entries (operating-system-directory-base-entries os)))
(cons* (service system-service-type entries)
%boot-service
@@ -497,20 +495,16 @@ a container or that of a \"bare metal\" system."
other-fs
(append mappings swaps
- ;; Add the firmware service, unless we are building for a
- ;; container.
- (if container?
- (list %containerized-shepherd-service)
- (list %linux-bare-metal-service
- (service firmware-service-type
- (operating-system-firmware os))))))))
-
-(define* (operating-system-services os #:key container?)
- "Return all the services of OS, including \"internal\" services that do not
-explicitly appear in OS."
+ ;; Add the firmware service.
+ (list %linux-bare-metal-service
+ (service firmware-service-type
+ (operating-system-firmware os)))))))
+
+(define* (operating-system-services os)
+ "Return all the services of OS, including \"essential\" services."
(instantiate-missing-services
(append (operating-system-user-services os)
- (essential-services os #:container? container?))))
+ (operating-system-essential-services os))))
;;;
@@ -808,20 +802,19 @@ use 'plain-file' instead~%")
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))
-(define* (operating-system-activation-script os #:key container?)
+(define* (operating-system-activation-script os)
"Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories,
etc."
- (let* ((services (operating-system-services os #:container? container?))
+ (let* ((services (operating-system-services os))
(activation (fold-services services
#:target-type activation-service-type)))
(activation-service->script activation)))
-(define* (operating-system-boot-script os #:key container?)
+(define* (operating-system-boot-script os)
"Return the boot script for OS---i.e., the code started by the initrd once
-we're running in the final root. When CONTAINER? is true, skip all
-hardware-related operations as necessary when booting a Linux container."
- (let* ((services (operating-system-services os #:container? container?))
+we're running in the final root."
+ (let* ((services (operating-system-services os))
(boot (fold-services services #:target-type boot-service-type)))
(service-value boot)))
@@ -841,17 +834,17 @@ hardware-related operations as necessary when booting a Linux container."
#:target-type
shepherd-root-service-type))))
-(define* (operating-system-derivation os #:key container?)
+(define* (operating-system-derivation os)
"Return a derivation that builds OS."
- (let* ((services (operating-system-services os #:container? container?))
+ (let* ((services (operating-system-services os))
(system (fold-services services)))
;; SYSTEM contains the derivation as a monadic value.
(service-value system)))
-(define* (operating-system-profile os #:key container?)
+(define* (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
(mlet* %store-monad
- ((services -> (operating-system-services os #:container? container?))
+ ((services -> (operating-system-services os))
(profile (fold-services services
#:target-type profile-service-type)))
(match profile
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)))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 5068cb3068..667624621f 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -58,6 +58,7 @@
#:use-module (gnu bootloader grub)
#:use-module (gnu system shadow)
#:use-module (gnu system pam)
+ #:use-module (gnu system linux-container)
#:use-module (gnu system linux-initrd)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
@@ -473,9 +474,9 @@ should set REGISTER-CLOSURES? to #f."
(local-file (search-path %load-path
"guix/store/schema.sql"))))
- (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
- (name -> (string-append name ".tar.gz"))
- (graph -> "system-graph"))
+ (let ((os (containerized-operating-system os '()))
+ (name (string-append name ".tar.gz"))
+ (graph "system-graph"))
(define build
(with-extensions (cons guile-json ;for (guix docker)
gcrypt-sqlite3&co) ;for (guix store database)
@@ -505,7 +506,7 @@ should set REGISTER-CLOSURES? to #f."
(initialize (root-partition-initializer
#:closures '(#$graph)
#:register-closures? #$register-closures?
- #:system-directory #$os-drv
+ #:system-directory #$os
;; De-duplication would fail due to
;; cross-device link errors, so don't do it.
#:deduplicate? #f))
@@ -523,7 +524,7 @@ should set REGISTER-CLOSURES? to #f."
(call-with-input-file
(string-append "/xchg/" #$graph)
read-reference-graph)))
- #$os-drv
+ #$os
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> "")))
@@ -534,7 +535,7 @@ should set REGISTER-CLOSURES? to #f."
name build
#:make-disk-image? #f
#:single-file-output? #t
- #:references-graphs `((,graph ,os-drv)))))
+ #:references-graphs `((,graph ,os)))))
;;;
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-13 21:43:01 +0000