system: Add 'essential-services' field to <operating-system>.
* gnu/system.scm (<operating-system>)[essential-services]: New field. (operating-system-directory-base-entries): Remove #:container? keyword and keep only the not-container branch. (essential-services): Likewise. (operating-system-services): Likewise, and call 'operating-system-essential-services' instead of 'essential-services'. (operating-system-activation-script): Remove #:container?. (operating-system-boot-script): Likewise. (operating-system-derivation): Likewise. * gnu/system/linux-container.scm (container-essential-services): New procedure. (containerized-operating-system): Use it and set the 'essential-services' field. (container-script): Remove call to 'operating-system-derivation'. * gnu/system/vm.scm (system-docker-image): Likewise. * doc/guix.texi (operating-system Reference): Document 'essential-services'.
This commit is contained in:
Ludovic Courtès
parent
cf848cc0a1
commit
69cae3d335
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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?)
|
||||
(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))))))))
|
||||
;; Add the firmware 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."
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(gexp->script "run-container" script))))
|
||||
(gexp->script "run-container" script)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Reference in New Issue