Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Fri, 22 Mar 2019 17:22:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 34948 in the body.
You can then email your comments to 34948 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Fri, 22 Mar 2019 17:22:02 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>:guix-patches <at> gnu.org.
(Fri, 22 Mar 2019 17:22:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Arun Isaac <arunisaac <at> systemreboot.net>, Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 0/3] Turn 'essential-services' into an <operating-system> field Date: Fri, 22 Mar 2019 18:21:20 +0100
Hello Guix!
This is the solution that Arun and I were discussing:
https://issues.guix.info/issue/28128#17
This series adds support for “self-referential records”: from
the definition of a thunked field, you can use ‘this-record’
to access the record that the field belongs to.
It then uses that to turn ‘essential-services’ into a thunked
field of <operating-system> rather than an inaccessible internal
procedure.
This allows us to remove all the #:container? flags from
(gnu system) and instead of (gnu system linux-container) simply
override ‘essential-services’ as needed.
Thoughts?
Thanks,
Ludo’.
Ludovic Courtès (3):
records: Allow thunked fields to refer to 'this-record'.
accounts: Add default value for the 'home-directory' field of
<user-account>.
system: Add 'essential-services' field to <operating-system>.
doc/guix.texi | 8 ++-
gnu/system.scm | 71 +++++++++-----------
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/system/linux-container.scm | 69 ++++++++++++-------
gnu/system/vm.scm | 13 ++--
gnu/tests.scm | 5 +-
gnu/tests/install.scm | 14 ++--
guix/records.scm | 24 ++++++-
tests/accounts.scm | 4 --
tests/records.scm | 40 +++++++++++
16 files changed, 169 insertions(+), 104 deletions(-)
--
2.21.0
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Fri, 22 Mar 2019 17:28:02 GMT) Full text and rfc822 format available.Message #8 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34948 <at> debbugs.gnu.org Cc: Arun Isaac <arunisaac <at> systemreboot.net>, Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Fri, 22 Mar 2019 18:27:17 +0100
* 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> 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> 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> 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> foo make-foo
--
2.21.0
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Fri, 22 Mar 2019 17:28:02 GMT) Full text and rfc822 format available.Message #11 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34948 <at> debbugs.gnu.org Cc: Arun Isaac <arunisaac <at> systemreboot.net>, Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account>. Date: Fri, 22 Mar 2019 18:27:18 +0100
* gnu/system/accounts.scm (<user-account>)[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 <ludo <at> gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe <at> gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me <at> tobias.gr>
;;;
@@ -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)))
--
2.21.0
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Fri, 22 Mar 2019 17:28:03 GMT) Full text and rfc822 format available.Message #14 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34948 <at> debbugs.gnu.org Cc: Arun Isaac <arunisaac <at> systemreboot.net>, Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>. Date: Fri, 22 Mar 2019 18:27:19 +0100
* 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'.
---
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 <ludo <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw <at> netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost <at> gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich <at> gmail.com>
@@ -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 ; <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 <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)
+ (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)))))
;;;
--
2.21.0
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Fri, 22 Mar 2019 21:54:01 GMT) Full text and rfc822 format available.Message #17 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ricardo Wurmus <rekado <at> elephly.net> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Fri, 22 Mar 2019 22:53:07 +0100
Ludovic Courtès <ludo <at> gnu.org> writes: > * 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. So the value of the thunked field is no longer strictly a thunk? I’m having difficulties understanding how this works. Why does the “thunked field” now require an argument (“x”)? We use the syntax parameter “this-record” to introduce a new binding with this name in the context of the “value” of the field. The parameter value is … hard to make out. How does the syntax-case macro in the following syntax-parameterize expression evaluate to the record itself? Would #,x not be sufficient to refer to the argument of the field accessor? > (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))))) -- Ricardo
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Sat, 23 Mar 2019 15:19:02 GMT) Full text and rfc822 format available.Message #20 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Ricardo Wurmus <rekado <at> elephly.net> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Sat, 23 Mar 2019 16:18:11 +0100
Hi!
Ricardo Wurmus <rekado <at> elephly.net> skribis:
> Ludovic Courtès <ludo <at> gnu.org> writes:
>
>> * 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.
>
> So the value of the thunked field is no longer strictly a thunk?
Indeed, it’s now a one-argument procedure. It doesn’t matter much
though because users never see this procedure.
> I’m having difficulties understanding how this works. Why does the
> “thunked field” now require an argument (“x”)?
This argument is the record itself, then bound to ‘this-record’ in the
lexical scope of the field.
> We use the syntax parameter “this-record” to introduce a new binding
> with this name in the context of the “value” of the field. The
> parameter value is … hard to make out. How does the syntax-case macro
> in the following syntax-parameterize expression evaluate to the record
> itself? Would #,x not be sufficient to refer to the argument of the
> field accessor?
>
>> (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)))))
Here ‘x’ is the identifier of a variable that exists at run time. So we
cannot write #,x because we’d be referring to a variable ‘x’ that exists
at macro-expansion time, and there’s no such variable here.
The ‘syntax-case’ here is just so that ‘this-record’ matches only when
used as an identifier, like this:
(foo this-record)
… and does not match when used like this:
(this-record)
or like that:
(this-record x y z)
We could just as well make it (identifier-syntax #'x) though that’s
slightly less precise.
A macro expansion is worth a thousand words :-), so:
--8<---------------cut here---------------start------------->8---
scheme@(guix records)> (define-record-type* <foo> foo make-foo foo?
(bar foo-bar (default 42))
(baz foo-baz (thunked)))
scheme@(guix records)> ,optimize (foo-baz x)
$11 = (let ((x x))
((if (eq? (struct-vtable x) <foo>)
(struct-ref x 1)
(throw 'wrong-type-arg
'%foo-baz-real
"Wrong type argument: ~S"
(list x)
(list x)))
x))
scheme@(guix records)> ,optimize (foo (baz (+ 77 (foo-bar this-record))))
$12 = (begin
(if (eq? #{% <foo> abi-cookie}# 2292347072401235576)
(if #f #f)
(throw 'record-abi-mismatch-error
'abi-check
"~a: record ABI mismatch; recompilation needed"
(list <foo>)
'()))
(let ((s (allocate-struct <foo> 2)))
(struct-set! s 0 42)
(struct-set!
s
1
(lambda (x)
(+ 77
(if (eq? (struct-vtable x) <foo>)
(struct-ref x 0)
(throw 'wrong-type-arg
'foo-bar
"Wrong type argument: ~S"
(list x)
(list x))))))
s))
--8<---------------cut here---------------end--------------->8---
I hope this clarifies things!
Ludo’.
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Sat, 23 Mar 2019 16:06:01 GMT) Full text and rfc822 format available.Message #23 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Ricardo Wurmus <rekado <at> elephly.net> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Sat, 23 Mar 2019 17:05:10 +0100
I should mention that there are other craaaazzy applications of this!
For example, the ‘self-native-input?’ field of <package> becomes
useless, because now you can write:
(package
;; …
(native-inputs
;; Add self as a native input when cross-compiling.
`(,@(if (%current-target-system)
`(("this" ,this-record))
'())
;; …
)))
I think there are other cases in package definitions where this can be
useful, possibly things like the ‘make-lua-*’ procedures that we have.
Ludo’.
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Mon, 25 Mar 2019 20:43:02 GMT) Full text and rfc822 format available.Message #26 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Arun Isaac <arunisaac <at> systemreboot.net> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>. Date: Tue, 26 Mar 2019 02:12:26 +0530
[Message part 1 (text/plain, inline)]
This neatly gets rid of all the #:container? arguments. That's very
nice! :-) I haven't actually built and tested these patches, but these
LGTM. Just one minor observation below.
> + (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))))
Why not rewrite this using just a call to append, that is remove the
call to cons? Like so:
(append base
(list (service system-service-type
(let ((locale (operating-system-locale-directory os)))
(with-monad %store-monad
(return `(("locale" ,locale))))))
%containerized-shepherd-service))
Or perhaps, this can be done with cons* also.
[signature.asc (application/pgp-signature, inline)]
Ludovic Courtès <ludo <at> gnu.org>:Ludovic Courtès <ludo <at> gnu.org>:Message #31 received at 34948-done <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Arun Isaac <arunisaac <at> systemreboot.net> Cc: 34948-done <at> debbugs.gnu.org Subject: Re: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>. Date: Tue, 26 Mar 2019 00:02:31 +0100
Hi Arun!
Arun Isaac <arunisaac <at> systemreboot.net> skribis:
> This neatly gets rid of all the #:container? arguments. That's very
> nice! :-) I haven't actually built and tested these patches, but these
> LGTM. Just one minor observation below.
>
>> + (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))))
>
> Why not rewrite this using just a call to append, that is remove the
> call to cons? Like so:
No, IIRC ‘system-service-type’ should be the first in the list (?), but
also I find it more pleasant to the eye than an unbalanced ‘append’
call. :-)
Thanks for your feedback, I’ve pushed it now:
69cae3d335 system: Add 'essential-services' field to <operating-system>.
cf848cc0a1 accounts: Add default value for the 'home-directory' field of <user-account>.
abd4d6b33d records: Allow thunked fields to refer to 'this-record'.
I hope that’ll help address your container use case!
Ludo’.
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Tue, 26 Mar 2019 06:59:02 GMT) Full text and rfc822 format available.Message #34 received at 34948-done <at> debbugs.gnu.org (full text, mbox):
From: Arun Isaac <arunisaac <at> systemreboot.net> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 34948-done <at> debbugs.gnu.org Subject: Re: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>. Date: Tue, 26 Mar 2019 12:28:01 +0530
[Message part 1 (text/plain, inline)]
> Thanks for your feedback, I’ve pushed it now: > > 69cae3d335 system: Add 'essential-services' field to <operating-system>. > cf848cc0a1 accounts: Add default value for the 'home-directory' field of <user-account>. > abd4d6b33d records: Allow thunked fields to refer to 'this-record'. Thank you! :-) > I hope that’ll help address your container use case! Yes, it should. I will work on it and send patches once I'm done.
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Sat, 30 Mar 2019 10:39:02 GMT) Full text and rfc822 format available.Message #37 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Ricardo Wurmus <rekado <at> elephly.net> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Sat, 30 Mar 2019 11:37:48 +0100
Hello!
I’ve extended this a bit with these commits:
d8bead6c5d system: Define 'this-operating-system'.
adb6462c4c packages: Define 'this-package' and 'this-origin'.
d2be7e3c4b records: Support custom 'this' identifiers.
Now you can refer to ‘this-package’ and it will refer to the closest
package in scope. The good thing is that you can refer to
‘this-package’ from within, say, an <origin> field, and it will DTRT.
That also means you could have things such as:
(define-record-type* <origin>
;; …
(file-name origin-file-name (thunked)
(default (string-append (package-name this-package)
"-source"))))
… which is pretty fun when you think about it, since it allows you to
implicitly refer to the lexically surrounding package.
That reminds me of Scala’s “implicit parameters”:
https://docs.scala-lang.org/tour/implicit-parameters.html
Ludo’.
guix-patches <at> gnu.org:bug#34948; Package guix-patches.
(Sat, 30 Mar 2019 14:22:01 GMT) Full text and rfc822 format available.Message #40 received at 34948 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Ricardo Wurmus <rekado <at> elephly.net> Cc: 34948 <at> debbugs.gnu.org Subject: Re: [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'. Date: Sat, 30 Mar 2019 15:20:37 +0100
Ludovic Courtès <ludo <at> gnu.org> skribis:
> I should mention that there are other craaaazzy applications of this!
>
> For example, the ‘self-native-input?’ field of <package> becomes
> useless, because now you can write:
>
> (package
> ;; …
> (native-inputs
> ;; Add self as a native input when cross-compiling.
> `(,@(if (%current-target-system)
> `(("this" ,this-record))
> '())
> ;; …
> )))
Done in a7646bc5e17a829d23519d0b199a576fb1edbd04!
Ludo'.
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Sun, 28 Apr 2019 11:24:08 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.