gnu/services.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Chris Marusich <cmmarusich@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
  20 (define-module (gnu services)
  21   #:use-module (guix gexp)
  22   #:use-module (guix monads)
  23   #:use-module (guix store)
  24   #:use-module (guix records)
  25   #:use-module (guix profiles)
  26   #:use-module (guix discovery)
  27   #:use-module (guix sets)
  28   #:use-module (guix ui)
  29   #:use-module ((guix utils) #:select (source-properties->location))
  30   #:use-module (guix modules)
  31   #:use-module (gnu packages base)
  32   #:use-module (gnu packages bash)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-9)
  35   #:use-module (srfi srfi-9 gnu)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:use-module (ice-9 vlist)
  40   #:use-module (ice-9 match)
  41   #:export (service-extension
  42             service-extension?
  43             service-extension-target
  44             service-extension-compute
  45
  46             service-type
  47             service-type?
  48             service-type-name
  49             service-type-extensions
  50             service-type-compose
  51             service-type-extend
  52             service-type-default-value
  53             service-type-description
  54             service-type-location
  55
  56             %service-type-path
  57             fold-service-types
  58
  59             service
  60             service?
  61             service-kind
  62             service-value
  63             service-parameters                    ;deprecated
  64
  65             simple-service
  66             modify-services
  67             service-back-edges
  68             fold-services
  69
  70             service-error?
  71             missing-value-service-error?
  72             missing-value-service-error-type
  73             missing-value-service-error-location
  74             missing-target-service-error?
  75             missing-target-service-error-service
  76             missing-target-service-error-target-type
  77             ambiguous-target-service-error?
  78             ambiguous-target-service-error-service
  79             ambiguous-target-service-error-target-type
  80
  81             system-service-type
  82             boot-service-type
  83             cleanup-service-type
  84             activation-service-type
  85             activation-service->script
  86             %linux-bare-metal-service
  87             special-files-service-type
  88             extra-special-file
  89             etc-service-type
  90             etc-directory
  91             setuid-program-service-type
  92             profile-service-type
  93             firmware-service-type
  94             gc-root-service-type
  95
  96             %boot-service
  97             %activation-service
  98             etc-service))
  99
 100 ;;; Comment:
 101 ;;;
 102 ;;; This module defines a broad notion of "service types" and "services."
 103 ;;;
 104 ;;; A service type describe how its instances extend instances of other
 105 ;;; service types.  For instance, some services extend the instance of
 106 ;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
 107 ;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
 108 ;;; <shepherd-service>.
 109 ;;;
 110 ;;; When applicable, the service type defines how it can itself be extended,
 111 ;;; by providing one procedure to compose extensions, and one procedure to
 112 ;;; extend itself.
 113 ;;;
 114 ;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
 115 ;;; instance, which is the root of the service DAG.  Its value is the
 116 ;;; derivation that produces the 'system' directory as returned by
 117 ;;; 'operating-system-derivation'.
 118 ;;;
 119 ;;; The 'fold-services' procedure can be passed a list of procedures, which it
 120 ;;; "folds" by propagating extensions down the graph; it returns the root
 121 ;;; service after the applying all its extensions.
 122 ;;;
 123 ;;; Code:
 124
 125 (define-record-type <service-extension>
 126   (service-extension target compute)
 127   service-extension?
 128   (target  service-extension-target)              ;<service-type>
 129   (compute service-extension-compute))            ;params -> params
 130
 131 (define &no-default-value
 132   ;; Value used to denote service types that have no associated default value.
 133   '(no default value))
 134
 135 (define-record-type* <service-type> service-type make-service-type
 136   service-type?
 137   (name       service-type-name)                  ;symbol (for debugging)
 138
 139   ;; Things extended by services of this type.
 140   (extensions service-type-extensions)            ;list of <service-extensions>
 141
 142   ;; Given a list of extensions, "compose" them.
 143   (compose    service-type-compose                ;list of Any -> Any
 144               (default #f))
 145
 146   ;; Extend the services' own parameters with the extension composition.
 147   (extend     service-type-extend                 ;list of Any -> parameters
 148               (default #f))
 149
 150   ;; Optional default value for instances of this type.
 151   (default-value service-type-default-value       ;Any
 152                  (default &no-default-value))
 153
 154   ;; Meta-data.
 155   (description  service-type-description          ;string
 156                 (default #f))
 157   (location     service-type-location             ;<location>
 158                 (default (and=> (current-source-location)
 159                                 source-properties->location))
 160                 (innate)))
 161
 162 (define (write-service-type type port)
 163   (format port "#<service-type ~a ~a>"
 164           (service-type-name type)
 165           (number->string (object-address type) 16)))
 166
 167 (set-record-type-printer! <service-type> write-service-type)
 168
 169 (define %distro-root-directory
 170   ;; Absolute file name of the module hierarchy.
 171   (dirname (search-path %load-path "guix.scm")))
 172
 173 (define %service-type-path
 174   ;; Search path for service types.
 175   (make-parameter `((,%distro-root-directory . "gnu/services")
 176                     (,%distro-root-directory . "gnu/system"))))
 177
 178 (define* (fold-service-types proc seed
 179                              #:optional
 180                              (modules (all-modules (%service-type-path))))
 181   "For each service type exported by one of MODULES, call (PROC RESULT).  SEED
 182 is used as the initial value of RESULT."
 183   (fold-module-public-variables (lambda (object result)
 184                                   (if (service-type? object)
 185                                       (proc object result)
 186                                       result))
 187                                 seed
 188                                 modules))
 189
 190 ;; Services of a given type.
 191 (define-record-type <service>
 192   (make-service type value)
 193   service?
 194   (type       service-kind)
 195   (value      service-value))
 196
 197 (define-syntax service
 198   (syntax-rules ()
 199     "Return a service instance of TYPE.  The service value is VALUE or, if
 200 omitted, TYPE's default value."
 201     ((_ type value)
 202      (make-service type value))
 203     ((_ type)
 204      (%service-with-default-value (current-source-location)
 205                                   type))))
 206
 207 (define (%service-with-default-value location type)
 208   "Return a instance of service type TYPE with its default value, if any.  If
 209 TYPE does not have a default value, an error is raised."
 210   ;; TODO: Currently this is a run-time error but with a little bit macrology
 211   ;; we could turn it into an expansion-time error.
 212   (let ((default (service-type-default-value type)))
 213     (if (eq? default &no-default-value)
 214         (let ((location (source-properties->location location)))
 215           (raise
 216            (condition
 217             (&missing-value-service-error (type type) (location location))
 218             (&message
 219              (message (format #f (G_ "~a: no value specified \
 220 for service of type '~a'")
 221                               (location->string location)
 222                               (service-type-name type)))))))
 223         (service type default))))
 224
 225 (define-condition-type &service-error &error
 226   service-error?)
 227
 228 (define-condition-type &missing-value-service-error &service-error
 229   missing-value-service-error?
 230   (type     missing-value-service-error-type)
 231   (location missing-value-service-error-location))
 232
 233
 234 \f
 235 ;;;
 236 ;;; Helpers.
 237 ;;;
 238
 239 (define service-parameters
 240   ;; Deprecated alias.
 241   service-value)
 242
 243 (define (simple-service name target value)
 244   "Return a service that extends TARGET with VALUE.  This works by creating a
 245 singleton service type NAME, of which the returned service is an instance."
 246   (let* ((extension (service-extension target identity))
 247          (type      (service-type (name name)
 248                                   (extensions (list extension)))))
 249     (service type value)))
 250
 251 (define-syntax %modify-service
 252   (syntax-rules (=>)
 253     ((_ service)
 254      service)
 255     ((_ svc (kind param => exp ...) clauses ...)
 256      (if (eq? (service-kind svc) kind)
 257          (let ((param (service-value svc)))
 258            (service (service-kind svc)
 259                     (begin exp ...)))
 260          (%modify-service svc clauses ...)))))
 261
 262 (define-syntax modify-services
 263   (syntax-rules ()
 264     "Modify the services listed in SERVICES according to CLAUSES and return
 265 the resulting list of services.  Each clause must have the form:
 266
 267   (TYPE VARIABLE => BODY)
 268
 269 where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
 270 identifier that is bound within BODY to the value of the service of that
 271 TYPE.  Consider this example:
 272
 273   (modify-services %base-services
 274     (guix-service-type config =>
 275                        (guix-configuration
 276                         (inherit config)
 277                         (use-substitutes? #f)
 278                         (extra-options '(\"--gc-keep-derivations\"))))
 279     (mingetty-service-type config =>
 280                            (mingetty-configuration
 281                             (inherit config)
 282                             (motd (plain-file \"motd\" \"Hi there!\")))))
 283
 284 It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
 285 all the MINGETTY-SERVICE-TYPE instances.
 286
 287 This is a shorthand for (map (lambda (svc) ...) %base-services)."
 288     ((_ services clauses ...)
 289      (map (lambda (service)
 290             (%modify-service service clauses ...))
 291           services))))
 292
 293 \f
 294 ;;;
 295 ;;; Core services.
 296 ;;;
 297
 298 (define (system-derivation mentries mextensions)
 299   "Return as a monadic value the derivation of the 'system' directory
 300 containing the given entries."
 301   (mlet %store-monad ((entries    mentries)
 302                       (extensions (sequence %store-monad mextensions)))
 303     (lower-object
 304      (file-union "system"
 305                  (append entries (concatenate extensions))))))
 306
 307 (define system-service-type
 308   ;; This is the ultimate service type, the root of the service DAG.  The
 309   ;; service of this type is extended by monadic name/item pairs.  These items
 310   ;; end up in the "system directory" as returned by
 311   ;; 'operating-system-derivation'.
 312   (service-type (name 'system)
 313                 (extensions '())
 314                 (compose identity)
 315                 (extend system-derivation)))
 316
 317 (define (compute-boot-script _ mexps)
 318   (mlet %store-monad ((gexps (sequence %store-monad mexps)))
 319     (gexp->file "boot"
 320                 ;; Clean up and activate the system, then spawn shepherd.
 321                 #~(begin #$@gexps))))
 322
 323 (define (boot-script-entry mboot)
 324   "Return, as a monadic value, an entry for the boot script in the system
 325 directory."
 326   (mlet %store-monad ((boot mboot))
 327     (return `(("boot" ,boot)))))
 328
 329 (define boot-service-type
 330   ;; The service of this type is extended by being passed gexps as monadic
 331   ;; values.  It aggregates them in a single script, as a monadic value, which
 332   ;; becomes its 'parameters'.  It is the only service that extends nothing.
 333   (service-type (name 'boot)
 334                 (extensions
 335                  (list (service-extension system-service-type
 336                                           boot-script-entry)))
 337                 (compose append)
 338                 (extend compute-boot-script)))
 339
 340 (define %boot-service
 341   ;; The service that produces the boot script.
 342   (service boot-service-type #t))
 343
 344 (define (cleanup-gexp _)
 345   "Return as a monadic value a gexp to clean up /tmp and similar places upon
 346 boot."
 347   (with-monad %store-monad
 348     (with-imported-modules '((guix build utils))
 349       (return #~(begin
 350                   (use-modules (guix build utils))
 351
 352                   ;; Clean out /tmp and /var/run.
 353                   ;;
 354                   ;; XXX This needs to happen before service activations, so it
 355                   ;; has to be here, but this also implicitly assumes that /tmp
 356                   ;; and /var/run are on the root partition.
 357                   (letrec-syntax ((fail-safe (syntax-rules ()
 358                                                ((_ exp rest ...)
 359                                                 (begin
 360                                                   (catch 'system-error
 361                                                     (lambda () exp)
 362                                                     (const #f))
 363                                                   (fail-safe rest ...)))
 364                                                ((_)
 365                                                 #t))))
 366                     ;; Ignore I/O errors so the system can boot.
 367                     (fail-safe
 368                      ;; Remove stale Shadow lock files as they would lead to
 369                      ;; failures of 'useradd' & co.
 370                      (delete-file "/etc/group.lock")
 371                      (delete-file "/etc/passwd.lock")
 372                      (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
 373
 374                      (delete-file-recursively "/tmp")
 375                      (delete-file-recursively "/var/run")
 376                      (mkdir "/tmp")
 377                      (chmod "/tmp" #o1777)
 378                      (mkdir "/var/run")
 379                      (chmod "/var/run" #o755))))))))
 380
 381 (define cleanup-service-type
 382   ;; Service that cleans things up in /tmp and similar.
 383   (service-type (name 'cleanup)
 384                 (extensions
 385                  (list (service-extension boot-service-type
 386                                           cleanup-gexp)))))
 387
 388 (define* (activation-service->script service)
 389   "Return as a monadic value the activation script for SERVICE, a service of
 390 ACTIVATION-SCRIPT-TYPE."
 391   (activation-script (service-value service)))
 392
 393 (define (activation-script gexps)
 394   "Return the system's activation script, which evaluates GEXPS."
 395   (define (service-activations)
 396     ;; Return the activation scripts for SERVICES.
 397     (mapm %store-monad
 398           (cut gexp->file "activate-service" <>)
 399           gexps))
 400
 401   (mlet* %store-monad ((actions (service-activations)))
 402     (gexp->file "activate"
 403                 (with-imported-modules (source-module-closure
 404                                         '((gnu build activation)
 405                                           (guix build utils)))
 406                   #~(begin
 407                       (use-modules (gnu build activation)
 408                                    (guix build utils))
 409
 410                       ;; Make sure the user accounting database exists.  If it
 411                       ;; does not exist, 'setutxent' does not create it and
 412                       ;; thus there is no accounting at all.
 413                       (close-port (open-file "/var/run/utmpx" "a0"))
 414
 415                       ;; Same for 'wtmp', which is populated by mingetty et
 416                       ;; al.
 417                       (mkdir-p "/var/log")
 418                       (close-port (open-file "/var/log/wtmp" "a0"))
 419
 420                       ;; Set up /run/current-system.  Among other things this
 421                       ;; sets up locales, which the activation snippets
 422                       ;; executed below may expect.
 423                       (activate-current-system)
 424
 425                       ;; Run the services' activation snippets.
 426                       ;; TODO: Use 'load-compiled'.
 427                       (for-each primitive-load '#$actions))))))
 428
 429 (define (gexps->activation-gexp gexps)
 430   "Return a gexp that runs the activation script containing GEXPS."
 431   (mlet %store-monad ((script (activation-script gexps)))
 432     (return #~(primitive-load #$script))))
 433
 434 (define (second-argument a b) b)
 435
 436 (define activation-service-type
 437   (service-type (name 'activate)
 438                 (extensions
 439                  (list (service-extension boot-service-type
 440                                           gexps->activation-gexp)))
 441                 (compose append)
 442                 (extend second-argument)))
 443
 444 (define %activation-service
 445   ;; The activation service produces the activation script from the gexps it
 446   ;; receives.
 447   (service activation-service-type #t))
 448
 449 (define %modprobe-wrapper
 450   ;; Wrapper for the 'modprobe' command that knows where modules live.
 451   ;;
 452   ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
 453   ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
 454   ;; environment variable is not set---hence the need for this wrapper.
 455   (let ((modprobe "/run/current-system/profile/bin/modprobe"))
 456     (program-file "modprobe"
 457                   #~(begin
 458                       (setenv "LINUX_MODULE_DIRECTORY"
 459                               "/run/booted-system/kernel/lib/modules")
 460                       (apply execl #$modprobe
 461                              (cons #$modprobe (cdr (command-line))))))))
 462
 463 (define %linux-kernel-activation
 464   ;; Activation of the Linux kernel running on the bare metal (as opposed to
 465   ;; running in a container.)
 466   #~(begin
 467       ;; Tell the kernel to use our 'modprobe' command.
 468       (activate-modprobe #$%modprobe-wrapper)
 469
 470       ;; Let users debug their own processes!
 471       (activate-ptrace-attach)))
 472
 473 (define %linux-bare-metal-service
 474   ;; The service that does things that are needed on the "bare metal", but not
 475   ;; necessary or impossible in a container.
 476   (simple-service 'linux-bare-metal
 477                   activation-service-type
 478                   %linux-kernel-activation))
 479
 480
 481 (define special-files-service-type
 482   ;; Service to install "special files" such as /bin/sh and /usr/bin/env.
 483   (service-type
 484    (name 'special-files)
 485    (extensions
 486     (list (service-extension activation-service-type
 487                              (lambda (files)
 488                                #~(activate-special-files '#$files)))))
 489    (compose concatenate)
 490    (extend append)))
 491
 492 (define (extra-special-file file target)
 493   "Use TARGET as the \"special file\" FILE.  For example, TARGET might be
 494   (file-append coreutils \"/bin/env\")
 495 and FILE could be \"/usr/bin/env\"."
 496   (simple-service (string->symbol (string-append "special-file-" file))
 497                   special-files-service-type
 498                   `((,file ,target))))
 499
 500 (define (etc-directory service)
 501   "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
 502   (files->etc-directory (service-value service)))
 503
 504 (define (files->etc-directory files)
 505   (file-union "etc" files))
 506
 507 (define (etc-entry files)
 508   "Return an entry for the /etc directory consisting of FILES in the system
 509 directory."
 510   (with-monad %store-monad
 511     (return `(("etc" ,(files->etc-directory files))))))
 512
 513 (define etc-service-type
 514   (service-type (name 'etc)
 515                 (extensions
 516                  (list
 517                   (service-extension activation-service-type
 518                                      (lambda (files)
 519                                        (let ((etc
 520                                               (files->etc-directory files)))
 521                                          #~(activate-etc #$etc))))
 522                   (service-extension system-service-type etc-entry)))
 523                 (compose concatenate)
 524                 (extend append)))
 525
 526 (define (etc-service files)
 527   "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
 528 FILES must be a list of name/file-like object pairs."
 529   (service etc-service-type files))
 530
 531 (define setuid-program-service-type
 532   (service-type (name 'setuid-program)
 533                 (extensions
 534                  (list (service-extension activation-service-type
 535                                           (lambda (programs)
 536                                             #~(activate-setuid-programs
 537                                                (list #$@programs))))))
 538                 (compose concatenate)
 539                 (extend append)))
 540
 541 (define (packages->profile-entry packages)
 542   "Return a system entry for the profile containing PACKAGES."
 543   (mlet %store-monad ((profile (profile-derivation
 544                                 (packages->manifest
 545                                  (delete-duplicates packages eq?)))))
 546     (return `(("profile" ,profile)))))
 547
 548 (define profile-service-type
 549   ;; The service that populates the system's profile---i.e.,
 550   ;; /run/current-system/profile.  It is extended by package lists.
 551   (service-type (name 'profile)
 552                 (extensions
 553                  (list (service-extension system-service-type
 554                                           packages->profile-entry)))
 555                 (compose concatenate)
 556                 (extend append)))
 557
 558 (define (firmware->activation-gexp firmware)
 559   "Return a gexp to make the packages listed in FIRMWARE loadable by the
 560 kernel."
 561   (let ((directory (directory-union "firmware" firmware)))
 562     ;; Tell the kernel where firmware is.
 563     #~(activate-firmware (string-append #$directory "/lib/firmware"))))
 564
 565 (define firmware-service-type
 566   ;; The service that collects firmware.
 567   (service-type (name 'firmware)
 568                 (extensions
 569                  (list (service-extension activation-service-type
 570                                           firmware->activation-gexp)))
 571                 (compose concatenate)
 572                 (extend append)))
 573
 574 (define (gc-roots->system-entry roots)
 575   "Return an entry in the system's output containing symlinks to ROOTS."
 576   (mlet %store-monad ((entry (gexp->derivation
 577                               "gc-roots"
 578                               #~(let ((roots '#$roots))
 579                                   (mkdir #$output)
 580                                   (chdir #$output)
 581                                   (for-each symlink
 582                                             roots
 583                                             (map number->string
 584                                                  (iota (length roots))))))))
 585     (return (if (null? roots)
 586                 '()
 587                 `(("gc-roots" ,entry))))))
 588
 589 (define gc-root-service-type
 590   ;; A service to associate extra garbage-collector roots to the system.  This
 591   ;; is a simple hack that guarantees that the system retains references to
 592   ;; the given list of roots.  Roots must be "lowerable" objects like
 593   ;; packages, or derivations.
 594   (service-type (name 'gc-roots)
 595                 (extensions
 596                  (list (service-extension system-service-type
 597                                           gc-roots->system-entry)))
 598                 (compose concatenate)
 599                 (extend append)))
 600
 601 \f
 602 ;;;
 603 ;;; Service folding.
 604 ;;;
 605
 606 (define-condition-type &missing-target-service-error &service-error
 607   missing-target-service-error?
 608   (service      missing-target-service-error-service)
 609   (target-type  missing-target-service-error-target-type))
 610
 611 (define-condition-type &ambiguous-target-service-error &service-error
 612   ambiguous-target-service-error?
 613   (service      ambiguous-target-service-error-service)
 614   (target-type  ambiguous-target-service-error-target-type))
 615
 616 (define (service-back-edges services)
 617   "Return a procedure that, when passed a <service>, returns the list of
 618 <service> objects that depend on it."
 619   (define (add-edges service edges)
 620     (define (add-edge extension edges)
 621       (let ((target-type (service-extension-target extension)))
 622         (match (filter (lambda (service)
 623                          (eq? (service-kind service) target-type))
 624                        services)
 625           ((target)
 626            (vhash-consq target service edges))
 627           (()
 628            (raise
 629             (condition (&missing-target-service-error
 630                         (service service)
 631                         (target-type target-type))
 632                        (&message
 633                         (message
 634                          (format #f (G_ "no target of type '~a' for service '~a'")
 635                                  (service-type-name target-type)
 636                                  (service-type-name
 637                                   (service-kind service))))))))
 638           (x
 639            (raise
 640             (condition (&ambiguous-target-service-error
 641                         (service service)
 642                         (target-type target-type))
 643                        (&message
 644                         (message
 645                          (format #f
 646                                  (G_ "more than one target service of type '~a'")
 647                                  (service-type-name target-type))))))))))
 648
 649     (fold add-edge edges (service-type-extensions (service-kind service))))
 650
 651   (let ((edges (fold add-edges vlist-null services)))
 652     (lambda (node)
 653       (reverse (vhash-foldq* cons '() node edges)))))
 654
 655 (define* (fold-services services
 656                         #:key (target-type system-service-type))
 657   "Fold SERVICES by propagating their extensions down to the root of type
 658 TARGET-TYPE; return the root service adjusted accordingly."
 659   (define dependents
 660     (service-back-edges services))
 661
 662   (define (matching-extension target)
 663     (let ((target (service-kind target)))
 664       (match-lambda
 665         (($ <service-extension> type)
 666          (eq? type target)))))
 667
 668   (define (apply-extension target)
 669     (lambda (service)
 670       (match (find (matching-extension target)
 671                    (service-type-extensions (service-kind service)))
 672         (($ <service-extension> _ compute)
 673          (compute (service-value service))))))
 674
 675   (match (filter (lambda (service)
 676                    (eq? (service-kind service) target-type))
 677                  services)
 678     ((sink)
 679      (let loop ((sink sink))
 680        (let* ((dependents (map loop (dependents sink)))
 681               (extensions (map (apply-extension sink) dependents))
 682               (extend     (service-type-extend (service-kind sink)))
 683               (compose    (service-type-compose (service-kind sink)))
 684               (params     (service-value sink)))
 685          ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a
 686          ;; different type than the elements of EXTENSIONS.
 687          (if extend
 688              (service (service-kind sink)
 689                       (extend params (compose extensions)))
 690              sink))))
 691     (()
 692      (raise
 693       (condition (&missing-target-service-error
 694                   (service #f)
 695                   (target-type target-type))
 696                  (&message
 697                   (message (format #f (G_ "service of type '~a' not found")
 698                                    (service-type-name target-type)))))))
 699     (x
 700      (raise
 701       (condition (&ambiguous-target-service-error
 702                   (service #f)
 703                   (target-type target-type))
 704                  (&message
 705                   (message
 706                    (format #f
 707                            (G_ "more than one target service of type '~a'")
 708                            (service-type-name target-type)))))))))
 709
 710 ;;; services.scm ends here.