gnu/services/base.scm

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