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