gnu/services/base.scm

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