[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