gnu/services/base.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 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 (udev kbd e2fsprogs))
  29   #:use-module ((gnu packages base)
  30                 #:select (glibc-final))
  31   #:use-module (gnu packages package-management)
  32   #:use-module (guix gexp)
  33   #:use-module (guix monads)
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (ice-9 format)
  37   #:export (root-file-system-service
  38             file-system-service
  39             user-processes-service
  40             host-name-service
  41             console-font-service
  42             udev-service
  43             mingetty-service
  44             nscd-service
  45             syslog-service
  46             guix-service
  47             %base-services))
  48
  49 ;;; Commentary:
  50 ;;;
  51 ;;; Base system services---i.e., services that 99% of the users will want to
  52 ;;; use.
  53 ;;;
  54 ;;; Code:
  55
  56 (define (root-file-system-service)
  57   "Return a service whose sole purpose is to re-mount read-only the root file
  58 system upon shutdown (aka. cleanly \"umounting\" root.)
  59
  60 This service must be the root of the service dependency graph so that its
  61 'stop' action is invoked when dmd is the only process left."
  62   (with-monad %store-monad
  63     (return
  64      (service
  65       (documentation "Take care of the root file system.")
  66       (provision '(root-file-system))
  67       (start #~(const #t))
  68       (stop #~(lambda _
  69                 ;; Return #f if successfully stopped.
  70                 (sync)
  71
  72                 (call-with-blocked-asyncs
  73                  (lambda ()
  74                    (let ((null (%make-void-port "w")))
  75                      ;; Close 'dmd.log'.
  76                      (display "closing log\n")
  77                      ;; XXX: Ideally we'd use 'stop-logging', but that one
  78                      ;; doesn't actually close the port as of dmd 0.1.
  79                      (close-port (@@ (dmd comm) log-output-port))
  80                      (set! (@@ (dmd comm) log-output-port) null)
  81
  82                      ;; Redirect the default output ports..
  83                      (set-current-output-port null)
  84                      (set-current-error-port null)
  85
  86                      ;; Close /dev/console.
  87                      (for-each close-fdes '(0 1 2))
  88
  89                      ;; At this point, there are no open files left, so the
  90                      ;; root file system can be re-mounted read-only.
  91                      (mount #f "/" #f
  92                             (logior MS_REMOUNT MS_RDONLY)
  93                             #:update-mtab? #f)
  94
  95                      #f)))))
  96       (respawn? #f)))))
  97
  98 (define* (file-system-service device target type
  99                               #:key (check? #t) options (title 'any))
 100   "Return a service that mounts DEVICE on TARGET as a file system TYPE with
 101 OPTIONS.  TITLE is a symbol specifying what kind of name DEVICE is: 'label for
 102 a partition label, 'device for a device file name, or 'any.  When CHECK? is
 103 true, check the file system before mounting it."
 104   (with-monad %store-monad
 105     (return
 106      (service
 107       (provision (list (symbol-append 'file-system- (string->symbol target))))
 108       (requirement '(root-file-system))
 109       (documentation "Check, mount, and unmount the given file system.")
 110       (start #~(lambda args
 111                  (let ((device (canonicalize-device-spec #$device '#$title)))
 112                    #$(if check?
 113                          #~(begin
 114                              ;; Make sure fsck.ext2 & co. can be found.
 115                              (setenv "PATH"
 116                                      (string-append
 117                                       #$e2fsprogs "/sbin:"
 118                                       "/run/current-system/profile/sbin:"
 119                                       (getenv "PATH")))
 120                              (check-file-system device #$type))
 121                          #~#t)
 122                    (mount device #$target #$type 0 #$options))
 123                  #t))
 124       (stop #~(lambda args
 125                 ;; Normally there are no processes left at this point, so
 126                 ;; TARGET can be safely unmounted.
 127                 (umount #$target)
 128                 #f))))))
 129
 130 (define %do-not-kill-file
 131   ;; Name of the file listing PIDs of processes that must survive when halting
 132   ;; the system.  Typical example is user-space file systems.
 133   "/etc/dmd/do-not-kill")
 134
 135 (define* (user-processes-service requirements #:key (grace-delay 2))
 136   "Return the service that is responsible for terminating all the processes so
 137 that the root file system can be re-mounted read-only, just before
 138 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 139 has been sent are terminated with SIGKILL.
 140
 141 The returned service will depend on 'root-file-system' and on all the services
 142 listed in REQUIREMENTS.
 143
 144 All the services that spawn processes must depend on this one so that they are
 145 stopped before 'kill' is called."
 146   (with-monad %store-monad
 147     (return (service
 148              (documentation "When stopped, terminate all user processes.")
 149              (provision '(user-processes))
 150              (requirement (cons 'root-file-system requirements))
 151              (start #~(const #t))
 152              (stop #~(lambda _
 153                        (define (kill-except omit signal)
 154                          ;; Kill all the processes with SIGNAL except those
 155                          ;; listed in OMIT and the current process.
 156                          (let ((omit (cons (getpid) omit)))
 157                            (for-each (lambda (pid)
 158                                        (unless (memv pid omit)
 159                                          (false-if-exception
 160                                           (kill pid signal))))
 161                                      (processes))))
 162
 163                        (define omitted-pids
 164                          ;; List of PIDs that must not be killed.
 165                          (if (file-exists? #$%do-not-kill-file)
 166                              (map string->number
 167                                   (call-with-input-file #$%do-not-kill-file
 168                                     (compose string-tokenize
 169                                              (@ (ice-9 rdelim) read-string))))
 170                              '()))
 171
 172                        ;; When this happens, all the processes have been
 173                        ;; killed, including 'deco', so DMD-OUTPUT-PORT and
 174                        ;; thus CURRENT-OUTPUT-PORT are dangling.
 175                        (call-with-output-file "/dev/console"
 176                          (lambda (port)
 177                            (display "sending all processes the TERM signal\n"
 178                                     port)))
 179
 180                        (if (null? omitted-pids)
 181                            (begin
 182                              ;; Easy: terminate all of them.
 183                              (kill -1 SIGTERM)
 184                              (sleep #$grace-delay)
 185                              (kill -1 SIGKILL))
 186                            (begin
 187                              ;; Kill them all except OMITTED-PIDS.  XXX: We
 188                              ;; would like to (kill -1 SIGSTOP) to get a fixed
 189                              ;; list of processes, like 'killall5' does, but
 190                              ;; that seems unreliable.
 191                              (kill-except omitted-pids SIGTERM)
 192                              (sleep #$grace-delay)
 193                              (kill-except omitted-pids SIGKILL)
 194                              (delete-file #$%do-not-kill-file)))
 195
 196                        (display "all processes have been terminated\n")
 197                        #f))
 198              (respawn? #f)))))
 199
 200 (define (host-name-service name)
 201   "Return a service that sets the host name to @var{name}."
 202   (with-monad %store-monad
 203     (return (service
 204              (documentation "Initialize the machine's host name.")
 205              (provision '(host-name))
 206              (start #~(lambda _
 207                         (sethostname #$name)))
 208              (respawn? #f)))))
 209
 210 (define (unicode-start tty)
 211   "Return a gexp to start Unicode support on @var{tty}."
 212
 213   ;; We have to run 'unicode_start' in a pipe so that when it invokes the
 214   ;; 'tty' command, that command returns TTY.
 215   #~(begin
 216       (let ((pid (primitive-fork)))
 217         (case pid
 218           ((0)
 219            (close-fdes 0)
 220            (dup2 (open-fdes #$tty O_RDONLY) 0)
 221            (close-fdes 1)
 222            (dup2 (open-fdes #$tty O_WRONLY) 1)
 223            (execl (string-append #$kbd "/bin/unicode_start")
 224                   "unicode_start"))
 225           (else
 226            (zero? (cdr (waitpid pid))))))))
 227
 228 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
 229   "Return a service that sets up Unicode support in @var{tty} and loads
 230 @var{font} for that tty (fonts are per virtual console in Linux.)"
 231   ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
 232   ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
 233   ;; codepoints notably found in the UTF-8 manual.
 234   (let ((device (string-append "/dev/" tty)))
 235     (with-monad %store-monad
 236       (return (service
 237                (documentation "Load a Unicode console font.")
 238                (provision (list (symbol-append 'console-font-
 239                                                (string->symbol tty))))
 240
 241                ;; Start after mingetty has been started on TTY, otherwise the
 242                ;; settings are ignored.
 243                (requirement (list (symbol-append 'term-
 244                                                  (string->symbol tty))))
 245
 246                (start #~(lambda _
 247                           (and #$(unicode-start device)
 248                                (zero?
 249                                 (system* (string-append #$kbd "/bin/setfont")
 250                                          "-C" #$device #$font)))))
 251                (stop #~(const #t))
 252                (respawn? #f))))))
 253
 254 (define* (mingetty-service tty
 255                            #:key
 256                            (motd (text-file "motd" "Welcome.\n"))
 257                            auto-login
 258                            login-program
 259                            login-pause?
 260
 261                            ;; Allow empty passwords by default so that
 262                            ;; first-time users can log in when the 'root'
 263                            ;; account has just been created.
 264                            (allow-empty-passwords? #t))
 265   "Return a service to run mingetty on @var{tty}.
 266
 267 When @var{allow-empty-passwords?} is true, allow empty log-in password.  When
 268 @var{auto-login} is true, it must be a user name under which to log-in
 269 automatically.  @var{login-pause?} can be set to @code{#t} in conjunction with
 270 @var{auto-login}, in which case the user will have to press a key before the
 271 login shell is launched.
 272
 273 When true, @var{login-program} is a gexp or a monadic gexp denoting the name
 274 of the log-in program (the default is the @code{login} program from the Shadow
 275 tool suite.)
 276
 277 @var{motd} is a monadic value containing a text file to use as
 278 the ``message of the day''."
 279   (mlet %store-monad ((motd motd)
 280                       (login-program (cond ((gexp? login-program)
 281                                             (return login-program))
 282                                            ((not login-program)
 283                                             (return #f))
 284                                            (else
 285                                             login-program))))
 286     (return
 287      (service
 288       (documentation (string-append "Run mingetty on " tty "."))
 289       (provision (list (symbol-append 'term- (string->symbol tty))))
 290
 291       ;; Since the login prompt shows the host name, wait for the 'host-name'
 292       ;; service to be done.
 293       (requirement '(user-processes host-name))
 294
 295       (start  #~(make-forkexec-constructor
 296                  (list (string-append #$mingetty "/sbin/mingetty")
 297                        "--noclear" #$tty
 298                        #$@(if auto-login
 299                               #~("--autologin" #$auto-login)
 300                               #~())
 301                        #$@(if login-program
 302                               #~("--loginprog" #$login-program)
 303                               #~())
 304                        #$@(if login-pause?
 305                               #~("--loginpause")
 306                               #~()))))
 307       (stop   #~(make-kill-destructor))
 308
 309       (pam-services
 310        ;; Let 'login' be known to PAM.  All the mingetty services will have
 311        ;; that PAM service, but that's fine because they're all identical and
 312        ;; duplicates are removed.
 313        (list (unix-pam-service "login"
 314                                #:allow-empty-passwords? allow-empty-passwords?
 315                                #:motd motd)))))))
 316
 317 (define* (nscd-service #:key (glibc glibc-final))
 318   "Return a service that runs libc's name service cache daemon (nscd)."
 319   (with-monad %store-monad
 320     (return (service
 321              (documentation "Run libc's name service cache daemon (nscd).")
 322              (provision '(nscd))
 323              (requirement '(user-processes))
 324
 325              (activate #~(begin
 326                            (use-modules (guix build utils))
 327                            (mkdir-p "/var/run/nscd")))
 328
 329              (start #~(make-forkexec-constructor
 330                        (list (string-append #$glibc "/sbin/nscd")
 331                              "-f" "/dev/null" "--foreground")))
 332              (stop #~(make-kill-destructor))
 333
 334              (respawn? #f)))))
 335
 336 (define (syslog-service)
 337   "Return a service that runs @code{syslogd} with reasonable default settings."
 338
 339   ;; Snippet adapted from the GNU inetutils manual.
 340   (define contents "
 341      # Log all error messages, authentication messages of
 342      # level notice or higher and anything of level err or
 343      # higher to the console.
 344      # Don't log private authentication messages!
 345      *.alert;auth.notice;authpriv.none       /dev/console
 346
 347      # Log anything (except mail) of level info or higher.
 348      # Don't log private authentication messages!
 349      *.info;mail.none;authpriv.none          /var/log/messages
 350
 351      # Same, in a different place.
 352      *.info;mail.none;authpriv.none          /dev/tty12
 353
 354      # The authpriv file has restricted access.
 355      authpriv.*                              /var/log/secure
 356
 357      # Log all the mail messages in one place.
 358      mail.*                                  /var/log/maillog
 359 ")
 360
 361   (mlet %store-monad
 362       ((syslog.conf (text-file "syslog.conf" contents)))
 363     (return
 364      (service
 365       (documentation "Run the syslog daemon (syslogd).")
 366       (provision '(syslogd))
 367       (requirement '(user-processes))
 368       (start
 369        #~(make-forkexec-constructor
 370           (list (string-append #$inetutils "/libexec/syslogd")
 371                 "--no-detach" "--rcfile" #$syslog.conf)))
 372       (stop #~(make-kill-destructor))))))
 373
 374 (define* (guix-build-accounts count #:key
 375                               (group "guixbuild")
 376                               (first-uid 30001)
 377                               (shadow shadow))
 378   "Return a list of COUNT user accounts for Guix build users, with UIDs
 379 starting at FIRST-UID, and under GID."
 380   (with-monad %store-monad
 381     (return (unfold (cut > <> count)
 382                     (lambda (n)
 383                       (user-account
 384                        (name (format #f "guixbuilder~2,'0d" n))
 385                        (system? #t)
 386                        (uid (+ first-uid n -1))
 387                        (group group)
 388
 389                        ;; guix-daemon expects GROUP to be listed as a
 390                        ;; supplementary group too:
 391                        ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
 392                        (supplementary-groups (list group))
 393
 394                        (comment (format #f "Guix Build User ~2d" n))
 395                        (home-directory "/var/empty")
 396                        (shell #~(string-append #$shadow "/sbin/nologin"))))
 397                     1+
 398                     1))))
 399
 400 (define (hydra-key-authorization guix)
 401   "Return a gexp with code to register the hydra.gnu.org public key with
 402 GUIX."
 403   #~(unless (file-exists? "/etc/guix/acl")
 404       (let ((pid (primitive-fork)))
 405         (case pid
 406           ((0)
 407            (let* ((key  (string-append #$guix
 408                                        "/share/guix/hydra.gnu.org.pub"))
 409                   (port (open-file key "r0b")))
 410              (format #t "registering public key '~a'...~%" key)
 411              (close-port (current-input-port))
 412              (dup port 0)
 413              (execl (string-append #$guix "/bin/guix")
 414                     "guix" "archive" "--authorize")
 415              (exit 1)))
 416           (else
 417            (let ((status (cdr (waitpid pid))))
 418              (unless (zero? status)
 419                (format (current-error-port) "warning: \
 420 failed to register hydra.gnu.org public key: ~a~%" status))))))))
 421
 422 (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
 423                        (build-accounts 10) authorize-hydra-key?
 424                        (use-substitutes? #t)
 425                        (extra-options '()))
 426   "Return a service that runs the build daemon from @var{guix}, and has
 427 @var{build-accounts} user accounts available under @var{builder-group}.
 428
 429 When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key
 430 provided by @var{guix} is authorized upon activation, meaning that substitutes
 431 from @code{hydra.gnu.org} are used by default.
 432
 433 If @var{use-substitutes?} is false, the daemon is run with
 434 @option{--no-substitutes} (@pxref{Invoking guix-daemon,
 435 @option{--no-substitutes}}).
 436
 437 Finally, @var{extra-options} is a list of additional command-line options
 438 passed to @command{guix-daemon}."
 439   (define activate
 440     ;; Assume that the store has BUILDER-GROUP as its group.  We could
 441     ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
 442     ;; chown leads to an entire copy of the tree, which is a bad idea.
 443
 444     ;; Optionally authorize hydra.gnu.org's key.
 445     (and authorize-hydra-key?
 446          (hydra-key-authorization guix)))
 447
 448   (mlet %store-monad ((accounts (guix-build-accounts build-accounts
 449                                                      #:group builder-group)))
 450     (return (service
 451              (provision '(guix-daemon))
 452              (requirement '(user-processes))
 453              (start
 454               #~(make-forkexec-constructor
 455                  (list (string-append #$guix "/bin/guix-daemon")
 456                        "--build-users-group" #$builder-group
 457                        #$@(if use-substitutes?
 458                               '()
 459                               '("--no-substitutes"))
 460                        #$@extra-options)))
 461              (stop #~(make-kill-destructor))
 462              (user-accounts accounts)
 463              (user-groups (list (user-group
 464                                  (name builder-group)
 465
 466                                  ;; Use a fixed GID so that we can create the
 467                                  ;; store with the right owner.
 468                                  (id 30000))))
 469              (activate activate)))))
 470
 471 (define* (udev-service #:key (udev udev))
 472   "Run @var{udev}, which populates the @file{/dev} directory dynamically."
 473   (with-monad %store-monad
 474     (return (service
 475              (provision '(udev))
 476              (requirement '(root-file-system))
 477              (documentation "Populate the /dev directory.")
 478              (start #~(lambda ()
 479                         (define udevd
 480                           (string-append #$udev "/libexec/udev/udevd"))
 481
 482                         (define (wait-for-udevd)
 483                           ;; Wait until someone's listening on udevd's control
 484                           ;; socket.
 485                           (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
 486                             (let try ()
 487                               (catch 'system-error
 488                                 (lambda ()
 489                                   (connect sock PF_UNIX "/run/udev/control")
 490                                   (close-port sock))
 491                                 (lambda args
 492                                   (format #t "waiting for udevd...~%")
 493                                   (usleep 500000)
 494                                   (try))))))
 495
 496                         ;; Allow udev to find the modules.
 497                         (setenv "LINUX_MODULE_DIRECTORY"
 498                                 "/run/booted-system/kernel/lib/modules")
 499
 500                         (let ((pid (primitive-fork)))
 501                           (case pid
 502                             ((0)
 503                              (exec-command (list udevd)))
 504                             (else
 505                              ;; Wait until udevd is up and running.  This
 506                              ;; appears to be needed so that the events
 507                              ;; triggered below are actually handled.
 508                              (wait-for-udevd)
 509
 510                              ;; Trigger device node creation.
 511                              (system* (string-append #$udev "/bin/udevadm")
 512                                       "trigger" "--action=add")
 513
 514                              ;; Wait for things to settle down.
 515                              (system* (string-append #$udev "/bin/udevadm")
 516                                       "settle")
 517                              pid)))))
 518              (stop #~(make-kill-destructor))))))
 519
 520 (define %base-services
 521   ;; Convenience variable holding the basic services.
 522   (let ((motd (text-file "motd" "
 523 This is the GNU operating system, welcome!\n\n")))
 524     (list (console-font-service "tty1")
 525           (console-font-service "tty2")
 526           (console-font-service "tty3")
 527           (console-font-service "tty4")
 528           (console-font-service "tty5")
 529           (console-font-service "tty6")
 530
 531           (mingetty-service "tty1" #:motd motd)
 532           (mingetty-service "tty2" #:motd motd)
 533           (mingetty-service "tty3" #:motd motd)
 534           (mingetty-service "tty4" #:motd motd)
 535           (mingetty-service "tty5" #:motd motd)
 536           (mingetty-service "tty6" #:motd motd)
 537           (static-networking-service "lo" "127.0.0.1"
 538                                      #:provision '(loopback))
 539           (syslog-service)
 540           (guix-service)
 541           (nscd-service)
 542           (udev-service))))
 543
 544 ;;; base.scm ends here