You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

2342 lines
99 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
  4. ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
  5. ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
  6. ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
  7. ;;; Copyright © 2016 David Craven <david@craven.ch>
  8. ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
  9. ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
  10. ;;;
  11. ;;; This file is part of GNU Guix.
  12. ;;;
  13. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  14. ;;; under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 3 of the License, or (at
  16. ;;; your option) any later version.
  17. ;;;
  18. ;;; GNU Guix is distributed in the hope that it will be useful, but
  19. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  25. (define-module (gnu services base)
  26. #:use-module (guix store)
  27. #:use-module (guix deprecation)
  28. #:use-module (gnu services)
  29. #:use-module (gnu services shepherd)
  30. #:use-module (gnu system pam)
  31. #:use-module (gnu system shadow) ; 'user-account', etc.
  32. #:use-module (gnu system uuid)
  33. #:use-module (gnu system file-systems) ; 'file-system', etc.
  34. #:use-module (gnu system mapped-devices)
  35. #:use-module ((gnu system linux-initrd)
  36. #:select (file-system-packages))
  37. #:use-module (gnu packages admin)
  38. #:use-module ((gnu packages linux)
  39. #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
  40. #:use-module ((gnu packages base)
  41. #:select (canonical-package glibc glibc-utf8-locales))
  42. #:use-module (gnu packages bash)
  43. #:use-module (gnu packages package-management)
  44. #:use-module (gnu packages linux)
  45. #:use-module (gnu packages terminals)
  46. #:use-module ((gnu build file-systems)
  47. #:select (mount-flags->bit-mask))
  48. #:use-module (guix gexp)
  49. #:use-module (guix records)
  50. #:use-module (guix modules)
  51. #:use-module (srfi srfi-1)
  52. #:use-module (srfi srfi-26)
  53. #:use-module (ice-9 match)
  54. #:use-module (ice-9 format)
  55. #:export (fstab-service-type
  56. root-file-system-service
  57. file-system-service-type
  58. swap-service
  59. user-processes-service-type
  60. host-name-service
  61. console-keymap-service
  62. %default-console-font
  63. console-font-service-type
  64. console-font-service
  65. virtual-terminal-service-type
  66. static-networking
  67. static-networking?
  68. static-networking-interface
  69. static-networking-ip
  70. static-networking-netmask
  71. static-networking-gateway
  72. static-networking-requirement
  73. static-networking-service
  74. static-networking-service-type
  75. udev-configuration
  76. udev-configuration?
  77. udev-configuration-rules
  78. udev-service-type
  79. udev-service
  80. udev-rule
  81. file->udev-rule
  82. login-configuration
  83. login-configuration?
  84. login-service-type
  85. login-service
  86. agetty-configuration
  87. agetty-configuration?
  88. agetty-service
  89. agetty-service-type
  90. mingetty-configuration
  91. mingetty-configuration?
  92. mingetty-service
  93. mingetty-service-type
  94. %nscd-default-caches
  95. %nscd-default-configuration
  96. nscd-configuration
  97. nscd-configuration?
  98. nscd-cache
  99. nscd-cache?
  100. nscd-service-type
  101. nscd-service
  102. syslog-configuration
  103. syslog-configuration?
  104. syslog-service
  105. syslog-service-type
  106. %default-syslog.conf
  107. %default-authorized-guix-keys
  108. guix-configuration
  109. guix-configuration?
  110. guix-configuration-guix
  111. guix-configuration-build-group
  112. guix-configuration-build-accounts
  113. guix-configuration-authorize-key?
  114. guix-configuration-authorized-keys
  115. guix-configuration-use-substitutes?
  116. guix-configuration-substitute-urls
  117. guix-configuration-extra-options
  118. guix-configuration-log-file
  119. guix-service
  120. guix-service-type
  121. guix-publish-configuration
  122. guix-publish-configuration?
  123. guix-publish-configuration-guix
  124. guix-publish-configuration-port
  125. guix-publish-configuration-host
  126. guix-publish-configuration-compression-level
  127. guix-publish-configuration-nar-path
  128. guix-publish-configuration-cache
  129. guix-publish-configuration-ttl
  130. guix-publish-service
  131. guix-publish-service-type
  132. gpm-configuration
  133. gpm-configuration?
  134. gpm-service-type
  135. gpm-service
  136. urandom-seed-service-type
  137. urandom-seed-service
  138. rngd-configuration
  139. rngd-configuration?
  140. rngd-service-type
  141. rngd-service
  142. kmscon-configuration
  143. kmscon-configuration?
  144. kmscon-service-type
  145. pam-limits-service-type
  146. pam-limits-service
  147. %base-services))
  148. ;;; Commentary:
  149. ;;;
  150. ;;; Base system services---i.e., services that 99% of the users will want to
  151. ;;; use.
  152. ;;;
  153. ;;; Code:
  154. ;;;
  155. ;;; User processes.
  156. ;;;
  157. (define %do-not-kill-file
  158. ;; Name of the file listing PIDs of processes that must survive when halting
  159. ;; the system. Typical example is user-space file systems.
  160. "/etc/shepherd/do-not-kill")
  161. (define (user-processes-shepherd-service requirements)
  162. "Return the 'user-processes' Shepherd service with dependencies on
  163. REQUIREMENTS (a list of service names).
  164. This is a synchronization point used to make sure user processes and daemons
  165. get started only after crucial initial services have been started---file
  166. system mounts, etc. This is similar to the 'sysvinit' target in systemd."
  167. (define grace-delay
  168. ;; Delay after sending SIGTERM and before sending SIGKILL.
  169. 4)
  170. (list (shepherd-service
  171. (documentation "When stopped, terminate all user processes.")
  172. (provision '(user-processes))
  173. (requirement requirements)
  174. (start #~(const #t))
  175. (stop #~(lambda _
  176. (define (kill-except omit signal)
  177. ;; Kill all the processes with SIGNAL except those listed
  178. ;; in OMIT and the current process.
  179. (let ((omit (cons (getpid) omit)))
  180. (for-each (lambda (pid)
  181. (unless (memv pid omit)
  182. (false-if-exception
  183. (kill pid signal))))
  184. (processes))))
  185. (define omitted-pids
  186. ;; List of PIDs that must not be killed.
  187. (if (file-exists? #$%do-not-kill-file)
  188. (map string->number
  189. (call-with-input-file #$%do-not-kill-file
  190. (compose string-tokenize
  191. (@ (ice-9 rdelim) read-string))))
  192. '()))
  193. (define (now)
  194. (car (gettimeofday)))
  195. (define (sleep* n)
  196. ;; Really sleep N seconds.
  197. ;; Work around <http://bugs.gnu.org/19581>.
  198. (define start (now))
  199. (let loop ((elapsed 0))
  200. (when (> n elapsed)
  201. (sleep (- n elapsed))
  202. (loop (- (now) start)))))
  203. (define lset= (@ (srfi srfi-1) lset=))
  204. (display "sending all processes the TERM signal\n")
  205. (if (null? omitted-pids)
  206. (begin
  207. ;; Easy: terminate all of them.
  208. (kill -1 SIGTERM)
  209. (sleep* #$grace-delay)
  210. (kill -1 SIGKILL))
  211. (begin
  212. ;; Kill them all except OMITTED-PIDS. XXX: We would
  213. ;; like to (kill -1 SIGSTOP) to get a fixed list of
  214. ;; processes, like 'killall5' does, but that seems
  215. ;; unreliable.
  216. (kill-except omitted-pids SIGTERM)
  217. (sleep* #$grace-delay)
  218. (kill-except omitted-pids SIGKILL)
  219. (delete-file #$%do-not-kill-file)))
  220. (let wait ()
  221. ;; Reap children, if any, so that we don't end up with
  222. ;; zombies and enter an infinite loop.
  223. (let reap-children ()
  224. (define result
  225. (false-if-exception
  226. (waitpid WAIT_ANY (if (null? omitted-pids)
  227. 0
  228. WNOHANG))))
  229. (when (and (pair? result)
  230. (not (zero? (car result))))
  231. (reap-children)))
  232. (let ((pids (processes)))
  233. (unless (lset= = pids (cons 1 omitted-pids))
  234. (format #t "waiting for process termination\
  235. (processes left: ~s)~%"
  236. pids)
  237. (sleep* 2)
  238. (wait))))
  239. (display "all processes have been terminated\n")
  240. #f))
  241. (respawn? #f))))
  242. (define user-processes-service-type
  243. (service-type
  244. (name 'user-processes)
  245. (extensions (list (service-extension shepherd-root-service-type
  246. user-processes-shepherd-service)))
  247. (compose concatenate)
  248. (extend append)
  249. ;; The value is the list of Shepherd services 'user-processes' depends on.
  250. ;; Extensions can add new services to this list.
  251. (default-value '())
  252. (description "The @code{user-processes} service is responsible for
  253. terminating all the processes so that the root file system can be re-mounted
  254. read-only, just before rebooting/halting. Processes still running after a few
  255. seconds after @code{SIGTERM} has been sent are terminated with
  256. @code{SIGKILL}.")))
  257. ;;;
  258. ;;; File systems.
  259. ;;;
  260. (define (file-system->fstab-entry file-system)
  261. "Return a @file{/etc/fstab} entry for @var{file-system}."
  262. (string-append (match (file-system-device file-system)
  263. ((? file-system-label? label)
  264. (string-append "LABEL="
  265. (file-system-label->string label)))
  266. ((? uuid? uuid)
  267. (string-append "UUID=" (uuid->string uuid)))
  268. ((? string? device)
  269. device))
  270. "\t"
  271. (file-system-mount-point file-system) "\t"
  272. (file-system-type file-system) "\t"
  273. (or (file-system-options file-system) "defaults") "\t"
  274. ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
  275. ;; don't have anything sensible to put in there.
  276. ))
  277. (define (file-systems->fstab file-systems)
  278. "Return a @file{/etc} entry for an @file{fstab} describing
  279. @var{file-systems}."
  280. `(("fstab" ,(plain-file "fstab"
  281. (string-append
  282. "\
  283. # This file was generated from your GuixSD configuration. Any changes
  284. # will be lost upon reboot or reconfiguration.\n\n"
  285. (string-join (map file-system->fstab-entry
  286. file-systems)
  287. "\n")
  288. "\n")))))
  289. (define fstab-service-type
  290. ;; The /etc/fstab service.
  291. (service-type (name 'fstab)
  292. (extensions
  293. (list (service-extension etc-service-type
  294. file-systems->fstab)))
  295. (compose concatenate)
  296. (extend append)
  297. (description
  298. "Populate the @file{/etc/fstab} based on the given file
  299. system objects.")))
  300. (define %root-file-system-shepherd-service
  301. (shepherd-service
  302. (documentation "Take care of the root file system.")
  303. (provision '(root-file-system))
  304. (start #~(const #t))
  305. (stop #~(lambda _
  306. ;; Return #f if successfully stopped.
  307. (sync)
  308. (call-with-blocked-asyncs
  309. (lambda ()
  310. (let ((null (%make-void-port "w")))
  311. ;; Close 'shepherd.log'.
  312. (display "closing log\n")
  313. ((@ (shepherd comm) stop-logging))
  314. ;; Redirect the default output ports..
  315. (set-current-output-port null)
  316. (set-current-error-port null)
  317. ;; Close /dev/console.
  318. (for-each close-fdes '(0 1 2))
  319. ;; At this point, there are no open files left, so the
  320. ;; root file system can be re-mounted read-only.
  321. (mount #f "/" #f
  322. (logior MS_REMOUNT MS_RDONLY)
  323. #:update-mtab? #f)
  324. #f)))))
  325. (respawn? #f)))
  326. (define root-file-system-service-type
  327. (shepherd-service-type 'root-file-system
  328. (const %root-file-system-shepherd-service)))
  329. (define (root-file-system-service)
  330. "Return a service whose sole purpose is to re-mount read-only the root file
  331. system upon shutdown (aka. cleanly \"umounting\" root.)
  332. This service must be the root of the service dependency graph so that its
  333. 'stop' action is invoked when shepherd is the only process left."
  334. (service root-file-system-service-type #f))
  335. (define (file-system->shepherd-service-name file-system)
  336. "Return the symbol that denotes the service mounting and unmounting
  337. FILE-SYSTEM."
  338. (symbol-append 'file-system-
  339. (string->symbol (file-system-mount-point file-system))))
  340. (define (mapped-device->shepherd-service-name md)
  341. "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
  342. (symbol-append 'device-mapping-
  343. (string->symbol (mapped-device-target md))))
  344. (define dependency->shepherd-service-name
  345. (match-lambda
  346. ((? mapped-device? md)
  347. (mapped-device->shepherd-service-name md))
  348. ((? file-system? fs)
  349. (file-system->shepherd-service-name fs))))
  350. (define (file-system-shepherd-service file-system)
  351. "Return the shepherd service for @var{file-system}, or @code{#f} if
  352. @var{file-system} is not auto-mounted upon boot."
  353. (let ((target (file-system-mount-point file-system))
  354. (create? (file-system-create-mount-point? file-system))
  355. (dependencies (file-system-dependencies file-system))
  356. (packages (file-system-packages (list file-system))))
  357. (and (file-system-mount? file-system)
  358. (with-imported-modules (source-module-closure
  359. '((gnu build file-systems)))
  360. (shepherd-service
  361. (provision (list (file-system->shepherd-service-name file-system)))
  362. (requirement `(root-file-system udev
  363. ,@(map dependency->shepherd-service-name dependencies)))
  364. (documentation "Check, mount, and unmount the given file system.")
  365. (start #~(lambda args
  366. #$(if create?
  367. #~(mkdir-p #$target)
  368. #t)
  369. (let (($PATH (getenv "PATH")))
  370. ;; Make sure fsck.ext2 & co. can be found.
  371. (dynamic-wind
  372. (lambda ()
  373. ;; Don’t display the PATH settings.
  374. (with-output-to-port (%make-void-port "w")
  375. (lambda ()
  376. (set-path-environment-variable "PATH"
  377. '("bin" "sbin")
  378. '#$packages))))
  379. (lambda ()
  380. (mount-file-system
  381. (spec->file-system
  382. '#$(file-system->spec file-system))
  383. #:root "/"))
  384. (lambda ()
  385. (setenv "PATH" $PATH)))
  386. #t)))
  387. (stop #~(lambda args
  388. ;; Normally there are no processes left at this point, so
  389. ;; TARGET can be safely unmounted.
  390. ;; Make sure PID 1 doesn't keep TARGET busy.
  391. (chdir "/")
  392. (umount #$target)
  393. #f))
  394. ;; We need additional modules.
  395. (modules `(((gnu build file-systems)
  396. #:select (mount-file-system))
  397. (gnu system file-systems)
  398. ,@%default-modules)))))))
  399. (define (file-system-shepherd-services file-systems)
  400. "Return the list of Shepherd services for FILE-SYSTEMS."
  401. (let* ((file-systems (filter file-system-mount? file-systems)))
  402. (define sink
  403. (shepherd-service
  404. (provision '(file-systems))
  405. (requirement (cons* 'root-file-system 'user-file-systems
  406. (map file-system->shepherd-service-name
  407. file-systems)))
  408. (documentation "Target for all the initially-mounted file systems")
  409. (start #~(const #t))
  410. (stop #~(const #f))))
  411. (define known-mount-points
  412. (map file-system-mount-point file-systems))
  413. (define user-unmount
  414. (shepherd-service
  415. (documentation "Unmount manually-mounted file systems.")
  416. (provision '(user-file-systems))
  417. (start #~(const #t))
  418. (stop #~(lambda args
  419. (define (known? mount-point)
  420. (member mount-point
  421. (cons* "/proc" "/sys" '#$known-mount-points)))
  422. ;; Make sure we don't keep the user's mount points busy.
  423. (chdir "/")
  424. (for-each (lambda (mount-point)
  425. (format #t "unmounting '~a'...~%" mount-point)
  426. (catch 'system-error
  427. (lambda ()
  428. (umount mount-point))
  429. (lambda args
  430. (let ((errno (system-error-errno args)))
  431. (format #t "failed to unmount '~a': ~a~%"
  432. mount-point (strerror errno))))))
  433. (filter (negate known?) (mount-points)))
  434. #f))))
  435. (cons* sink user-unmount
  436. (map file-system-shepherd-service file-systems))))
  437. (define file-system-service-type
  438. (service-type (name 'file-systems)
  439. (extensions
  440. (list (service-extension shepherd-root-service-type
  441. file-system-shepherd-services)
  442. (service-extension fstab-service-type
  443. identity)
  444. ;; Have 'user-processes' depend on 'file-systems'.
  445. (service-extension user-processes-service-type
  446. (const '(file-systems)))))
  447. (compose concatenate)
  448. (extend append)
  449. (description
  450. "Provide Shepherd services to mount and unmount the given
  451. file systems, as well as corresponding @file{/etc/fstab} entries.")))
  452. ;;;
  453. ;;; Preserve entropy to seed /dev/urandom on boot.
  454. ;;;
  455. (define %random-seed-file
  456. "/var/lib/random-seed")
  457. (define (urandom-seed-shepherd-service _)
  458. "Return a shepherd service for the /dev/urandom seed."
  459. (list (shepherd-service
  460. (documentation "Preserve entropy across reboots for /dev/urandom.")
  461. (provision '(urandom-seed))
  462. ;; Depend on udev so that /dev/hwrng is available.
  463. (requirement '(file-systems udev))
  464. (start #~(lambda _
  465. ;; On boot, write random seed into /dev/urandom.
  466. (when (file-exists? #$%random-seed-file)
  467. (call-with-input-file #$%random-seed-file
  468. (lambda (seed)
  469. (call-with-output-file "/dev/urandom"
  470. (lambda (urandom)
  471. (dump-port seed urandom))))))
  472. ;; Try writing from /dev/hwrng into /dev/urandom.
  473. ;; It seems that the file /dev/hwrng always exists, even
  474. ;; when there is no hardware random number generator
  475. ;; available. So, we handle a failed read or any other error
  476. ;; reported by the operating system.
  477. (let ((buf (catch 'system-error
  478. (lambda ()
  479. (call-with-input-file "/dev/hwrng"
  480. (lambda (hwrng)
  481. (get-bytevector-n hwrng 512))))
  482. ;; Silence is golden...
  483. (const #f))))
  484. (when buf
  485. (call-with-output-file "/dev/urandom"
  486. (lambda (urandom)
  487. (put-bytevector urandom buf)))))
  488. ;; Immediately refresh the seed in case the system doesn't
  489. ;; shut down cleanly.
  490. (call-with-input-file "/dev/urandom"
  491. (lambda (urandom)
  492. (let ((previous-umask (umask #o077))
  493. (buf (make-bytevector 512)))
  494. (mkdir-p (dirname #$%random-seed-file))
  495. (get-bytevector-n! urandom buf 0 512)
  496. (call-with-output-file #$%random-seed-file
  497. (lambda (seed)
  498. (put-bytevector seed buf)))
  499. (umask previous-umask))))
  500. #t))
  501. (stop #~(lambda _
  502. ;; During shutdown, write from /dev/urandom into random seed.
  503. (let ((buf (make-bytevector 512)))
  504. (call-with-input-file "/dev/urandom"
  505. (lambda (urandom)
  506. (let ((previous-umask (umask #o077)))
  507. (get-bytevector-n! urandom buf 0 512)
  508. (mkdir-p (dirname #$%random-seed-file))
  509. (call-with-output-file #$%random-seed-file
  510. (lambda (seed)
  511. (put-bytevector seed buf)))
  512. (umask previous-umask))
  513. #t)))))
  514. (modules `((rnrs bytevectors)
  515. (rnrs io ports)
  516. ,@%default-modules)))))
  517. (define urandom-seed-service-type
  518. (service-type (name 'urandom-seed)
  519. (extensions
  520. (list (service-extension shepherd-root-service-type
  521. urandom-seed-shepherd-service)
  522. ;; Have 'user-processes' depend on 'urandom-seed'.
  523. ;; This ensures that user processes and daemons don't
  524. ;; start until we have seeded the PRNG.
  525. (service-extension user-processes-service-type
  526. (const '(urandom-seed)))))
  527. (default-value #f)
  528. (description
  529. "Seed the @file{/dev/urandom} pseudo-random number
  530. generator (RNG) with the value recorded when the system was last shut
  531. down.")))
  532. (define-deprecated (urandom-seed-service)
  533. urandom-seed-service-type
  534. (service urandom-seed-service-type))
  535. ;;;
  536. ;;; Add hardware random number generator to entropy pool.
  537. ;;;
  538. (define-record-type* <rngd-configuration>
  539. rngd-configuration make-rngd-configuration
  540. rngd-configuration?
  541. (rng-tools rngd-configuration-rng-tools) ;package
  542. (device rngd-configuration-device)) ;string
  543. (define rngd-service-type
  544. (shepherd-service-type
  545. 'rngd
  546. (lambda (config)
  547. (define rng-tools (rngd-configuration-rng-tools config))
  548. (define device (rngd-configuration-device config))
  549. (define rngd-command
  550. (list (file-append rng-tools "/sbin/rngd")
  551. "-f" "-r" device))
  552. (shepherd-service
  553. (documentation "Add TRNG to entropy pool.")
  554. (requirement '(udev))
  555. (provision '(trng))
  556. (start #~(make-forkexec-constructor #$@rngd-command))
  557. (stop #~(make-kill-destructor))))))
  558. (define* (rngd-service #:key
  559. (rng-tools rng-tools)
  560. (device "/dev/hwrng"))
  561. "Return a service that runs the @command{rngd} program from @var{rng-tools}
  562. to add @var{device} to the kernel's entropy pool. The service will fail if
  563. @var{device} does not exist."
  564. (service rngd-service-type
  565. (rngd-configuration
  566. (rng-tools rng-tools)
  567. (device device))))
  568. ;;;
  569. ;;; Console & co.
  570. ;;;
  571. (define host-name-service-type
  572. (shepherd-service-type
  573. 'host-name
  574. (lambda (name)
  575. (shepherd-service
  576. (documentation "Initialize the machine's host name.")
  577. (provision '(host-name))
  578. (start #~(lambda _
  579. (sethostname #$name)))
  580. (respawn? #f)))))
  581. (define (host-name-service name)
  582. "Return a service that sets the host name to @var{name}."
  583. (service host-name-service-type name))
  584. (define virtual-terminal-service-type
  585. ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
  586. ;; default with recent Linux kernels, but this service allows us to ensure
  587. ;; this. This service must start before any 'term-' service so that newly
  588. ;; created terminals inherit this property. See
  589. ;; <https://bugs.gnu.org/30505> for a discussion.
  590. (shepherd-service-type
  591. 'virtual-terminal
  592. (lambda (utf8?)
  593. (let ((knob "/sys/module/vt/parameters/default_utf8"))
  594. (shepherd-service
  595. (documentation "Set virtual terminals in UTF-8 module.")
  596. (provision '(virtual-terminal))
  597. (requirement '(root-file-system))
  598. (start #~(lambda _
  599. ;; In containers /sys is read-only so don't insist on
  600. ;; writing to this file.
  601. (unless (= 1 (call-with-input-file #$knob read))
  602. (call-with-output-file #$knob
  603. (lambda (port)
  604. (display 1 port))))
  605. #t))
  606. (stop #~(const #f)))))
  607. #t)) ;default to UTF-8
  608. (define console-keymap-service-type
  609. (shepherd-service-type
  610. 'console-keymap
  611. (lambda (files)
  612. (shepherd-service
  613. (documentation (string-append "Load console keymap (loadkeys)."))
  614. (provision '(console-keymap))
  615. (start #~(lambda _
  616. (zero? (system* #$(file-append kbd "/bin/loadkeys")
  617. #$@files))))
  618. (respawn? #f)))))
  619. (define (console-keymap-service . files)
  620. "Return a service to load console keymaps from @var{files}."
  621. (service console-keymap-service-type files))
  622. (define %default-console-font
  623. ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
  624. ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
  625. ;; codepoints notably found in the UTF-8 manual.
  626. "LatGrkCyr-8x16")
  627. (define (console-font-shepherd-services tty+font)
  628. "Return a list of Shepherd services for each pair in TTY+FONT."
  629. (map (match-lambda
  630. ((tty . font)
  631. (let ((device (string-append "/dev/" tty)))
  632. (shepherd-service
  633. (documentation "Load a Unicode console font.")
  634. (provision (list (symbol-append 'console-font-
  635. (string->symbol tty))))
  636. ;; Start after mingetty has been started on TTY, otherwise the settings
  637. ;; are ignored.
  638. (requirement (list (symbol-append 'term-
  639. (string->symbol tty))))
  640. (start #~(lambda _
  641. ;; It could be that mingetty is not fully ready yet,
  642. ;; which we check by calling 'ttyname'.
  643. (let loop ((i 10))
  644. (unless (or (zero? i)
  645. (call-with-input-file #$device
  646. (lambda (port)
  647. (false-if-exception (ttyname port)))))
  648. (usleep 500)
  649. (loop (- i 1))))
  650. ;; Assume the VT is already in UTF-8 mode, thanks to
  651. ;; the 'virtual-terminal' service.
  652. ;;
  653. ;; 'setfont' returns EX_OSERR (71) when an
  654. ;; KDFONTOP ioctl fails, for example. Like
  655. ;; systemd's vconsole support, let's not treat
  656. ;; this as an error.
  657. (case (status:exit-val
  658. (system* #$(file-append kbd "/bin/setfont")
  659. "-C" #$device #$font))
  660. ((0 71) #t)
  661. (else #f))))
  662. (stop #~(const #t))
  663. (respawn? #f)))))
  664. tty+font))
  665. (define console-font-service-type
  666. (service-type (name 'console-fonts)
  667. (extensions
  668. (list (service-extension shepherd-root-service-type
  669. console-font-shepherd-services)))
  670. (compose concatenate)
  671. (extend append)
  672. (description
  673. "Install the given fonts on the specified ttys (fonts are per
  674. virtual console on GNU/Linux). The value of this service is a list of
  675. tty/font pairs like:
  676. @example
  677. '((\"tty1\" . \"LatGrkCyr-8x16\"))
  678. @end example\n")))
  679. (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
  680. "This procedure is deprecated in favor of @code{console-font-service-type}.
  681. Return a service that sets up Unicode support in @var{tty} and loads
  682. @var{font} for that tty (fonts are per virtual console in Linux.)"
  683. (simple-service (symbol-append 'console-font- (string->symbol tty))
  684. console-font-service-type `((,tty . ,font))))
  685. (define %default-motd
  686. (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
  687. (define-record-type* <login-configuration>
  688. login-configuration make-login-configuration
  689. login-configuration?
  690. (motd login-configuration-motd ;file-like
  691. (default %default-motd))
  692. ;; Allow empty passwords by default so that first-time users can log in when
  693. ;; the 'root' account has just been created.
  694. (allow-empty-passwords? login-configuration-allow-empty-passwords?
  695. (default #t))) ;Boolean
  696. (define (login-pam-service config)
  697. "Return the list of PAM service needed for CONF."
  698. ;; Let 'login' be known to PAM.
  699. (list (unix-pam-service "login"
  700. #:allow-empty-passwords?
  701. (login-configuration-allow-empty-passwords? config)
  702. #:motd
  703. (login-configuration-motd config))))
  704. (define login-service-type
  705. (service-type (name 'login)
  706. (extensions (list (service-extension pam-root-service-type
  707. login-pam-service)))
  708. (description
  709. "Provide a console log-in service as specified by its
  710. configuration value, a @code{login-configuration} object.")))
  711. (define* (login-service #:optional (config (login-configuration)))
  712. "Return a service configure login according to @var{config}, which specifies
  713. the message of the day, among other things."
  714. (service login-service-type config))
  715. (define-record-type* <agetty-configuration>
  716. agetty-configuration make-agetty-configuration
  717. agetty-configuration?
  718. (agetty agetty-configuration-agetty ;<package>
  719. (default util-linux))
  720. (tty agetty-configuration-tty) ;string | #f
  721. (term agetty-term ;string | #f
  722. (default #f))
  723. (baud-rate agetty-baud-rate ;string | #f
  724. (default #f))
  725. (auto-login agetty-auto-login ;list of strings | #f
  726. (default #f))
  727. (login-program agetty-login-program ;gexp
  728. (default (file-append shadow "/bin/login")))
  729. (login-pause? agetty-login-pause? ;Boolean
  730. (default #f))
  731. (eight-bits? agetty-eight-bits? ;Boolean
  732. (default #f))
  733. (no-reset? agetty-no-reset? ;Boolean
  734. (default #f))
  735. (remote? agetty-remote? ;Boolean
  736. (default #f))
  737. (flow-control? agetty-flow-control? ;Boolean
  738. (default #f))
  739. (host agetty-host ;string | #f
  740. (default #f))
  741. (no-issue? agetty-no-issue? ;Boolean
  742. (default #f))
  743. (init-string agetty-init-string ;string | #f
  744. (default #f))
  745. (no-clear? agetty-no-clear? ;Boolean
  746. (default #f))
  747. (local-line agetty-local-line ;always | never | auto
  748. (default #f))
  749. (extract-baud? agetty-extract-baud? ;Boolean
  750. (default #f))
  751. (skip-login? agetty-skip-login? ;Boolean
  752. (default #f))
  753. (no-newline? agetty-no-newline? ;Boolean
  754. (default #f))
  755. (login-options agetty-login-options ;string | #f
  756. (default #f))
  757. (chroot agetty-chroot ;string | #f
  758. (default #f))
  759. (hangup? agetty-hangup? ;Boolean
  760. (default #f))
  761. (keep-baud? agetty-keep-baud? ;Boolean
  762. (default #f))
  763. (timeout agetty-timeout ;integer | #f
  764. (default #f))
  765. (detect-case? agetty-detect-case? ;Boolean
  766. (default #f))
  767. (wait-cr? agetty-wait-cr? ;Boolean
  768. (default #f))
  769. (no-hints? agetty-no-hints? ;Boolean
  770. (default #f))
  771. (no-hostname? agetty-no hostname? ;Boolean
  772. (default #f))
  773. (long-hostname? agetty-long-hostname? ;Boolean
  774. (default #f))
  775. (erase-characters agetty-erase-characters ;string | #f
  776. (default #f))
  777. (kill-characters agetty-kill-characters ;string | #f
  778. (default #f))
  779. (chdir agetty-chdir ;string | #f
  780. (default #f))
  781. (delay agetty-delay ;integer | #f
  782. (default #f))
  783. (nice agetty-nice ;integer | #f
  784. (default #f))
  785. ;; "Escape hatch" for passing arbitrary command-line arguments.
  786. (extra-options agetty-extra-options ;list of strings
  787. (default '()))
  788. ;;; XXX Unimplemented for now!
  789. ;;; (issue-file agetty-issue-file ;file-like
  790. ;;; (default #f))
  791. )
  792. (define (default-serial-port)
  793. "Return a gexp that determines a reasonable default serial port
  794. to use as the tty. This is primarily useful for headless systems."
  795. #~(begin
  796. ;; console=device,options
  797. ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
  798. ;; options: BBBBPNF. P n|o|e, N number of bits,
  799. ;; F flow control (r RTS)
  800. (let* ((not-comma (char-set-complement (char-set #\,)))
  801. (command (linux-command-line))
  802. (agetty-specs (find-long-options "agetty.tty" command))
  803. (console-specs (filter (lambda (spec)
  804. (and (string-prefix? "tty" spec)
  805. (not (or
  806. (string-prefix? "tty0" spec)
  807. (string-prefix? "tty1" spec)
  808. (string-prefix? "tty2" spec)
  809. (string-prefix? "tty3" spec)
  810. (string-prefix? "tty4" spec)
  811. (string-prefix? "tty5" spec)
  812. (string-prefix? "tty6" spec)
  813. (string-prefix? "tty7" spec)
  814. (string-prefix? "tty8" spec)
  815. (string-prefix? "tty9" spec)))))
  816. (find-long-options "console" command)))
  817. (specs (append agetty-specs console-specs)))
  818. (match specs
  819. (() #f)
  820. ((spec _ ...)
  821. ;; Extract device name from first spec.
  822. (match (string-tokenize spec not-comma)
  823. ((device-name _ ...)
  824. device-name)))))))
  825. (define agetty-shepherd-service
  826. (match-lambda
  827. (($ <agetty-configuration> agetty tty term baud-rate auto-login
  828. login-program login-pause? eight-bits? no-reset? remote? flow-control?
  829. host no-issue? init-string no-clear? local-line extract-baud?
  830. skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
  831. detect-case? wait-cr? no-hints? no-hostname? long-hostname?
  832. erase-characters kill-characters chdir delay nice extra-options)
  833. (list
  834. (shepherd-service
  835. (modules '((ice-9 match) (gnu build linux-boot)))
  836. (documentation "Run agetty on a tty.")
  837. (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
  838. ;; Since the login prompt shows the host name, wait for the 'host-name'
  839. ;; service to be done. Also wait for udev essentially so that the tty
  840. ;; text is not lost in the middle of kernel messages (see also
  841. ;; mingetty-shepherd-service).
  842. (requirement '(user-processes host-name udev))
  843. (start #~(lambda args
  844. (let ((defaulted-tty #$(or tty (default-serial-port))))
  845. (apply
  846. (if defaulted-tty
  847. (make-forkexec-constructor
  848. (list #$(file-append util-linux "/sbin/agetty")
  849. #$@extra-options
  850. #$@(if eight-bits?
  851. #~("--8bits")
  852. #~())
  853. #$@(if no-reset?
  854. #~("--noreset")
  855. #~())
  856. #$@(if remote?
  857. #~("--remote")
  858. #~())
  859. #$@(if flow-control?
  860. #~("--flow-control")
  861. #~())
  862. #$@(if host
  863. #~("--host" #$host)
  864. #~())
  865. #$@(if no-issue?
  866. #~("--noissue")
  867. #~())
  868. #$@(if init-string
  869. #~("--init-string" #$init-string)
  870. #~())
  871. #$@(if no-clear?
  872. #~("--noclear")
  873. #~())
  874. ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
  875. ;;; is not passed, then the default is 'auto'. However, in my tests, when that
  876. ;;; option is selected, agetty never presents the login prompt, and the
  877. ;;; term-ttyS0 service respawns every few seconds.
  878. #$@(if local-line
  879. #~(#$(match local-line
  880. ('auto "--local-line=auto")
  881. ('always "--local-line=always")
  882. ('never "-local-line=never")))
  883. #~())
  884. #$@(if tty
  885. #~()
  886. #~("--keep-baud"))
  887. #$@(if extract-baud?
  888. #~("--extract-baud")
  889. #~())
  890. #$@(if skip-login?
  891. #~("--skip-login")
  892. #~())
  893. #$@(if no-newline?
  894. #~("--nonewline")
  895. #~())
  896. #$@(if login-options
  897. #~("--login-options" #$login-options)
  898. #~())
  899. #$@(if chroot
  900. #~("--chroot" #$chroot)
  901. #~())
  902. #$@(if hangup?
  903. #~("--hangup")
  904. #~())
  905. #$@(if keep-baud?
  906. #~("--keep-baud")
  907. #~())
  908. #$@(if timeout
  909. #~("--timeout" #$(number->string timeout))
  910. #~())
  911. #$@(if detect-case?
  912. #~("--detect-case")
  913. #~())
  914. #$@(if wait-cr?
  915. #~("--wait-cr")
  916. #~())
  917. #$@(if no-hints?
  918. #~("--nohints?")
  919. #~())
  920. #$@(if no-hostname?
  921. #~("--nohostname")
  922. #~())
  923. #$@(if long-hostname?
  924. #~("--long-hostname")
  925. #~())
  926. #$@(if erase-characters
  927. #~("--erase-chars" #$erase-characters)
  928. #~())
  929. #$@(if kill-characters
  930. #~("--kill-chars" #$kill-characters)
  931. #~())
  932. #$@(if chdir
  933. #~("--chdir" #$chdir)
  934. #~())
  935. #$@(if delay
  936. #~("--delay" #$(number->string delay))
  937. #~())
  938. #$@(if nice
  939. #~("--nice" #$(number->string nice))
  940. #~())
  941. #$@(if auto-login
  942. (list "--autologin" auto-login)
  943. '())
  944. #$@(if login-program
  945. #~("--login-program" #$login-program)
  946. #~())
  947. #$@(if login-pause?
  948. #~("--login-pause")
  949. #~())
  950. defaulted-tty
  951. #$@(if baud-rate
  952. #~(#$baud-rate)
  953. #~())
  954. #$@(if term
  955. #~(#$term)
  956. #~())))
  957. (const #f)) ; never start.
  958. args))))
  959. (stop #~(make-kill-destructor)))))))
  960. (define agetty-service-type
  961. (service-type (name 'agetty)
  962. (extensions (list (service-extension shepherd-root-service-type
  963. agetty-shepherd-service)))
  964. (description
  965. "Provide console login using the @command{agetty}
  966. program.")))
  967. (define* (agetty-service config)
  968. "Return a service to run agetty according to @var{config}, which specifies
  969. the tty to run, among other things."
  970. (service agetty-service-type config))
  971. (define-record-type* <mingetty-configuration>
  972. mingetty-configuration make-mingetty-configuration
  973. mingetty-configuration?
  974. (mingetty mingetty-configuration-mingetty ;<package>
  975. (default mingetty))
  976. (tty mingetty-configuration-tty) ;string
  977. (auto-login mingetty-auto-login ;string | #f
  978. (default #f))
  979. (login-program mingetty-login-program ;gexp
  980. (default #f))
  981. (login-pause? mingetty-login-pause? ;Boolean
  982. (default #f)))
  983. (define mingetty-shepherd-service
  984. (match-lambda
  985. (($ <mingetty-configuration> mingetty tty auto-login login-program
  986. login-pause?)
  987. (list
  988. (shepherd-service
  989. (documentation "Run mingetty on an tty.")
  990. (provision (list (symbol-append 'term- (string->symbol tty))))
  991. ;; Since the login prompt shows the host name, wait for the 'host-name'
  992. ;; service to be done. Also wait for udev essentially so that the tty
  993. ;; text is not lost in the middle of kernel messages (XXX).
  994. (requirement '(user-processes host-name udev virtual-terminal))
  995. (start #~(make-forkexec-constructor
  996. (list #$(file-append mingetty "/sbin/mingetty")
  997. "--noclear"
  998. ;; Avoiding 'vhangup' allows us to avoid 'setfont'
  999. ;; errors down the path where various ioctls get
  1000. ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
  1001. ;; in Linux.
  1002. "--nohangup" #$tty
  1003. #$@(if auto-login
  1004. #~("--autologin" #$auto-login)
  1005. #~())
  1006. #$@(if login-program
  1007. #~("--loginprog" #$login-program)
  1008. #~())
  1009. #$@(if login-pause?
  1010. #~("--loginpause")
  1011. #~()))))
  1012. (stop #~(make-kill-destructor)))))))
  1013. (define mingetty-service-type
  1014. (service-type (name 'mingetty)
  1015. (extensions (list (service-extension shepherd-root-service-type
  1016. mingetty-shepherd-service)))
  1017. (description
  1018. "Provide console login using the @command{mingetty}
  1019. program.")))
  1020. (define* (mingetty-service config)
  1021. "Return a service to run mingetty according to @var{config}, which specifies
  1022. the tty to run, among other things."
  1023. (service mingetty-service-type config))
  1024. (define-record-type* <nscd-configuration> nscd-configuration
  1025. make-nscd-configuration
  1026. nscd-configuration?
  1027. (log-file nscd-configuration-log-file ;string
  1028. (default "/var/log/nscd.log"))
  1029. (debug-level nscd-debug-level ;integer
  1030. (default 0))
  1031. ;; TODO: See nscd.conf in glibc for other options to add.
  1032. (caches nscd-configuration-caches ;list of <nscd-cache>
  1033. (default %nscd-default-caches))
  1034. (name-services nscd-configuration-name-services ;list of <packages>
  1035. (default '()))
  1036. (glibc nscd-configuration-glibc ;<package>
  1037. (default (canonical-package glibc))))
  1038. (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
  1039. nscd-cache?
  1040. (database nscd-cache-database) ;symbol
  1041. (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
  1042. (negative-time-to-live nscd-cache-negative-time-to-live
  1043. (default 20)) ;integer
  1044. (suggested-size nscd-cache-suggested-size ;integer ("default module
  1045. ;of hash table")
  1046. (default 211))
  1047. (check-files? nscd-cache-check-files? ;Boolean
  1048. (default #t))
  1049. (persistent? nscd-cache-persistent? ;Boolean
  1050. (default #t))
  1051. (shared? nscd-cache-shared? ;Boolean
  1052. (default #t))
  1053. (max-database-size nscd-cache-max-database-size ;integer
  1054. (default (* 32 (expt 2 20))))
  1055. (auto-propagate? nscd-cache-auto-propagate? ;Boolean
  1056. (default #t)))
  1057. (define %nscd-default-caches
  1058. ;; Caches that we want to enable by default. Note that when providing an
  1059. ;; empty nscd.conf, all caches are disabled.
  1060. (list (nscd-cache (database 'hosts)
  1061. ;; Aggressively cache the host name cache to improve
  1062. ;; privacy and resilience.
  1063. (positive-time-to-live (* 3600 12))
  1064. (negative-time-to-live 20)
  1065. (persistent? #t))
  1066. (nscd-cache (database 'services)
  1067. ;; Services are unlikely to change, so we can be even more
  1068. ;; aggressive.
  1069. (positive-time-to-live (* 3600 24))
  1070. (negative-time-to-live 3600)
  1071. (check-files? #t) ;check /etc/services changes
  1072. (persistent? #t))))
  1073. (define %nscd-default-configuration
  1074. ;; Default nscd configuration.
  1075. (nscd-configuration))
  1076. (define (nscd.conf-file config)
  1077. "Return the @file{nscd.conf} configuration file for @var{config}, an
  1078. @code{<nscd-configuration>} object."
  1079. (define cache->config
  1080. (match-lambda
  1081. (($ <nscd-cache> (= symbol->string database)
  1082. positive-ttl negative-ttl size check-files?
  1083. persistent? shared? max-size propagate?)
  1084. (string-append "\nenable-cache\t" database "\tyes\n"
  1085. "positive-time-to-live\t" database "\t"
  1086. (number->string positive-ttl) "\n"
  1087. "negative-time-to-live\t" database "\t"
  1088. (number->string negative-ttl) "\n"
  1089. "suggested-size\t" database "\t"
  1090. (number->string size) "\n"
  1091. "check-files\t" database "\t"
  1092. (if check-files? "yes\n" "no\n")
  1093. "persistent\t" database "\t"
  1094. (if persistent? "yes\n" "no\n")
  1095. "shared\t" database "\t"
  1096. (if shared? "yes\n" "no\n")
  1097. "max-db-size\t" database "\t"
  1098. (number->string max-size) "\n"
  1099. "auto-propagate\t" database "\t"
  1100. (if propagate? "yes\n" "no\n")))))
  1101. (match config
  1102. (($ <nscd-configuration> log-file debug-level caches)
  1103. (plain-file "nscd.conf"
  1104. (string-append "\
  1105. # Configuration of libc's name service cache daemon (nscd).\n\n"
  1106. (if log-file
  1107. (string-append "logfile\t" log-file)
  1108. "")
  1109. "\n"
  1110. (if debug-level
  1111. (string-append "debug-level\t"
  1112. (number->string debug-level))
  1113. "")
  1114. "\n"
  1115. (string-concatenate
  1116. (map cache->config caches)))))))
  1117. (define (nscd-action-procedure nscd config option)
  1118. ;; XXX: This is duplicated from mcron; factorize.
  1119. #~(lambda (_ . args)
  1120. ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
  1121. ;; 'current-output-port', which at this stage is bound to the client
  1122. ;; connection.
  1123. (let ((pipe (apply open-pipe* OPEN_READ #$nscd
  1124. "-f" #$config #$option args)))
  1125. (let loop ()
  1126. (match (read-line pipe 'concat)
  1127. ((? eof-object?)
  1128. (catch 'system-error
  1129. (lambda ()
  1130. (zero? (close-pipe pipe)))
  1131. (lambda args
  1132. ;; There's a race with the SIGCHLD handler, which could
  1133. ;; call 'waitpid' before 'close-pipe' above does. If we
  1134. ;; get ECHILD, that means we lost the race, but that's
  1135. ;; fine.
  1136. (or (= ECHILD (system-error-errno args))
  1137. (apply throw args)))))
  1138. (line
  1139. (display line)
  1140. (loop)))))))
  1141. (define (nscd-actions nscd config)
  1142. "Return Shepherd actions for NSCD."
  1143. ;; Make this functionality available as actions because that's a simple way
  1144. ;; to run the right 'nscd' binary with the right config file.
  1145. (list (shepherd-action
  1146. (name 'statistics)
  1147. (documentation "Display statistics about nscd usage.")
  1148. (procedure (nscd-action-procedure nscd config "--statistics")))
  1149. (shepherd-action
  1150. (name 'invalidate)
  1151. (documentation
  1152. "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
  1153. (procedure (nscd-action-procedure nscd config "--invalidate")))))
  1154. (define (nscd-shepherd-service config)
  1155. "Return a shepherd service for CONFIG, an <nscd-configuration> object."
  1156. (let ((nscd (file-append (nscd-configuration-glibc config)
  1157. "/sbin/nscd"))
  1158. (nscd.conf (nscd.conf-file config))
  1159. (name-services (nscd-configuration-name-services config)))
  1160. (list (shepherd-service
  1161. (documentation "Run libc's name service cache daemon (nscd).")
  1162. (provision '(nscd))
  1163. (requirement '(user-processes))
  1164. (start #~(make-forkexec-constructor
  1165. (list #$nscd "-f" #$nscd.conf "--foreground")
  1166. ;; Wait for the PID file. However, the PID file is
  1167. ;; written before nscd is actually listening on its
  1168. ;; socket (XXX).
  1169. #:pid-file "/var/run/nscd/nscd.pid"
  1170. #:environment-variables
  1171. (list (string-append "LD_LIBRARY_PATH="
  1172. (string-join
  1173. (map (lambda (dir)
  1174. (string-append dir "/lib"))
  1175. (list #$@name-services))
  1176. ":")))))
  1177. (stop #~(make-kill-destructor))
  1178. (modules `((ice-9 popen) ;for the actions
  1179. (ice-9 rdelim)
  1180. (ice-9 match)
  1181. ,@%default-modules))
  1182. (actions (nscd-actions nscd nscd.conf))))))
  1183. (define nscd-activation
  1184. ;; Actions to take before starting nscd.
  1185. #~(begin
  1186. (use-modules (guix build utils))
  1187. (mkdir-p "/var/run/nscd")
  1188. (mkdir-p "/var/db/nscd") ;for the persistent cache
  1189. ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
  1190. ;; that file exists when it is started. Thus create it here. Note: on
  1191. ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
  1192. ;; is a symlink, hence 'lstat'.
  1193. (unless (false-if-exception (lstat "/etc/resolv.conf"))
  1194. (call-with-output-file "/etc/resolv.conf"
  1195. (lambda (port)
  1196. (display "# This is a placeholder.\n" port))))))
  1197. (define nscd-service-type
  1198. (service-type (name 'nscd)
  1199. (extensions
  1200. (list (service-extension activation-service-type
  1201. (const nscd-activation))
  1202. (service-extension shepherd-root-service-type
  1203. nscd-shepherd-service)))
  1204. ;; This can be extended by providing additional name services
  1205. ;; such as nss-mdns.
  1206. (compose concatenate)
  1207. (extend (lambda (config name-services)
  1208. (nscd-configuration
  1209. (inherit config)
  1210. (name-services (append
  1211. (nscd-configuration-name-services config)
  1212. name-services)))))
  1213. (description
  1214. "Runs libc's @dfn{name service cache daemon} (nscd) with the
  1215. given configuration---an @code{<nscd-configuration>} object. @xref{Name
  1216. Service Switch}, for an example.")))
  1217. (define* (nscd-service #:optional (config %nscd-default-configuration))
  1218. "Return a service that runs libc's name service cache daemon (nscd) with the
  1219. given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
  1220. Service Switch}, for an example."
  1221. (service nscd-service-type config))
  1222. (define-record-type* <syslog-configuration>
  1223. syslog-configuration make-syslog-configuration
  1224. syslog-configuration?
  1225. (syslogd syslog-configuration-syslogd
  1226. (default (file-append inetutils "/libexec/syslogd")))
  1227. (config-file syslog-configuration-config-file
  1228. (default %default-syslog.conf)))
  1229. (define syslog-service-type
  1230. (shepherd-service-type
  1231. 'syslog
  1232. (lambda (config)
  1233. (shepherd-service
  1234. (documentation "Run the syslog daemon (syslogd).")
  1235. (provision '(syslogd))
  1236. (requirement '(user-processes))
  1237. (start #~(make-forkexec-constructor
  1238. (list #$(syslog-configuration-syslogd config)
  1239. "--rcfile" #$(syslog-configuration-config-file config))
  1240. #:pid-file "/var/run/syslog.pid"))
  1241. (stop #~(make-kill-destructor))))))
  1242. ;; Snippet adapted from the GNU inetutils manual.
  1243. (define %default-syslog.conf
  1244. (plain-file "syslog.conf" "
  1245. # Log all error messages, authentication messages of
  1246. # level notice or higher and anything of level err or
  1247. # higher to the console.
  1248. # Don't log private authentication messages!
  1249. *.alert;auth.notice;authpriv.none /dev/console
  1250. # Log anything (except mail) of level info or higher.
  1251. # Don't log private authentication messages!
  1252. *.info;mail.none;authpriv.none /var/log/messages
  1253. # Like /var/log/messages, but also including \"debug\"-level logs.
  1254. *.debug;mail.none;authpriv.none /var/log/debug
  1255. # Same, in a different place.
  1256. *.info;mail.none;authpriv.none /dev/tty12
  1257. # The authpriv file has restricted access.
  1258. authpriv.* /var/log/secure
  1259. # Log all the mail messages in one place.
  1260. mail.* /var/log/maillog
  1261. "))
  1262. (define* (syslog-service #:optional (config (syslog-configuration)))
  1263. "Return a service that runs @command{syslogd} and takes
  1264. @var{<syslog-configuration>} as a parameter.
  1265. @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
  1266. information on the configuration file syntax."
  1267. (service syslog-service-type config))
  1268. (define pam-limits-service-type
  1269. (let ((security-limits
  1270. ;; Create /etc/security containing the provided "limits.conf" file.
  1271. (lambda (limits-file)
  1272. `(("security"
  1273. ,(computed-file
  1274. "security"
  1275. #~(begin
  1276. (mkdir #$output)
  1277. (stat #$limits-file)
  1278. (symlink #$limits-file
  1279. (string-append #$output "/limits.conf"))))))))
  1280. (pam-extension
  1281. (lambda (pam)
  1282. (let ((pam-limits (pam-entry
  1283. (control "required")
  1284. (module "pam_limits.so")
  1285. (arguments '("conf=/etc/security/limits.conf")))))
  1286. (if (member (pam-service-name pam)
  1287. '("login" "su" "slim"))
  1288. (pam-service
  1289. (inherit pam)
  1290. (session (cons pam-limits
  1291. (pam-service-session pam))))
  1292. pam)))))
  1293. (service-type
  1294. (name 'limits)
  1295. (extensions
  1296. (list (service-extension etc-service-type security-limits)
  1297. (service-extension pam-root-service-type
  1298. (lambda _ (list pam-extension)))))
  1299. (description
  1300. "Install the specified resource usage limits by populating
  1301. @file{/etc/security/limits.conf} and using the @code{pam_limits}
  1302. authentication module."))))
  1303. (define* (pam-limits-service #:optional (limits '()))
  1304. "Return a service that makes selected programs respect the list of
  1305. pam-limits-entry specified in LIMITS via pam_limits.so."
  1306. (service pam-limits-service-type
  1307. (plain-file "limits.conf"
  1308. (string-join (map pam-limits-entry->string limits)
  1309. "\n"))))
  1310. ;;;
  1311. ;;; Guix services.
  1312. ;;;
  1313. (define* (guix-build-accounts count #:key
  1314. (group "guixbuild")
  1315. (first-uid 30001)
  1316. (shadow shadow))
  1317. "Return a list of COUNT user accounts for Guix build users, with UIDs
  1318. starting at FIRST-UID, and under GID."
  1319. (unfold (cut > <> count)
  1320. (lambda (n)
  1321. (user-account
  1322. (name (format #f "guixbuilder~2,'0d" n))
  1323. (system? #t)
  1324. (uid (+ first-uid n -1))
  1325. (group group)
  1326. ;; guix-daemon expects GROUP to be listed as a
  1327. ;; supplementary group too:
  1328. ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
  1329. (supplementary-groups (list group "kvm"))
  1330. (comment (format #f "Guix Build User ~2d" n))
  1331. (home-directory "/var/empty")
  1332. (shell (file-append shadow "/sbin/nologin"))))
  1333. 1+
  1334. 1))
  1335. (define (hydra-key-authorization keys guix)
  1336. "Return a gexp with code to register KEYS, a list of files containing 'guix
  1337. archive' public keys, with GUIX."
  1338. #~(unless (file-exists? "/etc/guix/acl")
  1339. (for-each (lambda (key)
  1340. (let ((pid (primitive-fork)))
  1341. (case pid
  1342. ((0)
  1343. (let* ((port (open-file key "r0b")))
  1344. (format #t "registering public key '~a'...~%" key)
  1345. (close-port (current-input-port))
  1346. (dup port 0)
  1347. (execl #$(file-append guix "/bin/guix")
  1348. "guix" "archive" "--authorize")
  1349. (primitive-exit 1)))
  1350. (else
  1351. (let ((status (cdr (waitpid pid))))
  1352. (unless (zero? status)
  1353. (format (current-error-port) "warning: \
  1354. failed to register public key '~a': ~a~%" key status)))))))
  1355. '(#$@keys))))
  1356. (define %default-authorized-guix-keys
  1357. ;; List of authorized substitute keys.
  1358. (list (file-append guix "/share/guix/hydra.gnu.org.pub")
  1359. (file-append guix "/share/guix/berlin.guixsd.org.pub")))
  1360. (define-record-type* <guix-configuration>
  1361. guix-configuration make-guix-configuration
  1362. guix-configuration?
  1363. (guix guix-configuration-guix ;<package>
  1364. (default guix))
  1365. (build-group guix-configuration-build-group ;string
  1366. (default "guixbuild"))
  1367. (build-accounts guix-configuration-build-accounts ;integer
  1368. (default 10))
  1369. (authorize-key? guix-configuration-authorize-key? ;Boolean
  1370. (default #t))
  1371. (authorized-keys guix-configuration-authorized-keys ;list of gexps
  1372. (default %default-authorized-guix-keys))
  1373. (use-substitutes? guix-configuration-use-substitutes? ;Boolean
  1374. (default #t))
  1375. (substitute-urls guix-configuration-substitute-urls ;list of strings
  1376. (default %default-substitute-urls))
  1377. (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
  1378. (default '()))
  1379. (max-silent-time guix-configuration-max-silent-time ;integer
  1380. (default 0))
  1381. (timeout guix-configuration-timeout ;integer
  1382. (default 0))
  1383. (log-compression guix-configuration-log-compression
  1384. (default 'bzip2))
  1385. (extra-options guix-configuration-extra-options ;list of strings
  1386. (default '()))
  1387. (log-file guix-configuration-log-file ;string
  1388. (default "/var/log/guix-daemon.log"))
  1389. (http-proxy guix-http-proxy ;string | #f
  1390. (default #f))
  1391. (tmpdir guix-tmpdir ;string | #f
  1392. (default #f)))
  1393. (define %default-guix-configuration
  1394. (guix-configuration))
  1395. (define (guix-shepherd-service config)
  1396. "Return a <shepherd-service> for the Guix daemon service with CONFIG."
  1397. (match-record config <guix-configuration>
  1398. (guix build-group build-accounts authorize-key? authorized-keys
  1399. use-substitutes? substitute-urls max-silent-time timeout
  1400. log-compression extra-options log-file http-proxy tmpdir
  1401. chroot-directories)
  1402. (list (shepherd-service
  1403. (documentation "Run the Guix daemon.")
  1404. (provision '(guix-daemon))
  1405. (requirement '(user-processes))
  1406. (modules '((srfi srfi-1)))
  1407. (start
  1408. #~(make-forkexec-constructor
  1409. (cons* #$(file-append guix "/bin/guix-daemon")
  1410. "--build-users-group" #$build-group
  1411. "--max-silent-time" #$(number->string max-silent-time)
  1412. "--timeout" #$(number->string timeout)
  1413. "--log-compression" #$(symbol->string log-compression)
  1414. #$@(if use-substitutes?
  1415. '()
  1416. '("--no-substitutes"))
  1417. "--substitute-urls" #$(string-join substitute-urls)
  1418. #$@extra-options
  1419. ;; Add CHROOT-DIRECTORIES and all their dependencies (if
  1420. ;; these are store items) to the chroot.
  1421. (append-map (lambda (file)
  1422. (append-map (lambda (directory)
  1423. (list "--chroot-directory"
  1424. directory))
  1425. (call-with-input-file file
  1426. read)))
  1427. '#$(map references-file chroot-directories)))
  1428. #:environment-variables
  1429. (list #$@(if http-proxy
  1430. (list (string-append "http_proxy=" http-proxy))
  1431. '())
  1432. #$@(if tmpdir
  1433. (list (string-append "TMPDIR=" tmpdir))
  1434. '())
  1435. ;; Make sure we run in a UTF-8 locale so that 'guix
  1436. ;; offload' correctly restores nars that contain UTF-8
  1437. ;; file names such as 'nss-certs'. See
  1438. ;; <https://bugs.gnu.org/32942>.
  1439. (string-append "GUIX_LOCPATH="
  1440. #$glibc-utf8-locales "/lib/locale")
  1441. "LC_ALL=en_US.utf8")
  1442. #:log-file #$log-file))
  1443. (stop #~(make-kill-destructor))))))
  1444. (define (guix-accounts config)
  1445. "Return the user accounts and user groups for CONFIG."
  1446. (match config
  1447. (($ <guix-configuration> _ build-group build-accounts)
  1448. (cons (user-group
  1449. (name build-group)
  1450. (system? #t)
  1451. ;; Use a fixed GID so that we can create the store with the right
  1452. ;; owner.
  1453. (id 30000))
  1454. (guix-build-accounts build-accounts
  1455. #:group build-group)))))
  1456. (define (guix-activation config)
  1457. "Return the activation gexp for CONFIG."
  1458. (match config
  1459. (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
  1460. ;; Assume that the store has BUILD-GROUP as its group. We could
  1461. ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
  1462. ;; chown leads to an entire copy of the tree, which is a bad idea.
  1463. ;; Optionally authorize substitute server keys.
  1464. (if authorize-key?
  1465. (hydra-key-authorization keys guix)
  1466. #~#f))))
  1467. (define* (references-file item #:optional (name "references"))
  1468. "Return a file that contains the list of references of ITEM."
  1469. (if (struct? item) ;lowerable object
  1470. (computed-file name
  1471. (with-imported-modules (source-module-closure
  1472. '((guix build store-copy)))
  1473. #~(begin
  1474. (use-modules (guix build store-copy))
  1475. (call-with-output-file #$output
  1476. (lambda (port)
  1477. (write (map store-info-item
  1478. (call-with-input-file "graph"
  1479. read-reference-graph))
  1480. port)))))
  1481. #:options `(#:local-build? #f
  1482. #:references-graphs (("graph" ,item))))
  1483. (plain-file name "()")))
  1484. (define guix-service-type
  1485. (service-type
  1486. (name 'guix)
  1487. (extensions
  1488. (list (service-extension shepherd-root-service-type guix-shepherd-service)
  1489. (service-extension account-service-type guix-accounts)
  1490. (service-extension activation-service-type guix-activation)
  1491. (service-extension profile-service-type
  1492. (compose list guix-configuration-guix))))
  1493. ;; Extensions can specify extra directories to add to the build chroot.
  1494. (compose concatenate)
  1495. (extend (lambda (config directories)
  1496. (guix-configuration
  1497. (inherit config)
  1498. (chroot-directories
  1499. (append (guix-configuration-chroot-directories config)
  1500. directories)))))
  1501. (default-value (guix-configuration))
  1502. (description
  1503. "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
  1504. (define-deprecated (guix-service #:optional
  1505. (config %default-guix-configuration))
  1506. guix-service-type
  1507. "Return a service that runs the Guix build daemon according to
  1508. @var{config}."
  1509. (service guix-service-type config))
  1510. (define-record-type* <guix-publish-configuration>
  1511. guix-publish-configuration make-guix-publish-configuration
  1512. guix-publish-configuration?
  1513. (guix guix-publish-configuration-guix ;package
  1514. (default guix))
  1515. (port guix-publish-configuration-port ;number
  1516. (default 80))
  1517. (host guix-publish-configuration-host ;string
  1518. (default "localhost"))
  1519. (compression-level guix-publish-configuration-compression-level ;integer
  1520. (default 3))
  1521. (nar-path guix-publish-configuration-nar-path ;string
  1522. (default "nar"))
  1523. (cache guix-publish-configuration-cache ;#f | string
  1524. (default #f))
  1525. (workers guix-publish-configuration-workers ;#f | integer
  1526. (default #f))
  1527. (ttl guix-publish-configuration-ttl ;#f | integer
  1528. (default #f)))
  1529. (define guix-publish-shepherd-service
  1530. (match-lambda
  1531. (($ <guix-publish-configuration> guix port host compression
  1532. nar-path cache workers ttl)
  1533. (list (shepherd-service
  1534. (provision '(guix-publish))
  1535. (requirement '(guix-daemon))
  1536. (start #~(make-forkexec-constructor
  1537. (list #$(file-append guix "/bin/guix")
  1538. "publish" "-u" "guix-publish"
  1539. "-p" #$(number->string port)
  1540. "-C" #$(number->string compression)
  1541. (string-append "--nar-path=" #$nar-path)
  1542. (string-append "--listen=" #$host)
  1543. #$@(if workers
  1544. #~((string-append "--workers="
  1545. #$(number->string
  1546. workers)))
  1547. #~())
  1548. #$@(if ttl
  1549. #~((string-append "--ttl="
  1550. #$(number->string ttl)
  1551. "s"))
  1552. #~())
  1553. #$@(if cache
  1554. #~((string-append "--cache=" #$cache))
  1555. #~()))
  1556. ;; Make sure we run in a UTF-8 locale so we can produce
  1557. ;; nars for packages that contain UTF-8 file names such
  1558. ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
  1559. #:environment-variables
  1560. (list (string-append "GUIX_LOCPATH="
  1561. #$glibc-utf8-locales "/lib/locale")
  1562. "LC_ALL=en_US.utf8")))
  1563. (stop #~(make-kill-destructor)))))))
  1564. (define %guix-publish-accounts
  1565. (list (user-group (name "guix-publish") (system? #t))
  1566. (user-account
  1567. (name "guix-publish")
  1568. (group "guix-publish")
  1569. (system? #t)
  1570. (comment "guix publish user")
  1571. (home-directory "/var/empty")
  1572. (shell (file-append shadow "/sbin/nologin")))))
  1573. (define (guix-publish-activation config)
  1574. (let ((cache (guix-publish-configuration-cache config)))
  1575. (if cache
  1576. (with-imported-modules '((guix build utils))
  1577. #~(begin
  1578. (use-modules (guix build utils))
  1579. (mkdir-p #$cache)
  1580. (let* ((pw (getpw "guix-publish"))
  1581. (uid (passwd:uid pw))
  1582. (gid (passwd:gid pw)))
  1583. (chown #$cache uid gid))))
  1584. #t)))
  1585. (define guix-publish-service-type
  1586. (service-type (name 'guix-publish)
  1587. (extensions
  1588. (list (service-extension shepherd-root-service-type
  1589. guix-publish-shepherd-service)
  1590. (service-extension account-service-type
  1591. (const %guix-publish-accounts))
  1592. (service-extension activation-service-type
  1593. guix-publish-activation)))
  1594. (default-value (guix-publish-configuration))
  1595. (description
  1596. "Add a Shepherd service running @command{guix publish}, a
  1597. command that allows you to share pre-built binaries with others over HTTP.")))
  1598. (define-deprecated (guix-publish-service #:key (guix guix)
  1599. (port 80) (host "localhost"))
  1600. guix-publish-service-type
  1601. "Return a service that runs @command{guix publish} listening on @var{host}
  1602. and @var{port} (@pxref{Invoking guix publish}).
  1603. This assumes that @file{/etc/guix} already contains a signing key pair as
  1604. created by @command{guix archive --generate-key} (@pxref{Invoking guix
  1605. archive}). If that is not the case, the service will fail to start."
  1606. ;; Deprecated.
  1607. (service guix-publish-service-type
  1608. (guix-publish-configuration (guix guix) (port port) (host host))))
  1609. ;;;
  1610. ;;; Udev.
  1611. ;;;
  1612. (define-record-type* <udev-configuration>
  1613. udev-configuration make-udev-configuration
  1614. udev-configuration?
  1615. (udev udev-configuration-udev ;<package>
  1616. (default udev))
  1617. (rules udev-configuration-rules ;list of <package>
  1618. (default '())))
  1619. (define (udev-rules-union packages)
  1620. "Return the union of the @code{lib/udev/rules.d} directories found in each
  1621. item of @var{packages}."
  1622. (define build
  1623. (with-imported-modules '((guix build union)
  1624. (guix build utils))
  1625. #~(begin
  1626. (use-modules (guix build union)
  1627. (guix build utils)
  1628. (srfi srfi-1)
  1629. (srfi srfi-26))
  1630. (define %standard-locations
  1631. '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
  1632. (define (rules-sub-directory directory)
  1633. ;; Return the sub-directory of DIRECTORY containing udev rules, or
  1634. ;; #f if none was found.
  1635. (find directory-exists?
  1636. (map (cut string-append directory <>) %standard-locations)))
  1637. (mkdir-p (string-append #$output "/lib/udev"))
  1638. (union-build (string-append #$output "/lib/udev/rules.d")
  1639. (filter-map rules-sub-directory '#$packages)))))
  1640. (computed-file "udev-rules" build))
  1641. (define (udev-rule file-name contents)
  1642. "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
  1643. (computed-file file-name
  1644. (with-imported-modules '((guix build utils))
  1645. #~(begin
  1646. (use-modules (guix build utils))
  1647. (define rules.d
  1648. (string-append #$output "/lib/udev/rules.d"))
  1649. (mkdir-p rules.d)
  1650. (call-with-output-file
  1651. (string-append rules.d "/" #$file-name)
  1652. (lambda (port)
  1653. (display #$contents port)))))))
  1654. (define (file->udev-rule file-name file)
  1655. "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
  1656. (computed-file file-name
  1657. (with-imported-modules '((guix build utils))
  1658. #~(begin
  1659. (use-modules (guix build utils))
  1660. (define rules.d
  1661. (string-append #$output "/lib/udev/rules.d"))
  1662. (define file-copy-dest
  1663. (string-append rules.d "/" #$file-name))
  1664. (mkdir-p rules.d)
  1665. (copy-file #$file file-copy-dest)))))
  1666. (define kvm-udev-rule
  1667. ;; Return a directory with a udev rule that changes the group of /dev/kvm to
  1668. ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
  1669. ;; but now we have to add it by ourselves.
  1670. ;; Build users are part of the "kvm" group, so we can fearlessly make
  1671. ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
  1672. (udev-rule "90-kvm.rules"
  1673. "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
  1674. (define udev-shepherd-service
  1675. ;; Return a <shepherd-service> for UDEV with RULES.
  1676. (match-lambda
  1677. (($ <udev-configuration> udev rules)
  1678. (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
  1679. (udev.conf (computed-file "udev.conf"
  1680. #~(call-with-output-file #$output
  1681. (lambda (port)
  1682. (format port
  1683. "udev_rules=\"~a/lib/udev/rules.d\"\n"
  1684. #$rules))))))
  1685. (list
  1686. (shepherd-service
  1687. (provision '(udev))
  1688. ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
  1689. ;; be added: see
  1690. ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
  1691. (requirement '(root-file-system))
  1692. (documentation "Populate the /dev directory, dynamically.")
  1693. (start #~(lambda ()
  1694. (define udevd
  1695. ;; 'udevd' from eudev.
  1696. #$(file-append udev "/sbin/udevd"))
  1697. (define (wait-for-udevd)
  1698. ;; Wait until someone's listening on udevd's control
  1699. ;; socket.
  1700. (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
  1701. (let try ()
  1702. (catch 'system-error
  1703. (lambda ()
  1704. (connect sock PF_UNIX "/run/udev/control")
  1705. (close-port sock))
  1706. (lambda args
  1707. (format #t "waiting for udevd...~%")
  1708. (usleep 500000)
  1709. (try))))))
  1710. ;; Allow udev to find the modules.
  1711. (setenv "LINUX_MODULE_DIRECTORY"
  1712. "/run/booted-system/kernel/lib/modules")
  1713. ;; The first one is for udev, the second one for eudev.
  1714. (setenv "UDEV_CONFIG_FILE" #$udev.conf)
  1715. (setenv "EUDEV_RULES_DIRECTORY"
  1716. #$(file-append rules "/lib/udev/rules.d"))
  1717. (let* ((kernel-release
  1718. (utsname:release (uname)))
  1719. (linux-module-directory
  1720. (getenv "LINUX_MODULE_DIRECTORY"))
  1721. (directory
  1722. (string-append linux-module-directory "/"
  1723. kernel-release))
  1724. (old-umask (umask #o022)))
  1725. ;; If we're in a container, DIRECTORY might not exist,
  1726. ;; for instance because the host runs a different
  1727. ;; kernel. In that case, skip it; we'll just miss a few
  1728. ;; nodes like /dev/fuse.
  1729. (when (file-exists? directory)
  1730. (make-static-device-nodes directory))
  1731. (umask old-umask))
  1732. (let ((pid (fork+exec-command (list udevd))))
  1733. ;; Wait until udevd is up and running. This appears to
  1734. ;; be needed so that the events triggered below are
  1735. ;; actually handled.
  1736. (wait-for-udevd)
  1737. ;; Trigger device node creation.
  1738. (system* #$(file-append udev "/bin/udevadm")
  1739. "trigger" "--action=add")
  1740. ;; Wait for things to settle down.
  1741. (system* #$(file-append udev "/bin/udevadm")
  1742. "settle")
  1743. pid)))
  1744. (stop #~(make-kill-destructor))
  1745. ;; When halting the system, 'udev' is actually killed by
  1746. ;; 'user-processes', i.e., before its own 'stop' method was called.
  1747. ;; Thus, make sure it is not respawned.
  1748. (respawn? #f)
  1749. ;; We need additional modules.
  1750. (modules `((gnu build linux-boot)
  1751. ,@%default-modules))
  1752. (actions (list (shepherd-action
  1753. (name 'rules)
  1754. (documentation "Display the directory containing
  1755. the udev rules in use.")
  1756. (procedure #~(lambda (_)
  1757. (display #$rules)
  1758. (newline))))))))))))
  1759. (define udev-service-type
  1760. (service-type (name 'udev)
  1761. (extensions
  1762. (list (service-extension shepherd-root-service-type
  1763. udev-shepherd-service)))
  1764. (compose concatenate) ;concatenate the list of rules
  1765. (extend (lambda (config rules)
  1766. (match config
  1767. (($ <udev-configuration> udev initial-rules)
  1768. (udev-configuration
  1769. (udev udev)
  1770. (rules (append initial-rules rules)))))))
  1771. (description
  1772. "Run @command{udev}, which populates the @file{/dev}
  1773. directory dynamically. Get extra rules from the packages listed in the
  1774. @code{rules} field of its value, @code{udev-configuration} object.")))
  1775. (define* (udev-service #:key (udev eudev) (rules '()))
  1776. "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
  1777. extra rules from the packages listed in @var{rules}."
  1778. (service udev-service-type
  1779. (udev-configuration (udev udev) (rules rules))))
  1780. (define swap-service-type
  1781. (shepherd-service-type
  1782. 'swap
  1783. (lambda (device)
  1784. (define requirement
  1785. (if (string-prefix? "/dev/mapper/" device)
  1786. (list (symbol-append 'device-mapping-
  1787. (string->symbol (basename device))))
  1788. '()))
  1789. (shepherd-service
  1790. (provision (list (symbol-append 'swap- (string->symbol device))))
  1791. (requirement `(udev ,@requirement))
  1792. (documentation "Enable the given swap device.")
  1793. (start #~(lambda ()
  1794. (restart-on-EINTR (swapon #$device))
  1795. #t))
  1796. (stop #~(lambda _
  1797. (restart-on-EINTR (swapoff #$device))
  1798. #f))
  1799. (respawn? #f)))))
  1800. (define (swap-service device)
  1801. "Return a service that uses @var{device} as a swap device."
  1802. (service swap-service-type device))
  1803. (define %default-gpm-options
  1804. ;; Default options for GPM.
  1805. '("-m" "/dev/input/mice" "-t" "ps2"))
  1806. (define-record-type* <gpm-configuration>
  1807. gpm-configuration make-gpm-configuration gpm-configuration?
  1808. (gpm gpm-configuration-gpm ;package
  1809. (default gpm))
  1810. (options gpm-configuration-options ;list of strings
  1811. (default %default-gpm-options)))
  1812. (define gpm-shepherd-service
  1813. (match-lambda
  1814. (($ <gpm-configuration> gpm options)
  1815. (list (shepherd-service
  1816. (requirement '(udev))
  1817. (provision '(gpm))
  1818. (start #~(lambda ()
  1819. ;; 'gpm' runs in the background and sets a PID file.
  1820. ;; Note that it requires running as "root".
  1821. (false-if-exception (delete-file "/var/run/gpm.pid"))
  1822. (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
  1823. #$@options))
  1824. ;; Wait for the PID file to appear; declare failure if
  1825. ;; it doesn't show up.
  1826. (let loop ((i 3))
  1827. (or (file-exists? "/var/run/gpm.pid")
  1828. (if (zero? i)
  1829. #f
  1830. (begin
  1831. (sleep 1)
  1832. (loop (1- i))))))))
  1833. (stop #~(lambda (_)
  1834. ;; Return #f if successfully stopped.
  1835. (not (zero? (system* #$(file-append gpm "/sbin/gpm")
  1836. "-k"))))))))))
  1837. (define gpm-service-type
  1838. (service-type (name 'gpm)
  1839. (extensions
  1840. (list (service-extension shepherd-root-service-type
  1841. gpm-shepherd-service)))
  1842. (default-value (gpm-configuration))
  1843. (description
  1844. "Run GPM, the general-purpose mouse daemon, with the given
  1845. command-line options. GPM allows users to use the mouse in the console,
  1846. notably to select, copy, and paste text. The default options use the
  1847. @code{ps2} protocol, which works for both USB and PS/2 mice.")))
  1848. (define-deprecated (gpm-service #:key (gpm gpm)
  1849. (options %default-gpm-options))
  1850. gpm-service-type
  1851. "Run @var{gpm}, the general-purpose mouse daemon, with the given
  1852. command-line @var{options}. GPM allows users to use the mouse in the console,
  1853. notably to select, copy, and paste text. The default value of @var{options}
  1854. uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
  1855. This service is not part of @var{%base-services}."
  1856. ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
  1857. ;; "info mice" and "mouse_set X" to use the right mouse.
  1858. (service gpm-service-type
  1859. (gpm-configuration (gpm gpm) (options options))))
  1860. (define-record-type* <kmscon-configuration>
  1861. kmscon-configuration make-kmscon-configuration
  1862. kmscon-configuration?
  1863. (kmscon kmscon-configuration-kmscon
  1864. (default kmscon))
  1865. (virtual-terminal kmscon-configuration-virtual-terminal)
  1866. (login-program kmscon-configuration-login-program
  1867. (default (file-append shadow "/bin/login")))
  1868. (login-arguments kmscon-configuration-login-arguments
  1869. (default '("-p")))
  1870. (auto-login kmscon-configuration-auto-login
  1871. (default #f))
  1872. (hardware-acceleration? kmscon-configuration-hardware-acceleration?
  1873. (default #f))) ; #t causes failure
  1874. (define kmscon-service-type
  1875. (shepherd-service-type
  1876. 'kmscon
  1877. (lambda (config)
  1878. (let ((kmscon (kmscon-configuration-kmscon config))
  1879. (virtual-terminal (kmscon-configuration-virtual-terminal config))
  1880. (login-program (kmscon-configuration-login-program config))
  1881. (login-arguments (kmscon-configuration-login-arguments config))
  1882. (auto-login (kmscon-configuration-auto-login config))
  1883. (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
  1884. (define kmscon-command
  1885. #~(list
  1886. #$(file-append kmscon "/bin/kmscon") "--login"
  1887. "--vt" #$virtual-terminal
  1888. "--no-switchvt" ;Prevent a switch to the virtual terminal.
  1889. #$@(if hardware-acceleration? '("--hwaccel") '())
  1890. "--login" "--"
  1891. #$login-program #$@login-arguments
  1892. #$@(if auto-login
  1893. #~(#$auto-login)
  1894. #~())))
  1895. (shepherd-service
  1896. (documentation "kmscon virtual terminal")
  1897. (requirement '(user-processes udev dbus-system))
  1898. (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
  1899. (start #~(make-forkexec-constructor #$kmscon-command))
  1900. (stop #~(make-kill-destructor)))))))
  1901. (define-record-type* <static-networking>
  1902. static-networking make-static-networking
  1903. static-networking?
  1904. (interface static-networking-interface)
  1905. (ip static-networking-ip)
  1906. (netmask static-networking-netmask
  1907. (default #f))
  1908. (gateway static-networking-gateway ;FIXME: doesn't belong here
  1909. (default #f))
  1910. (provision static-networking-provision
  1911. (default #f))
  1912. (requirement static-networking-requirement
  1913. (default '()))
  1914. (name-servers static-networking-name-servers ;FIXME: doesn't belong here
  1915. (default '())))
  1916. (define static-networking-shepherd-service
  1917. (match-lambda
  1918. (($ <static-networking> interface ip netmask gateway provision
  1919. requirement name-servers)
  1920. (let ((loopback? (and provision (memq 'loopback provision))))
  1921. (shepherd-service
  1922. (documentation
  1923. "Bring up the networking interface using a static IP address.")
  1924. (requirement requirement)
  1925. (provision (or provision
  1926. (list (symbol-append 'networking-
  1927. (string->symbol interface)))))
  1928. (start #~(lambda _
  1929. ;; Return #t if successfully started.
  1930. (let* ((addr (inet-pton AF_INET #$ip))
  1931. (sockaddr (make-socket-address AF_INET addr 0))
  1932. (mask (and #$netmask
  1933. (inet-pton AF_INET #$netmask)))
  1934. (maskaddr (and mask
  1935. (make-socket-address AF_INET
  1936. mask 0)))
  1937. (gateway (and #$gateway
  1938. (inet-pton AF_INET #$gateway)))
  1939. (gatewayaddr (and gateway
  1940. (make-socket-address AF_INET
  1941. gateway 0))))
  1942. (configure-network-interface #$interface sockaddr
  1943. (logior IFF_UP
  1944. #$(if loopback?
  1945. #~IFF_LOOPBACK
  1946. 0))
  1947. #:netmask maskaddr)
  1948. (when gateway
  1949. (let ((sock (socket AF_INET SOCK_DGRAM 0)))
  1950. (add-network-route/gateway sock gatewayaddr)
  1951. (close-port sock))))))
  1952. (stop #~(lambda _
  1953. ;; Return #f is successfully stopped.
  1954. (let ((sock (socket AF_INET SOCK_STREAM 0)))
  1955. (when #$gateway
  1956. (delete-network-route sock
  1957. (make-socket-address
  1958. AF_INET INADDR_ANY 0)))
  1959. (set-network-interface-flags sock #$interface 0)
  1960. (close-port sock)
  1961. #f)))
  1962. (respawn? #f))))))
  1963. (define (static-networking-etc-files interfaces)
  1964. "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
  1965. (match (delete-duplicates
  1966. (append-map static-networking-name-servers
  1967. interfaces))
  1968. (()
  1969. '())
  1970. ((name-servers ...)
  1971. (let ((content (string-join
  1972. (map (cut string-append "nameserver " <>)
  1973. name-servers)
  1974. "\n" 'suffix)))
  1975. `(("resolv.conf"
  1976. ,(plain-file "resolv.conf"
  1977. (string-append "\
  1978. # Generated by 'static-networking-service'.\n"
  1979. content))))))))
  1980. (define (static-networking-shepherd-services interfaces)
  1981. "Return the list of Shepherd services to bring up INTERFACES, a list of
  1982. <static-networking> objects."
  1983. (define (loopback? service)
  1984. (memq 'loopback (shepherd-service-provision service)))
  1985. (let ((services (map static-networking-shepherd-service interfaces)))
  1986. (match (remove loopback? services)
  1987. (()
  1988. ;; There's no interface other than 'loopback', so we assume that the
  1989. ;; 'networking' service will be provided by dhclient or similar.
  1990. services)
  1991. ((non-loopback ...)
  1992. ;; Assume we're providing all the interfaces, and thus, provide a
  1993. ;; 'networking' service.
  1994. (cons (shepherd-service
  1995. (provision '(networking))
  1996. (requirement (append-map shepherd-service-provision
  1997. services))
  1998. (start #~(const #t))
  1999. (stop #~(const #f))
  2000. (documentation "Bring up all the networking interfaces."))
  2001. services)))))
  2002. (define static-networking-service-type
  2003. ;; The service type for statically-defined network interfaces.
  2004. (service-type (name 'static-networking)
  2005. (extensions
  2006. (list
  2007. (service-extension shepherd-root-service-type
  2008. static-networking-shepherd-services)
  2009. (service-extension etc-service-type
  2010. static-networking-etc-files)))
  2011. (compose concatenate)
  2012. (extend append)
  2013. (description
  2014. "Turn up the specified network interfaces upon startup,
  2015. with the given IP address, gateway, netmask, and so on. The value for
  2016. services of this type is a list of @code{static-networking} objects, one per
  2017. network interface.")))
  2018. (define* (static-networking-service interface ip
  2019. #:key
  2020. netmask gateway provision
  2021. ;; Most interfaces require udev to be usable.
  2022. (requirement '(udev))
  2023. (name-servers '()))
  2024. "Return a service that starts @var{interface} with address @var{ip}. If
  2025. @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
  2026. it must be a string specifying the default network gateway.
  2027. This procedure can be called several times, one for each network
  2028. interface of interest. Behind the scenes what it does is extend
  2029. @code{static-networking-service-type} with additional network interfaces
  2030. to handle."
  2031. (simple-service 'static-network-interface
  2032. static-networking-service-type
  2033. (list (static-networking (interface interface) (ip ip)
  2034. (netmask netmask) (gateway gateway)
  2035. (provision provision)
  2036. (requirement requirement)
  2037. (name-servers name-servers)))))
  2038. (define %base-services
  2039. ;; Convenience variable holding the basic services.
  2040. (list (login-service)
  2041. (service virtual-terminal-service-type)
  2042. (service console-font-service-type
  2043. (map (lambda (tty)
  2044. (cons tty %default-console-font))
  2045. '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
  2046. (agetty-service (agetty-configuration
  2047. (extra-options '("-L")) ; no carrier detect
  2048. (term "vt100")
  2049. (tty #f))) ; automatic
  2050. (mingetty-service (mingetty-configuration
  2051. (tty "tty1")))
  2052. (mingetty-service (mingetty-configuration
  2053. (tty "tty2")))
  2054. (mingetty-service (mingetty-configuration
  2055. (tty "tty3")))
  2056. (mingetty-service (mingetty-configuration
  2057. (tty "tty4")))
  2058. (mingetty-service (mingetty-configuration
  2059. (tty "tty5")))
  2060. (mingetty-service (mingetty-configuration
  2061. (tty "tty6")))
  2062. (service static-networking-service-type
  2063. (list (static-networking (interface "lo")
  2064. (ip "127.0.0.1")
  2065. (requirement '())
  2066. (provision '(loopback)))))
  2067. (syslog-service)
  2068. (service urandom-seed-service-type)
  2069. (guix-service)
  2070. (nscd-service)
  2071. ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
  2072. ;; used, so enable them by default. The FUSE and ALSA rules are
  2073. ;; less critical, but handy.
  2074. (udev-service #:rules (list lvm2 fuse alsa-utils crda))
  2075. (service special-files-service-type
  2076. `(("/bin/sh" ,(file-append (canonical-package bash)
  2077. "/bin/sh"))))))
  2078. ;;; base.scm ends here