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