gnu: dmd: Add 'user-accounts' and 'user-groups' fields to <service>.

* gnu/system/shadow.scm (guix-build-accounts): Move to...
* gnu/system/dmd.scm (guix-build-accounts): ... here.
  (<service>)[user-accounts, user-groups]: New fields.
  (guix-service): New #:build-user-id and #:build-accounts parameters.
  Use 'guix-build-accounts' and set the 'user-accounts' and
  'user-groups' fields accordingly.
* gnu/system/vm.scm (system-qemu-image): Remove use of
  'guix-build-accounts'.  Augment ACCOUNTS and GROUPS from what SERVICES
  demand.

3 files changed, 62 insertions, 45 deletions

diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 8a79f0a50f..8e3f7e976a 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -24,13 +24,16 @@
   #:use-module ((gnu packages base)
                 #:select (glibc-final))
   #:use-module ((gnu packages system)
-                #:select (mingetty inetutils))
+                #:select (mingetty inetutils shadow))
   #:use-module ((gnu packages package-management)
                 #:select (guix))
   #:use-module ((gnu packages linux)
                 #:select (net-tools))
+  #:use-module (gnu system shadow)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (guix monads)
   #:export (service?
             service
@@ -40,6 +43,8 @@
             service-start
             service-stop
             service-inputs
+            service-user-accounts
+            service-user-groups
 
             host-name-service
             syslog-service
@@ -70,6 +75,10 @@
   (stop          service-stop                     ; expression
                  (default #f))
   (inputs        service-inputs                   ; list of inputs
+                 (default '()))
+  (user-accounts service-user-accounts            ; list of <user-account>
+                 (default '()))
+  (user-groups   service-user-groups              ; list of <user-groups>
                  (default '())))
 
 (define (host-name-service name)
@@ -149,16 +158,47 @@
       (inputs `(("inetutils" ,inetutils)
                 ("syslog.conf" ,syslog.conf)))))))
 
-(define* (guix-service #:key (guix guix) (builder-group "guixbuild"))
-  "Return a service that runs the build daemon from GUIX."
-  (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")))
+(define* (guix-build-accounts count #:key
+                              (first-uid 30001)
+                              (gid 30000)
+                              (shadow shadow))
+  "Return a list of COUNT user accounts for Guix build users, with UIDs
+starting at FIRST-UID, and under GID."
+  (mlet* %store-monad ((gid* -> gid)
+                       (no-login (package-file shadow "sbin/nologin")))
+    (return (unfold (cut > <> count)
+                    (lambda (n)
+                      (user-account
+                       (name (format #f "guixbuilder~2,'0d" n))
+                       (password "!")
+                       (uid (+ first-uid n -1))
+                       (gid gid*)
+                       (comment (format #f "Guix Build User ~2d" n))
+                       (home-directory "/var/empty")
+                       (shell no-login)))
+                    1+
+                    1))))
+
+(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
+                       (build-user-gid 30000) (build-accounts 10))
+  "Return a service that runs the build daemon from GUIX, and has
+BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
+  (mlet %store-monad ((daemon   (package-file guix "bin/guix-daemon"))
+                      (accounts (guix-build-accounts build-accounts
+                                                     #:gid build-user-gid)))
     (return (service
              (provision '(guix-daemon))
              (start `(make-forkexec-constructor ,daemon
                                                 "--build-users-group"
                                                 ,builder-group))
              (stop  `(make-kill-destructor))
-             (inputs `(("guix" ,guix)))))))
+             (inputs `(("guix" ,guix)))
+             (user-accounts accounts)
+             (user-groups (list (user-group
+                                 (name builder-group)
+                                 (id build-user-gid)
+                                 (members (map user-account-name
+                                               user-accounts)))))))))
 
 (define* (static-networking-service interface ip
                                     #:key
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 654fd4d55b..2cc0b89162 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -24,9 +24,7 @@
   #:use-module ((gnu packages system)
                 #:select (shadow))
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 format)
   #:export (user-account
             user-account?
             user-account-name
@@ -117,25 +115,4 @@ file."
 
   (text-file (if shadow? "shadow" "passwd") contents))
 
-(define* (guix-build-accounts count #:key
-                              (first-uid 30001)
-                              (gid 30000)
-                              (shadow shadow))
-  "Return a list of COUNT user accounts for Guix build users, with UIDs
-starting at FIRST-UID, and under GID."
-  (mlet* %store-monad ((gid* -> gid)
-                       (no-login (package-file shadow "sbin/nologin")))
-    (return (unfold (cut > <> count)
-                    (lambda (n)
-                      (user-account
-                       (name (format #f "guixbuilder~2,'0d" n))
-                       (password "!")
-                       (uid (+ first-uid n -1))
-                       (gid gid*)
-                       (comment (format #f "Guix Build User ~2d" n))
-                       (home-directory "/var/empty")
-                       (shell no-login)))
-                    1+
-                    1))))
-
 ;;; shadow.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 502c13b973..16be5ac59a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -535,8 +535,6 @@ alias ll='ls -l'
 
 (define (system-qemu-image)
   "Return the derivation of a QEMU image of the GNU system."
-  (define build-user-gid 30000)
-
   (mlet* %store-monad
       ((services (listm %store-monad
                         (host-name-service "gnu")
@@ -565,8 +563,6 @@ Happy birthday, GNU!                                http://www.gnu.org/gnu30
                                              #:allow-empty-passwords? #t
                                              #:motd motd)))
 
-       (build-accounts (guix-build-accounts 10 #:gid build-user-gid))
-
        (bash-file (package-file bash "bin/bash"))
        (dmd-file  (package-file dmd "bin/dmd"))
        (dmd-conf  (dmd-configuration-file services))
@@ -584,19 +580,23 @@ Happy birthday, GNU!                                http://www.gnu.org/gnu30
                             (comment "Guest of GNU")
                             (home-directory "/home/guest")
                             (shell bash-file))
-                           build-accounts))
-       (groups   -> (list (user-group
-                           (name "root")
-                           (id 0))
-                          (user-group
-                           (name "users")
-                           (id 100)
-                           (members '("guest")))
-                          (user-group
-                           (name "guixbuild")
-                           (id build-user-gid)
-                           (members (map user-account-name
-                                         build-accounts)))))
+                           (append-map service-user-accounts
+                                       services)))
+       (groups   -> (cons* (user-group
+                            (name "root")
+                            (id 0))
+                           (user-group
+                            (name "users")
+                            (id 100)
+                            (members '("guest")))
+                           (append-map service-user-groups services)))
+       (build-user-gid -> (any (lambda (service)
+                                 (and (equal? '(guix-daemon)
+                                              (service-provision service))
+                                      (match (service-user-groups service)
+                                        ((group)
+                                         (user-group-id group)))))
+                               services))
        (packages -> `(("coreutils" ,coreutils)
                       ("bash" ,bash)
                       ("guile" ,guile-2.0)