guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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'.
version-1.0.0
Ludovic Courtès 3 years ago
parent
cf848cc0a1
commit
69cae3d335
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
4 changed files with 90 additions and 72 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 7
      doc/guix.texi
  2. 73
      gnu/system.scm
  3. 69
      gnu/system/linux-container.scm
  4. 13
      gnu/system/vm.scm

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

73
gnu/system.scm
View File

@ -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

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

@ -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)))

13
gnu/system/vm.scm
View File

@ -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)))))
;;;

Write Preview
Loading…
Cancel
Save