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