| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 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 | |
| 19 | (define-module (gnu services) |
| 20 | #:use-module (guix gexp) |
| 21 | #:use-module (guix monads) |
| 22 | #:use-module (guix store) |
| 23 | #:use-module (guix records) |
| 24 | #:use-module (guix profiles) |
| 25 | #:use-module (guix sets) |
| 26 | #:use-module (guix ui) |
| 27 | #:use-module (gnu packages base) |
| 28 | #:use-module (gnu packages bash) |
| 29 | #:use-module (srfi srfi-1) |
| 30 | #:use-module (srfi srfi-9) |
| 31 | #:use-module (srfi srfi-9 gnu) |
| 32 | #:use-module (srfi srfi-26) |
| 33 | #:use-module (srfi srfi-34) |
| 34 | #:use-module (srfi srfi-35) |
| 35 | #:use-module (ice-9 vlist) |
| 36 | #:use-module (ice-9 match) |
| 37 | #:export (service-extension |
| 38 | service-extension? |
| 39 | |
| 40 | service-type |
| 41 | service-type? |
| 42 | service-type-name |
| 43 | service-type-extensions |
| 44 | service-type-compose |
| 45 | service-type-extend |
| 46 | |
| 47 | service |
| 48 | service? |
| 49 | service-kind |
| 50 | service-parameters |
| 51 | |
| 52 | modify-services |
| 53 | service-back-edges |
| 54 | fold-services |
| 55 | |
| 56 | service-error? |
| 57 | missing-target-service-error? |
| 58 | missing-target-service-error-service |
| 59 | missing-target-service-error-target-type |
| 60 | ambiguous-target-service-error? |
| 61 | ambiguous-target-service-error-service |
| 62 | ambiguous-target-service-error-target-type |
| 63 | |
| 64 | system-service-type |
| 65 | boot-service-type |
| 66 | cleanup-service-type |
| 67 | activation-service-type |
| 68 | activation-service->script |
| 69 | %linux-bare-metal-service |
| 70 | etc-service-type |
| 71 | etc-directory |
| 72 | setuid-program-service-type |
| 73 | profile-service-type |
| 74 | firmware-service-type |
| 75 | |
| 76 | %boot-service |
| 77 | %activation-service |
| 78 | etc-service |
| 79 | |
| 80 | file-union)) ;XXX: for lack of a better place |
| 81 | |
| 82 | ;;; Comment: |
| 83 | ;;; |
| 84 | ;;; This module defines a broad notion of "service types" and "services." |
| 85 | ;;; |
| 86 | ;;; A service type describe how its instances extend instances of other |
| 87 | ;;; service types. For instance, some services extend the instance of |
| 88 | ;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create; |
| 89 | ;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of |
| 90 | ;;; <dmd-service>. |
| 91 | ;;; |
| 92 | ;;; When applicable, the service type defines how it can itself be extended, |
| 93 | ;;; by providing one procedure to compose extensions, and one procedure to |
| 94 | ;;; extend itself. |
| 95 | ;;; |
| 96 | ;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single |
| 97 | ;;; instance, which is the root of the service DAG. Its value is the |
| 98 | ;;; derivation that produces the 'system' directory as returned by |
| 99 | ;;; 'operating-system-derivation'. |
| 100 | ;;; |
| 101 | ;;; The 'fold-services' procedure can be passed a list of procedures, which it |
| 102 | ;;; "folds" by propagating extensions down the graph; it returns the root |
| 103 | ;;; service after the applying all its extensions. |
| 104 | ;;; |
| 105 | ;;; Code: |
| 106 | |
| 107 | (define-record-type <service-extension> |
| 108 | (service-extension target compute) |
| 109 | service-extension? |
| 110 | (target service-extension-target) ;<service-type> |
| 111 | (compute service-extension-compute)) ;params -> params |
| 112 | |
| 113 | (define-record-type* <service-type> service-type make-service-type |
| 114 | service-type? |
| 115 | (name service-type-name) ;symbol (for debugging) |
| 116 | |
| 117 | ;; Things extended by services of this type. |
| 118 | (extensions service-type-extensions) ;list of <service-extensions> |
| 119 | |
| 120 | ;; Given a list of extensions, "compose" them. |
| 121 | (compose service-type-compose ;list of Any -> Any |
| 122 | (default #f)) |
| 123 | |
| 124 | ;; Extend the services' own parameters with the extension composition. |
| 125 | (extend service-type-extend ;list of Any -> parameters |
| 126 | (default #f))) |
| 127 | |
| 128 | (define (write-service-type type port) |
| 129 | (format port "#<service-type ~a ~a>" |
| 130 | (service-type-name type) |
| 131 | (number->string (object-address type) 16))) |
| 132 | |
| 133 | (set-record-type-printer! <service-type> write-service-type) |
| 134 | |
| 135 | ;; Services of a given type. |
| 136 | (define-record-type <service> |
| 137 | (service type parameters) |
| 138 | service? |
| 139 | (type service-kind) |
| 140 | (parameters service-parameters)) |
| 141 | |
| 142 | |
| 143 | (define-syntax %modify-service |
| 144 | (syntax-rules (=>) |
| 145 | ((_ service) |
| 146 | service) |
| 147 | ((_ svc (kind param => exp ...) clauses ...) |
| 148 | (if (eq? (service-kind svc) kind) |
| 149 | (let ((param (service-parameters svc))) |
| 150 | (service (service-kind svc) |
| 151 | (begin exp ...))) |
| 152 | (%modify-service svc clauses ...))))) |
| 153 | |
| 154 | (define-syntax modify-services |
| 155 | (syntax-rules () |
| 156 | "Modify the services listed in SERVICES according to CLAUSES. Each clause |
| 157 | must have the form: |
| 158 | |
| 159 | (TYPE VARIABLE => BODY) |
| 160 | |
| 161 | where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an |
| 162 | identifier that is bound within BODY to the value of the service of that |
| 163 | TYPE. Consider this example: |
| 164 | |
| 165 | (modify-services %base-services |
| 166 | (guix-service-type config => |
| 167 | (guix-configuration |
| 168 | (inherit config) |
| 169 | (use-substitutes? #f) |
| 170 | (extra-options '(\"--gc-keep-derivations\")))) |
| 171 | (mingetty-service-type config => |
| 172 | (mingetty-configuration |
| 173 | (inherit config) |
| 174 | (motd (plain-file \"motd\" \"Hi there!\"))))) |
| 175 | |
| 176 | It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of |
| 177 | all the MINGETTY-SERVICE-TYPE instances. |
| 178 | |
| 179 | This is a shorthand for (map (lambda (svc) ...) %base-services)." |
| 180 | ((_ services clauses ...) |
| 181 | (map (lambda (service) |
| 182 | (%modify-service service clauses ...)) |
| 183 | services)))) |
| 184 | |
| 185 | \f |
| 186 | ;;; |
| 187 | ;;; Core services. |
| 188 | ;;; |
| 189 | |
| 190 | (define (system-derivation mentries mextensions) |
| 191 | "Return as a monadic value the derivation of the 'system' directory |
| 192 | containing the given entries." |
| 193 | (mlet %store-monad ((entries mentries) |
| 194 | (extensions (sequence %store-monad mextensions))) |
| 195 | (lower-object |
| 196 | (file-union "system" |
| 197 | (append entries (concatenate extensions)))))) |
| 198 | |
| 199 | (define system-service-type |
| 200 | ;; This is the ultimate service type, the root of the service DAG. The |
| 201 | ;; service of this type is extended by monadic name/item pairs. These items |
| 202 | ;; end up in the "system directory" as returned by |
| 203 | ;; 'operating-system-derivation'. |
| 204 | (service-type (name 'system) |
| 205 | (extensions '()) |
| 206 | (compose identity) |
| 207 | (extend system-derivation))) |
| 208 | |
| 209 | (define (compute-boot-script _ mexps) |
| 210 | (mlet %store-monad ((gexps (sequence %store-monad mexps))) |
| 211 | (gexp->file "boot" |
| 212 | ;; Clean up and activate the system, then spawn dmd. |
| 213 | #~(begin #$@gexps)))) |
| 214 | |
| 215 | (define (boot-script-entry mboot) |
| 216 | "Return, as a monadic value, an entry for the boot script in the system |
| 217 | directory." |
| 218 | (mlet %store-monad ((boot mboot)) |
| 219 | (return `(("boot" ,boot))))) |
| 220 | |
| 221 | (define boot-service-type |
| 222 | ;; The service of this type is extended by being passed gexps as monadic |
| 223 | ;; values. It aggregates them in a single script, as a monadic value, which |
| 224 | ;; becomes its 'parameters'. It is the only service that extends nothing. |
| 225 | (service-type (name 'boot) |
| 226 | (extensions |
| 227 | (list (service-extension system-service-type |
| 228 | boot-script-entry))) |
| 229 | (compose append) |
| 230 | (extend compute-boot-script))) |
| 231 | |
| 232 | (define %boot-service |
| 233 | ;; The service that produces the boot script. |
| 234 | (service boot-service-type #t)) |
| 235 | |
| 236 | (define (cleanup-gexp _) |
| 237 | "Return as a monadic value a gexp to clean up /tmp and similar places upon |
| 238 | boot." |
| 239 | (define %modules |
| 240 | '((guix build utils))) |
| 241 | |
| 242 | (mlet %store-monad ((modules (imported-modules %modules)) |
| 243 | (compiled (compiled-modules %modules))) |
| 244 | (return #~(begin |
| 245 | (eval-when (expand load eval) |
| 246 | ;; Make sure 'use-modules' below succeeds. |
| 247 | (set! %load-path (cons #$modules %load-path)) |
| 248 | (set! %load-compiled-path |
| 249 | (cons #$compiled %load-compiled-path))) |
| 250 | |
| 251 | (use-modules (guix build utils)) |
| 252 | |
| 253 | ;; Clean out /tmp and /var/run. |
| 254 | ;; |
| 255 | ;; XXX This needs to happen before service activations, so it |
| 256 | ;; has to be here, but this also implicitly assumes that /tmp |
| 257 | ;; and /var/run are on the root partition. |
| 258 | (letrec-syntax ((fail-safe (syntax-rules () |
| 259 | ((_ exp rest ...) |
| 260 | (begin |
| 261 | (catch 'system-error |
| 262 | (lambda () exp) |
| 263 | (const #f)) |
| 264 | (fail-safe rest ...))) |
| 265 | ((_) |
| 266 | #t)))) |
| 267 | ;; Ignore I/O errors so the system can boot. |
| 268 | (fail-safe |
| 269 | (delete-file-recursively "/tmp") |
| 270 | (delete-file-recursively "/var/run") |
| 271 | (mkdir "/tmp") |
| 272 | (chmod "/tmp" #o1777) |
| 273 | (mkdir "/var/run") |
| 274 | (chmod "/var/run" #o755))))))) |
| 275 | |
| 276 | (define cleanup-service-type |
| 277 | ;; Service that cleans things up in /tmp and similar. |
| 278 | (service-type (name 'cleanup) |
| 279 | (extensions |
| 280 | (list (service-extension boot-service-type |
| 281 | cleanup-gexp))))) |
| 282 | |
| 283 | (define* (file-union name files) ;FIXME: Factorize. |
| 284 | "Return a <computed-file> that builds a directory containing all of FILES. |
| 285 | Each item in FILES must be a list where the first element is the file name to |
| 286 | use in the new directory, and the second element is a gexp denoting the target |
| 287 | file." |
| 288 | (computed-file name |
| 289 | #~(begin |
| 290 | (mkdir #$output) |
| 291 | (chdir #$output) |
| 292 | #$@(map (match-lambda |
| 293 | ((target source) |
| 294 | #~(symlink #$source #$target))) |
| 295 | files)))) |
| 296 | |
| 297 | (define (directory-union name things) |
| 298 | "Return a directory that is the union of THINGS." |
| 299 | (match things |
| 300 | ((one) |
| 301 | ;; Only one thing; return it. |
| 302 | one) |
| 303 | (_ |
| 304 | (computed-file name |
| 305 | #~(begin |
| 306 | (use-modules (guix build union)) |
| 307 | (union-build #$output '#$things)) |
| 308 | #:modules '((guix build union)))))) |
| 309 | |
| 310 | (define* (activation-service->script service) |
| 311 | "Return as a monadic value the activation script for SERVICE, a service of |
| 312 | ACTIVATION-SCRIPT-TYPE." |
| 313 | (activation-script (service-parameters service))) |
| 314 | |
| 315 | (define (activation-script gexps) |
| 316 | "Return the system's activation script, which evaluates GEXPS." |
| 317 | (define %modules |
| 318 | '((gnu build activation) |
| 319 | (gnu build linux-boot) |
| 320 | (gnu build linux-modules) |
| 321 | (gnu build file-systems) |
| 322 | (guix build utils) |
| 323 | (guix build syscalls) |
| 324 | (guix elf))) |
| 325 | |
| 326 | (define (service-activations) |
| 327 | ;; Return the activation scripts for SERVICES. |
| 328 | (mapm %store-monad |
| 329 | (cut gexp->file "activate-service" <>) |
| 330 | gexps)) |
| 331 | |
| 332 | (mlet* %store-monad ((actions (service-activations)) |
| 333 | (modules (imported-modules %modules)) |
| 334 | (compiled (compiled-modules %modules))) |
| 335 | (gexp->file "activate" |
| 336 | #~(begin |
| 337 | (eval-when (expand load eval) |
| 338 | ;; Make sure 'use-modules' below succeeds. |
| 339 | (set! %load-path (cons #$modules %load-path)) |
| 340 | (set! %load-compiled-path |
| 341 | (cons #$compiled %load-compiled-path))) |
| 342 | |
| 343 | (use-modules (gnu build activation)) |
| 344 | |
| 345 | ;; Make sure /bin/sh is valid and current. |
| 346 | (activate-/bin/sh |
| 347 | (string-append #$(canonical-package bash) "/bin/sh")) |
| 348 | |
| 349 | ;; Run the services' activation snippets. |
| 350 | ;; TODO: Use 'load-compiled'. |
| 351 | (for-each primitive-load '#$actions) |
| 352 | |
| 353 | ;; Set up /run/current-system. |
| 354 | (activate-current-system))))) |
| 355 | |
| 356 | (define (gexps->activation-gexp gexps) |
| 357 | "Return a gexp that runs the activation script containing GEXPS." |
| 358 | (mlet %store-monad ((script (activation-script gexps))) |
| 359 | (return #~(primitive-load #$script)))) |
| 360 | |
| 361 | (define (second-argument a b) b) |
| 362 | |
| 363 | (define activation-service-type |
| 364 | (service-type (name 'activate) |
| 365 | (extensions |
| 366 | (list (service-extension boot-service-type |
| 367 | gexps->activation-gexp))) |
| 368 | (compose append) |
| 369 | (extend second-argument))) |
| 370 | |
| 371 | (define %activation-service |
| 372 | ;; The activation service produces the activation script from the gexps it |
| 373 | ;; receives. |
| 374 | (service activation-service-type #t)) |
| 375 | |
| 376 | (define %modprobe-wrapper |
| 377 | ;; Wrapper for the 'modprobe' command that knows where modules live. |
| 378 | ;; |
| 379 | ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe', |
| 380 | ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' |
| 381 | ;; environment variable is not set---hence the need for this wrapper. |
| 382 | (let ((modprobe "/run/current-system/profile/bin/modprobe")) |
| 383 | (program-file "modprobe" |
| 384 | #~(begin |
| 385 | (setenv "LINUX_MODULE_DIRECTORY" |
| 386 | "/run/booted-system/kernel/lib/modules") |
| 387 | (apply execl #$modprobe |
| 388 | (cons #$modprobe (cdr (command-line)))))))) |
| 389 | |
| 390 | (define %linux-kernel-activation |
| 391 | ;; Activation of the Linux kernel running on the bare metal (as opposed to |
| 392 | ;; running in a container.) |
| 393 | #~(begin |
| 394 | ;; Tell the kernel to use our 'modprobe' command. |
| 395 | (activate-modprobe #$%modprobe-wrapper) |
| 396 | |
| 397 | ;; Let users debug their own processes! |
| 398 | (activate-ptrace-attach))) |
| 399 | |
| 400 | (define linux-bare-metal-service-type |
| 401 | (service-type (name 'linux-bare-metal) |
| 402 | (extensions |
| 403 | (list (service-extension activation-service-type |
| 404 | (const %linux-kernel-activation)))))) |
| 405 | |
| 406 | (define %linux-bare-metal-service |
| 407 | ;; The service that does things that are needed on the "bare metal", but not |
| 408 | ;; necessary or impossible in a container. |
| 409 | (service linux-bare-metal-service-type #f)) |
| 410 | |
| 411 | (define (etc-directory service) |
| 412 | "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." |
| 413 | (files->etc-directory (service-parameters service))) |
| 414 | |
| 415 | (define (files->etc-directory files) |
| 416 | (file-union "etc" files)) |
| 417 | |
| 418 | (define (etc-entry files) |
| 419 | "Return an entry for the /etc directory consisting of FILES in the system |
| 420 | directory." |
| 421 | (with-monad %store-monad |
| 422 | (return `(("etc" ,(files->etc-directory files)))))) |
| 423 | |
| 424 | (define etc-service-type |
| 425 | (service-type (name 'etc) |
| 426 | (extensions |
| 427 | (list |
| 428 | (service-extension activation-service-type |
| 429 | (lambda (files) |
| 430 | (let ((etc |
| 431 | (files->etc-directory files))) |
| 432 | #~(activate-etc #$etc)))) |
| 433 | (service-extension system-service-type etc-entry))) |
| 434 | (compose concatenate) |
| 435 | (extend append))) |
| 436 | |
| 437 | (define (etc-service files) |
| 438 | "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES. |
| 439 | FILES must be a list of name/file-like object pairs." |
| 440 | (service etc-service-type files)) |
| 441 | |
| 442 | (define setuid-program-service-type |
| 443 | (service-type (name 'setuid-program) |
| 444 | (extensions |
| 445 | (list (service-extension activation-service-type |
| 446 | (lambda (programs) |
| 447 | #~(activate-setuid-programs |
| 448 | (list #$@programs)))))) |
| 449 | (compose concatenate) |
| 450 | (extend append))) |
| 451 | |
| 452 | (define (packages->profile-entry packages) |
| 453 | "Return a system entry for the profile containing PACKAGES." |
| 454 | (mlet %store-monad ((profile (profile-derivation |
| 455 | (manifest (map package->manifest-entry |
| 456 | (delete-duplicates packages eq?)))))) |
| 457 | (return `(("profile" ,profile))))) |
| 458 | |
| 459 | (define profile-service-type |
| 460 | ;; The service that populates the system's profile---i.e., |
| 461 | ;; /run/current-system/profile. It is extended by package lists. |
| 462 | (service-type (name 'profile) |
| 463 | (extensions |
| 464 | (list (service-extension system-service-type |
| 465 | packages->profile-entry))) |
| 466 | (compose concatenate) |
| 467 | (extend append))) |
| 468 | |
| 469 | (define (firmware->activation-gexp firmware) |
| 470 | "Return a gexp to make the packages listed in FIRMWARE loadable by the |
| 471 | kernel." |
| 472 | (let ((directory (directory-union "firmware" firmware))) |
| 473 | ;; Tell the kernel where firmware is. |
| 474 | #~(activate-firmware (string-append #$directory "/lib/firmware")))) |
| 475 | |
| 476 | (define firmware-service-type |
| 477 | ;; The service that collects firmware. |
| 478 | (service-type (name 'firmware) |
| 479 | (extensions |
| 480 | (list (service-extension activation-service-type |
| 481 | firmware->activation-gexp))) |
| 482 | (compose concatenate) |
| 483 | (extend append))) |
| 484 | |
| 485 | \f |
| 486 | ;;; |
| 487 | ;;; Service folding. |
| 488 | ;;; |
| 489 | |
| 490 | (define-condition-type &service-error &error |
| 491 | service-error?) |
| 492 | |
| 493 | (define-condition-type &missing-target-service-error &service-error |
| 494 | missing-target-service-error? |
| 495 | (service missing-target-service-error-service) |
| 496 | (target-type missing-target-service-error-target-type)) |
| 497 | |
| 498 | (define-condition-type &ambiguous-target-service-error &service-error |
| 499 | ambiguous-target-service-error? |
| 500 | (service ambiguous-target-service-error-service) |
| 501 | (target-type ambiguous-target-service-error-target-type)) |
| 502 | |
| 503 | (define (service-back-edges services) |
| 504 | "Return a procedure that, when passed a <service>, returns the list of |
| 505 | <service> objects that depend on it." |
| 506 | (define (add-edges service edges) |
| 507 | (define (add-edge extension edges) |
| 508 | (let ((target-type (service-extension-target extension))) |
| 509 | (match (filter (lambda (service) |
| 510 | (eq? (service-kind service) target-type)) |
| 511 | services) |
| 512 | ((target) |
| 513 | (vhash-consq target service edges)) |
| 514 | (() |
| 515 | (raise |
| 516 | (condition (&missing-target-service-error |
| 517 | (service service) |
| 518 | (target-type target-type)) |
| 519 | (&message |
| 520 | (message |
| 521 | (format #f (_ "no target of type '~a' for service ~s") |
| 522 | (service-type-name target-type) |
| 523 | service)))))) |
| 524 | (x |
| 525 | (raise |
| 526 | (condition (&ambiguous-target-service-error |
| 527 | (service service) |
| 528 | (target-type target-type)) |
| 529 | (&message |
| 530 | (message |
| 531 | (format #f |
| 532 | (_ "more than one target service of type '~a'") |
| 533 | (service-type-name target-type)))))))))) |
| 534 | |
| 535 | (fold add-edge edges (service-type-extensions (service-kind service)))) |
| 536 | |
| 537 | (let ((edges (fold add-edges vlist-null services))) |
| 538 | (lambda (node) |
| 539 | (reverse (vhash-foldq* cons '() node edges))))) |
| 540 | |
| 541 | (define* (fold-services services |
| 542 | #:key (target-type system-service-type)) |
| 543 | "Fold SERVICES by propagating their extensions down to the root of type |
| 544 | TARGET-TYPE; return the root service adjusted accordingly." |
| 545 | (define dependents |
| 546 | (service-back-edges services)) |
| 547 | |
| 548 | (define (matching-extension target) |
| 549 | (let ((target (service-kind target))) |
| 550 | (match-lambda |
| 551 | (($ <service-extension> type) |
| 552 | (eq? type target))))) |
| 553 | |
| 554 | (define (apply-extension target) |
| 555 | (lambda (service) |
| 556 | (match (find (matching-extension target) |
| 557 | (service-type-extensions (service-kind service))) |
| 558 | (($ <service-extension> _ compute) |
| 559 | (compute (service-parameters service)))))) |
| 560 | |
| 561 | (match (filter (lambda (service) |
| 562 | (eq? (service-kind service) target-type)) |
| 563 | services) |
| 564 | ((sink) |
| 565 | (let loop ((sink sink)) |
| 566 | (let* ((dependents (map loop (dependents sink))) |
| 567 | (extensions (map (apply-extension sink) dependents)) |
| 568 | (extend (service-type-extend (service-kind sink))) |
| 569 | (compose (service-type-compose (service-kind sink))) |
| 570 | (params (service-parameters sink))) |
| 571 | ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a |
| 572 | ;; different type than the elements of EXTENSIONS. |
| 573 | (if extend |
| 574 | (service (service-kind sink) |
| 575 | (extend params (compose extensions))) |
| 576 | sink)))) |
| 577 | (() |
| 578 | (raise |
| 579 | (condition (&missing-target-service-error |
| 580 | (service #f) |
| 581 | (target-type target-type)) |
| 582 | (&message |
| 583 | (message (format #f (_ "service of type '~a' not found") |
| 584 | (service-type-name target-type))))))) |
| 585 | (x |
| 586 | (raise |
| 587 | (condition (&ambiguous-target-service-error |
| 588 | (service #f) |
| 589 | (target-type target-type)) |
| 590 | (&message |
| 591 | (message |
| 592 | (format #f |
| 593 | (_ "more than one target service of type '~a'") |
| 594 | (service-type-name target-type))))))))) |
| 595 | |
| 596 | ;;; services.scm ends here. |