[bug#34948] [PATCH 0/3] Turn 'essential-services' into an <operating-system> field

[bug#34948] [PATCH 0/3] Turn 'essential-services' into an <operating-system> field

[Ludovic Courtès]

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

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

* 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

[bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account>.

[Ludovic Courtès]

* 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

[bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.

[Ludovic Courtès]

* 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

[bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.

[Arun Isaac]

[-- 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 --]

bug#34948: [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.

[Ludovic Courtès]

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’.

[bug#34948] [PATCH 3/3] system: Add 'essential-services' field to <operating-system>.

[Arun Isaac]

[-- 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 --]

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ricardo Wurmus]

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

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

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’.

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

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’.

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

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’.

[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

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'.