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