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