gnu/services/base.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016 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 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 file-systems)          ; 'file-system', etc.
  33   #:use-module (gnu system mapped-devices)
  34   #:use-module (gnu packages admin)
  35   #:use-module ((gnu packages linux)
  36                 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
  37   #:use-module ((gnu packages base)
  38                 #:select (canonical-package glibc))
  39   #:use-module (gnu packages package-management)
  40   #:use-module (gnu packages lsof)
  41   #:use-module (gnu packages terminals)
  42   #:use-module ((gnu build file-systems)
  43                 #:select (mount-flags->bit-mask))
  44   #:use-module (guix gexp)
  45   #:use-module (guix records)
  46   #:use-module (srfi srfi-1)
  47   #:use-module (srfi srfi-26)
  48   #:use-module (ice-9 match)
  49   #:use-module (ice-9 format)
  50   #:export (fstab-service-type
  51             root-file-system-service
  52             file-system-service-type
  53             user-unmount-service
  54             swap-service
  55             user-processes-service
  56             session-environment-service
  57             session-environment-service-type
  58             host-name-service
  59             console-keymap-service
  60             %default-console-font
  61             console-font-service-type
  62             console-font-service
  63
  64             udev-configuration
  65             udev-configuration?
  66             udev-configuration-rules
  67             udev-service-type
  68             udev-service
  69             udev-rule
  70
  71             login-configuration
  72             login-configuration?
  73             login-service-type
  74             login-service
  75
  76             mingetty-configuration
  77             mingetty-configuration?
  78             mingetty-service
  79             mingetty-service-type
  80
  81             %nscd-default-caches
  82             %nscd-default-configuration
  83
  84             nscd-configuration
  85             nscd-configuration?
  86
  87             nscd-cache
  88             nscd-cache?
  89
  90             nscd-service-type
  91             nscd-service
  92
  93             syslog-configuration
  94             syslog-configuration?
  95             syslog-service
  96             syslog-service-type
  97             %default-syslog.conf
  98
  99             %default-authorized-guix-keys
 100             guix-configuration
 101             guix-configuration?
 102             guix-service
 103             guix-service-type
 104             guix-publish-configuration
 105             guix-publish-configuration?
 106             guix-publish-service
 107             guix-publish-service-type
 108
 109             gpm-configuration
 110             gpm-configuration?
 111             gpm-service-type
 112             gpm-service
 113
 114             urandom-seed-service-type
 115             urandom-seed-service
 116
 117             rngd-configuration
 118             rngd-configuration?
 119             rngd-service-type
 120             rngd-service
 121
 122             kmscon-configuration
 123             kmscon-configuration?
 124             kmscon-service-type
 125
 126             pam-limits-service-type
 127             pam-limits-service
 128
 129             %base-services))
 130
 131 ;;; Commentary:
 132 ;;;
 133 ;;; Base system services---i.e., services that 99% of the users will want to
 134 ;;; use.
 135 ;;;
 136 ;;; Code:
 137
 138 \f
 139 ;;;
 140 ;;; File systems.
 141 ;;;
 142
 143 (define (file-system->fstab-entry file-system)
 144   "Return a @file{/etc/fstab} entry for @var{file-system}."
 145   (string-append (case (file-system-title file-system)
 146                    ((label)
 147                     (string-append "LABEL=" (file-system-device file-system)))
 148                    ((uuid)
 149                     (string-append
 150                      "UUID="
 151                      (uuid->string (file-system-device file-system))))
 152                    (else
 153                     (file-system-device file-system)))
 154                  "\t"
 155                  (file-system-mount-point file-system) "\t"
 156                  (file-system-type file-system) "\t"
 157                  (or (file-system-options file-system) "defaults") "\t"
 158
 159                  ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
 160                  ;; don't have anything sensible to put in there.
 161                  ))
 162
 163 (define (file-systems->fstab file-systems)
 164   "Return a @file{/etc} entry for an @file{fstab} describing
 165 @var{file-systems}."
 166   `(("fstab" ,(plain-file "fstab"
 167                           (string-append
 168                            "\
 169 # This file was generated from your GuixSD configuration.  Any changes
 170 # will be lost upon reboot or reconfiguration.\n\n"
 171                            (string-join (map file-system->fstab-entry
 172                                              file-systems)
 173                                         "\n")
 174                            "\n")))))
 175
 176 (define fstab-service-type
 177   ;; The /etc/fstab service.
 178   (service-type (name 'fstab)
 179                 (extensions
 180                  (list (service-extension etc-service-type
 181                                           file-systems->fstab)))
 182                 (compose concatenate)
 183                 (extend append)))
 184
 185 (define %root-file-system-shepherd-service
 186   (shepherd-service
 187    (documentation "Take care of the root file system.")
 188    (provision '(root-file-system))
 189    (start #~(const #t))
 190    (stop #~(lambda _
 191              ;; Return #f if successfully stopped.
 192              (sync)
 193
 194              (call-with-blocked-asyncs
 195               (lambda ()
 196                 (let ((null (%make-void-port "w")))
 197                   ;; Close 'shepherd.log'.
 198                   (display "closing log\n")
 199                   ((@ (shepherd comm) stop-logging))
 200
 201                   ;; Redirect the default output ports..
 202                   (set-current-output-port null)
 203                   (set-current-error-port null)
 204
 205                   ;; Close /dev/console.
 206                   (for-each close-fdes '(0 1 2))
 207
 208                   ;; At this point, there are no open files left, so the
 209                   ;; root file system can be re-mounted read-only.
 210                   (mount #f "/" #f
 211                          (logior MS_REMOUNT MS_RDONLY)
 212                          #:update-mtab? #f)
 213
 214                   #f)))))
 215    (respawn? #f)))
 216
 217 (define root-file-system-service-type
 218   (shepherd-service-type 'root-file-system
 219                          (const %root-file-system-shepherd-service)))
 220
 221 (define (root-file-system-service)
 222   "Return a service whose sole purpose is to re-mount read-only the root file
 223 system upon shutdown (aka. cleanly \"umounting\" root.)
 224
 225 This service must be the root of the service dependency graph so that its
 226 'stop' action is invoked when shepherd is the only process left."
 227   (service root-file-system-service-type #f))
 228
 229 (define (file-system->shepherd-service-name file-system)
 230   "Return the symbol that denotes the service mounting and unmounting
 231 FILE-SYSTEM."
 232   (symbol-append 'file-system-
 233                  (string->symbol (file-system-mount-point file-system))))
 234
 235 (define (mapped-device->shepherd-service-name md)
 236   "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
 237   (symbol-append 'device-mapping-
 238                  (string->symbol (mapped-device-target md))))
 239
 240 (define dependency->shepherd-service-name
 241   (match-lambda
 242     ((? mapped-device? md)
 243      (mapped-device->shepherd-service-name md))
 244     ((? file-system? fs)
 245      (file-system->shepherd-service-name fs))))
 246
 247 (define (file-system-shepherd-service file-system)
 248   "Return the shepherd service for @var{file-system}, or @code{#f} if
 249 @var{file-system} is not auto-mounted upon boot."
 250   (let ((target  (file-system-mount-point file-system))
 251         (device  (file-system-device file-system))
 252         (type    (file-system-type file-system))
 253         (title   (file-system-title file-system))
 254         (flags   (file-system-flags file-system))
 255         (options (file-system-options file-system))
 256         (check?  (file-system-check? file-system))
 257         (create? (file-system-create-mount-point? file-system))
 258         (dependencies (file-system-dependencies file-system)))
 259     (and (file-system-mount? file-system)
 260          (with-imported-modules '((gnu build file-systems)
 261                                   (guix build bournish))
 262            (shepherd-service
 263             (provision (list (file-system->shepherd-service-name file-system)))
 264             (requirement `(root-file-system
 265                            ,@(map dependency->shepherd-service-name dependencies)))
 266             (documentation "Check, mount, and unmount the given file system.")
 267             (start #~(lambda args
 268                        #$(if create?
 269                              #~(mkdir-p #$target)
 270                              #t)
 271
 272                        (let (($PATH (getenv "PATH")))
 273                          ;; Make sure fsck.ext2 & co. can be found.
 274                          (dynamic-wind
 275                            (lambda ()
 276                              (setenv "PATH"
 277                                      (string-append
 278                                       #$e2fsprogs "/sbin:"
 279                                       "/run/current-system/profile/sbin:"
 280                                       $PATH)))
 281                            (lambda ()
 282                              (mount-file-system
 283                               `(#$device #$title #$target #$type #$flags
 284                                          #$options #$check?)
 285                               #:root "/"))
 286                            (lambda ()
 287                              (setenv "PATH" $PATH)))
 288                          #t)))
 289             (stop #~(lambda args
 290                       ;; Normally there are no processes left at this point, so
 291                       ;; TARGET can be safely unmounted.
 292
 293                       ;; Make sure PID 1 doesn't keep TARGET busy.
 294                       (chdir "/")
 295
 296                       (umount #$target)
 297                       #f))
 298
 299             ;; We need an additional module.
 300             (modules `(((gnu build file-systems)
 301                         #:select (mount-file-system))
 302                        ,@%default-modules)))))))
 303
 304 (define file-system-service-type
 305   (service-type (name 'file-systems)
 306                 (extensions
 307                  (list (service-extension shepherd-root-service-type
 308                                           (lambda (file-systems)
 309                                             (filter-map file-system-shepherd-service
 310                                                         file-systems)))
 311                        (service-extension fstab-service-type
 312                                           identity)))
 313                 (compose concatenate)
 314                 (extend append)))
 315
 316 (define user-unmount-service-type
 317   (shepherd-service-type
 318    'user-file-systems
 319    (lambda (known-mount-points)
 320      (shepherd-service
 321       (documentation "Unmount manually-mounted file systems.")
 322       (provision '(user-file-systems))
 323       (start #~(const #t))
 324       (stop #~(lambda args
 325                 (define (known? mount-point)
 326                   (member mount-point
 327                           (cons* "/proc" "/sys" '#$known-mount-points)))
 328
 329                 ;; Make sure we don't keep the user's mount points busy.
 330                 (chdir "/")
 331
 332                 (for-each (lambda (mount-point)
 333                             (format #t "unmounting '~a'...~%" mount-point)
 334                             (catch 'system-error
 335                               (lambda ()
 336                                 (umount mount-point))
 337                               (lambda args
 338                                 (let ((errno (system-error-errno args)))
 339                                   (format #t "failed to unmount '~a': ~a~%"
 340                                           mount-point (strerror errno))))))
 341                           (filter (negate known?) (mount-points)))
 342                 #f))))))
 343
 344 (define (user-unmount-service known-mount-points)
 345   "Return a service whose sole purpose is to unmount file systems not listed
 346 in KNOWN-MOUNT-POINTS when it is stopped."
 347   (service user-unmount-service-type known-mount-points))
 348
 349 (define %do-not-kill-file
 350   ;; Name of the file listing PIDs of processes that must survive when halting
 351   ;; the system.  Typical example is user-space file systems.
 352   "/etc/shepherd/do-not-kill")
 353
 354 (define user-processes-service-type
 355   (shepherd-service-type
 356    'user-processes
 357    (match-lambda
 358      ((requirements grace-delay)
 359       (shepherd-service
 360        (documentation "When stopped, terminate all user processes.")
 361        (provision '(user-processes))
 362        (requirement (cons* 'root-file-system 'user-file-systems
 363                            (map file-system->shepherd-service-name
 364                                 requirements)))
 365        (start #~(const #t))
 366        (stop #~(lambda _
 367                  (define (kill-except omit signal)
 368                    ;; Kill all the processes with SIGNAL except those listed
 369                    ;; in OMIT and the current process.
 370                    (let ((omit (cons (getpid) omit)))
 371                      (for-each (lambda (pid)
 372                                  (unless (memv pid omit)
 373                                    (false-if-exception
 374                                     (kill pid signal))))
 375                                (processes))))
 376
 377                  (define omitted-pids
 378                    ;; List of PIDs that must not be killed.
 379                    (if (file-exists? #$%do-not-kill-file)
 380                        (map string->number
 381                             (call-with-input-file #$%do-not-kill-file
 382                               (compose string-tokenize
 383                                        (@ (ice-9 rdelim) read-string))))
 384                        '()))
 385
 386                  (define (now)
 387                    (car (gettimeofday)))
 388
 389                  (define (sleep* n)
 390                    ;; Really sleep N seconds.
 391                    ;; Work around <http://bugs.gnu.org/19581>.
 392                    (define start (now))
 393                    (let loop ((elapsed 0))
 394                      (when (> n elapsed)
 395                        (sleep (- n elapsed))
 396                        (loop (- (now) start)))))
 397
 398                  (define lset= (@ (srfi srfi-1) lset=))
 399
 400                  (display "sending all processes the TERM signal\n")
 401
 402                  (if (null? omitted-pids)
 403                      (begin
 404                        ;; Easy: terminate all of them.
 405                        (kill -1 SIGTERM)
 406                        (sleep* #$grace-delay)
 407                        (kill -1 SIGKILL))
 408                      (begin
 409                        ;; Kill them all except OMITTED-PIDS.  XXX: We would
 410                        ;; like to (kill -1 SIGSTOP) to get a fixed list of
 411                        ;; processes, like 'killall5' does, but that seems
 412                        ;; unreliable.
 413                        (kill-except omitted-pids SIGTERM)
 414                        (sleep* #$grace-delay)
 415                        (kill-except omitted-pids SIGKILL)
 416                        (delete-file #$%do-not-kill-file)))
 417
 418                  (let wait ()
 419                    (let ((pids (processes)))
 420                      (unless (lset= = pids (cons 1 omitted-pids))
 421                        (format #t "waiting for process termination\
 422  (processes left: ~s)~%"
 423                                pids)
 424                        (sleep* 2)
 425                        (wait))))
 426
 427                  (display "all processes have been terminated\n")
 428                  #f))
 429        (respawn? #f))))))
 430
 431 (define* (user-processes-service file-systems #:key (grace-delay 4))
 432   "Return the service that is responsible for terminating all the processes so
 433 that the root file system can be re-mounted read-only, just before
 434 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 435 has been sent are terminated with SIGKILL.
 436
 437 The returned service will depend on 'root-file-system' and on all the shepherd
 438 services corresponding to FILE-SYSTEMS.
 439
 440 All the services that spawn processes must depend on this one so that they are
 441 stopped before 'kill' is called."
 442   (service user-processes-service-type
 443            (list (filter file-system-mount? file-systems) grace-delay)))
 444
 445 \f
 446 ;;;
 447 ;;; Preserve entropy to seed /dev/urandom on boot.
 448 ;;;
 449
 450 (define %random-seed-file
 451   "/var/lib/random-seed")
 452
 453 (define (urandom-seed-shepherd-service _)
 454   "Return a shepherd service for the /dev/urandom seed."
 455   (list (shepherd-service
 456          (documentation "Preserve entropy across reboots for /dev/urandom.")
 457          (provision '(urandom-seed))
 458          (requirement '(user-processes))
 459          (start #~(lambda _
 460                     ;; On boot, write random seed into /dev/urandom.
 461                     (when (file-exists? #$%random-seed-file)
 462                       (call-with-input-file #$%random-seed-file
 463                         (lambda (seed)
 464                           (call-with-output-file "/dev/urandom"
 465                             (lambda (urandom)
 466                               (dump-port seed urandom))))))
 467                     ;; Immediately refresh the seed in case the system doesn't
 468                     ;; shut down cleanly.
 469                     (call-with-input-file "/dev/urandom"
 470                       (lambda (urandom)
 471                         (let ((previous-umask (umask #o077))
 472                               (buf (make-bytevector 512)))
 473                           (mkdir-p (dirname #$%random-seed-file))
 474                           (get-bytevector-n! urandom buf 0 512)
 475                           (call-with-output-file #$%random-seed-file
 476                             (lambda (seed)
 477                               (put-bytevector seed buf)))
 478                           (umask previous-umask))))
 479                     #t))
 480          (stop #~(lambda _
 481                    ;; During shutdown, write from /dev/urandom into random seed.
 482                    (let ((buf (make-bytevector 512)))
 483                      (call-with-input-file "/dev/urandom"
 484                        (lambda (urandom)
 485                          (let ((previous-umask (umask #o077)))
 486                            (get-bytevector-n! urandom buf 0 512)
 487                            (mkdir-p (dirname #$%random-seed-file))
 488                            (call-with-output-file #$%random-seed-file
 489                              (lambda (seed)
 490                                (put-bytevector seed buf)))
 491                            (umask previous-umask))
 492                          #t)))))
 493          (modules `((rnrs bytevectors)
 494                     (rnrs io ports)
 495                     ,@%default-modules)))))
 496
 497 (define urandom-seed-service-type
 498   (service-type (name 'urandom-seed)
 499                 (extensions
 500                  (list (service-extension shepherd-root-service-type
 501                                           urandom-seed-shepherd-service)))))
 502
 503 (define (urandom-seed-service)
 504   (service urandom-seed-service-type #f))
 505
 506
 507 ;;;
 508 ;;; Add hardware random number generator to entropy pool.
 509 ;;;
 510
 511 (define-record-type* <rngd-configuration>
 512   rngd-configuration make-rngd-configuration
 513   rngd-configuration?
 514   (rng-tools rngd-configuration-rng-tools)        ;package
 515   (device    rngd-configuration-device))          ;string
 516
 517 (define rngd-service-type
 518   (shepherd-service-type
 519     'rngd
 520     (lambda (config)
 521       (define rng-tools (rngd-configuration-rng-tools config))
 522       (define device (rngd-configuration-device config))
 523
 524       (define rngd-command
 525         (list (file-append rng-tools "/sbin/rngd")
 526               "-f" "-r" device))
 527
 528       (shepherd-service
 529         (documentation "Add TRNG to entropy pool.")
 530         (requirement '(udev))
 531         (provision '(trng))
 532         (start #~(make-forkexec-constructor #$@rngd-command))
 533         (stop #~(make-kill-destructor))))))
 534
 535 (define* (rngd-service #:key
 536                        (rng-tools rng-tools)
 537                        (device "/dev/hwrng"))
 538   "Return a service that runs the @command{rngd} program from @var{rng-tools}
 539 to add @var{device} to the kernel's entropy pool.  The service will fail if
 540 @var{device} does not exist."
 541   (service rngd-service-type
 542            (rngd-configuration
 543             (rng-tools rng-tools)
 544             (device device))))
 545
 546
 547 ;;;
 548 ;;; System-wide environment variables.
 549 ;;;
 550
 551 (define (environment-variables->environment-file vars)
 552   "Return a file for pam_env(8) that contains environment variables VARS."
 553   (apply mixed-text-file "environment"
 554          (append-map (match-lambda
 555                        ((key . value)
 556                         (list key "=" value "\n")))
 557                      vars)))
 558
 559 (define session-environment-service-type
 560   (service-type
 561    (name 'session-environment)
 562    (extensions
 563     (list (service-extension
 564            etc-service-type
 565            (lambda (vars)
 566              (list `("environment"
 567                      ,(environment-variables->environment-file vars)))))))
 568    (compose concatenate)
 569    (extend append)))
 570
 571 (define (session-environment-service vars)
 572   "Return a service that builds the @file{/etc/environment}, which can be read
 573 by PAM-aware applications to set environment variables for sessions.
 574
 575 VARS should be an association list in which both the keys and the values are
 576 strings or string-valued gexps."
 577   (service session-environment-service-type vars))
 578
 579 \f
 580 ;;;
 581 ;;; Console & co.
 582 ;;;
 583
 584 (define host-name-service-type
 585   (shepherd-service-type
 586    'host-name
 587    (lambda (name)
 588      (shepherd-service
 589       (documentation "Initialize the machine's host name.")
 590       (provision '(host-name))
 591       (start #~(lambda _
 592                  (sethostname #$name)))
 593       (respawn? #f)))))
 594
 595 (define (host-name-service name)
 596   "Return a service that sets the host name to @var{name}."
 597   (service host-name-service-type name))
 598
 599 (define (unicode-start tty)
 600   "Return a gexp to start Unicode support on @var{tty}."
 601
 602   ;; We have to run 'unicode_start' in a pipe so that when it invokes the
 603   ;; 'tty' command, that command returns TTY.
 604   #~(begin
 605       (let ((pid (primitive-fork)))
 606         (case pid
 607           ((0)
 608            (close-fdes 0)
 609            (dup2 (open-fdes #$tty O_RDONLY) 0)
 610            (close-fdes 1)
 611            (dup2 (open-fdes #$tty O_WRONLY) 1)
 612            (execl #$(file-append kbd "/bin/unicode_start")
 613                   "unicode_start"))
 614           (else
 615            (zero? (cdr (waitpid pid))))))))
 616
 617 (define console-keymap-service-type
 618   (shepherd-service-type
 619    'console-keymap
 620    (lambda (files)
 621      (shepherd-service
 622       (documentation (string-append "Load console keymap (loadkeys)."))
 623       (provision '(console-keymap))
 624       (start #~(lambda _
 625                  (zero? (system* #$(file-append kbd "/bin/loadkeys")
 626                                  #$@files))))
 627       (respawn? #f)))))
 628
 629 (define (console-keymap-service . files)
 630   "Return a service to load console keymaps from @var{files}."
 631   (service console-keymap-service-type files))
 632
 633 (define %default-console-font
 634   ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
 635   ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
 636   ;; codepoints notably found in the UTF-8 manual.
 637   "LatGrkCyr-8x16")
 638
 639 (define (console-font-shepherd-services tty+font)
 640   "Return a list of Shepherd services for each pair in TTY+FONT."
 641   (map (match-lambda
 642          ((tty . font)
 643           (let ((device (string-append "/dev/" tty)))
 644             (shepherd-service
 645              (documentation "Load a Unicode console font.")
 646              (provision (list (symbol-append 'console-font-
 647                                              (string->symbol tty))))
 648
 649              ;; Start after mingetty has been started on TTY, otherwise the settings
 650              ;; are ignored.
 651              (requirement (list (symbol-append 'term-
 652                                                (string->symbol tty))))
 653
 654              (start #~(lambda _
 655                         (and #$(unicode-start device)
 656                              (zero?
 657                               (system* #$(file-append kbd "/bin/setfont")
 658                                        "-C" #$device #$font)))))
 659              (stop #~(const #t))
 660              (respawn? #f)))))
 661        tty+font))
 662
 663 (define console-font-service-type
 664   (service-type (name 'console-fonts)
 665                 (extensions
 666                  (list (service-extension shepherd-root-service-type
 667                                           console-font-shepherd-services)))
 668                 (compose concatenate)
 669                 (extend append)))
 670
 671 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
 672   "This procedure is deprecated in favor of @code{console-font-service-type}.
 673
 674 Return a service that sets up Unicode support in @var{tty} and loads
 675 @var{font} for that tty (fonts are per virtual console in Linux.)"
 676   (simple-service (symbol-append 'console-font- (string->symbol tty))
 677                   console-font-service-type `((,tty . ,font))))
 678
 679 (define %default-motd
 680   (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
 681
 682 (define-record-type* <login-configuration>
 683   login-configuration make-login-configuration
 684   login-configuration?
 685   (motd                   login-configuration-motd     ;file-like
 686                           (default %default-motd))
 687   ;; Allow empty passwords by default so that first-time users can log in when
 688   ;; the 'root' account has just been created.
 689   (allow-empty-passwords? login-configuration-allow-empty-passwords?
 690                           (default #t)))               ;Boolean
 691
 692 (define (login-pam-service config)
 693   "Return the list of PAM service needed for CONF."
 694   ;; Let 'login' be known to PAM.
 695   (list (unix-pam-service "login"
 696                           #:allow-empty-passwords?
 697                           (login-configuration-allow-empty-passwords? config)
 698                           #:motd
 699                           (login-configuration-motd config))))
 700
 701 (define login-service-type
 702   (service-type (name 'login)
 703                 (extensions (list (service-extension pam-root-service-type
 704                                                      login-pam-service)))))
 705
 706 (define* (login-service #:optional (config (login-configuration)))
 707   "Return a service configure login according to @var{config}, which specifies
 708 the message of the day, among other things."
 709   (service login-service-type config))
 710
 711 (define-record-type* <mingetty-configuration>
 712   mingetty-configuration make-mingetty-configuration
 713   mingetty-configuration?
 714   (mingetty       mingetty-configuration-mingetty ;<package>
 715                   (default mingetty))
 716   (tty            mingetty-configuration-tty)     ;string
 717   (auto-login     mingetty-auto-login             ;string | #f
 718                   (default #f))
 719   (login-program  mingetty-login-program          ;gexp
 720                   (default #f))
 721   (login-pause?   mingetty-login-pause?           ;Boolean
 722                   (default #f)))
 723
 724 (define mingetty-shepherd-service
 725   (match-lambda
 726     (($ <mingetty-configuration> mingetty tty auto-login login-program
 727                                  login-pause?)
 728      (list
 729       (shepherd-service
 730        (documentation "Run mingetty on an tty.")
 731        (provision (list (symbol-append 'term- (string->symbol tty))))
 732
 733        ;; Since the login prompt shows the host name, wait for the 'host-name'
 734        ;; service to be done.  Also wait for udev essentially so that the tty
 735        ;; text is not lost in the middle of kernel messages (XXX).
 736        (requirement '(user-processes host-name udev))
 737
 738        (start  #~(make-forkexec-constructor
 739                   (list #$(file-append mingetty "/sbin/mingetty")
 740                         "--noclear" #$tty
 741                         #$@(if auto-login
 742                                #~("--autologin" #$auto-login)
 743                                #~())
 744                         #$@(if login-program
 745                                #~("--loginprog" #$login-program)
 746                                #~())
 747                         #$@(if login-pause?
 748                                #~("--loginpause")
 749                                #~()))))
 750        (stop   #~(make-kill-destructor)))))))
 751
 752 (define mingetty-service-type
 753   (service-type (name 'mingetty)
 754                 (extensions (list (service-extension shepherd-root-service-type
 755                                                      mingetty-shepherd-service)))))
 756
 757 (define* (mingetty-service config)
 758   "Return a service to run mingetty according to @var{config}, which specifies
 759 the tty to run, among other things."
 760   (service mingetty-service-type config))
 761
 762 (define-record-type* <nscd-configuration> nscd-configuration
 763   make-nscd-configuration
 764   nscd-configuration?
 765   (log-file    nscd-configuration-log-file        ;string
 766                (default "/var/log/nscd.log"))
 767   (debug-level nscd-debug-level                   ;integer
 768                (default 0))
 769   ;; TODO: See nscd.conf in glibc for other options to add.
 770   (caches     nscd-configuration-caches           ;list of <nscd-cache>
 771               (default %nscd-default-caches))
 772   (name-services nscd-configuration-name-services ;list of <packages>
 773                  (default '()))
 774   (glibc      nscd-configuration-glibc            ;<package>
 775               (default (canonical-package glibc))))
 776
 777 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
 778   nscd-cache?
 779   (database              nscd-cache-database)              ;symbol
 780   (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
 781   (negative-time-to-live nscd-cache-negative-time-to-live
 782                          (default 20))             ;integer
 783   (suggested-size        nscd-cache-suggested-size ;integer ("default module
 784                                                    ;of hash table")
 785                          (default 211))
 786   (check-files?          nscd-cache-check-files?  ;Boolean
 787                          (default #t))
 788   (persistent?           nscd-cache-persistent?   ;Boolean
 789                          (default #t))
 790   (shared?               nscd-cache-shared?       ;Boolean
 791                          (default #t))
 792   (max-database-size     nscd-cache-max-database-size ;integer
 793                          (default (* 32 (expt 2 20))))
 794   (auto-propagate?       nscd-cache-auto-propagate? ;Boolean
 795                          (default #t)))
 796
 797 (define %nscd-default-caches
 798   ;; Caches that we want to enable by default.  Note that when providing an
 799   ;; empty nscd.conf, all caches are disabled.
 800   (list (nscd-cache (database 'hosts)
 801
 802                     ;; Aggressively cache the host name cache to improve
 803                     ;; privacy and resilience.
 804                     (positive-time-to-live (* 3600 12))
 805                     (negative-time-to-live 20)
 806                     (persistent? #t))
 807
 808         (nscd-cache (database 'services)
 809
 810                     ;; Services are unlikely to change, so we can be even more
 811                     ;; aggressive.
 812                     (positive-time-to-live (* 3600 24))
 813                     (negative-time-to-live 3600)
 814                     (check-files? #t)             ;check /etc/services changes
 815                     (persistent? #t))))
 816
 817 (define %nscd-default-configuration
 818   ;; Default nscd configuration.
 819   (nscd-configuration))
 820
 821 (define (nscd.conf-file config)
 822   "Return the @file{nscd.conf} configuration file for @var{config}, an
 823 @code{<nscd-configuration>} object."
 824   (define cache->config
 825     (match-lambda
 826       (($ <nscd-cache> (= symbol->string database)
 827                        positive-ttl negative-ttl size check-files?
 828                        persistent? shared? max-size propagate?)
 829        (string-append "\nenable-cache\t" database "\tyes\n"
 830
 831                       "positive-time-to-live\t" database "\t"
 832                       (number->string positive-ttl) "\n"
 833                       "negative-time-to-live\t" database "\t"
 834                       (number->string negative-ttl) "\n"
 835                       "suggested-size\t" database "\t"
 836                       (number->string size) "\n"
 837                       "check-files\t" database "\t"
 838                       (if check-files? "yes\n" "no\n")
 839                       "persistent\t" database "\t"
 840                       (if persistent? "yes\n" "no\n")
 841                       "shared\t" database "\t"
 842                       (if shared? "yes\n" "no\n")
 843                       "max-db-size\t" database "\t"
 844                       (number->string max-size) "\n"
 845                       "auto-propagate\t" database "\t"
 846                       (if propagate? "yes\n" "no\n")))))
 847
 848   (match config
 849     (($ <nscd-configuration> log-file debug-level caches)
 850      (plain-file "nscd.conf"
 851                  (string-append "\
 852 # Configuration of libc's name service cache daemon (nscd).\n\n"
 853                                 (if log-file
 854                                     (string-append "logfile\t" log-file)
 855                                     "")
 856                                 "\n"
 857                                 (if debug-level
 858                                     (string-append "debug-level\t"
 859                                                    (number->string debug-level))
 860                                     "")
 861                                 "\n"
 862                                 (string-concatenate
 863                                  (map cache->config caches)))))))
 864
 865 (define (nscd-shepherd-service config)
 866   "Return a shepherd service for CONFIG, an <nscd-configuration> object."
 867   (let ((nscd.conf     (nscd.conf-file config))
 868         (name-services (nscd-configuration-name-services config)))
 869     (list (shepherd-service
 870            (documentation "Run libc's name service cache daemon (nscd).")
 871            (provision '(nscd))
 872            (requirement '(user-processes))
 873            (start #~(make-forkexec-constructor
 874                      (list #$(file-append (nscd-configuration-glibc config)
 875                                           "/sbin/nscd")
 876                            "-f" #$nscd.conf "--foreground")
 877
 878                      ;; Wait for the PID file.  However, the PID file is
 879                      ;; written before nscd is actually listening on its
 880                      ;; socket (XXX).
 881                      #:pid-file "/var/run/nscd/nscd.pid"
 882
 883                      #:environment-variables
 884                      (list (string-append "LD_LIBRARY_PATH="
 885                                           (string-join
 886                                            (map (lambda (dir)
 887                                                   (string-append dir "/lib"))
 888                                                 (list #$@name-services))
 889                                            ":")))))
 890            (stop #~(make-kill-destructor))))))
 891
 892 (define nscd-activation
 893   ;; Actions to take before starting nscd.
 894   #~(begin
 895       (use-modules (guix build utils))
 896       (mkdir-p "/var/run/nscd")
 897       (mkdir-p "/var/db/nscd")))                  ;for the persistent cache
 898
 899 (define nscd-service-type
 900   (service-type (name 'nscd)
 901                 (extensions
 902                  (list (service-extension activation-service-type
 903                                           (const nscd-activation))
 904                        (service-extension shepherd-root-service-type
 905                                           nscd-shepherd-service)))
 906
 907                 ;; This can be extended by providing additional name services
 908                 ;; such as nss-mdns.
 909                 (compose concatenate)
 910                 (extend (lambda (config name-services)
 911                           (nscd-configuration
 912                            (inherit config)
 913                            (name-services (append
 914                                            (nscd-configuration-name-services config)
 915                                            name-services)))))))
 916
 917 (define* (nscd-service #:optional (config %nscd-default-configuration))
 918   "Return a service that runs libc's name service cache daemon (nscd) with the
 919 given @var{config}---an @code{<nscd-configuration>} object.  @xref{Name
 920 Service Switch}, for an example."
 921   (service nscd-service-type config))
 922
 923
 924 (define-record-type* <syslog-configuration>
 925   syslog-configuration  make-syslog-configuration
 926   syslog-configuration?
 927   (syslogd              syslog-configuration-syslogd
 928                         (default (file-append inetutils "/libexec/syslogd")))
 929   (config-file          syslog-configuration-config-file
 930                         (default %default-syslog.conf)))
 931
 932 (define syslog-service-type
 933   (shepherd-service-type
 934    'syslog
 935    (lambda (config)
 936      (shepherd-service
 937       (documentation "Run the syslog daemon (syslogd).")
 938       (provision '(syslogd))
 939       (requirement '(user-processes))
 940       (start #~(make-forkexec-constructor
 941                 (list #$(syslog-configuration-syslogd config)
 942                       "--rcfile" #$(syslog-configuration-config-file config))
 943                 #:pid-file "/var/run/syslog.pid"))
 944       (stop #~(make-kill-destructor))))))
 945
 946 ;; Snippet adapted from the GNU inetutils manual.
 947 (define %default-syslog.conf
 948   (plain-file "syslog.conf" "
 949      # Log all error messages, authentication messages of
 950      # level notice or higher and anything of level err or
 951      # higher to the console.
 952      # Don't log private authentication messages!
 953      *.alert;auth.notice;authpriv.none       /dev/console
 954
 955      # Log anything (except mail) of level info or higher.
 956      # Don't log private authentication messages!
 957      *.info;mail.none;authpriv.none          /var/log/messages
 958
 959      # Same, in a different place.
 960      *.info;mail.none;authpriv.none          /dev/tty12
 961
 962      # The authpriv file has restricted access.
 963      authpriv.*                              /var/log/secure
 964
 965      # Log all the mail messages in one place.
 966      mail.*                                  /var/log/maillog
 967 "))
 968
 969 (define* (syslog-service #:optional (config (syslog-configuration)))
 970   "Return a service that runs @command{syslogd} and takes
 971 @var{<syslog-configuration>} as a parameter.
 972
 973 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
 974 information on the configuration file syntax."
 975   (service syslog-service-type config))
 976
 977
 978 (define pam-limits-service-type
 979   (let ((security-limits
 980          ;; Create /etc/security containing the provided "limits.conf" file.
 981          (lambda (limits-file)
 982            `(("security"
 983               ,(computed-file
 984                 "security"
 985                 #~(begin
 986                     (mkdir #$output)
 987                     (stat #$limits-file)
 988                     (symlink #$limits-file
 989                              (string-append #$output "/limits.conf"))))))))
 990         (pam-extension
 991          (lambda (pam)
 992            (let ((pam-limits (pam-entry
 993                               (control "required")
 994                               (module "pam_limits.so")
 995                               (arguments '("conf=/etc/security/limits.conf")))))
 996              (if (member (pam-service-name pam)
 997                          '("login" "su" "slim"))
 998                  (pam-service
 999                   (inherit pam)
1000                   (session (cons pam-limits
1001                                  (pam-service-session pam))))
1002                  pam)))))
1003     (service-type
1004      (name 'limits)
1005      (extensions
1006       (list (service-extension etc-service-type security-limits)
1007             (service-extension pam-root-service-type
1008                                (lambda _ (list pam-extension))))))))
1009
1010 (define* (pam-limits-service #:optional (limits '()))
1011   "Return a service that makes selected programs respect the list of
1012 pam-limits-entry specified in LIMITS via pam_limits.so."
1013   (service pam-limits-service-type
1014            (plain-file "limits.conf"
1015                        (string-join (map pam-limits-entry->string limits)
1016                                     "\n"))))
1017
1018 \f
1019 ;;;
1020 ;;; Guix services.
1021 ;;;
1022
1023 (define* (guix-build-accounts count #:key
1024                               (group "guixbuild")
1025                               (first-uid 30001)
1026                               (shadow shadow))
1027   "Return a list of COUNT user accounts for Guix build users, with UIDs
1028 starting at FIRST-UID, and under GID."
1029   (unfold (cut > <> count)
1030           (lambda (n)
1031             (user-account
1032              (name (format #f "guixbuilder~2,'0d" n))
1033              (system? #t)
1034              (uid (+ first-uid n -1))
1035              (group group)
1036
1037              ;; guix-daemon expects GROUP to be listed as a
1038              ;; supplementary group too:
1039              ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1040              (supplementary-groups (list group "kvm"))
1041
1042              (comment (format #f "Guix Build User ~2d" n))
1043              (home-directory "/var/empty")
1044              (shell (file-append shadow "/sbin/nologin"))))
1045           1+
1046           1))
1047
1048 (define (hydra-key-authorization key guix)
1049   "Return a gexp with code to register KEY, a file containing a 'guix archive'
1050 public key, with GUIX."
1051   #~(unless (file-exists? "/etc/guix/acl")
1052       (let ((pid (primitive-fork)))
1053         (case pid
1054           ((0)
1055            (let* ((key  #$key)
1056                   (port (open-file key "r0b")))
1057              (format #t "registering public key '~a'...~%" key)
1058              (close-port (current-input-port))
1059              (dup port 0)
1060              (execl #$(file-append guix "/bin/guix")
1061                     "guix" "archive" "--authorize")
1062              (exit 1)))
1063           (else
1064            (let ((status (cdr (waitpid pid))))
1065              (unless (zero? status)
1066                (format (current-error-port) "warning: \
1067 failed to register hydra.gnu.org public key: ~a~%" status))))))))
1068
1069 (define %default-authorized-guix-keys
1070   ;; List of authorized substitute keys.
1071   (list (file-append guix "/share/guix/hydra.gnu.org.pub")))
1072
1073 (define-record-type* <guix-configuration>
1074   guix-configuration make-guix-configuration
1075   guix-configuration?
1076   (guix             guix-configuration-guix       ;<package>
1077                     (default guix))
1078   (build-group      guix-configuration-build-group ;string
1079                     (default "guixbuild"))
1080   (build-accounts   guix-configuration-build-accounts ;integer
1081                     (default 10))
1082   (authorize-key?   guix-configuration-authorize-key? ;Boolean
1083                     (default #t))
1084   (authorized-keys  guix-configuration-authorized-keys ;list of gexps
1085                     (default %default-authorized-guix-keys))
1086   (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1087                     (default #t))
1088   (substitute-urls  guix-configuration-substitute-urls ;list of strings
1089                     (default %default-substitute-urls))
1090   (extra-options    guix-configuration-extra-options ;list of strings
1091                     (default '()))
1092   (lsof             guix-configuration-lsof       ;<package>
1093                     (default lsof)))
1094
1095 (define %default-guix-configuration
1096   (guix-configuration))
1097
1098 (define (guix-shepherd-service config)
1099   "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1100   (match config
1101     (($ <guix-configuration> guix build-group build-accounts
1102                              authorize-key? keys
1103                              use-substitutes? substitute-urls extra-options
1104                              lsof)
1105      (list (shepherd-service
1106             (documentation "Run the Guix daemon.")
1107             (provision '(guix-daemon))
1108             (requirement '(user-processes))
1109             (start
1110              #~(make-forkexec-constructor
1111                 (list #$(file-append guix "/bin/guix-daemon")
1112                       "--build-users-group" #$build-group
1113                       #$@(if use-substitutes?
1114                              '()
1115                              '("--no-substitutes"))
1116                       "--substitute-urls" #$(string-join substitute-urls)
1117                       #$@extra-options)
1118
1119                 ;; Add 'lsof' (for the GC) to the daemon's $PATH.
1120                 #:environment-variables
1121                 (list (string-append "PATH=" #$lsof "/bin"))))
1122             (stop #~(make-kill-destructor)))))))
1123
1124 (define (guix-accounts config)
1125   "Return the user accounts and user groups for CONFIG."
1126   (match config
1127     (($ <guix-configuration> _ build-group build-accounts)
1128      (cons (user-group
1129             (name build-group)
1130             (system? #t)
1131
1132             ;; Use a fixed GID so that we can create the store with the right
1133             ;; owner.
1134             (id 30000))
1135            (guix-build-accounts build-accounts
1136                                 #:group build-group)))))
1137
1138 (define (guix-activation config)
1139   "Return the activation gexp for CONFIG."
1140   (match config
1141     (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1142      ;; Assume that the store has BUILD-GROUP as its group.  We could
1143      ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
1144      ;; chown leads to an entire copy of the tree, which is a bad idea.
1145
1146      ;; Optionally authorize hydra.gnu.org's key.
1147      (if authorize-key?
1148          #~(begin
1149              #$@(map (cut hydra-key-authorization <> guix) keys))
1150          #~#f))))
1151
1152 (define guix-service-type
1153   (service-type
1154    (name 'guix)
1155    (extensions
1156     (list (service-extension shepherd-root-service-type guix-shepherd-service)
1157           (service-extension account-service-type guix-accounts)
1158           (service-extension activation-service-type guix-activation)
1159           (service-extension profile-service-type
1160                              (compose list guix-configuration-guix))))))
1161
1162 (define* (guix-service #:optional (config %default-guix-configuration))
1163   "Return a service that runs the Guix build daemon according to
1164 @var{config}."
1165   (service guix-service-type config))
1166
1167
1168 (define-record-type* <guix-publish-configuration>
1169   guix-publish-configuration make-guix-publish-configuration
1170   guix-publish-configuration?
1171   (guix    guix-publish-configuration-guix        ;package
1172            (default guix))
1173   (port    guix-publish-configuration-port        ;number
1174            (default 80))
1175   (host    guix-publish-configuration-host        ;string
1176            (default "localhost")))
1177
1178 (define guix-publish-shepherd-service
1179   (match-lambda
1180     (($ <guix-publish-configuration> guix port host)
1181      (list (shepherd-service
1182             (provision '(guix-publish))
1183             (requirement '(guix-daemon))
1184             (start #~(make-forkexec-constructor
1185                       (list #$(file-append guix "/bin/guix")
1186                             "publish" "-u" "guix-publish"
1187                             "-p" #$(number->string port)
1188                             (string-append "--listen=" #$host))))
1189             (stop #~(make-kill-destructor)))))))
1190
1191 (define %guix-publish-accounts
1192   (list (user-group (name "guix-publish") (system? #t))
1193         (user-account
1194          (name "guix-publish")
1195          (group "guix-publish")
1196          (system? #t)
1197          (comment "guix publish user")
1198          (home-directory "/var/empty")
1199          (shell (file-append shadow "/sbin/nologin")))))
1200
1201 (define guix-publish-service-type
1202   (service-type (name 'guix-publish)
1203                 (extensions
1204                  (list (service-extension shepherd-root-service-type
1205                                           guix-publish-shepherd-service)
1206                        (service-extension account-service-type
1207                                           (const %guix-publish-accounts))))))
1208
1209 (define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1210   "Return a service that runs @command{guix publish} listening on @var{host}
1211 and @var{port} (@pxref{Invoking guix publish}).
1212
1213 This assumes that @file{/etc/guix} already contains a signing key pair as
1214 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1215 archive}).  If that is not the case, the service will fail to start."
1216   (service guix-publish-service-type
1217            (guix-publish-configuration (guix guix) (port port) (host host))))
1218
1219 \f
1220 ;;;
1221 ;;; Udev.
1222 ;;;
1223
1224 (define-record-type* <udev-configuration>
1225   udev-configuration make-udev-configuration
1226   udev-configuration?
1227   (udev   udev-configuration-udev                 ;<package>
1228           (default udev))
1229   (rules  udev-configuration-rules                ;list of <package>
1230           (default '())))
1231
1232 (define (udev-rules-union packages)
1233   "Return the union of the @code{lib/udev/rules.d} directories found in each
1234 item of @var{packages}."
1235   (define build
1236     (with-imported-modules '((guix build union)
1237                              (guix build utils))
1238       #~(begin
1239           (use-modules (guix build union)
1240                        (guix build utils)
1241                        (srfi srfi-1)
1242                        (srfi srfi-26))
1243
1244           (define %standard-locations
1245             '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1246
1247           (define (rules-sub-directory directory)
1248             ;; Return the sub-directory of DIRECTORY containing udev rules, or
1249             ;; #f if none was found.
1250             (find directory-exists?
1251                   (map (cut string-append directory <>) %standard-locations)))
1252
1253           (mkdir-p (string-append #$output "/lib/udev"))
1254           (union-build (string-append #$output "/lib/udev/rules.d")
1255                        (filter-map rules-sub-directory '#$packages)))))
1256
1257   (computed-file "udev-rules" build))
1258
1259 (define (udev-rule file-name contents)
1260   "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1261   (computed-file file-name
1262                  (with-imported-modules '((guix build utils))
1263                    #~(begin
1264                        (use-modules (guix build utils))
1265
1266                        (define rules.d
1267                          (string-append #$output "/lib/udev/rules.d"))
1268
1269                        (mkdir-p rules.d)
1270                        (call-with-output-file
1271                            (string-append rules.d "/" #$file-name)
1272                          (lambda (port)
1273                            (display #$contents port)))))))
1274
1275 (define kvm-udev-rule
1276   ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1277   ;; "kvm" and makes it #o660.  Apparently QEMU-KVM used to ship this rule,
1278   ;; but now we have to add it by ourselves.
1279
1280   ;; Build users are part of the "kvm" group, so we can fearlessly make
1281   ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1282   (udev-rule "90-kvm.rules"
1283              "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1284
1285 (define udev-shepherd-service
1286   ;; Return a <shepherd-service> for UDEV with RULES.
1287   (match-lambda
1288     (($ <udev-configuration> udev rules)
1289      (let* ((rules     (udev-rules-union (cons* udev kvm-udev-rule rules)))
1290             (udev.conf (computed-file "udev.conf"
1291                                       #~(call-with-output-file #$output
1292                                           (lambda (port)
1293                                             (format port
1294                                                     "udev_rules=\"~a/lib/udev/rules.d\"\n"
1295                                                     #$rules))))))
1296        (list
1297         (shepherd-service
1298          (provision '(udev))
1299
1300          ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1301          ;; be added: see
1302          ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1303          (requirement '(root-file-system))
1304
1305          (documentation "Populate the /dev directory, dynamically.")
1306          (start #~(lambda ()
1307                     (define find
1308                       (@ (srfi srfi-1) find))
1309
1310                     (define udevd
1311                       ;; Choose the right 'udevd'.
1312                       (find file-exists?
1313                             (map (lambda (suffix)
1314                                    (string-append #$udev suffix))
1315                                  '("/libexec/udev/udevd" ;udev
1316                                    "/sbin/udevd"))))     ;eudev
1317
1318                     (define (wait-for-udevd)
1319                       ;; Wait until someone's listening on udevd's control
1320                       ;; socket.
1321                       (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1322                         (let try ()
1323                           (catch 'system-error
1324                             (lambda ()
1325                               (connect sock PF_UNIX "/run/udev/control")
1326                               (close-port sock))
1327                             (lambda args
1328                               (format #t "waiting for udevd...~%")
1329                               (usleep 500000)
1330                               (try))))))
1331
1332                     ;; Allow udev to find the modules.
1333                     (setenv "LINUX_MODULE_DIRECTORY"
1334                             "/run/booted-system/kernel/lib/modules")
1335
1336                     ;; The first one is for udev, the second one for eudev.
1337                     (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1338                     (setenv "EUDEV_RULES_DIRECTORY"
1339                             #$(file-append rules "/lib/udev/rules.d"))
1340
1341                     (let ((pid (primitive-fork)))
1342                       (case pid
1343                         ((0)
1344                          (exec-command (list udevd)))
1345                         (else
1346                          ;; Wait until udevd is up and running.  This
1347                          ;; appears to be needed so that the events
1348                          ;; triggered below are actually handled.
1349                          (wait-for-udevd)
1350
1351                          ;; Trigger device node creation.
1352                          (system* #$(file-append udev "/bin/udevadm")
1353                                   "trigger" "--action=add")
1354
1355                          ;; Wait for things to settle down.
1356                          (system* #$(file-append udev "/bin/udevadm")
1357                                   "settle")
1358                          pid)))))
1359          (stop #~(make-kill-destructor))
1360
1361          ;; When halting the system, 'udev' is actually killed by
1362          ;; 'user-processes', i.e., before its own 'stop' method was called.
1363          ;; Thus, make sure it is not respawned.
1364          (respawn? #f)))))))
1365
1366 (define udev-service-type
1367   (service-type (name 'udev)
1368                 (extensions
1369                  (list (service-extension shepherd-root-service-type
1370                                           udev-shepherd-service)))
1371
1372                 (compose concatenate)           ;concatenate the list of rules
1373                 (extend (lambda (config rules)
1374                           (match config
1375                             (($ <udev-configuration> udev initial-rules)
1376                              (udev-configuration
1377                               (udev udev)
1378                               (rules (append initial-rules rules)))))))))
1379
1380 (define* (udev-service #:key (udev eudev) (rules '()))
1381   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
1382 extra rules from the packages listed in @var{rules}."
1383   (service udev-service-type
1384            (udev-configuration (udev udev) (rules rules))))
1385
1386 (define swap-service-type
1387   (shepherd-service-type
1388    'swap
1389    (lambda (device)
1390      (define requirement
1391        (if (string-prefix? "/dev/mapper/" device)
1392            (list (symbol-append 'device-mapping-
1393                                 (string->symbol (basename device))))
1394            '()))
1395
1396      (shepherd-service
1397       (provision (list (symbol-append 'swap- (string->symbol device))))
1398       (requirement `(udev ,@requirement))
1399       (documentation "Enable the given swap device.")
1400       (start #~(lambda ()
1401                  (restart-on-EINTR (swapon #$device))
1402                  #t))
1403       (stop #~(lambda _
1404                 (restart-on-EINTR (swapoff #$device))
1405                 #f))
1406       (respawn? #f)))))
1407
1408 (define (swap-service device)
1409   "Return a service that uses @var{device} as a swap device."
1410   (service swap-service-type device))
1411
1412 (define-record-type* <gpm-configuration>
1413   gpm-configuration make-gpm-configuration gpm-configuration?
1414   (gpm      gpm-configuration-gpm)                ;package
1415   (options  gpm-configuration-options))           ;list of strings
1416
1417 (define gpm-shepherd-service
1418   (match-lambda
1419     (($ <gpm-configuration> gpm options)
1420      (list (shepherd-service
1421             (requirement '(udev))
1422             (provision '(gpm))
1423             (start #~(lambda ()
1424                        ;; 'gpm' runs in the background and sets a PID file.
1425                        ;; Note that it requires running as "root".
1426                        (false-if-exception (delete-file "/var/run/gpm.pid"))
1427                        (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
1428                                                 #$@options))
1429
1430                        ;; Wait for the PID file to appear; declare failure if
1431                        ;; it doesn't show up.
1432                        (let loop ((i 3))
1433                          (or (file-exists? "/var/run/gpm.pid")
1434                              (if (zero? i)
1435                                  #f
1436                                  (begin
1437                                    (sleep 1)
1438                                    (loop (1- i))))))))
1439
1440             (stop #~(lambda (_)
1441                       ;; Return #f if successfully stopped.
1442                       (not (zero? (system* #$(file-append gpm "/sbin/gpm")
1443                                            "-k"))))))))))
1444
1445 (define gpm-service-type
1446   (service-type (name 'gpm)
1447                 (extensions
1448                  (list (service-extension shepherd-root-service-type
1449                                           gpm-shepherd-service)))))
1450
1451 (define* (gpm-service #:key (gpm gpm)
1452                       (options '("-m" "/dev/input/mice" "-t" "ps2")))
1453   "Run @var{gpm}, the general-purpose mouse daemon, with the given
1454 command-line @var{options}.  GPM allows users to use the mouse in the console,
1455 notably to select, copy, and paste text.  The default value of @var{options}
1456 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
1457
1458 This service is not part of @var{%base-services}."
1459   ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
1460   ;; "info mice" and "mouse_set X" to use the right mouse.
1461   (service gpm-service-type
1462            (gpm-configuration (gpm gpm) (options options))))
1463
1464 (define-record-type* <kmscon-configuration>
1465   kmscon-configuration     make-kmscon-configuration
1466   kmscon-configuration?
1467   (kmscon                  kmscon-configuration-kmscon
1468                            (default kmscon))
1469   (virtual-terminal        kmscon-configuration-virtual-terminal)
1470   (login-program           kmscon-configuration-login-program
1471                            (default (file-append shadow "/bin/login")))
1472   (login-arguments         kmscon-configuration-login-arguments
1473                            (default '("-p")))
1474   (hardware-acceleration?  kmscon-configuration-hardware-acceleration?
1475                            (default #f))) ; #t causes failure
1476
1477 (define kmscon-service-type
1478   (shepherd-service-type
1479    'kmscon
1480    (lambda (config)
1481      (let ((kmscon (kmscon-configuration-kmscon config))
1482            (virtual-terminal (kmscon-configuration-virtual-terminal config))
1483            (login-program (kmscon-configuration-login-program config))
1484            (login-arguments (kmscon-configuration-login-arguments config))
1485            (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
1486
1487        (define kmscon-command
1488          #~(list
1489             #$(file-append kmscon "/bin/kmscon") "--login"
1490             "--vt" #$virtual-terminal
1491             #$@(if hardware-acceleration? '("--hwaccel") '())
1492             "--" #$login-program #$@login-arguments))
1493
1494        (shepherd-service
1495         (documentation "kmscon virtual terminal")
1496         (requirement '(user-processes udev dbus-system))
1497         (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
1498         (start #~(make-forkexec-constructor #$kmscon-command))
1499         (stop #~(make-kill-destructor)))))))
1500
1501 \f
1502 (define %base-services
1503   ;; Convenience variable holding the basic services.
1504   (list (login-service)
1505
1506         (service console-font-service-type
1507                  (map (lambda (tty)
1508                         (cons tty %default-console-font))
1509                       '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
1510
1511         (mingetty-service (mingetty-configuration
1512                            (tty "tty1")))
1513         (mingetty-service (mingetty-configuration
1514                            (tty "tty2")))
1515         (mingetty-service (mingetty-configuration
1516                            (tty "tty3")))
1517         (mingetty-service (mingetty-configuration
1518                            (tty "tty4")))
1519         (mingetty-service (mingetty-configuration
1520                            (tty "tty5")))
1521         (mingetty-service (mingetty-configuration
1522                            (tty "tty6")))
1523
1524         (static-networking-service "lo" "127.0.0.1"
1525                                    #:provision '(loopback))
1526         (syslog-service)
1527         (urandom-seed-service)
1528         (guix-service)
1529         (nscd-service)
1530
1531         ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
1532         ;; used, so enable them by default.  The FUSE and ALSA rules are
1533         ;; less critical, but handy.
1534         (udev-service #:rules (list lvm2 fuse alsa-utils crda))))
1535
1536 ;;; base.scm ends here