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.  @xref{Name Service Switch}, for an example."
 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 #:key config-file)
 530   "Return a service that runs @code{syslogd}.
 531 If configuration file name @var{config-file} is not specified, use some
 532 reasonable default settings."
 533
 534   ;; Snippet adapted from the GNU inetutils manual.
 535   (define contents "
 536      # Log all error messages, authentication messages of
 537      # level notice or higher and anything of level err or
 538      # higher to the console.
 539      # Don't log private authentication messages!
 540      *.alert;auth.notice;authpriv.none       /dev/console
 541
 542      # Log anything (except mail) of level info or higher.
 543      # Don't log private authentication messages!
 544      *.info;mail.none;authpriv.none          /var/log/messages
 545
 546      # Same, in a different place.
 547      *.info;mail.none;authpriv.none          /dev/tty12
 548
 549      # The authpriv file has restricted access.
 550      authpriv.*                              /var/log/secure
 551
 552      # Log all the mail messages in one place.
 553      mail.*                                  /var/log/maillog
 554 ")
 555
 556   (mlet %store-monad
 557       ((syslog.conf (text-file "syslog.conf" contents)))
 558     (return
 559      (service
 560       (documentation "Run the syslog daemon (syslogd).")
 561       (provision '(syslogd))
 562       (requirement '(user-processes))
 563       (start
 564        #~(make-forkexec-constructor
 565           (list (string-append #$inetutils "/libexec/syslogd")
 566                 "--no-detach" "--rcfile" #$(or config-file syslog.conf))))
 567       (stop #~(make-kill-destructor))))))
 568
 569 (define* (guix-build-accounts count #:key
 570                               (group "guixbuild")
 571                               (first-uid 30001)
 572                               (shadow shadow))
 573   "Return a list of COUNT user accounts for Guix build users, with UIDs
 574 starting at FIRST-UID, and under GID."
 575   (unfold (cut > <> count)
 576           (lambda (n)
 577             (user-account
 578              (name (format #f "guixbuilder~2,'0d" n))
 579              (system? #t)
 580              (uid (+ first-uid n -1))
 581              (group group)
 582
 583              ;; guix-daemon expects GROUP to be listed as a
 584              ;; supplementary group too:
 585              ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
 586              (supplementary-groups (list group "kvm"))
 587
 588              (comment (format #f "Guix Build User ~2d" n))
 589              (home-directory "/var/empty")
 590              (shell #~(string-append #$shadow "/sbin/nologin"))))
 591           1+
 592           1))
 593
 594 (define (hydra-key-authorization guix)
 595   "Return a gexp with code to register the hydra.gnu.org public key with
 596 GUIX."
 597   #~(unless (file-exists? "/etc/guix/acl")
 598       (let ((pid (primitive-fork)))
 599         (case pid
 600           ((0)
 601            (let* ((key  (string-append #$guix
 602                                        "/share/guix/hydra.gnu.org.pub"))
 603                   (port (open-file key "r0b")))
 604              (format #t "registering public key '~a'...~%" key)
 605              (close-port (current-input-port))
 606              (dup port 0)
 607              (execl (string-append #$guix "/bin/guix")
 608                     "guix" "archive" "--authorize")
 609              (exit 1)))
 610           (else
 611            (let ((status (cdr (waitpid pid))))
 612              (unless (zero? status)
 613                (format (current-error-port) "warning: \
 614 failed to register hydra.gnu.org public key: ~a~%" status))))))))
 615
 616 (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
 617                        (build-accounts 10) (authorize-hydra-key? #t)
 618                        (use-substitutes? #t)
 619                        (extra-options '())
 620                        (lsof lsof) (lsh lsh))
 621   "Return a service that runs the build daemon from @var{guix}, and has
 622 @var{build-accounts} user accounts available under @var{builder-group}.
 623
 624 When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key
 625 provided by @var{guix} is authorized upon activation, meaning that substitutes
 626 from @code{hydra.gnu.org} are used by default.
 627
 628 If @var{use-substitutes?} is false, the daemon is run with
 629 @option{--no-substitutes} (@pxref{Invoking guix-daemon,
 630 @option{--no-substitutes}}).
 631
 632 Finally, @var{extra-options} is a list of additional command-line options
 633 passed to @command{guix-daemon}."
 634   (define activate
 635     ;; Assume that the store has BUILDER-GROUP as its group.  We could
 636     ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
 637     ;; chown leads to an entire copy of the tree, which is a bad idea.
 638
 639     ;; Optionally authorize hydra.gnu.org's key.
 640     (and authorize-hydra-key?
 641          (hydra-key-authorization guix)))
 642
 643   (with-monad %store-monad
 644     (return (service
 645              (documentation "Run the Guix daemon.")
 646              (provision '(guix-daemon))
 647              (requirement '(user-processes))
 648              (start
 649               #~(make-forkexec-constructor
 650                  (list (string-append #$guix "/bin/guix-daemon")
 651                        "--build-users-group" #$builder-group
 652                        #$@(if use-substitutes?
 653                               '()
 654                               '("--no-substitutes"))
 655                        #$@extra-options)
 656
 657                  ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
 658                  ;; daemon's $PATH.
 659                  #:environment-variables
 660                  (list (string-append "PATH=" #$lsof "/bin:"
 661                                       #$lsh "/bin"))))
 662              (stop #~(make-kill-destructor))
 663              (user-accounts (guix-build-accounts build-accounts
 664                                                  #:group builder-group))
 665              (user-groups (list (user-group
 666                                  (name builder-group)
 667                                  (system? #t)
 668
 669                                  ;; Use a fixed GID so that we can create the
 670                                  ;; store with the right owner.
 671                                  (id 30000))))
 672              (activate activate)))))
 673
 674 (define (udev-rules-union packages)
 675   "Return the union of the @code{lib/udev/rules.d} directories found in each
 676 item of @var{packages}."
 677   (define build
 678     #~(begin
 679         (use-modules (guix build union)
 680                      (guix build utils)
 681                      (srfi srfi-1)
 682                      (srfi srfi-26))
 683
 684         (define %standard-locations
 685           '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
 686
 687         (define (rules-sub-directory directory)
 688           ;; Return the sub-directory of DIRECTORY containing udev rules, or
 689           ;; #f if none was found.
 690           (find directory-exists?
 691                 (map (cut string-append directory <>) %standard-locations)))
 692
 693         (mkdir-p (string-append #$output "/lib/udev"))
 694         (union-build (string-append #$output "/lib/udev/rules.d")
 695                      (filter-map rules-sub-directory '#$packages))))
 696
 697   (gexp->derivation "udev-rules" build
 698                     #:modules '((guix build union)
 699                                 (guix build utils))
 700                     #:local-build? #t))
 701
 702 (define* (kvm-udev-rule)
 703   "Return a directory with a udev rule that changes the group of
 704 @file{/dev/kvm} to \"kvm\" and makes it #o660."
 705   ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by
 706   ;; ourselves.
 707   (gexp->derivation "kvm-udev-rules"
 708                     #~(begin
 709                         (use-modules (guix build utils))
 710
 711                         (define rules.d
 712                           (string-append #$output "/lib/udev/rules.d"))
 713
 714                         (mkdir-p rules.d)
 715                         (call-with-output-file
 716                             (string-append rules.d "/90-kvm.rules")
 717                           (lambda (port)
 718                             ;; FIXME: As a workaround for
 719                             ;; <http://bugs.gnu.org/18994>, make /dev/kvm 666
 720                             ;; instead of 660.
 721                             (display "\
 722 KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0666\"\n" port))))
 723                     #:modules '((guix build utils))))
 724
 725 (define* (udev-service #:key (udev eudev) (rules '()))
 726   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
 727 extra rules from the packages listed in @var{rules}."
 728   (mlet* %store-monad ((kvm       (kvm-udev-rule))
 729                        (rules     (udev-rules-union (cons* udev kvm rules)))
 730                        (udev.conf (text-file* "udev.conf"
 731                                               "udev_rules=\"" rules
 732                                               "/lib/udev/rules.d\"\n")))
 733     (return (service
 734              (provision '(udev))
 735
 736              ;; Udev needs /dev to be a 'devtmpfs' mount so that new device
 737              ;; nodes can be added: see
 738              ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
 739              (requirement '(root-file-system))
 740
 741              (documentation "Populate the /dev directory, dynamically.")
 742              (start #~(lambda ()
 743                         (define find
 744                           (@ (srfi srfi-1) find))
 745
 746                         (define udevd
 747                           ;; Choose the right 'udevd'.
 748                           (find file-exists?
 749                                 (map (lambda (suffix)
 750                                        (string-append #$udev suffix))
 751                                      '("/libexec/udev/udevd" ;udev
 752                                        "/sbin/udevd"))))     ;eudev
 753
 754                         (define (wait-for-udevd)
 755                           ;; Wait until someone's listening on udevd's control
 756                           ;; socket.
 757                           (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
 758                             (let try ()
 759                               (catch 'system-error
 760                                 (lambda ()
 761                                   (connect sock PF_UNIX "/run/udev/control")
 762                                   (close-port sock))
 763                                 (lambda args
 764                                   (format #t "waiting for udevd...~%")
 765                                   (usleep 500000)
 766                                   (try))))))
 767
 768                         ;; Allow udev to find the modules.
 769                         (setenv "LINUX_MODULE_DIRECTORY"
 770                                 "/run/booted-system/kernel/lib/modules")
 771
 772                         ;; The first one is for udev, the second one for eudev.
 773                         (setenv "UDEV_CONFIG_FILE" #$udev.conf)
 774                         (setenv "EUDEV_RULES_DIRECTORY"
 775                                 (string-append #$rules "/lib/udev/rules.d"))
 776
 777                         (let ((pid (primitive-fork)))
 778                           (case pid
 779                             ((0)
 780                              (exec-command (list udevd)))
 781                             (else
 782                              ;; Wait until udevd is up and running.  This
 783                              ;; appears to be needed so that the events
 784                              ;; triggered below are actually handled.
 785                              (wait-for-udevd)
 786
 787                              ;; Trigger device node creation.
 788                              (system* (string-append #$udev "/bin/udevadm")
 789                                       "trigger" "--action=add")
 790
 791                              ;; Wait for things to settle down.
 792                              (system* (string-append #$udev "/bin/udevadm")
 793                                       "settle")
 794                              pid)))))
 795              (stop #~(make-kill-destructor))
 796
 797              ;; When halting the system, 'udev' is actually killed by
 798              ;; 'user-processes', i.e., before its own 'stop' method was
 799              ;; called.  Thus, make sure it is not respawned.
 800              (respawn? #f)))))
 801
 802 (define (device-mapping-service target open close)
 803   "Return a service that maps device @var{target}, a string such as
 804 @code{\"home\"} (meaning @code{/dev/mapper/home}).  Evaluate @var{open}, a
 805 gexp, to open it, and evaluate @var{close} to close it."
 806   (with-monad %store-monad
 807     (return (service
 808              (provision (list (symbol-append 'device-mapping-
 809                                              (string->symbol target))))
 810              (requirement '(udev))
 811              (documentation "Map a device node using Linux's device mapper.")
 812              (start #~(lambda () #$open))
 813              (stop #~(lambda _ (not #$close)))
 814              (respawn? #f)))))
 815
 816 (define (swap-service device)
 817   "Return a service that uses @var{device} as a swap device."
 818   (define requirement
 819     (if (string-prefix? "/dev/mapper/" device)
 820         (list (symbol-append 'device-mapping-
 821                              (string->symbol (basename device))))
 822         '()))
 823
 824   (with-monad %store-monad
 825     (return (service
 826              (provision (list (symbol-append 'swap- (string->symbol device))))
 827              (requirement `(udev ,@requirement))
 828              (documentation "Enable the given swap device.")
 829              (start #~(lambda ()
 830                         (swapon #$device)
 831                         #t))
 832              (stop #~(lambda _
 833                        (swapoff #$device)
 834                        #f))
 835              (respawn? #f)))))
 836
 837 (define %base-services
 838   ;; Convenience variable holding the basic services.
 839   (let ((motd (text-file "motd" "
 840 This is the GNU operating system, welcome!\n\n")))
 841     (list (console-font-service "tty1")
 842           (console-font-service "tty2")
 843           (console-font-service "tty3")
 844           (console-font-service "tty4")
 845           (console-font-service "tty5")
 846           (console-font-service "tty6")
 847
 848           (mingetty-service "tty1" #:motd motd)
 849           (mingetty-service "tty2" #:motd motd)
 850           (mingetty-service "tty3" #:motd motd)
 851           (mingetty-service "tty4" #:motd motd)
 852           (mingetty-service "tty5" #:motd motd)
 853           (mingetty-service "tty6" #:motd motd)
 854           (static-networking-service "lo" "127.0.0.1"
 855                                      #:provision '(loopback))
 856           (syslog-service)
 857           (guix-service)
 858           (nscd-service)
 859
 860           ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
 861           ;; used, so enable them by default.  The FUSE and ALSA rules are
 862           ;; less critical, but handy.
 863           (udev-service #:rules (list lvm2 fuse alsa-utils)))))
 864
 865 ;;; base.scm ends here