guix-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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


From: Mathieu Othacehe
Subject: Re: Invoking user shepherd; Was: Re: Defining *user* services in Guix
Date: Sun, 11 Jun 2017 10:33:00 +0200
User-agent: mu4e 0.9.18; emacs 25.2.1

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
>From 1d02fd18b187bb5c8fae8413116a7608eb7e5088 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <address@hidden>
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))
+
 
 ;;;
 ;;; 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 <address@hidden>
+;;;
+;;; 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))
+
+
+;;;
+;;; 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))
+
+
+;;;
+;;; 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)))))
+
+
+;;;
+;;; 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


reply via email to

[Prev in Thread] Current Thread [Next in Thread]