services: Add 'profile-service-type'.

* gnu/services.scm (packages->profile-entry): New procedure.
  (profile-service-type): New variable.
* gnu/system.scm (operating-system-directory-base-entries): Remove
  the "profile" entry.
  (essential-services): Add a PROFILE-SERVICE-TYPE instance.
  (operating-system-profile): Rewrite in terms of 'fold-services'.
* doc/guix.texi (Service Reference): Add 'profile-service-type'.
* doc/images/service-graph.dot: Likewise.
This commit is contained in:
Ludovic Courtès 2015-11-02 21:52:28 +01:00
parent d62e201cfd
commit af4c3fd5e3
4 changed files with 41 additions and 10 deletions

View file

@ -7899,6 +7899,12 @@ executable file names, passed as gexps, and adds them to the set of
setuid-root programs on the system (@pxref{Setuid Programs}). setuid-root programs on the system (@pxref{Setuid Programs}).
@end defvr @end defvr
@defvr {Scheme Variable} profile-service-type
Type of the service that populates the @dfn{system profile}---i.e., the
programs under @file{/run/current-system/profile}. Other services can
extend it by passing it lists of packages to add to the system profile.
@end defvr
@node dmd Services @node dmd Services
@subsubsection dmd Services @subsubsection dmd Services

View file

@ -2,6 +2,7 @@ digraph "Service Type Dependencies" {
dmd [shape = box, fontname = Helvetica]; dmd [shape = box, fontname = Helvetica];
pam [shape = box, fontname = Helvetica]; pam [shape = box, fontname = Helvetica];
etc [shape = box, fontname = Helvetica]; etc [shape = box, fontname = Helvetica];
profile [shape = box, fontname = Helvetica];
accounts [shape = box, fontname = Helvetica]; accounts [shape = box, fontname = Helvetica];
activation [shape = box, fontname = Helvetica]; activation [shape = box, fontname = Helvetica];
boot [shape = box, fontname = Helvetica]; boot [shape = box, fontname = Helvetica];
@ -35,4 +36,5 @@ digraph "Service Type Dependencies" {
guix -> accounts; guix -> accounts;
boot -> system; boot -> system;
etc -> system; etc -> system;
profile -> system;
} }

View file

@ -21,6 +21,7 @@ (define-module (gnu services)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix profiles)
#:use-module (guix sets) #:use-module (guix sets)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (gnu packages base) #:use-module (gnu packages base)
@ -68,6 +69,7 @@ (define-module (gnu services)
etc-service-type etc-service-type
etc-directory etc-directory
setuid-program-service-type setuid-program-service-type
profile-service-type
firmware-service-type firmware-service-type
%boot-service %boot-service
@ -414,6 +416,23 @@ (define setuid-program-service-type
(compose concatenate) (compose concatenate)
(extend append))) (extend append)))
(define (packages->profile-entry packages)
"Return a system entry for the profile containing PACKAGES."
(mlet %store-monad ((profile (profile-derivation
(manifest (map package->manifest-entry
(delete-duplicates packages eq?))))))
(return `(("profile" ,profile)))))
(define profile-service-type
;; The service that populates the system's profile---i.e.,
;; /run/current-system/profile. It is extended by package lists.
(service-type (name 'profile)
(extensions
(list (service-extension system-service-type
packages->profile-entry)))
(compose concatenate)
(extend append)))
(define (firmware->activation-gexp firmware) (define (firmware->activation-gexp firmware)
"Return a gexp to make the packages listed in FIRMWARE loadable by the "Return a gexp to make the packages listed in FIRMWARE loadable by the
kernel." kernel."

View file

@ -257,11 +257,9 @@ (define (swap-services os)
(define* (operating-system-directory-base-entries os #:key container?) (define* (operating-system-directory-base-entries os #:key container?)
"Return the basic entries of the 'system' directory of OS for use as the "Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service." value of the SYSTEM-SERVICE-TYPE service."
(mlet* %store-monad ((profile (operating-system-profile os)) (mlet %store-monad ((locale (operating-system-locale-directory os)))
(locale (operating-system-locale-directory os)))
(if container? (if container?
(return `(("profile" ,profile) (return `(("locale" ,locale)))
("locale" ,locale)))
(mlet %store-monad (mlet %store-monad
((kernel -> (operating-system-kernel os)) ((kernel -> (operating-system-kernel os))
(initrd (operating-system-initrd-file os)) (initrd (operating-system-initrd-file os))
@ -269,7 +267,6 @@ (define* (operating-system-directory-base-entries os #:key container?)
(return `(("kernel" ,kernel) (return `(("kernel" ,kernel)
("parameters" ,params) ("parameters" ,params)
("initrd" ,initrd) ("initrd" ,initrd)
("profile" ,profile)
("locale" ,locale))))))) ;used by libc ("locale" ,locale))))))) ;used by libc
(define* (essential-services os #:key container?) (define* (essential-services os #:key container?)
@ -305,6 +302,8 @@ (define known-fs
host-name procs root-fs unmount host-name procs root-fs unmount
(service setuid-program-service-type (service setuid-program-service-type
(operating-system-setuid-programs os)) (operating-system-setuid-programs os))
(service profile-service-type
(operating-system-packages os))
(append other-fs mappings swaps (append other-fs mappings swaps
;; Add the firmware service, unless we are building for a ;; Add the firmware service, unless we are building for a
@ -534,11 +533,6 @@ (define* (operating-system-etc-service os)
#$(operating-system-timezone os))) #$(operating-system-timezone os)))
("sudoers" ,(operating-system-sudoers-file os)))))) ("sudoers" ,(operating-system-sudoers-file os))))))
(define (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
(profile-derivation (manifest (map package->manifest-entry
(operating-system-packages os)))))
(define %root-account (define %root-account
;; Default root account. ;; Default root account.
(user-account (user-account
@ -639,6 +633,16 @@ (define* (operating-system-derivation os #:key container?)
;; SYSTEM contains the derivation as a monadic value. ;; SYSTEM contains the derivation as a monadic value.
(service-parameters system))) (service-parameters system)))
(define* (operating-system-profile os #:key container?)
"Return a derivation that builds the system profile of OS."
(mlet* %store-monad
((services -> (operating-system-services os #:container? container?))
(profile (fold-services services
#:target-type profile-service-type)))
(match profile
(("profile" profile)
(return profile)))))
(define (operating-system-root-file-system os) (define (operating-system-root-file-system os)
"Return the root file system of OS." "Return the root file system of OS."
(find (match-lambda (find (match-lambda