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