[jackhill/guix/guix.git] / gnu / services / dbus.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;;
;;; 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 (gnu services dbus)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module (gnu system pam)
  #:use-module ((gnu packages glib) #:select (dbus))
  #:use-module (gnu packages polkit)
  #:use-module (gnu packages admin)
  #:use-module (guix gexp)
  #:use-module ((guix packages) #:select (package-name))
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (dbus-configuration
            dbus-configuration?
            dbus-root-service-type
            dbus-service
            wrapped-dbus-service

            polkit-service-type
            polkit-service))

;;;
;;; D-Bus.
;;;

(define-record-type* <dbus-configuration>
  dbus-configuration make-dbus-configuration
  dbus-configuration?
  (dbus      dbus-configuration-dbus              ;<package>
             (default dbus))
  (services  dbus-configuration-services          ;list of <package>
             (default '())))

(define (system-service-directory services)
  "Return the system service directory, containing @code{.service} files for
all the services that may be activated by the daemon."
  (computed-file "dbus-system-services"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils)
                                    (srfi srfi-1))

                       (define files
                         (append-map (lambda (service)
                                       (find-files
                                        (string-append
                                         service
                                         "/share/dbus-1/")
                                        "\\.service$"))
                                     (list #$@services)))

                       (mkdir #$output)
                       (for-each (lambda (file)
                                   (symlink file
                                            (string-append #$output "/"
                                                           (basename file))))
                                 files)
                       #t))))

(define (dbus-configuration-directory services)
  "Return a directory contains the @code{system-local.conf} file for DBUS that
includes the @code{etc/dbus-1/system.d} directories of each package listed in
@var{services}."
  (define build
    #~(begin
        (use-modules (sxml simple)
                     (srfi srfi-1))

        (define (services->sxml services)
          ;; Return the SXML 'includedir' clauses for DIRS.
          `(busconfig
            (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")

            ;; First, the '.service' files of services subject to activation.
            ;; We use a fixed location under /etc because the setuid helper
            ;; looks for them in that location and nowhere else.  See
            ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
            (servicedir "/etc/dbus-1/system-services")

            ,@(append-map (lambda (dir)
                            `((includedir
                               ,(string-append dir "/etc/dbus-1/system.d"))
                              (servicedir       ;for '.service' files
                               ,(string-append dir "/share/dbus-1/services"))))
                          services)))

        (mkdir #$output)

        ;; Provide /etc/dbus-1/system-services, which is where the setuid
        ;; helper looks for system service files.
        (symlink #$(system-service-directory services)
                 (string-append #$output "/system-services"))

        ;; 'system-local.conf' is automatically included by the default
        ;; 'system.conf', so this is where we stuff our own things.
        (call-with-output-file (string-append #$output "/system-local.conf")
          (lambda (port)
            (sxml->xml (services->sxml (list #$@services))
                       port)))))

  (computed-file "dbus-configuration" build))

(define (dbus-etc-files config)
  "Return a list of FILES for @var{etc-service-type} to build the
@code{/etc/dbus-1} directory."
  (list `("dbus-1" ,(dbus-configuration-directory
                     (dbus-configuration-services config)))))

(define %dbus-accounts
  ;; Accounts used by the system bus.
  (list (user-group (name "messagebus") (system? #t))
        (user-account
         (name "messagebus")
         (group "messagebus")
         (system? #t)
         (comment "D-Bus system bus user")
         (home-directory "/var/run/dbus")
         (shell (file-append shadow "/sbin/nologin")))))

(define dbus-setuid-programs
  ;; Return the file name of the setuid program that we need.
  (match-lambda
    (($ <dbus-configuration> dbus services)
     (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))

(define (dbus-activation config)
  "Return an activation gexp for D-Bus using @var{config}."
  #~(begin
      (use-modules (guix build utils))

      (mkdir-p "/var/run/dbus")

      (let ((user (getpwnam "messagebus")))
        (chown "/var/run/dbus"
               (passwd:uid user) (passwd:gid user))

        ;; This directory contains the daemon's socket so it must be
        ;; world-readable.
        (chmod "/var/run/dbus" #o755))

      (unless (file-exists? "/etc/machine-id")
        (format #t "creating /etc/machine-id...~%")
        (let ((prog (string-append #$(dbus-configuration-dbus config)
                                   "/bin/dbus-uuidgen")))
          ;; XXX: We can't use 'system' because the initrd's
          ;; guile system(3) only works when 'sh' is in $PATH.
          (let ((pid (primitive-fork)))
            (if (zero? pid)
                (call-with-output-file "/etc/machine-id"
                  (lambda (port)
                    (close-fdes 1)
                    (dup2 (port->fdes port) 1)
                    (execl prog)))
                (waitpid pid)))))))

(define dbus-shepherd-service
  (match-lambda
    (($ <dbus-configuration> dbus)
     (list (shepherd-service
            (documentation "Run the D-Bus system daemon.")
            (provision '(dbus-system))
            (requirement '(user-processes))
            (start #~(make-forkexec-constructor
                      (list (string-append #$dbus "/bin/dbus-daemon")
                            "--nofork" "--system")
                      #:pid-file "/var/run/dbus/pid"))
            (stop #~(make-kill-destructor)))))))

(define dbus-root-service-type
  (service-type (name 'dbus)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          dbus-shepherd-service)
                       (service-extension activation-service-type
                                          dbus-activation)
                       (service-extension etc-service-type
                                          dbus-etc-files)
                       (service-extension account-service-type
                                          (const %dbus-accounts))
                       (service-extension setuid-program-service-type
                                          dbus-setuid-programs)))

                ;; Extensions consist of lists of packages (representing D-Bus
                ;; services) that we just concatenate.
                (compose concatenate)

                ;; The service's parameters field is extended by augmenting
                ;; its <dbus-configuration> 'services' field.
                (extend (lambda (config services)
                          (dbus-configuration
                           (inherit config)
                           (services
                            (append (dbus-configuration-services config)
                                    services)))))

                (default-value (dbus-configuration))))

(define* (dbus-service #:key (dbus dbus) (services '()))
  "Return a service that runs the \"system bus\", using @var{dbus}, with
support for @var{services}.

@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
facility.  Its system bus is used to allow system services to communicate and
be notified of system-wide events.

@var{services} must be a list of packages that provide an
@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
and policy files.  For example, to allow avahi-daemon to use the system bus,
@var{services} must be equal to @code{(list avahi)}."
  (service dbus-root-service-type
           (dbus-configuration (dbus dbus)
                               (services services))))

(define (wrapped-dbus-service service program variable value)
  "Return a wrapper for @var{service}, a package containing a D-Bus service,
where @var{program} is wrapped such that environment variable @var{variable}
is set to @var{value} when the bus daemon launches it."
  (define wrapper
    (program-file (string-append (package-name service) "-program-wrapper")
                  #~(begin
                      (setenv #$variable #$value)
                      (apply execl (string-append #$service "/" #$program)
                             (string-append #$service "/" #$program)
                             (cdr (command-line))))))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))

          (define service-directory
            "/share/dbus-1/system-services")

          (mkdir-p (dirname (string-append #$output
                                           service-directory)))
          (copy-recursively (string-append #$service
                                           service-directory)
                            (string-append #$output
                                           service-directory))
          (symlink (string-append #$service "/etc") ;for etc/dbus-1
                   (string-append #$output "/etc"))

          (for-each (lambda (file)
                      (substitute* file
                        (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
                          _ original-program arguments)
                         (string-append "Exec=" #$wrapper arguments
                                        "\n"))))
                    (find-files #$output "\\.service$")))))

  (computed-file (string-append (package-name service) "-wrapper")
                 build))

\f
;;;
;;; Polkit privilege management service.
;;;

(define-record-type* <polkit-configuration>
  polkit-configuration make-polkit-configuration
  polkit-configuration?
  (polkit   polkit-configuration-polkit           ;<package>
            (default polkit))
  (actions  polkit-configuration-actions          ;list of <package>
            (default '())))

(define %polkit-accounts
  (list (user-group (name "polkitd") (system? #t))
        (user-account
         (name "polkitd")
         (group "polkitd")
         (system? #t)
         (comment "Polkit daemon user")
         (home-directory "/var/empty")
         (shell "/run/current-system/profile/sbin/nologin"))))

(define %polkit-pam-services
  (list (unix-pam-service "polkit-1")))

(define (polkit-directory packages)
  "Return a directory containing an @file{actions} and possibly a
@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
  (with-imported-modules '((guix build union))
    (computed-file "etc-polkit-1"
                   #~(begin
                       (use-modules (guix build union) (srfi srfi-26))

                       (union-build #$output
                                    (map (cut string-append <>
                                              "/share/polkit-1")
                                         (list #$@packages)))))))

(define polkit-etc-files
  (match-lambda
    (($ <polkit-configuration> polkit packages)
     `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))

(define polkit-setuid-programs
  (match-lambda
    (($ <polkit-configuration> polkit)
     (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
           (file-append polkit "/bin/pkexec")))))

(define polkit-service-type
  (service-type (name 'polkit)
                (extensions
                 (list (service-extension account-service-type
                                          (const %polkit-accounts))
                       (service-extension pam-root-service-type
                                          (const %polkit-pam-services))
                       (service-extension dbus-root-service-type
                                          (compose
                                           list
                                           polkit-configuration-polkit))
                       (service-extension etc-service-type
                                          polkit-etc-files)
                       (service-extension setuid-program-service-type
                                          polkit-setuid-programs)))

                ;; Extensions are lists of packages that provide polkit rules
                ;; or actions under share/polkit-1/{actions,rules.d}.
                (compose concatenate)
                (extend (lambda (config actions)
                          (polkit-configuration
                           (inherit config)
                           (actions
                            (append (polkit-configuration-actions config)
                                    actions)))))

                (default-value (polkit-configuration))))

(define* (polkit-service #:key (polkit polkit))
  "Return a service that runs the
@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
management service}, which allows system administrators to grant access to
privileged operations in a structured way.  By querying the Polkit service, a
privileged system component can know when it should grant additional
capabilities to ordinary users.  For example, an ordinary user can be granted
the capability to suspend the system if the user is logged in locally."
  (service polkit-service-type
           (polkit-configuration (polkit polkit))))

;;; dbus.scm ends here
Commit	Line	Data
0adfe95a	1	;;; GNU Guix --- Functional package management for GNU
d429878d	2	;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
64643b90	3	;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
0adfe95a LC	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
	20	(define-module (gnu services dbus)
	21	#:use-module (gnu services)
0190c1c0	22	#:use-module (gnu services shepherd)
0adfe95a	23	#:use-module (gnu system shadow)
2e328698	24	#:use-module (gnu system pam)
f5a91039	25	#:use-module ((gnu packages glib) #:select (dbus))
2e328698	26	#:use-module (gnu packages polkit)
0adfe95a LC	27	#:use-module (gnu packages admin)
0adfe95a LC	28	#:use-module (guix gexp)
b68f6500	29	#:use-module ((guix packages) #:select (package-name))
0adfe95a LC	30	#:use-module (guix records)
	31	#:use-module (srfi srfi-1)
	32	#:use-module (ice-9 match)
24e96431 TČ	33	#:export (dbus-configuration
	34	dbus-configuration?
	35	dbus-root-service-type
2e328698	36	dbus-service
b68f6500	37	wrapped-dbus-service
2e328698 LC	38
	39	polkit-service-type
	40	polkit-service))
0adfe95a LC	41
	42	;;;
	43	;;; D-Bus.
	44	;;;
	45
	46	(define-record-type* <dbus-configuration>
	47	dbus-configuration make-dbus-configuration
	48	dbus-configuration?
	49	(dbus dbus-configuration-dbus ;<package>
f5a91039	50	(default dbus))
0adfe95a LC	51	(services dbus-configuration-services ;list of <package>
	52	(default '())))
	53
cde04021 LC	54	(define (system-service-directory services)
	55	"Return the system service directory, containing @code{.service} files for
	56	all the services that may be activated by the daemon."
	57	(computed-file "dbus-system-services"
4ee96a79 LC	58	(with-imported-modules '((guix build utils))
	59	#~(begin
	60	(use-modules (guix build utils)
	61	(srfi srfi-1))
cde04021	62
4ee96a79 LC	63	(define files
	64	(append-map (lambda (service)
	65	(find-files
	66	(string-append
	67	service
6a2b9065	68	"/share/dbus-1/")
4ee96a79 LC	69	"\\.service$"))
4ee96a79 LC	70	(list #$@services)))
cde04021	71
4ee96a79 LC	72	(mkdir #$output)
	73	(for-each (lambda (file)
	74	(symlink file
	75	(string-append #$output "/"
	76	(basename file))))
	77	files)
	78	#t))))
cde04021	79
64643b90 SB	80	(define (dbus-configuration-directory services)
	81	"Return a directory contains the @code{system-local.conf} file for DBUS that
	82	includes the @code{etc/dbus-1/system.d} directories of each package listed in
0adfe95a LC	83	@var{services}."
	84	(define build
	85	#~(begin
	86	(use-modules (sxml simple)
	87	(srfi srfi-1))
	88
	89	(define (services->sxml services)
	90	;; Return the SXML 'includedir' clauses for DIRS.
	91	`(busconfig
cde04021 LC	92	(servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
	93
	94	;; First, the '.service' files of services subject to activation.
	95	;; We use a fixed location under /etc because the setuid helper
	96	;; looks for them in that location and nowhere else. See
	97	;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
	98	(servicedir "/etc/dbus-1/system-services")
	99
0adfe95a LC	100	,@(append-map (lambda (dir)
	101	`((includedir
	102	,(string-append dir "/etc/dbus-1/system.d"))
cde04021 LC	103	(servicedir ;for '.service' files
cde04021 LC	104	,(string-append dir "/share/dbus-1/services"))))
0adfe95a LC	105	services)))
	106
	107	(mkdir #$output)
cde04021 LC	108
	109	;; Provide /etc/dbus-1/system-services, which is where the setuid
	110	;; helper looks for system service files.
	111	(symlink #$(system-service-directory services)
	112	(string-append #$output "/system-services"))
	113
0adfe95a LC	114	;; 'system-local.conf' is automatically included by the default
	115	;; 'system.conf', so this is where we stuff our own things.
	116	(call-with-output-file (string-append #$output "/system-local.conf")
	117	(lambda (port)
	118	(sxml->xml (services->sxml (list #$@services))
	119	port)))))
	120
	121	(computed-file "dbus-configuration" build))
	122
64643b90 SB	123	(define (dbus-etc-files config)
	124	"Return a list of FILES for @var{etc-service-type} to build the
	125	@code{/etc/dbus-1} directory."
	126	(list `("dbus-1" ,(dbus-configuration-directory
	127	(dbus-configuration-services config)))))
	128
0adfe95a LC	129	(define %dbus-accounts
	130	;; Accounts used by the system bus.
	131	(list (user-group (name "messagebus") (system? #t))
	132	(user-account
	133	(name "messagebus")
	134	(group "messagebus")
	135	(system? #t)
	136	(comment "D-Bus system bus user")
	137	(home-directory "/var/run/dbus")
9e41130b	138	(shell (file-append shadow "/sbin/nologin")))))
0adfe95a	139
cde04021 LC	140	(define dbus-setuid-programs
	141	;; Return the file name of the setuid program that we need.
	142	(match-lambda
	143	(($ <dbus-configuration> dbus services)
9e41130b	144	(list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
cde04021	145
0adfe95a LC	146	(define (dbus-activation config)
	147	"Return an activation gexp for D-Bus using @var{config}."
	148	#~(begin
	149	(use-modules (guix build utils))
	150
	151	(mkdir-p "/var/run/dbus")
	152
	153	(let ((user (getpwnam "messagebus")))
	154	(chown "/var/run/dbus"
d429878d LC	155	(passwd:uid user) (passwd:gid user))
	156
	157	;; This directory contains the daemon's socket so it must be
	158	;; world-readable.
	159	(chmod "/var/run/dbus" #o755))
0adfe95a LC	160
	161	(unless (file-exists? "/etc/machine-id")
	162	(format #t "creating /etc/machine-id...~%")
	163	(let ((prog (string-append #$(dbus-configuration-dbus config)
	164	"/bin/dbus-uuidgen")))
	165	;; XXX: We can't use 'system' because the initrd's
	166	;; guile system(3) only works when 'sh' is in $PATH.
	167	(let ((pid (primitive-fork)))
	168	(if (zero? pid)
	169	(call-with-output-file "/etc/machine-id"
	170	(lambda (port)
	171	(close-fdes 1)
	172	(dup2 (port->fdes port) 1)
	173	(execl prog)))
	174	(waitpid pid)))))))
	175
d4053c71	176	(define dbus-shepherd-service
4a663ca4 LC	177	(match-lambda
4a663ca4 LC	178	(($ <dbus-configuration> dbus)
d4053c71	179	(list (shepherd-service
4a663ca4 LC	180	(documentation "Run the D-Bus system daemon.")
	181	(provision '(dbus-system))
	182	(requirement '(user-processes))
	183	(start #~(make-forkexec-constructor
	184	(list (string-append #$dbus "/bin/dbus-daemon")
b9bb50c6 LC	185	"--nofork" "--system")
b9bb50c6 LC	186	#:pid-file "/var/run/dbus/pid"))
4a663ca4	187	(stop #~(make-kill-destructor)))))))
0adfe95a LC	188
	189	(define dbus-root-service-type
	190	(service-type (name 'dbus)
	191	(extensions
d4053c71 AK	192	(list (service-extension shepherd-root-service-type
d4053c71 AK	193	dbus-shepherd-service)
0adfe95a LC	194	(service-extension activation-service-type
0adfe95a LC	195	dbus-activation)
64643b90 SB	196	(service-extension etc-service-type
64643b90 SB	197	dbus-etc-files)
0adfe95a	198	(service-extension account-service-type
cde04021 LC	199	(const %dbus-accounts))
	200	(service-extension setuid-program-service-type
	201	dbus-setuid-programs)))
0adfe95a LC	202
	203	;; Extensions consist of lists of packages (representing D-Bus
	204	;; services) that we just concatenate.
0adfe95a LC	205	(compose concatenate)
	206
	207	;; The service's parameters field is extended by augmenting
	208	;; its <dbus-configuration> 'services' field.
	209	(extend (lambda (config services)
	210	(dbus-configuration
	211	(inherit config)
	212	(services
	213	(append (dbus-configuration-services config)
3e8d037b LC	214	services)))))
	215
	216	(default-value (dbus-configuration))))
0adfe95a	217
f5a91039	218	(define* (dbus-service #:key (dbus dbus) (services '()))
0adfe95a LC	219	"Return a service that runs the \"system bus\", using @var{dbus}, with
	220	support for @var{services}.
	221
	222	@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
	223	facility. Its system bus is used to allow system services to communicate and
	224	be notified of system-wide events.
	225
	226	@var{services} must be a list of packages that provide an
	227	@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
	228	and policy files. For example, to allow avahi-daemon to use the system bus,
	229	@var{services} must be equal to @code{(list avahi)}."
	230	(service dbus-root-service-type
	231	(dbus-configuration (dbus dbus)
	232	(services services))))
	233
b68f6500 LC	234	(define (wrapped-dbus-service service program variable value)
	235	"Return a wrapper for @var{service}, a package containing a D-Bus service,
	236	where @var{program} is wrapped such that environment variable @var{variable}
	237	is set to @var{value} when the bus daemon launches it."
	238	(define wrapper
	239	(program-file (string-append (package-name service) "-program-wrapper")
	240	#~(begin
	241	(setenv #$variable #$value)
	242	(apply execl (string-append #$service "/" #$program)
	243	(string-append #$service "/" #$program)
	244	(cdr (command-line))))))
	245
	246	(define build
	247	(with-imported-modules '((guix build utils))
	248	#~(begin
	249	(use-modules (guix build utils))
	250
	251	(define service-directory
	252	"/share/dbus-1/system-services")
	253
	254	(mkdir-p (dirname (string-append #$output
	255	service-directory)))
	256	(copy-recursively (string-append #$service
	257	service-directory)
	258	(string-append #$output
	259	service-directory))
	260	(symlink (string-append #$service "/etc") ;for etc/dbus-1
	261	(string-append #$output "/etc"))
	262
	263	(for-each (lambda (file)
	264	(substitute* file
	265	(("Exec[[:blank:]]=[[:blank:]]([[:graph:]]+)(.*)$"
	266	_ original-program arguments)
	267	(string-append "Exec=" #$wrapper arguments
	268	"\n"))))
	269	(find-files #$output "\\.service$")))))
	270
	271	(computed-file (string-append (package-name service) "-wrapper")
	272	build))
	273
2e328698 LC	274	\f
	275	;;;
	276	;;; Polkit privilege management service.
	277	;;;
	278
	279	(define-record-type* <polkit-configuration>
	280	polkit-configuration make-polkit-configuration
	281	polkit-configuration?
	282	(polkit polkit-configuration-polkit ;<package>
	283	(default polkit))
	284	(actions polkit-configuration-actions ;list of <package>
	285	(default '())))
	286
	287	(define %polkit-accounts
	288	(list (user-group (name "polkitd") (system? #t))
	289	(user-account
	290	(name "polkitd")
	291	(group "polkitd")
	292	(system? #t)
	293	(comment "Polkit daemon user")
	294	(home-directory "/var/empty")
	295	(shell "/run/current-system/profile/sbin/nologin"))))
	296
	297	(define %polkit-pam-services
	298	(list (unix-pam-service "polkit-1")))
	299
	300	(define (polkit-directory packages)
	301	"Return a directory containing an @file{actions} and possibly a
	302	@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
	303	(with-imported-modules '((guix build union))
	304	(computed-file "etc-polkit-1"
	305	#~(begin
	306	(use-modules (guix build union) (srfi srfi-26))
	307
	308	(union-build #$output
	309	(map (cut string-append <>
	310	"/share/polkit-1")
	311	(list #$@packages)))))))
	312
	313	(define polkit-etc-files
	314	(match-lambda
	315	(($ <polkit-configuration> polkit packages)
	316	`(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
	317
	318	(define polkit-setuid-programs
	319	(match-lambda
	320	(($ <polkit-configuration> polkit)
	321	(list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
	322	(file-append polkit "/bin/pkexec")))))
	323
	324	(define polkit-service-type
	325	(service-type (name 'polkit)
	326	(extensions
	327	(list (service-extension account-service-type
	328	(const %polkit-accounts))
	329	(service-extension pam-root-service-type
	330	(const %polkit-pam-services))
	331	(service-extension dbus-root-service-type
	332	(compose
	333	list
	334	polkit-configuration-polkit))
	335	(service-extension etc-service-type
	336	polkit-etc-files)
	337	(service-extension setuid-program-service-type
338	polkit-setuid-programs)))
339
340	;; Extensions are lists of packages that provide polkit rules
341	;; or actions under share/polkit-1/{actions,rules.d}.
342	(compose concatenate)
343	(extend (lambda (config actions)
344	(polkit-configuration
345	(inherit config)
346	(actions
347	(append (polkit-configuration-actions config)
3e8d037b LC	348	actions)))))
	349
	350	(default-value (polkit-configuration))))
2e328698 LC	351
	352	(define* (polkit-service #:key (polkit polkit))
	353	"Return a service that runs the
	354	@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
	355	management service}, which allows system administrators to grant access to
	356	privileged operations in a structured way. By querying the Polkit service, a
	357	privileged system component can know when it should grant additional
	358	capabilities to ordinary users. For example, an ordinary user can be granted
	359	the capability to suspend the system if the user is logged in locally."
	360	(service polkit-service-type
	361	(polkit-configuration (polkit polkit))))
	362
0adfe95a	363	;;; dbus.scm ends here