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