Re: Invoking user shepherd; Was: Re: Defining *user* services in Guix

[Mathieu Othacehe <m.othacehe@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1736 bytes --]


Hi Danny,

> Or should we just expect the user to put a (shepherd with fix)
> invocation into their HOME startup scripts like .xinitrc ?

I wrote a first draft of user services a month ago. The idea here is
that guix user -r user-manifest.scm generates a script that lauches a
user shepherd.

For instance with the following user-manifest.scm :

--8<---------------cut here---------------start------------->8---
(define (redshift-service config)
  (list (shepherd-service
         (documentation "Run redshift.")
         (provision '(redshift-test))
         (requirement '())
         (start #~(make-forkexec-constructor
                   (list (string-append #$redshift "/bin/redshift")
                         "-l" "48:2")))
         (stop  #~(make-kill-destructor)))))

(define redshift-service-type
  (service-type
   (name 'test-user)
   (extensions
    (list
     (service-extension shepherd-user-service-type
                        test-shepherd-service)))))

(user-configuration
 (services (list (service redshift-service-type #f))))
--8<---------------cut here---------------end--------------->8---

I get a script that lauches shepherd himself starting redshift.

The plan here was to add a symlink, (don't know where !), pointing to
the last generated shepherd script, and have the user start shepherd by
executing the script pointed by the symlink in his .xinitrc for
instance.

> Note that if we did that there's some session-specific stuff in the session's environment that shepherd will inherit.  Probably not that bad if invoked early enough.

Starting shepherd there ensures to have DISPLAY, XAUTHORITY and other
variables that user services may use (like redshift).

I attached my draft patch.

Thanks,

Mathieu

[-- Attachment #2: 0001-user-services.patch --]
[-- Type: text/x-patch, Size: 11488 bytes --]

From 1d02fd18b187bb5c8fae8413116a7608eb7e5088 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Mon, 1 May 2017 16:22:23 +0200
Subject: [PATCH] user services.

---
 Makefile.am               |   1 +
 gnu/services.scm          |   5 ++
 gnu/services/shepherd.scm |  70 +++++++++++++++++++++-----
 gnu/system.scm            |   9 ++++
 guix/scripts/user.scm     | 125 ++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 197 insertions(+), 13 deletions(-)
 create mode 100644 guix/scripts/user.scm

diff --git a/Makefile.am b/Makefile.am
index 8fe9e350c..7a87f548a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -165,6 +165,7 @@ MODULES =					\
   guix/scripts/publish.scm			\
   guix/scripts/edit.scm				\
   guix/scripts/size.scm				\
+  guix/scripts/user.scm				\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
diff --git a/gnu/services.scm b/gnu/services.scm
index 5c314748d..08b595a60 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -73,6 +73,7 @@
             ambiguous-target-service-error-target-type
 
             system-service-type
+            user-service-type
             boot-service-type
             cleanup-service-type
             activation-service-type
@@ -281,6 +282,10 @@ containing the given entries."
                 (compose identity)
                 (extend system-derivation)))
 
+(define user-service-type
+  (service-type (name 'user)
+                (extensions '())))
+
 (define (compute-boot-script _ mexps)
   (mlet %store-monad ((gexps (sequence %store-monad mexps)))
     (gexp->file "boot"
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 7281746ab..787d8b2b0 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -35,7 +35,11 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (shepherd-root-service-type
+            shepherd-user-service-type
+
             %shepherd-root-service
+            %shepherd-user-root-service
+
             shepherd-service-type
 
             shepherd-service
@@ -86,6 +90,14 @@
                 (execl #$(file-append shepherd "/bin/shepherd")
                        "shepherd" "--config" #$shepherd-conf)))))
 
+(define (shepherd-user-gexp _ services)
+  (mlet %store-monad ((shepherd-conf
+                       (shepherd-user-configuration-file services)))
+    (return #~(begin
+                ;; Start shepherd.
+                (execl #$(file-append shepherd "/bin/shepherd")
+                       "shepherd" "--config" #$shepherd-conf)))))
+
 (define shepherd-root-service-type
   (service-type
    (name 'shepherd-root)
@@ -98,11 +110,21 @@
                      (service-extension profile-service-type
                                         (const (list shepherd)))))))
 
+(define shepherd-user-service-type
+  (service-type
+   (name 'shepherd-user)
+   (compose concatenate)
+   (extend shepherd-user-gexp)
+   (extensions (list (service-extension user-service-type (const #t))))))
+
 (define %shepherd-root-service
   ;; The root shepherd service, aka. PID 1.  Its parameter is a list of
   ;; <shepherd-service> objects.
   (service shepherd-root-service-type '()))
 
+(define %shepherd-user-root-service
+  (service shepherd-user-service-type #f))
+
 (define-syntax-rule (shepherd-service-type service-name proc)
   "Return a <service-type> denoting a simple shepherd service--i.e., the type
 for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
@@ -216,6 +238,22 @@ stored."
                       #:start #$(shepherd-service-start service)
                       #:stop #$(shepherd-service-stop service))))))
 
+(define (shepherd-start-services services)
+  #~(for-each
+     (lambda (service)
+       ;; In the Shepherd 0.3 the 'start' method can raise
+       ;; '&action-runtime-error' if it fails, so protect
+       ;; against it.  (XXX: 'action-runtime-error?' is not
+       ;; exported is 0.3, hence 'service-error?'.)
+       (guard (c ((service-error? c)
+                  (format (current-error-port)
+                          "failed to start service '~a'~%"
+                          service)))
+         (start service)))
+     '#$(append-map shepherd-service-provision
+                    (filter shepherd-service-auto-start?
+                            services))))
+
 (define (shepherd-configuration-file services)
   "Return the shepherd configuration file for SERVICES."
   (assert-valid-graph services)
@@ -238,19 +276,25 @@ stored."
               (setenv "PATH" "/run/current-system/profile/bin")
 
               (format #t "starting services...~%")
-              (for-each (lambda (service)
-                          ;; In the Shepherd 0.3 the 'start' method can raise
-                          ;; '&action-runtime-error' if it fails, so protect
-                          ;; against it.  (XXX: 'action-runtime-error?' is not
-                          ;; exported is 0.3, hence 'service-error?'.)
-                          (guard (c ((service-error? c)
-                                     (format (current-error-port)
-                                             "failed to start service '~a'~%"
-                                             service)))
-                            (start service)))
-                        '#$(append-map shepherd-service-provision
-                                       (filter shepherd-service-auto-start?
-                                               services)))))))
+              #$(shepherd-start-services services)))))
+
+    (gexp->file "shepherd.conf" config)))
+
+(define (shepherd-user-configuration-file services)
+  "Return the shepherd configuration file for SERVICES."
+  (assert-valid-graph services)
+
+  (mlet %store-monad ((files (mapm %store-monad
+                                   shepherd-service-file services)))
+    (define config
+      #~(begin
+          (use-modules (srfi srfi-34)
+                       (system repl error-handling))
+
+          ;; (action 'shepherd 'daemonize)
+
+          (apply register-services (map primitive-load '#$files))
+          #$(shepherd-start-services services)))
 
     (gexp->file "shepherd.conf" config)))
 
diff --git a/gnu/system.scm b/gnu/system.scm
index a35a416cb..dd69e31aa 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -65,6 +65,10 @@
   #:export (operating-system
             operating-system?
 
+            user-configuration
+            user-configuration?
+            user-configuration-services
+
             operating-system-bootloader
             operating-system-services
             operating-system-user-services
@@ -182,6 +186,11 @@
   (sudoers-file operating-system-sudoers-file     ; file-like
                 (default %sudoers-specification)))
 
+(define-record-type* <user-configuration> user-configuration
+  make-user-configuration
+  user-configuration?
+  (services user-configuration-services))
+
 \f
 ;;;
 ;;; Services.
diff --git a/guix/scripts/user.scm b/guix/scripts/user.scm
new file mode 100644
index 000000000..1ee3f9535
--- /dev/null
+++ b/guix/scripts/user.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts user)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix derivations)
+  #:use-module (guix records)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts build)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix gexp)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:export (guix-user))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %options
+  ;; Specifications of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\r "reconfigure") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'action `(reconfigure . ,arg) result)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix user")))
+         %standard-build-options))
+
+(define %default-options
+  `((system . ,(%current-system))
+    (substitutes? . #t)
+    (graft? . #t)
+    (max-silent-time . 3600)
+    (verbosity . 0)))
+
+(define (show-help)
+  (display (G_ "Usage: guix user [OPTION]...
+Create a bundle of PACKAGE.\n"))
+  (display (G_ "
+  -r, --reconfigure-services=FILE  reconfigure services described in FILE"))
+  (newline)
+  (display (G_ "
+  -h, --help                       display this help and exit"))
+  (display (G_ "
+  -V, --version                    display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+\f
+;;;
+;;; User services.
+;;;
+
+(define (fold-user-services services)
+  (fold-services (cons* (service user-service-type #f)
+                        %shepherd-user-root-service
+                        services)
+                 #:target-type shepherd-user-service-type))
+
+(define (generate-sheperd-configuration services opts)
+  (mlet* %store-monad ((services -> (fold-user-services services))
+                       (shepherd-conf.drv (service-value services))
+                       (shepherd-launch (gexp->script "shepherd" shepherd-conf.drv))
+                       (drvs -> (list shepherd-launch)))
+    (mbegin %store-monad
+      (show-what-to-build* drvs
+                           #:use-substitutes?
+                           (assoc-ref opts 'substitutes?))
+      (built-derivations drvs)
+      (return (derivation->output-path shepherd-launch)))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define %user-module
+  ;; Module in which the user configuration file is loaded.
+  (make-user-module '((gnu system)
+                      (gnu services))))
+
+(define (process-action store opts)
+  (let ((action (assoc-ref opts 'action)))
+    (match action
+      (('reconfigure . file)
+       (let* ((user-conf
+               (if file
+                   (load* file %user-module)
+                   (leave (G_ "no user configuration file specified~%"))))
+              (services (user-configuration-services user-conf)))
+         (format #t "~a\n" (run-with-store store
+                             (generate-sheperd-configuration services opts))))))))
+
+(define (guix-user . args)
+  (with-error-handling
+    (let ((opts  (parse-command-line args %options (list %default-options)))
+          (store (open-connection)))
+      (process-action store opts))))
-- 
2.13.1