;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Cyril Roelandt ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Efraim Flashner ;;; Copyright © 2016, 2017 Nikita ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2018, 2019, 2020 Tobias Geerinckx-Rice ;;; Copyright © 2019 HiPhish ;;; Copyright © 2019 Julien Lepiller ;;; Copyright © 2019, 2020 Jakub Kądziołka ;;; Copyright © 2020 Jack Hill ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015, 2016, 2020 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 John Soo <jsoo1@asu.edu>
;;; Copyright © 2019, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021 qblade <qblade@protonmail.com>
;;; Copyright © 2021 Hui Lu <luhuins@163.com>
;;; Copyright © 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 muradm <mail@muradm.net>
;;; Copyright © 2022 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2022 Justin Veilleux <terramorpha@cock.li>
;;; Copyright © 2022 ( <paren@disroot.org>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services base)
  #:use-module (guix store)
  #:use-module (guix deprecation)
  #:autoload   (guix diagnostics) (warning formatted-message &fix-hint)
  #:autoload   (guix i18n) (G_)
  #:use-module (guix combinators)
  #:use-module (gnu services)
  #:use-module (gnu services admin)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services sysctl)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)                ; 'user-account', etc.
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)          ; 'file-system', etc.
  #:use-module (gnu system keyboard)
  #:use-module (gnu system mapped-devices)
  #:use-module ((gnu system linux-initrd)
                #:select (file-system-packages))
  #:use-module (gnu packages admin)
  #:use-module ((gnu packages linux)
                #:select (alsa-utils btrfs-progs crda eudev
                          e2fsprogs f2fs-tools fuse gpm kbd lvm2 rng-tools
                          util-linux xfsprogs))
  #:use-module (gnu packages bash)
  #:use-module ((gnu packages base)
                #:select (coreutils glibc glibc/hurd
                          glibc-utf8-locales
                          libc-utf8-locales-for-target
                          make-glibc-utf8-locales
                          tar canonical-package))
  #:use-module ((gnu packages compression) #:select (gzip))
  #:use-module (gnu packages fonts)
  #:autoload   (gnu packages guile-xyz) (guile-netlink)
  #:autoload   (gnu packages hurd) (hurd)
  #:use-module (gnu packages package-management)
  #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
  #:use-module ((gnu packages disk)
                #:select (dosfstools))
  #:use-module ((gnu packages file-systems)
                #:select (bcachefs-tools exfat-utils jfsutils zfs))
  #:use-module (gnu packages fonts)
  #:use-module (gnu packages terminals)
  #:use-module ((gnu packages wm) #:select (sway))
  #:use-module ((gnu build file-systems)
                #:select (mount-flags->bit-mask
                          swap-space->flags-bit-mask))
  #:autoload   (guix channels) (%default-channels channel->code)
  #:use-module (guix gexp)
  #:use-module ((guix packages) #:select (package-version))
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (guix pki)
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:autoload   (guix utils) (target-hurd?)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:re-export (user-processes-service-type        ;backwards compatibility
               %default-substitute-urls)
  #:export (fstab-service-type
            root-file-system-service
            file-system-service-type
            file-system-utilities
            swap-service
            host-name-service  ; deprecated
            host-name-service-type
            %default-console-font
            console-font-service-type
            console-font-service
            virtual-terminal-service-type

            host
            host?
            host-address
            host-canonical-name
            host-aliases
            hosts-service-type

            static-networking
            static-networking?
            static-networking-addresses
            static-networking-links
            static-networking-routes
            static-networking-requirement

            network-address
            network-address?
            network-address-device
            network-address-value
            network-address-ipv6?

            network-link
            network-link?
            network-link-name
            network-link-type
            network-link-arguments

            network-route
            network-route?
            network-route-destination
            network-route-source
            network-route-device
            network-route-ipv6?
            network-route-gateway

            static-networking-service
            static-networking-service-type

            %loopback-static-networking
            %qemu-static-networking

            udev-configuration
            udev-configuration?
            udev-configuration-rules
            udev-configuration-hardware
            udev-service-type
            udev-service  ; deprecated
            udev-rule
            udev-hardware
            file->udev-rule
            file->udev-hardware
            udev-rules-service
            udev-hardware-service

            login-configuration
            login-configuration?
            login-service-type
            login-service  ; deprecated

            agetty-configuration
            agetty-configuration?
            agetty-service  ; deprecated
            agetty-service-type

            mingetty-configuration
            mingetty-configuration-tty
            mingetty-configuration-auto-login
            mingetty-configuration-login-program
            mingetty-configuration-login-pause?
            mingetty-configuration-clear-on-logout?
            mingetty-configuration-mingetty
            mingetty-configuration?
            mingetty-service  ; deprecated
            mingetty-service-type

            %nscd-default-caches
            %nscd-default-configuration  ; deprecated

            nscd-configuration
            nscd-configuration?

            nscd-cache
            nscd-cache?

            nscd-service-type
            nscd-service  ; deprecated

            syslog-configuration
            syslog-configuration?
            syslog-service  ; deprecated
            syslog-service-type
            %default-syslog.conf

            %default-authorized-guix-keys
            guix-configuration
            guix-configuration?

            guix-configuration-guix
            guix-configuration-build-group
            guix-configuration-build-accounts
            guix-configuration-build-machines
            guix-configuration-authorize-key?
            guix-configuration-authorized-keys
            guix-configuration-use-substitutes?
            guix-configuration-substitute-urls
            guix-configuration-generate-substitute-key?
            guix-configuration-channels
            guix-configuration-extra-options
            guix-configuration-log-file
            guix-configuration-environment

            guix-extension
            guix-extension?
            guix-extension-authorized-keys
            guix-extension-substitute-urls
            guix-extension-chroot-directories

            guix-service-type
            guix-publish-configuration
            guix-publish-configuration?
            guix-publish-configuration-guix
            guix-publish-configuration-port
            guix-publish-configuration-host
            guix-publish-configuration-compression
            guix-publish-configuration-nar-path
            guix-publish-configuration-cache
            guix-publish-configuration-ttl
            guix-publish-configuration-negative-ttl
            guix-publish-service-type

            gpm-configuration
            gpm-configuration?
            gpm-service-type

            urandom-seed-service-type

            rngd-configuration
            rngd-configuration?
            rngd-service-type
            rngd-service  ; deprecated

            kmscon-configuration
            kmscon-configuration?
            kmscon-service-type

            pam-limits-service-type
            pam-limits-service  ; deprecated

            greetd-service-type
            greetd-configuration
            greetd-terminal-configuration
            greetd-agreety-session
            greetd-wlgreet-session
            greetd-wlgreet-sway-session

            %base-services))

