gnu/services/base.scm

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