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