nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2019-03-22 17:48:37 +01:00
parent cf848cc0a1
commit 69cae3d335
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 88 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
doc/guix.texi
View File

@ -10531,6 +10531,13 @@ details.
@item @code{services} (default: @var{%base-services}) @item @code{services} (default: @var{%base-services})
A list of service objects denoting system services. @xref{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)}) @item @code{pam-services} (default: @code{(base-pam-services)})
@cindex PAM @cindex PAM
@cindex pluggable authentication modules @cindex pluggable authentication modules

69
gnu/system.scm
View File

@ -69,6 +69,7 @@
operating-system-bootloader operating-system-bootloader
operating-system-services operating-system-services
operating-system-essential-services
operating-system-user-services operating-system-user-services
operating-system-packages operating-system-packages
operating-system-host-name operating-system-host-name
@ -201,6 +202,9 @@
(name-service-switch operating-system-name-service-switch ; <name-service-switch> (name-service-switch operating-system-name-service-switch ; <name-service-switch>
(default %default-nss)) (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 (services operating-system-user-services ; list of services
(default %base-services)) (default %base-services))
@ -438,27 +442,22 @@ OS."
(file-append (operating-system-kernel os) (file-append (operating-system-kernel os)
"/" (system-linux-image-file-name 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 "Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service." value of the SYSTEM-SERVICE-TYPE service."
(let ((locale (operating-system-locale-directory os))) (let ((locale (operating-system-locale-directory os)))
(with-monad %store-monad (mlet %store-monad ((kernel -> (operating-system-kernel os))
(if container? (initrd -> (operating-system-initrd-file os))
(return `(("locale" ,locale))) (params (operating-system-boot-parameters-file os)))
(mlet %store-monad (return `(("kernel" ,kernel)
((kernel -> (operating-system-kernel os)) ("parameters" ,params)
(initrd -> (operating-system-initrd-file os)) ("initrd" ,initrd)
(params (operating-system-boot-parameters-file os))) ("locale" ,locale)))))) ;used by libc
(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 "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 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 bookkeeping."
a container or that of a \"bare metal\" system."
(define known-fs (define known-fs
(map file-system-mount-point (operating-system-file-systems os))) (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)) (swaps (swap-services os))
(procs (service user-processes-service-type)) (procs (service user-processes-service-type))
(host-name (host-name-service (operating-system-host-name os))) (host-name (host-name-service (operating-system-host-name os)))
(entries (operating-system-directory-base-entries (entries (operating-system-directory-base-entries os)))
os #:container? container?)))
(cons* (service system-service-type entries) (cons* (service system-service-type entries)
%boot-service %boot-service
@ -497,20 +495,16 @@ a container or that of a \"bare metal\" system."
other-fs other-fs
(append mappings swaps (append mappings swaps
;; Add the firmware service, unless we are building for a ;; Add the firmware service.
;; container. (list %linux-bare-metal-service
(if container? (service firmware-service-type
(list %containerized-shepherd-service) (operating-system-firmware os)))))))
(list %linux-bare-metal-service
(service firmware-service-type
(operating-system-firmware os))))))))
(define* (operating-system-services os #:key container?) (define* (operating-system-services os)
"Return all the services of OS, including \"internal\" services that do not "Return all the services of OS, including \"essential\" services."
explicitly appear in OS."
(instantiate-missing-services (instantiate-missing-services
(append (operating-system-user-services os) (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 root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n")) %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 "Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories, stateful part of OS, including user accounts and groups, special directories,
etc." etc."
(let* ((services (operating-system-services os #:container? container?)) (let* ((services (operating-system-services os))
(activation (fold-services services (activation (fold-services services
#:target-type activation-service-type))) #:target-type activation-service-type)))
(activation-service->script activation))) (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 "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 we're running in the final root."
hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os))
(let* ((services (operating-system-services os #:container? container?))
(boot (fold-services services #:target-type boot-service-type))) (boot (fold-services services #:target-type boot-service-type)))
(service-value boot))) (service-value boot)))
@ -841,17 +834,17 @@ hardware-related operations as necessary when booting a Linux container."
#:target-type #:target-type
shepherd-root-service-type)))) shepherd-root-service-type))))
(define* (operating-system-derivation os #:key container?) (define* (operating-system-derivation os)
"Return a derivation that builds 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 (fold-services services)))
;; SYSTEM contains the derivation as a monadic value. ;; SYSTEM contains the derivation as a monadic value.
(service-value system))) (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." "Return a derivation that builds the system profile of OS."
(mlet* %store-monad (mlet* %store-monad
((services -> (operating-system-services os #:container? container?)) ((services -> (operating-system-services os))
(profile (fold-services services (profile (fold-services services
#:target-type profile-service-type))) #:target-type profile-service-type)))
(match profile (match profile

69
gnu/system/linux-container.scm
View File

@ -29,12 +29,31 @@
#:use-module (gnu build linux-container) #:use-module (gnu build linux-container)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu services shepherd)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:export (system-container #:export (system-container
containerized-operating-system containerized-operating-system
container-script)) 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) (define (containerized-operating-system os mappings)
"Return an operating system based on OS for use in a Linux container "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 environment. MAPPINGS is a list of <file-system-mapping> to realize in the
@ -62,8 +81,10 @@ containerized OS."
mingetty-service-type mingetty-service-type
agetty-service-type)) agetty-service-type))
(operating-system (inherit os) (operating-system
(inherit os)
(swap-devices '()) ; disable swap (swap-devices '()) ; disable swap
(essential-services (container-essential-services os))
(services (remove (lambda (service) (services (remove (lambda (service)
(memq (service-kind service) (memq (service-kind service)
useless-services)) useless-services))
@ -81,30 +102,26 @@ that will be shared with the host system."
(operating-system-file-systems os))) (operating-system-file-systems os)))
(specs (map file-system->spec file-systems))) (specs (map file-system->spec file-systems)))
(mlet* %store-monad ((os-drv (operating-system-derivation (define script
os (with-imported-modules (source-module-closure
#:container? #t))) '((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 (call-with-container (map spec->file-system '#$specs)
(with-imported-modules (source-module-closure (lambda ()
'((guix build utils) (setenv "HOME" "/root")
(gnu build linux-container))) (setenv "TMPDIR" "/tmp")
#~(begin (setenv "GUIX_NEW_SYSTEM" #$os)
(use-modules (gnu build linux-container) (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
(gnu system file-systems) ;spec->file-system (primitive-load (string-append #$os "/boot")))
(guix build utils)) ;; 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) (gexp->script "run-container" script)))
(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))))

13
gnu/system/vm.scm
View File

@ -58,6 +58,7 @@
#:use-module (gnu bootloader grub) #:use-module (gnu bootloader grub)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system pam) #:use-module (gnu system pam)
#:use-module (gnu system linux-container)
#:use-module (gnu system linux-initrd) #:use-module (gnu system linux-initrd)
#:use-module (gnu bootloader) #:use-module (gnu bootloader)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
@ -473,9 +474,9 @@ should set REGISTER-CLOSURES? to #f."
(local-file (search-path %load-path (local-file (search-path %load-path
"guix/store/schema.sql")))) "guix/store/schema.sql"))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (let ((os (containerized-operating-system os '()))
(name -> (string-append name ".tar.gz")) (name (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph "system-graph"))
(define build (define build
(with-extensions (cons guile-json ;for (guix docker) (with-extensions (cons guile-json ;for (guix docker)
gcrypt-sqlite3&co) ;for (guix store database) gcrypt-sqlite3&co) ;for (guix store database)
@ -505,7 +506,7 @@ should set REGISTER-CLOSURES? to #f."
(initialize (root-partition-initializer (initialize (root-partition-initializer
#:closures '(#$graph) #:closures '(#$graph)
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:system-directory #$os-drv #:system-directory #$os
;; De-duplication would fail due to ;; De-duplication would fail due to
;; cross-device link errors, so don't do it. ;; cross-device link errors, so don't do it.
#:deduplicate? #f)) #:deduplicate? #f))
@ -523,7 +524,7 @@ should set REGISTER-CLOSURES? to #f."
(call-with-input-file (call-with-input-file
(string-append "/xchg/" #$graph) (string-append "/xchg/" #$graph)
read-reference-graph))) read-reference-graph)))
#$os-drv #$os
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1) #:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))) #:transformations `((,root-directory -> "")))
@ -534,7 +535,7 @@ should set REGISTER-CLOSURES? to #f."
name build name build
#:make-disk-image? #f #:make-disk-image? #f
#:single-file-output? #t #:single-file-output? #t
#:references-graphs `((,graph ,os-drv))))) #:references-graphs `((,graph ,os)))))
;;; ;;;