ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

system: Add 'essential-services' field to <operating-system>.

Browse source 
* 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})
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

55
gnu/system.scm
View file

@ -69,6 +69,7 @@ (define-module (gnu system)
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 @@ (define-record-type* <operating-system> operating-system
(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 @@ (define (operating-system-kernel-file 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))
(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
("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 @@ (define known-fs
(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 @@ (define known-fs
other-fs
(append mappings swaps
;; Add the firmware service, unless we are building for a
;; container.
(if container?
(list %containerized-shepherd-service)
;; Add the firmware service.
(list %linux-bare-metal-service
(service firmware-service-type
(operating-system-firmware os))))))))
(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 @@ (define %sudoers-specification
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 @@ (define (operating-system-shepherd-service-names os)
#: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

33
gnu/system/linux-container.scm
View file

@ -29,12 +29,31 @@ (define-module (gnu system linux-container)
#: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 @@ (define useless-services
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,10 +102,6 @@ (define* (container-script os #:key (mappings '()))
(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)
@ -98,13 +115,13 @@ (define script
(lambda ()
(setenv "HOME" "/root")
(setenv "TMPDIR" "/tmp")
(setenv "GUIX_NEW_SYSTEM" #$os-drv)
(setenv "GUIX_NEW_SYSTEM" #$os)
(for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
(primitive-load (string-append #$os-drv "/boot")))
(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)))

13
gnu/system/vm.scm
View file

@ -58,6 +58,7 @@ (define-module (gnu system vm)
#: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 @@ (define schema
(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 @@ (define build
(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 @@ (define build
(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 @@ (define build
name build
#:make-disk-image? #f
#:single-file-output? #t
#:references-graphs `((,graph ,os-drv)))))
#:references-graphs `((,graph ,os)))))
;;;