From patchwork Fri Mar 22 17:27:17 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 1528 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 EA84016DA2; Fri, 22 Mar 2019 17:44:56 +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 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 9139616D88 for ; Fri, 22 Mar 2019 17:44:56 +0000 (GMT) Received: from localhost ([127.0.0.1]:60818 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7ODv-0006n4-Pj for patchwork@mira.cbaines.net; Fri, 22 Mar 2019 13:44:55 -0400 Received: from eggs.gnu.org ([209.51.188.92]:58998) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OBJ-0004Nl-PN for guix-patches@gnu.org; Fri, 22 Mar 2019 13:42:16 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h7Nxa-0005tR-Vq for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:41107) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h7Nxa-0005rl-OK for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h7Nxa-0001Zg-Cu for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. References: <20190322172120.10974-1-ludo@gnu.org> In-Reply-To: <20190322172120.10974-1-ludo@gnu.org> 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:02 +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.15532756596001 (code B ref 34948); Fri, 22 Mar 2019 17:28:02 +0000 Received: (at 34948) by debbugs.gnu.org; 22 Mar 2019 17:27:39 +0000 Received: from localhost ([127.0.0.1]:54647 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxC-0001Yh-AD for submit@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:38 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42616) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxA-0001YO-Hr for 34948@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:36 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46963) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7Nx4-0004is-F1; Fri, 22 Mar 2019 13:27:30 -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 1h7Nx3-0001o0-Qc; Fri, 22 Mar 2019 13:27:30 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 22 Mar 2019 18:27:17 +0100 Message-Id: <20190322172719.11199-1-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 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 * guix/records.scm (this-record): New syntax parameter. (make-syntactic-constructor)[wrap-field-value]: When F is thunked, return a one-argument lambda instead of a thunk, and parameterize THIS-RECORD. (define-record-type*)[thunked-field-accessor-definition]: Pass X to (real-get X). * tests/records.scm ("define-record-type* & thunked & this-record") ("define-record-type* & thunked & default & this-record") ("define-record-type* & thunked & inherit & this-record"): New tests. --- guix/records.scm | 24 ++++++++++++++++++++++-- tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 2 deletions(-) diff --git a/guix/records.scm b/guix/records.scm index 0649c90ea3..244b124098 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -25,6 +25,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:export (define-record-type* + this-record + alist->record object->fields recutils->alist @@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE." (() #t))))))) +(define-syntax-parameter this-record + (lambda (s) + "Return the record being defined. This macro may only be used in the +context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-record + "cannot be used outside of a record instantiation" + #'id))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -148,7 +161,14 @@ of TYPE matches the expansion-time ABI." (define (wrap-field-value f value) (cond ((thunked-field? f) - #`(lambda () #,value)) + #`(lambda (x) + (syntax-parameterize ((this-record + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) ((delayed-field? f) #`(delay #,value)) (else value))) @@ -308,7 +328,7 @@ inherited." (with-syntax ((real-get (wrapped-field-accessor-name field))) #'(define-inlinable (get x) ;; The real value of that field is a thunk, so call it. - ((real-get x))))))) + ((real-get x) x)))))) (define (delayed-field-accessor-definition field) ;; Return the real accessor for FIELD, which is assumed to be a diff --git a/tests/records.scm b/tests/records.scm index d9469a78bd..45614093a0 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -170,6 +170,46 @@ (parameterize ((mark (cons 'a 'b))) (eq? (foo-bar y) (mark))))))) +(test-assert "define-record-type* & thunked & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let ((x (foo (bar 40) + (baz (+ (foo-bar this-record) 2))))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & default & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let ((x (foo (bar 40)))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & inherit & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let* ((x (foo (bar 40))) + (y (foo (inherit x) (bar -2))) + (z (foo (inherit x) (baz -2)))) + (and (= -2 (foo-bar y)) + (= 0 (foo-baz y)) + (= 40 (foo-bar z)) + (= -2 (foo-baz z)))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo From patchwork Fri Mar 22 17:27:18 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: 1529 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 CDD5B16DA2; Fri, 22 Mar 2019 17:47:18 +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 298E516D88 for ; Fri, 22 Mar 2019 17:47:18 +0000 (GMT) Received: from localhost ([127.0.0.1]:60878 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OGD-0008MC-Oc for patchwork@mira.cbaines.net; Fri, 22 Mar 2019 13:47:17 -0400 Received: from eggs.gnu.org ([209.51.188.92]:58972) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7OBU-0004Mr-Ue for guix-patches@gnu.org; Fri, 22 Mar 2019 13:42:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h7Nxb-0005uA-DF for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:41108) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h7Nxb-0005tZ-3e 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 1h7Nxa-0001Zn-Uu for guix-patches@gnu.org; Fri, 22 Mar 2019 13:28:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of . 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:02 +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.15532756606014 (code B ref 34948); Fri, 22 Mar 2019 17:28:02 +0000 Received: (at 34948) by debbugs.gnu.org; 22 Mar 2019 17:27:40 +0000 Received: from localhost ([127.0.0.1]:54649 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxE-0001Yw-1b for submit@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:40 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42619) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h7NxA-0001YP-JH for 34948@debbugs.gnu.org; Fri, 22 Mar 2019 13:27:37 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46964) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h7Nx5-0004kh-Bt; Fri, 22 Mar 2019 13:27:31 -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 1h7Nx4-0001o0-Qg; Fri, 22 Mar 2019 13:27:31 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 22 Mar 2019 18:27:18 +0100 Message-Id: <20190322172719.11199-2-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/accounts.scm ()[home-directory]: Mark as thunked and add a default value. (default-home-directory): New procedure. * doc/guix.texi (User Accounts): Remove 'home-directory' from example. * gnu/system/examples/bare-bones.tmpl: Likewise. * gnu/system/examples/beaglebone-black.tmpl: Likewise. * gnu/system/examples/desktop.tmpl: Likewise. * gnu/system/examples/docker-image.tmpl: Likewise. * gnu/system/examples/lightweight-desktop.tmpl: Likewise. * gnu/system/install.scm (installation-os): Likewise. * gnu/tests.scm (%simple-os): Likewise. * gnu/tests/install.scm (%minimal-os, %minimal-os-on-vda): (%separate-home-os, %encrypted-root-os, %btrfs-root-os): Likewise. * tests/accounts.scm ("allocate-passwd") ("allocate-passwd with previous state"): Likewise. --- doc/guix.texi | 1 - gnu/system/accounts.scm | 7 ++++++- gnu/system/examples/bare-bones.tmpl | 3 +-- gnu/system/examples/beaglebone-black.tmpl | 3 +-- gnu/system/examples/desktop.tmpl | 3 +-- gnu/system/examples/docker-image.tmpl | 3 +-- gnu/system/examples/lightweight-desktop.tmpl | 3 +-- gnu/system/install.scm | 3 +-- gnu/tests.scm | 5 ++--- gnu/tests/install.scm | 14 ++++---------- tests/accounts.scm | 4 ---- 11 files changed, 18 insertions(+), 31 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 94d7a29bdf..642232ee9c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10868,7 +10868,6 @@ this field must contain the encrypted password, as a string. You can use the @example (user-account (name "charlie") - (home-directory "/home/charlie") (group "users") ;; Specify a SHA-512-hashed initial password. diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm index eb18fb5e43..586cff1842 100644 --- a/gnu/system/accounts.scm +++ b/gnu/system/accounts.scm @@ -67,7 +67,8 @@ (supplementary-groups user-account-supplementary-groups (default '())) ; list of strings (comment user-account-comment (default "")) - (home-directory user-account-home-directory) + (home-directory user-account-home-directory (thunked) + (default (default-home-directory this-record))) (create-home-directory? user-account-create-home-directory? ;Boolean (default #t)) (shell user-account-shell ; gexp @@ -84,6 +85,10 @@ (system? user-group-system? ; Boolean (default #f))) +(define (default-home-directory account) + "Return the default home directory for ACCOUNT." + (string-append "/home/" (user-account-name account))) + (define (sexp->user-group sexp) "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a user-group record." diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index a88bab034f..4f30a5b756 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -35,8 +35,7 @@ ;; and "video" allows the user to play sound ;; and access the webcam. (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl index 11678063b2..def05e807d 100644 --- a/gnu/system/examples/beaglebone-black.tmpl +++ b/gnu/system/examples/beaglebone-black.tmpl @@ -38,8 +38,7 @@ ;; and "video" allows the user to play sound ;; and access the webcam. (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index c59bf92681..bc5cbd6e6b 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -42,8 +42,7 @@ (comment "Alice's brother") (group "users") (supplementary-groups '("wheel" "netdev" - "audio" "video")) - (home-directory "/home/bob")) + "audio" "video"))) %base-user-accounts)) ;; This is where we specify system-wide packages. diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl index 9690d651c1..ca633cc838 100644 --- a/gnu/system/examples/docker-image.tmpl +++ b/gnu/system/examples/docker-image.tmpl @@ -15,8 +15,7 @@ (comment "Bob's sister") (group "users") (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index a234badd2b..45d9bf447f 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -35,8 +35,7 @@ (comment "Bob's sister") (group "users") (supplementary-groups '("wheel" "netdev" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Add a bunch of window managers; we can choose one at diff --git a/gnu/system/install.scm b/gnu/system/install.scm index bad318d06b..aad1deb913 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -379,8 +379,7 @@ You have been warned. Thanks for being so brave.\x1b[0m (group "users") (supplementary-groups '("wheel")) ; allow use of sudo (password "") - (comment "Guest of GNU") - (home-directory "/home/guest")))) + (comment "Guest of GNU")))) (issue %issue) (services %installation-services) diff --git a/gnu/tests.scm b/gnu/tests.scm index 9e8eed7d95..0871b4c6f7 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; @@ -219,8 +219,7 @@ the system under test." (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)))) (define-syntax-rule (simple-operating-system user-services ...) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 277908cc49..c0debbd840 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -74,8 +74,7 @@ (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -357,8 +356,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.") (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -435,12 +433,10 @@ reboot\n") %base-file-systems)) (users (cons* (user-account (name "alice") - (group "users") - (home-directory "/home/alice")) + (group "users")) (user-account (name "charlie") - (group "users") - (home-directory "/home/charlie")) + (group "users")) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -655,7 +651,6 @@ by 'mdadm'.") (users (cons (user-account (name "charlie") (group "users") - (home-directory "/home/charlie") (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type @@ -776,7 +771,6 @@ build (current-guix) and then store a couple of full system images.") (users (cons (user-account (name "charlie") (group "users") - (home-directory "/home/charlie") (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type diff --git a/tests/accounts.scm b/tests/accounts.scm index 127861042d..923ba7dc83 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -199,12 +199,10 @@ nobody:!:0::::::\n")) (directory "/var/empty"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") - (home-directory "/home/alice") (shell "/bin/sh") (group "users")) (user-account (name "bob") (comment "Bob") - (home-directory "/home/bob") (shell "/bin/gash") (group "wheel")) (user-account (name "sshd") (system? #t) @@ -234,12 +232,10 @@ nobody:!:0::::::\n")) (directory "/home/charlie"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") - (home-directory "/home/alice") (shell "/bin/sh") ;ignored (group "users")) (user-account (name "charlie") (comment "Charlie") - (home-directory "/home/charlie") (shell "/bin/sh") (group "users"))) (list (group-entry (name "users") (gid 1000))) 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))))) ;;;