dbus.scm 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (gnu services dbus)
  20. #:use-module (gnu services)
  21. #:use-module (gnu services shepherd)
  22. #:use-module (gnu system shadow)
  23. #:use-module (gnu system pam)
  24. #:use-module ((gnu packages glib) #:select (dbus))
  25. #:use-module (gnu packages polkit)
  26. #:use-module (gnu packages admin)
  27. #:use-module (guix gexp)
  28. #:use-module (guix records)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (ice-9 match)
  31. #:export (dbus-configuration
  32. dbus-configuration?
  33. dbus-root-service-type
  34. dbus-service
  35. polkit-service-type
  36. polkit-service))
  37. ;;;
  38. ;;; D-Bus.
  39. ;;;
  40. (define-record-type* <dbus-configuration>
  41. dbus-configuration make-dbus-configuration
  42. dbus-configuration?
  43. (dbus dbus-configuration-dbus ;<package>
  44. (default dbus))
  45. (services dbus-configuration-services ;list of <package>
  46. (default '())))
  47. (define (system-service-directory services)
  48. "Return the system service directory, containing @code{.service} files for
  49. all the services that may be activated by the daemon."
  50. (computed-file "dbus-system-services"
  51. (with-imported-modules '((guix build utils))
  52. #~(begin
  53. (use-modules (guix build utils)
  54. (srfi srfi-1))
  55. (define files
  56. (append-map (lambda (service)
  57. (find-files
  58. (string-append
  59. service
  60. "/share/dbus-1/system-services")
  61. "\\.service$"))
  62. (list #$@services)))
  63. (mkdir #$output)
  64. (for-each (lambda (file)
  65. (symlink file
  66. (string-append #$output "/"
  67. (basename file))))
  68. files)
  69. #t))))
  70. (define (dbus-configuration-directory services)
  71. "Return a directory contains the @code{system-local.conf} file for DBUS that
  72. includes the @code{etc/dbus-1/system.d} directories of each package listed in
  73. @var{services}."
  74. (define build
  75. #~(begin
  76. (use-modules (sxml simple)
  77. (srfi srfi-1))
  78. (define (services->sxml services)
  79. ;; Return the SXML 'includedir' clauses for DIRS.
  80. `(busconfig
  81. (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
  82. ;; First, the '.service' files of services subject to activation.
  83. ;; We use a fixed location under /etc because the setuid helper
  84. ;; looks for them in that location and nowhere else. See
  85. ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
  86. (servicedir "/etc/dbus-1/system-services")
  87. ,@(append-map (lambda (dir)
  88. `((includedir
  89. ,(string-append dir "/etc/dbus-1/system.d"))
  90. (servicedir ;for '.service' files
  91. ,(string-append dir "/share/dbus-1/services"))))
  92. services)))
  93. (mkdir #$output)
  94. ;; Provide /etc/dbus-1/system-services, which is where the setuid
  95. ;; helper looks for system service files.
  96. (symlink #$(system-service-directory services)
  97. (string-append #$output "/system-services"))
  98. ;; 'system-local.conf' is automatically included by the default
  99. ;; 'system.conf', so this is where we stuff our own things.
  100. (call-with-output-file (string-append #$output "/system-local.conf")
  101. (lambda (port)
  102. (sxml->xml (services->sxml (list #$@services))
  103. port)))))
  104. (computed-file "dbus-configuration" build))
  105. (define (dbus-etc-files config)
  106. "Return a list of FILES for @var{etc-service-type} to build the
  107. @code{/etc/dbus-1} directory."
  108. (list `("dbus-1" ,(dbus-configuration-directory
  109. (dbus-configuration-services config)))))
  110. (define %dbus-accounts
  111. ;; Accounts used by the system bus.
  112. (list (user-group (name "messagebus") (system? #t))
  113. (user-account
  114. (name "messagebus")
  115. (group "messagebus")
  116. (system? #t)
  117. (comment "D-Bus system bus user")
  118. (home-directory "/var/run/dbus")
  119. (shell (file-append shadow "/sbin/nologin")))))
  120. (define dbus-setuid-programs
  121. ;; Return the file name of the setuid program that we need.
  122. (match-lambda
  123. (($ <dbus-configuration> dbus services)
  124. (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
  125. (define (dbus-activation config)
  126. "Return an activation gexp for D-Bus using @var{config}."
  127. #~(begin
  128. (use-modules (guix build utils))
  129. (mkdir-p "/var/run/dbus")
  130. (let ((user (getpwnam "messagebus")))
  131. (chown "/var/run/dbus"
  132. (passwd:uid user) (passwd:gid user)))
  133. (unless (file-exists? "/etc/machine-id")
  134. (format #t "creating /etc/machine-id...~%")
  135. (let ((prog (string-append #$(dbus-configuration-dbus config)
  136. "/bin/dbus-uuidgen")))
  137. ;; XXX: We can't use 'system' because the initrd's
  138. ;; guile system(3) only works when 'sh' is in $PATH.
  139. (let ((pid (primitive-fork)))
  140. (if (zero? pid)
  141. (call-with-output-file "/etc/machine-id"
  142. (lambda (port)
  143. (close-fdes 1)
  144. (dup2 (port->fdes port) 1)
  145. (execl prog)))
  146. (waitpid pid)))))))
  147. (define dbus-shepherd-service
  148. (match-lambda
  149. (($ <dbus-configuration> dbus)
  150. (list (shepherd-service
  151. (documentation "Run the D-Bus system daemon.")
  152. (provision '(dbus-system))
  153. (requirement '(user-processes))
  154. (start #~(make-forkexec-constructor
  155. (list (string-append #$dbus "/bin/dbus-daemon")
  156. "--nofork" "--system")
  157. #:pid-file "/var/run/dbus/pid"))
  158. (stop #~(make-kill-destructor)))))))
  159. (define dbus-root-service-type
  160. (service-type (name 'dbus)
  161. (extensions
  162. (list (service-extension shepherd-root-service-type
  163. dbus-shepherd-service)
  164. (service-extension activation-service-type
  165. dbus-activation)
  166. (service-extension etc-service-type
  167. dbus-etc-files)
  168. (service-extension account-service-type
  169. (const %dbus-accounts))
  170. (service-extension setuid-program-service-type
  171. dbus-setuid-programs)))
  172. ;; Extensions consist of lists of packages (representing D-Bus
  173. ;; services) that we just concatenate.
  174. (compose concatenate)
  175. ;; The service's parameters field is extended by augmenting
  176. ;; its <dbus-configuration> 'services' field.
  177. (extend (lambda (config services)
  178. (dbus-configuration
  179. (inherit config)
  180. (services
  181. (append (dbus-configuration-services config)
  182. services)))))
  183. (default-value (dbus-configuration))))
  184. (define* (dbus-service #:key (dbus dbus) (services '()))
  185. "Return a service that runs the \"system bus\", using @var{dbus}, with
  186. support for @var{services}.
  187. @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
  188. facility. Its system bus is used to allow system services to communicate and
  189. be notified of system-wide events.
  190. @var{services} must be a list of packages that provide an
  191. @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
  192. and policy files. For example, to allow avahi-daemon to use the system bus,
  193. @var{services} must be equal to @code{(list avahi)}."
  194. (service dbus-root-service-type
  195. (dbus-configuration (dbus dbus)
  196. (services services))))
  197. ;;;
  198. ;;; Polkit privilege management service.
  199. ;;;
  200. (define-record-type* <polkit-configuration>
  201. polkit-configuration make-polkit-configuration
  202. polkit-configuration?
  203. (polkit polkit-configuration-polkit ;<package>
  204. (default polkit))
  205. (actions polkit-configuration-actions ;list of <package>
  206. (default '())))
  207. (define %polkit-accounts
  208. (list (user-group (name "polkitd") (system? #t))
  209. (user-account
  210. (name "polkitd")
  211. (group "polkitd")
  212. (system? #t)
  213. (comment "Polkit daemon user")
  214. (home-directory "/var/empty")
  215. (shell "/run/current-system/profile/sbin/nologin"))))
  216. (define %polkit-pam-services
  217. (list (unix-pam-service "polkit-1")))
  218. (define (polkit-directory packages)
  219. "Return a directory containing an @file{actions} and possibly a
  220. @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
  221. (with-imported-modules '((guix build union))
  222. (computed-file "etc-polkit-1"
  223. #~(begin
  224. (use-modules (guix build union) (srfi srfi-26))
  225. (union-build #$output
  226. (map (cut string-append <>
  227. "/share/polkit-1")
  228. (list #$@packages)))))))
  229. (define polkit-etc-files
  230. (match-lambda
  231. (($ <polkit-configuration> polkit packages)
  232. `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
  233. (define polkit-setuid-programs
  234. (match-lambda
  235. (($ <polkit-configuration> polkit)
  236. (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
  237. (file-append polkit "/bin/pkexec")))))
  238. (define polkit-service-type
  239. (service-type (name 'polkit)
  240. (extensions
  241. (list (service-extension account-service-type
  242. (const %polkit-accounts))
  243. (service-extension pam-root-service-type
  244. (const %polkit-pam-services))
  245. (service-extension dbus-root-service-type
  246. (compose
  247. list
  248. polkit-configuration-polkit))
  249. (service-extension etc-service-type
  250. polkit-etc-files)
  251. (service-extension setuid-program-service-type
  252. polkit-setuid-programs)))
  253. ;; Extensions are lists of packages that provide polkit rules
  254. ;; or actions under share/polkit-1/{actions,rules.d}.
  255. (compose concatenate)
  256. (extend (lambda (config actions)
  257. (polkit-configuration
  258. (inherit config)
  259. (actions
  260. (append (polkit-configuration-actions config)
  261. actions)))))
  262. (default-value (polkit-configuration))))
  263. (define* (polkit-service #:key (polkit polkit))
  264. "Return a service that runs the
  265. @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
  266. management service}, which allows system administrators to grant access to
  267. privileged operations in a structured way. By querying the Polkit service, a
  268. privileged system component can know when it should grant additional
  269. capabilities to ordinary users. For example, an ordinary user can be granted
  270. the capability to suspend the system if the user is logged in locally."
  271. (service polkit-service-type
  272. (polkit-configuration (polkit polkit))))
  273. ;;; dbus.scm ends here