services.scm 47 KB

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