gnu/services/base.scm

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