* [bug#34948] [PATCH 0/3] Turn 'essential-services' into an <operating-system> field
@ 2019-03-22 17:21 Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
0 siblings, 1 reply; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-22 17:21 UTC (permalink / raw)
To: 34948
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
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-22 17:21 [bug#34948] [PATCH 0/3] Turn 'essential-services' into an <operating-system> field Ludovic Courtès
@ 2019-03-22 17:27 ` Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account> Ludovic Courtès
` (2 more replies)
0 siblings, 3 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-22 17:27 UTC (permalink / raw)
To: 34948
* 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
^ permalink raw reply related [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account>.
2019-03-22 17:27 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
@ 2019-03-22 17:27 ` Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system> Ludovic Courtès
2019-03-22 21:53 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ricardo Wurmus
2 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-22 17:27 UTC (permalink / raw)
To: 34948
* 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@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@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
^ permalink raw reply related [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.
2019-03-22 17:27 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account> Ludovic Courtès
@ 2019-03-22 17:27 ` Ludovic Courtès
2019-03-25 20:42 ` Arun Isaac
2019-03-22 21:53 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ricardo Wurmus
2 siblings, 1 reply; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-22 17:27 UTC (permalink / raw)
To: 34948
* 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@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@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))))
\f
;;;
@@ -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)))))
\f
;;;
--
2.21.0
^ permalink raw reply related [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-22 17:27 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account> Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system> Ludovic Courtès
@ 2019-03-22 21:53 ` Ricardo Wurmus
2019-03-23 15:18 ` Ludovic Courtès
2019-03-23 16:05 ` Ludovic Courtès
2 siblings, 2 replies; 12+ messages in thread
From: Ricardo Wurmus @ 2019-03-22 21:53 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 34948
Ludovic Courtès <ludo@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
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-22 21:53 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ricardo Wurmus
@ 2019-03-23 15:18 ` Ludovic Courtès
2019-03-23 16:05 ` Ludovic Courtès
1 sibling, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-23 15:18 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34948
Hi!
Ricardo Wurmus <rekado@elephly.net> skribis:
> Ludovic Courtès <ludo@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’.
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-22 21:53 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ricardo Wurmus
2019-03-23 15:18 ` Ludovic Courtès
@ 2019-03-23 16:05 ` Ludovic Courtès
2019-03-30 10:37 ` Ludovic Courtès
2019-03-30 14:20 ` Ludovic Courtès
1 sibling, 2 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-23 16:05 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34948
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’.
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.
2019-03-22 17:27 ` [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system> Ludovic Courtès
@ 2019-03-25 20:42 ` Arun Isaac
2019-03-25 23:02 ` bug#34948: " Ludovic Courtès
0 siblings, 1 reply; 12+ messages in thread
From: Arun Isaac @ 2019-03-25 20:42 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 34948
[-- Attachment #1: Type: text/plain, Size: 911 bytes --]
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.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#34948: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.
2019-03-25 20:42 ` Arun Isaac
@ 2019-03-25 23:02 ` Ludovic Courtès
2019-03-26 6:58 ` [bug#34948] " Arun Isaac
0 siblings, 1 reply; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-25 23:02 UTC (permalink / raw)
To: Arun Isaac; +Cc: 34948-done
Hi Arun!
Arun Isaac <arunisaac@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’.
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.
2019-03-25 23:02 ` bug#34948: " Ludovic Courtès
@ 2019-03-26 6:58 ` Arun Isaac
0 siblings, 0 replies; 12+ messages in thread
From: Arun Isaac @ 2019-03-26 6:58 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 34948-done
[-- Attachment #1: Type: text/plain, Size: 448 bytes --]
> 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.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-23 16:05 ` Ludovic Courtès
@ 2019-03-30 10:37 ` Ludovic Courtès
2019-03-30 14:20 ` Ludovic Courtès
1 sibling, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-30 10:37 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34948
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’.
^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.
2019-03-23 16:05 ` Ludovic Courtès
2019-03-30 10:37 ` Ludovic Courtès
@ 2019-03-30 14:20 ` Ludovic Courtès
1 sibling, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-03-30 14:20 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34948
Ludovic Courtès <ludo@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'.
^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2019-03-30 14:22 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-03-22 17:21 [bug#34948] [PATCH 0/3] Turn 'essential-services' into an <operating-system> field Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account> Ludovic Courtès
2019-03-22 17:27 ` [bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system> Ludovic Courtès
2019-03-25 20:42 ` Arun Isaac
2019-03-25 23:02 ` bug#34948: " Ludovic Courtès
2019-03-26 6:58 ` [bug#34948] " Arun Isaac
2019-03-22 21:53 ` [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ricardo Wurmus
2019-03-23 15:18 ` Ludovic Courtès
2019-03-23 16:05 ` Ludovic Courtès
2019-03-30 10:37 ` Ludovic Courtès
2019-03-30 14:20 ` Ludovic Courtès
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.