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