You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

281 lines
11 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gnu services shepherd)
  19. #:use-module (guix ui)
  20. #:use-module (guix sets)
  21. #:use-module (guix gexp)
  22. #:use-module (guix store)
  23. #:use-module (guix monads)
  24. #:use-module (guix records)
  25. #:use-module (guix derivations) ;imported-modules, etc.
  26. #:use-module (gnu services)
  27. #:use-module (gnu packages admin)
  28. #:use-module (ice-9 match)
  29. #:use-module (ice-9 vlist)
  30. #:use-module (srfi srfi-1)
  31. #:use-module (srfi srfi-26)
  32. #:use-module (srfi srfi-34)
  33. #:use-module (srfi srfi-35)
  34. #:export (shepherd-root-service-type
  35. %shepherd-root-service
  36. shepherd-service-type
  37. shepherd-service
  38. shepherd-service?
  39. shepherd-service-documentation
  40. shepherd-service-provision
  41. shepherd-service-canonical-name
  42. shepherd-service-requirement
  43. shepherd-service-respawn?
  44. shepherd-service-start
  45. shepherd-service-stop
  46. shepherd-service-auto-start?
  47. shepherd-service-modules
  48. %default-modules
  49. shepherd-service-file
  50. shepherd-service-back-edges))
  51. ;;; Commentary:
  52. ;;;
  53. ;;; Instantiating system services as a shepherd configuration file.
  54. ;;;
  55. ;;; Code:
  56. (define (shepherd-boot-gexp services)
  57. (mlet %store-monad ((shepherd-conf (shepherd-configuration-file services)))
  58. (return #~(begin
  59. ;; Keep track of the booted system.
  60. (false-if-exception (delete-file "/run/booted-system"))
  61. (symlink (readlink "/run/current-system")
  62. "/run/booted-system")
  63. ;; Close any remaining open file descriptors to be on the safe
  64. ;; side. This must be the very last thing we do, because
  65. ;; Guile has internal FDs such as 'sleep_pipe' that need to be
  66. ;; alive.
  67. (let loop ((fd 3))
  68. (when (< fd 1024)
  69. (false-if-exception (close-fdes fd))
  70. (loop (+ 1 fd))))
  71. ;; Start shepherd.
  72. (execl (string-append #$shepherd "/bin/shepherd")
  73. "shepherd" "--config" #$shepherd-conf)))))
  74. (define shepherd-root-service-type
  75. (service-type
  76. (name 'shepherd-root)
  77. ;; Extending the root shepherd service (aka. PID 1) happens by
  78. ;; concatenating the list of services provided by the extensions.
  79. (compose concatenate)
  80. (extend append)
  81. (extensions (list (service-extension boot-service-type
  82. shepherd-boot-gexp)
  83. (service-extension profile-service-type
  84. (const (list shepherd)))))))
  85. (define %shepherd-root-service
  86. ;; The root shepherd service, aka. PID 1. Its parameter is a list of
  87. ;; <shepherd-service> objects.
  88. (service shepherd-root-service-type '()))
  89. (define-syntax-rule (shepherd-service-type service-name proc)
  90. "Return a <service-type> denoting a simple shepherd service--i.e., the type
  91. for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
  92. (service-type
  93. (name service-name)
  94. (extensions
  95. (list (service-extension shepherd-root-service-type
  96. (compose list proc))))))
  97. (define %default-imported-modules
  98. ;; Default set of modules imported for a service's consumption.
  99. '((guix build utils)
  100. (guix build syscalls)))
  101. (define %default-modules
  102. ;; Default set of modules visible in a service's file.
  103. `((shepherd service)
  104. (oop goops)
  105. (guix build utils)
  106. (guix build syscalls)))
  107. (define-record-type* <shepherd-service>
  108. shepherd-service make-shepherd-service
  109. shepherd-service?
  110. (documentation shepherd-service-documentation ;string
  111. (default "[No documentation.]"))
  112. (provision shepherd-service-provision) ;list of symbols
  113. (requirement shepherd-service-requirement ;list of symbols
  114. (default '()))
  115. (respawn? shepherd-service-respawn? ;Boolean
  116. (default #t))
  117. (start shepherd-service-start) ;g-expression (procedure)
  118. (stop shepherd-service-stop ;g-expression (procedure)
  119. (default #~(const #f)))
  120. (auto-start? shepherd-service-auto-start? ;Boolean
  121. (default #t))
  122. (modules shepherd-service-modules ;list of module names
  123. (default %default-modules)))
  124. (define (shepherd-service-canonical-name service)
  125. "Return the 'canonical name' of SERVICE."
  126. (first (shepherd-service-provision service)))
  127. (define (assert-valid-graph services)
  128. "Raise an error if SERVICES does not define a valid shepherd service graph,
  129. for instance if a service requires a nonexistent service, or if more than one
  130. service uses a given name.
  131. These are constraints that shepherd's 'register-service' verifies but we'd
  132. better verify them here statically than wait until PID 1 halts with an
  133. assertion failure."
  134. (define provisions
  135. ;; The set of provisions (symbols). Bail out if a symbol is given more
  136. ;; than once.
  137. (fold (lambda (service set)
  138. (define (assert-unique symbol)
  139. (when (set-contains? set symbol)
  140. (raise (condition
  141. (&message
  142. (message
  143. (format #f (_ "service '~a' provided more than once")
  144. symbol)))))))
  145. (for-each assert-unique (shepherd-service-provision service))
  146. (fold set-insert set (shepherd-service-provision service)))
  147. (setq 'shepherd)
  148. services))
  149. (define (assert-satisfied-requirements service)
  150. ;; Bail out if the requirements of SERVICE aren't satisfied.
  151. (for-each (lambda (requirement)
  152. (unless (set-contains? provisions requirement)
  153. (raise (condition
  154. (&message
  155. (message
  156. (format #f (_ "service '~a' requires '~a', \
  157. which is not provided by any service")
  158. (match (shepherd-service-provision service)
  159. ((head . _) head)
  160. (_ service))
  161. requirement)))))))
  162. (shepherd-service-requirement service)))
  163. (for-each assert-satisfied-requirements services))
  164. (define (shepherd-service-file-name service)
  165. "Return the file name where the initialization code for SERVICE is to be
  166. stored."
  167. (let ((provisions (string-join (map symbol->string
  168. (shepherd-service-provision service)))))
  169. (string-append "shepherd-"
  170. (string-map (match-lambda
  171. (#\/ #\-)
  172. (chr chr))
  173. provisions)
  174. ".scm")))
  175. (define (shepherd-service-file service)
  176. "Return a file defining SERVICE."
  177. (gexp->file (shepherd-service-file-name service)
  178. (with-imported-modules %default-imported-modules
  179. #~(begin
  180. (use-modules #$@(shepherd-service-modules service))
  181. (make <service>
  182. #:docstring '#$(shepherd-service-documentation service)
  183. #:provides '#$(shepherd-service-provision service)
  184. #:requires '#$(shepherd-service-requirement service)
  185. #:respawn? '#$(shepherd-service-respawn? service)
  186. #:start #$(shepherd-service-start service)
  187. #:stop #$(shepherd-service-stop service))))))
  188. (define (shepherd-configuration-file services)
  189. "Return the shepherd configuration file for SERVICES."
  190. (assert-valid-graph services)
  191. (mlet %store-monad ((files (mapm %store-monad
  192. shepherd-service-file services)))
  193. (define config
  194. #~(begin
  195. (use-modules (srfi srfi-34)
  196. (system repl error-handling))
  197. ;; Arrange to spawn a REPL if something goes wrong. This is better
  198. ;; than a kernel panic.
  199. (call-with-error-handling
  200. (lambda ()
  201. (apply register-services (map primitive-load '#$files))
  202. ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around
  203. ;; it.
  204. (setenv "PATH" "/run/current-system/profile/bin")
  205. (format #t "starting services...~%")
  206. (for-each (lambda (service)
  207. ;; In the Shepherd 0.3 the 'start' method can raise
  208. ;; '&action-runtime-error' if it fails, so protect
  209. ;; against it. (XXX: 'action-runtime-error?' is not
  210. ;; exported is 0.3, hence 'service-error?'.)
  211. (guard (c ((service-error? c)
  212. (format (current-error-port)
  213. "failed to start service '~a'~%"
  214. service)))
  215. (start service)))
  216. '#$(append-map shepherd-service-provision
  217. (filter shepherd-service-auto-start?
  218. services)))))))
  219. (gexp->file "shepherd.conf" config)))
  220. (define (shepherd-service-back-edges services)
  221. "Return a procedure that, when given a <shepherd-service> from SERVICES,
  222. returns the list of <shepherd-service> that depend on it."
  223. (define provision->service
  224. (let ((services (fold (lambda (service result)
  225. (fold (cut vhash-consq <> service <>)
  226. result
  227. (shepherd-service-provision service)))
  228. vlist-null
  229. services)))
  230. (lambda (name)
  231. (match (vhash-assq name services)
  232. ((_ . service) service)
  233. (#f #f)))))
  234. (define edges
  235. (fold (lambda (service edges)
  236. (fold (lambda (requirement edges)
  237. (vhash-consq (provision->service requirement) service
  238. edges))
  239. edges
  240. (shepherd-service-requirement service)))
  241. vlist-null
  242. services))
  243. (lambda (service)
  244. (vhash-foldq* cons '() service edges)))
  245. ;;; shepherd.scm ends here