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