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