From patchwork Fri Mar 22 17:27:19 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 1527 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A09A916DA2; Fri, 22 Mar 2019 17:42:53 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id A47A116D88 for ; Fri, 22 Mar 2019 17:42:51 +0000 (GMT) Received: from localhost ([127.0.0.1]:60799 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OBu-0004qM-WD for patchwork@mira.cbaines.net; Fri, 22 Mar 2019 13:42:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:59028) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OBU-0004OG-Sw for guix-patches@gnu.org; Fri, 22 Mar 2019 13:42:27 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h7Nxb-0005uy-Rl for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:41109) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h7Nxb-0005uQ-J9 for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h7Nxb-0001Zw-Fb for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to . Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 22 Mar 2019 17:28:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34948 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34948@debbugs.gnu.org Received: via spool by 34948-submit@debbugs.gnu.org id=B34948.15532756666028 (code B ref 34948); Fri, 22 Mar 2019 17:28:03 +0000 Received: (at 34948) by debbugs.gnu.org; 22 Mar 2019 17:27:46 +0000 Received: from localhost ([127.0.0.1]:54651 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxH-0001Z6-Ms for submit@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:44 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42623) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxC-0001YS-6x for 34948@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:39 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46965) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7Nx6-0004nO-OX; Fri, 22 Mar 2019 13:27:33 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=49252 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1h7Nx5-0001o0-Q1; Fri, 22 Mar 2019 13:27:32 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 22 Mar 2019 18:27:19 +0100 Message-Id: <20190322172719.11199-3-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190322172719.11199-1-ludo@gnu.org> References: <20190322172719.11199-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu/system.scm ()[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'. --- doc/guix.texi | 7 ++++ gnu/system.scm | 71 +++++++++++++++------------------- gnu/system/linux-container.scm | 69 ++++++++++++++++++++------------- gnu/system/vm.scm | 13 ++++--- 4 files changed, 89 insertions(+), 71 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 642232ee9c..0b88503f3b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10472,6 +10472,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 6bccdaa8c2..f059c1b07d 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich @@ -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 @@ -199,6 +200,9 @@ (name-service-switch operating-system-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)) @@ -436,27 +440,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))) @@ -466,8 +465,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 @@ -495,20 +493,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)))) ;;; @@ -806,20 +800,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))) @@ -839,17 +832,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 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))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b671c74ab8..95fd97a8b8 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 -> "")))))))) @@ -531,7 +532,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))))) ;;;