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