From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mathieu Othacehe Subject: Re: Invoking user shepherd; Was: Re: Defining *user* services in Guix Date: Sun, 11 Jun 2017 10:33:00 +0200 Message-ID: <877f0iorer.fsf@gmail.com> References: <87o9vowfn0.fsf@gmail.com> <20170422203131.610f2a30@scratchpost.org> <878tmsghzk.fsf@gnu.org> <87inlvdr76.fsf@gmail.com> <87r30hbbi7.fsf@gmail.com> <87fugwsx2s.fsf@elephly.net> <8737cu7z0s.fsf@gnu.org> <877f24pnem.fsf@gmail.com> <87mvavk243.fsf@gnu.org> <20170611032900.6ac194b9@scratchpost.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:57625) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dJyJ6-0001V8-PE for guix-devel@gnu.org; Sun, 11 Jun 2017 04:33:14 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dJyJ3-0005Uy-3l for guix-devel@gnu.org; Sun, 11 Jun 2017 04:33:11 -0400 In-reply-to: <20170611032900.6ac194b9@scratchpost.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: Danny Milosavljevic Cc: guix-devel@gnu.org --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0001-user-services.patch Content-Transfer-Encoding: 8bit >From 1d02fd18b187bb5c8fae8413116a7608eb7e5088 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe 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 ;; 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 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 + 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 +;;; +;;; 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 . + +(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 --=-=-=--