;;; Commentary:
;;;
;;; Base system services---i.e., services that 99% of the users will want to
;;; use.
;;;
;;; Code:



;;;
;;; File systems.
;;;

(define (file-system->fstab-entry file-system)
  "Return a @file{/etc/fstab} entry for @var{file-system}."
  (string-append (match (file-system-device file-system)
                   ((? file-system-label? label)
                    (string-append "LABEL="
                                   (file-system-label->string label)))
                   ((? uuid? uuid)
                    (string-append "UUID=" (uuid->string uuid)))
                   ((? string? device)
                    device))
                 "\t"
                 (file-system-mount-point file-system) "\t"
                 (file-system-type file-system) "\t"
                 (or (file-system-options file-system) "defaults") "\t"

                 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
                 ;; don't have anything sensible to put in there.
                 ))

(define (file-systems->fstab file-systems)
  "Return a @file{/etc} entry for an @file{fstab} describing
@var{file-systems}."
  `(("fstab" ,(plain-file "fstab"
                          (string-append
                           "\
# This file was generated from your Guix configuration.  Any changes
# will be lost upon reboot or reconfiguration.\n\n"
                           (string-join (map file-system->fstab-entry
                                             file-systems)
                                        "\n")
                           "\n")))))

(define fstab-service-type
  ;; The /etc/fstab service.
  (service-type (name 'fstab)
                (extensions
                 (list (service-extension etc-service-type
                                          file-systems->fstab)))
                (compose concatenate)
                (extend append)
                (description
                 "Populate the @file{/etc/fstab} based on the given file
system objects.")))

(define %root-file-system-shepherd-service
  (shepherd-service
   (documentation "Take care of the root file system.")
   (provision '(root-file-system))
   (start #~(const #t))
   (stop #~(lambda _
             ;; Return #f if successfully stopped.
             (sync)

             (let ((null (%make-void-port "w")))
               ;; Redirect the default output ports.
               (set-current-output-port null)
               (set-current-error-port null)

               ;; Close /dev/console.
               (for-each close-fdes '(0 1 2))

               ;; At this point, there should be no open files left so the
               ;; root file system can be re-mounted read-only.
               (let loop ((n 10))
                 (unless (catch 'system-error
                           (lambda ()
                             (mount #f "/" #f
                                    (logior MS_REMOUNT MS_RDONLY)
                                    #:update-mtab? #f)
                             #t)
                           (const #f))
                   (unless (zero? n)
                     ;; Yield to the other fibers.  That gives logging fibers
                     ;; an opportunity to close log files so the 'mount' call
                     ;; doesn't fail with EBUSY.
                     ((@ (fibers) sleep) 1)
                     (loop (- n 1)))))

               #f)))
   (respawn? #f)))

(define root-file-system-service-type
  (shepherd-service-type 'root-file-system
                         (const %root-file-system-shepherd-service)
                         (description "Take care of syncing the root file
system and of remounting it read-only when the system shuts down.")))

(define (root-file-system-service)
  "Return a service whose sole purpose is to re-mount read-only the root file
system upon shutdown (aka. cleanly \"umounting\" root.)

This service must be the root of the service dependency graph so that its
'stop' action is invoked when shepherd is the only process left."
  (service root-file-system-service-type #f))

(define (file-system->shepherd-service-name file-system)
  "Return the symbol that denotes the service mounting and unmounting
FILE-SYSTEM."
  (symbol-append 'file-system-
                 (string->symbol (file-system-mount-point file-system))))

(define (mapped-device->shepherd-service-name md)
  "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
  (symbol-append 'device-mapping-
                 (string->symbol (string-join
                                  (mapped-device-targets md) "-"))))

(define dependency->shepherd-service-name
  (match-lambda
    ((? mapped-device? md)
     (mapped-device->shepherd-service-name md))
    ((? file-system? fs)
     (file-system->shepherd-service-name fs))))

(define (file-system-shepherd-service file-system)
  "Return the shepherd service for @var{file-system}, or @code{#f} if
@var{file-system} is not auto-mounted or doesn't have its mount point created
upon boot."
  (let ((target  (file-system-mount-point file-system))
        (create? (file-system-create-mount-point? file-system))
        (mount?  (file-system-mount? file-system))
        (dependencies (file-system-dependencies file-system))
        (requirements (file-system-shepherd-requirements file-system))
        (packages (file-system-packages (list file-system))))
    (and (or mount? create?)
         (with-imported-modules (source-module-closure
                                 '((gnu build file-systems)))
           (shepherd-service
            (provision (list (file-system->shepherd-service-name file-system)))
            (requirement `(root-file-system
                           udev
                           ,@(map dependency->shepherd-service-name dependencies)
                           ,@requirements))
            (documentation "Check, mount, and unmount the given file system.")
            (start #~(lambda args
                       #$(if create?
                             #~(mkdir-p #$target)
                             #t)

                       #$(if mount?
                             #~(let (($PATH (getenv "PATH")))
                                 ;; Make sure fsck.ext2 & co. can be found.
                                 (dynamic-wind
                                   (lambda ()
                                     ;; Don’t display the PATH settings.
                                     (with-output-to-port (%make-void-port "w")
                                       (lambda ()
                                         (set-path-environment-variable "PATH"
                                                                        '("bin" "sbin")
                                                                        '#$packages))))
                                   (lambda ()
                                     (mount-file-system
                                      (spec->file-system
                                       '#$(file-system->spec file-system))
                                      #:root "/"))
                                   (lambda ()
                                     (setenv "PATH" $PATH))))
                             #t)
                       #t))
            (stop #~(lambda args
                      ;; Normally there are no processes left at this point, so
                      ;; TARGET can be safely unmounted.

                      ;; Make sure PID 1 doesn't keep TARGET busy.
                      (chdir "/")

                      #$(if (file-system-mount-may-fail? file-system)
                            #~(catch 'system-error
                                (lambda () (umount #$target))
                                (const #f))
                            #~(umount #$target))
                      #f))

            ;; We need additional modules.
            (modules `(((gnu build file-systems)
                        #:select (mount-file-system))
                       (gnu system file-systems)
                       ,@%default-modules)))))))

(define (file-system-shepherd-services file-systems)
  "Return the list of Shepherd services for FILE-SYSTEMS."
  (let* ((file-systems (filter (lambda (x)
                                 (or (file-system-mount? x)
                                     (file-system-create-mount-point? x)))
                               file-systems)))

    (define sink
      (shepherd-service
       (provision '(file-systems))
       (requirement (cons* 'root-file-system 'user-file-systems
                           (map file-system->shepherd-service-name
                                ;; Do not require file systems with Shepherd
                                ;; requirements to provision
                                ;; 'file-systems. Many Shepherd services
                                ;; require 'file-systems, so we would likely
                                ;; deadlock.
                                (filter (lambda (file-system)
                                          (null? (file-system-shepherd-requirements file-system)))
                                        file-systems))))
       (documentation "Target for all the initially-mounted file systems")
       (start #~(const #t))
       (stop #~(const #f))))

    (define known-mount-points
      (map file-system-mount-point file-systems))

    (define user-unmount
      (shepherd-service
       (documentation "Unmount manually-mounted file systems.")
       (provision '(user-file-systems))
       (start #~(const #t))
       (stop #~(lambda args
                 (define (known? mount-point)
                   (member mount-point
                           (cons* "/proc" "/sys" '#$known-mount-points)))

                 ;; Make sure we don't keep the user's mount points busy.
                 (chdir "/")

                 (for-each (lambda (mount-point)
                             (format #t "unmounting '~a'...~%" mount-point)
                             (catch 'system-error
                               (lambda ()
                                 (umount mount-point))
                               (lambda args
                                 (let ((errno (system-error-errno args)))
                                   (format #t "failed to unmount '~a': ~a~%"
                                           mount-point (strerror errno))))))
                           (filter (negate known?) (mount-points)))
                 #f))))

    (cons* sink user-unmount
           (map file-system-shepherd-service file-systems))))

(define (file-system-fstab-entries file-systems)
  "Return the subset of @var{file-systems} that should have an entry in
@file{/etc/fstab}."
  ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
  ;; relevant file systems they'll have to deal with.  That excludes "pseudo"
  ;; file systems.
  ;;
  ;; In particular, things like GIO (part of GLib) use it to determine the set
  ;; of mounts, which is then used by graphical file managers and desktop
  ;; environments to display "volume" icons.  Thus, we really need to exclude
  ;; those pseudo file systems from the list.
  (remove (lambda (file-system)
            (or (member (file-system-type file-system)
                        %pseudo-file-system-types)
                (memq 'bind-mount (file-system-flags file-system))))
          file-systems))

(define (file-system-type->utilities type)
  "Return the package providing the utilities for file system TYPE, #f
otherwise."
  (assoc-ref
   `(("bcachefs" . ,bcachefs-tools)
     ("btrfs" . ,btrfs-progs)
     ("exfat" . ,exfat-utils)
     ("ext2" . ,e2fsprogs)
     ("ext3" . ,e2fsprogs)
     ("ext4" . ,e2fsprogs)
     ("fat" . ,dosfstools)
     ("f2fs" . ,f2fs-tools)
     ("jfs" . ,jfsutils)
     ("vfat" . ,dosfstools)
     ("xfs" . ,xfsprogs)
     ("zfs" . ,zfs))
   type))

(define (file-system-utilities file-systems)
  "Return a list of packages containing file system utilities for
FILE-SYSTEMS."
  (filter-map (lambda (file-system)
                (file-system-type->utilities (file-system-type file-system)))
              file-systems))

(define file-system-service-type
  (service-type (name 'file-systems)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          file-system-shepherd-services)
                       (service-extension fstab-service-type
                                          file-system-fstab-entries)
                       (service-extension profile-service-type
                                          file-system-utilities)

                       ;; Have 'user-processes' depend on 'file-systems'.
                       (service-extension user-processes-service-type
                                          (const '(file-systems)))))
                (compose concatenate)
                (extend append)
                (description
                 "Provide Shepherd services to mount and unmount the given
file systems, as well as corresponding @file{/etc/fstab} entries.")))



;;;
;;; Preserve entropy to seed /dev/urandom on boot.
;;;

(define %random-seed-file
  "/var/lib/random-seed")

(define (urandom-seed-shepherd-service _)
  "Return a shepherd service for the /dev/urandom seed."
  (list (shepherd-service
         (documentation "Preserve entropy across reboots for /dev/urandom.")
         (provision '(urandom-seed))

         ;; Depend on udev so that /dev/hwrng is available.
         (requirement '(file-systems udev))

         (start #~(lambda _
                    ;; On boot, write random seed into /dev/urandom.
                    (when (file-exists? #$%random-seed-file)
                      (call-with-input-file #$%random-seed-file
                        (lambda (seed)
                          (call-with-output-file "/dev/urandom"
                            (lambda (urandom)
                              (dump-port seed urandom)

                              ;; Writing SEED to URANDOM isn't enough: we must
                              ;; also tell the kernel to account for these
                              ;; extra bits of entropy.
                              (let ((bits (* 8 (stat:size (stat seed)))))
                                (add-to-entropy-count urandom bits)))))))

                    ;; Try writing from /dev/hwrng into /dev/urandom.
                    ;; It seems that the file /dev/hwrng always exists, even
                    ;; when there is no hardware random number generator
                    ;; available. So, we handle a failed read or any other error
                    ;; reported by the operating system.
                    (let ((buf (catch 'system-error
                                 (lambda ()
                                   (call-with-input-file "/dev/hwrng"
                                     (lambda (hwrng)
                                       (get-bytevector-n hwrng 512))))
                                 ;; Silence is golden...
                                 (const #f))))
                      (when buf
                        (call-with-output-file "/dev/urandom"
                          (lambda (urandom)
                            (put-bytevector urandom buf)
                            (let ((bits (* 8 (bytevector-length buf))))
                              (add-to-entropy-count urandom bits))))))

                    ;; Immediately refresh the seed in case the system doesn't
                    ;; shut down cleanly.
                    (call-with-input-file "/dev/urandom"
                      (lambda (urandom)
                        (let ((previous-umask (umask #o077))
                              (buf (make-bytevector 512)))
                          (mkdir-p (dirname #$%random-seed-file))
                          (get-bytevector-n! urandom buf 0 512)
                          (call-with-output-file #$%random-seed-file
                            (lambda (seed)
                              (put-bytevector seed buf)))
                          (umask previous-umask))))
                    #t))
         (stop #~(lambda _
                   ;; During shutdown, write from /dev/urandom into random seed.
                   (let ((buf (make-bytevector 512)))
                     (call-with-input-file "/dev/urandom"
                       (lambda (urandom)
                         (let ((previous-umask (umask #o077)))
                           (get-bytevector-n! urandom buf 0 512)
                           (mkdir-p (dirname #$%random-seed-file))
                           (call-with-output-file #$%random-seed-file
                             (lambda (seed)
                               (put-bytevector seed buf)))
                           (umask previous-umask))
                         #t)))))
         (modules `((rnrs bytevectors)
                    (rnrs io ports)
                    ,@%default-modules)))))

(define urandom-seed-service-type
  (service-type (name 'urandom-seed)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          urandom-seed-shepherd-service)

                       ;; Have 'user-processes' depend on 'urandom-seed'.
                       ;; This ensures that user processes and daemons don't
                       ;; start until we have seeded the PRNG.
                       (service-extension user-processes-service-type
                                          (const '(urandom-seed)))))
                (default-value #f)
                (description
                 "Seed the @file{/dev/urandom} pseudo-random number
generator (RNG) with the value recorded when the system was last shut
down.")))


;;;
;;; Add hardware random number generator to entropy pool.
;;;

(define-record-type* <rngd-configuration>
  rngd-configuration make-rngd-configuration
  rngd-configuration?
  (rng-tools rngd-configuration-rng-tools         ;file-like
             (default rng-tools))
  (device    rngd-configuration-device            ;string
             (default "/dev/hwrng")))

(define rngd-service-type
  (shepherd-service-type
    'rngd
    (lambda (config)
      (define rng-tools (rngd-configuration-rng-tools config))
      (define device (rngd-configuration-device config))

      (define rngd-command
        (list (file-append rng-tools "/sbin/rngd")
              "-f" "-r" device))

      (shepherd-service
        (documentation "Add TRNG to entropy pool.")
        (requirement '(udev))
        (provision '(trng))
        (start #~(make-forkexec-constructor '#$rngd-command))
        (stop #~(make-kill-destructor))))
    (rngd-configuration)
    (description "Run the @command{rngd} random number generation daemon to
supply entropy to the kernel's pool.")))

(define-deprecated (rngd-service #:key (rng-tools rng-tools)
                                 (device "/dev/hwrng"))
  rngd-service-type
  "Return a service that runs the @command{rngd} program from @var{rng-tools}
to add @var{device} to the kernel's entropy pool.  The service will fail if
@var{device} does not exist."
  (service rngd-service-type
           (rngd-configuration
            (rng-tools rng-tools)
            (device device))))

;;;
;;; /etc/hosts
;;;

(eval-when (expand load eval)
  (define (valid-name? name)
    "Return true if @var{name} is likely to be a valid host name."
    (false-if-exception (not (string-any char-set:whitespace name)))))

(define-compile-time-procedure (assert-valid-name (name valid-name?))
  "Ensure @var{name} is likely to be a valid host name."
  ;; TODO: RFC compliant implementation.
  (unless (valid-name? name)
    (raise
     (make-compound-condition
      (formatted-message (G_ "host name '~a' contains invalid characters")
                         name)
      (condition (&error-location
                  (location
                   (source-properties->location procedure-call-location)))))))
  name)

(define-record-type* <host> %host
  ;; XXX: Using the record type constructor becomes tiresome when
  ;; there's multiple records to make.
  make-host host?
  (address        host-address)
  (canonical-name host-canonical-name
                  (sanitize assert-valid-name))
  (aliases        host-aliases
                  (default '())
                  (sanitize (cut map assert-valid-name <>))))

(define* (host address canonical-name #:optional (aliases '()))
  "Return a new record for the host at @var{address} with the given
@var{canonical-name} and possibly @var{aliases}.

@var{address} must be a string denoting a valid IPv4 or IPv6 address, and
@var{canonical-name} and the strings listed in @var{aliases} must be valid
host names."
  (%host
   (address address)
   (canonical-name canonical-name)
   (aliases aliases)))

(define hosts-service-type
  ;; Extend etc-service-type with a entry for @file{/etc/hosts}.
  (let* ((serialize-host-record
          (lambda (record)
            (match-record record <host> (address canonical-name aliases)
              (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases))))
         (host-etc-service
          (lambda (lst)
            `(("hosts" ,(plain-file "hosts"
                                    (format #f "~{~a~}"
                                            (map serialize-host-record
                                                 lst))))))))
    (service-type
     (name 'etc-hosts)
     (extensions
      (list
       (service-extension etc-service-type
                          host-etc-service)))
     (compose concatenate)
     (extend append)
     (description "Populate the @file{/etc/hosts} file."))))


;;;
;;; Console & co.
;;;

(define host-name-service-type
  (shepherd-service-type
   'host-name
   (lambda (name)
     (shepherd-service
      (documentation "Initialize the machine's host name.")
      (provision '(host-name))
      (start #~(lambda _
                 (sethostname #$name)))
      (one-shot? #t)))
   (description "Initialize the machine's host name.")))

(define-deprecated (host-name-service name)
  host-name-service-type
  "Return a service that sets the host name to @var{name}."
  (service host-name-service-type name))

(define virtual-terminal-service-type
  ;; Ensure that virtual terminals run in UTF-8 mode.  This is the case by
  ;; default with recent Linux kernels, but this service allows us to ensure
  ;; this.  This service must start before any 'term-' service so that newly
  ;; created terminals inherit this property.  See
  ;; <https://bugs.gnu.org/30505> for a discussion.
  (shepherd-service-type
   'virtual-terminal
   (lambda (utf8?)
     (let ((knob "/sys/module/vt/parameters/default_utf8"))
       (shepherd-service
        (documentation "Set virtual terminals in UTF-8 module.")
        (provision '(virtual-terminal))
        (requirement '(root-file-system))
        (start #~(