gnu/services/base.scm

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