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 (gnu services)
  21   #:use-module (gnu system shadow)                ; 'user-account', etc.
  22   #:use-module (gnu system linux)                 ; 'pam-service', etc.
  23   #:use-module (gnu packages admin)
  24   #:use-module ((gnu packages base)
  25                 #:select (glibc-final))
  26   #:use-module (gnu packages package-management)
  27   #:use-module (guix gexp)
  28   #:use-module (guix monads)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (ice-9 format)
  32   #:export (root-file-system-service
  33             file-system-service
  34             user-processes-service
  35             host-name-service
  36             mingetty-service
  37             nscd-service
  38             syslog-service
  39             guix-service
  40             %base-services))
  41
  42 ;;; Commentary:
  43 ;;;
  44 ;;; Base system services---i.e., services that 99% of the users will want to
  45 ;;; use.
  46 ;;;
  47 ;;; Code:
  48
  49 (define (root-file-system-service)
  50   "Return a service whose sole purpose is to re-mount read-only the root file
  51 system upon shutdown (aka. cleanly \"umounting\" root.)
  52
  53 This service must be the root of the service dependency graph so that its
  54 'stop' action is invoked when dmd is the only process left."
  55   (with-monad %store-monad
  56     (return
  57      (service
  58       (documentation "Take care of the root file system.")
  59       (provision '(root-file-system))
  60       (start #~(const #t))
  61       (stop #~(lambda _
  62                 ;; Return #f if successfully stopped.
  63                 (sync)
  64
  65                 (call-with-blocked-asyncs
  66                  (lambda ()
  67                    (let ((null (%make-void-port "w")))
  68                      ;; Close 'dmd.log'.
  69                      (display "closing log\n")
  70                      ;; XXX: Ideally we'd use 'stop-logging', but that one
  71                      ;; doesn't actually close the port as of dmd 0.1.
  72                      (close-port (@@ (dmd comm) log-output-port))
  73                      (set! (@@ (dmd comm) log-output-port) null)
  74
  75                      ;; Redirect the default output ports..
  76                      (set-current-output-port null)
  77                      (set-current-error-port null)
  78
  79                      ;; Close /dev/console.
  80                      (for-each close-fdes '(0 1 2))
  81
  82                      ;; At this point, there are no open files left, so the
  83                      ;; root file system can be re-mounted read-only.
  84                      (mount #f "/" #f
  85                             (logior MS_REMOUNT MS_RDONLY)
  86                             #:update-mtab? #f)
  87
  88                      #f)))))
  89       (respawn? #f)))))
  90
  91 (define* (file-system-service device target type
  92                               #:key (check? #t) options)
  93   "Return a service that mounts DEVICE on TARGET as a file system TYPE with
  94 OPTIONS.  When CHECK? is true, check the file system before mounting it."
  95   (with-monad %store-monad
  96     (return
  97      (service
  98       (provision (list (symbol-append 'file-system- (string->symbol target))))
  99       (requirement '(root-file-system))
 100       (documentation "Check, mount, and unmount the given file system.")
 101       (start #~(lambda args
 102                  #$(if check?
 103                        #~(check-file-system #$device #$type)
 104                        #~#t)
 105                  (mount #$device #$target #$type 0 #$options)
 106                  #t))
 107       (stop #~(lambda args
 108                 ;; Normally there are no processes left at this point, so
 109                 ;; TARGET can be safely unmounted.
 110                 (umount #$target)
 111                 #f))))))
 112
 113 (define %do-not-kill-file
 114   ;; Name of the file listing PIDs of processes that must survive when halting
 115   ;; the system.  Typical example is user-space file systems.
 116   "/etc/dmd/do-not-kill")
 117
 118 (define* (user-processes-service requirements #:key (grace-delay 2))
 119   "Return the service that is responsible for terminating all the processes so
 120 that the root file system can be re-mounted read-only, just before
 121 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 122 has been sent are terminated with SIGKILL.
 123
 124 The returned service will depend on 'root-file-system' and on all the services
 125 listed in REQUIREMENTS.
 126
 127 All the services that spawn processes must depend on this one so that they are
 128 stopped before 'kill' is called."
 129   (with-monad %store-monad
 130     (return (service
 131              (documentation "When stopped, terminate all user processes.")
 132              (provision '(user-processes))
 133              (requirement (cons 'root-file-system requirements))
 134              (start #~(const #t))
 135              (stop #~(lambda _
 136                        (define (kill-except omit signal)
 137                          ;; Kill all the processes with SIGNAL except those
 138                          ;; listed in OMIT and the current process.
 139                          (let ((omit (cons (getpid) omit)))
 140                            (for-each (lambda (pid)
 141                                        (unless (memv pid omit)
 142                                          (false-if-exception
 143                                           (kill pid signal))))
 144                                      (processes))))
 145
 146                        (define omitted-pids
 147                          ;; List of PIDs that must not be killed.
 148                          (if (file-exists? #$%do-not-kill-file)
 149                              (map string->number
 150                                   (call-with-input-file #$%do-not-kill-file
 151                                     (compose string-tokenize
 152                                              (@ (ice-9 rdelim) read-string))))
 153                              '()))
 154
 155                        ;; When this happens, all the processes have been
 156                        ;; killed, including 'deco', so DMD-OUTPUT-PORT and
 157                        ;; thus CURRENT-OUTPUT-PORT are dangling.
 158                        (call-with-output-file "/dev/console"
 159                          (lambda (port)
 160                            (display "sending all processes the TERM signal\n"
 161                                     port)))
 162
 163                        (if (null? omitted-pids)
 164                            (begin
 165                              ;; Easy: terminate all of them.
 166                              (kill -1 SIGTERM)
 167                              (sleep #$grace-delay)
 168                              (kill -1 SIGKILL))
 169                            (begin
 170                              ;; Kill them all except OMITTED-PIDS.  XXX: We
 171                              ;; would like to (kill -1 SIGSTOP) to get a fixed
 172                              ;; list of processes, like 'killall5' does, but
 173                              ;; that seems unreliable.
 174                              (kill-except omitted-pids SIGTERM)
 175                              (sleep #$grace-delay)
 176                              (kill-except omitted-pids SIGKILL)
 177                              (delete-file #$%do-not-kill-file)))
 178
 179                        (display "all processes have been terminated\n")
 180                        #f))
 181              (respawn? #f)))))
 182
 183 (define (host-name-service name)
 184   "Return a service that sets the host name to NAME."
 185   (with-monad %store-monad
 186     (return (service
 187              (documentation "Initialize the machine's host name.")
 188              (provision '(host-name))
 189              (start #~(lambda _
 190                         (sethostname #$name)))
 191              (respawn? #f)))))
 192
 193 (define* (mingetty-service tty
 194                            #:key
 195                            (motd (text-file "motd" "Welcome.\n"))
 196                            (allow-empty-passwords? #t))
 197   "Return a service to run mingetty on TTY."
 198   (mlet %store-monad ((motd motd))
 199     (return
 200      (service
 201       (documentation (string-append "Run mingetty on " tty "."))
 202       (provision (list (symbol-append 'term- (string->symbol tty))))
 203
 204       ;; Since the login prompt shows the host name, wait for the 'host-name'
 205       ;; service to be done.
 206       (requirement '(user-processes host-name))
 207
 208       (start  #~(make-forkexec-constructor
 209                  (string-append #$mingetty "/sbin/mingetty")
 210                  "--noclear" #$tty))
 211       (stop   #~(make-kill-destructor))
 212
 213       (pam-services
 214        ;; Let 'login' be known to PAM.  All the mingetty services will have
 215        ;; that PAM service, but that's fine because they're all identical and
 216        ;; duplicates are removed.
 217        (list (unix-pam-service "login"
 218                                #:allow-empty-passwords? allow-empty-passwords?
 219                                #:motd motd)))))))
 220
 221 (define* (nscd-service #:key (glibc glibc-final))
 222   "Return a service that runs libc's name service cache daemon (nscd)."
 223   (with-monad %store-monad
 224     (return (service
 225              (documentation "Run libc's name service cache daemon (nscd).")
 226              (provision '(nscd))
 227              (requirement '(user-processes))
 228              (start
 229               #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd")
 230                                            "-f" "/dev/null"
 231                                            "--foreground"))
 232              (stop #~(make-kill-destructor))
 233
 234              (respawn? #f)))))
 235
 236 (define (syslog-service)
 237   "Return a service that runs 'syslogd' with reasonable default settings."
 238
 239   ;; Snippet adapted from the GNU inetutils manual.
 240   (define contents "
 241      # Log all kernel messages, authentication messages of
 242      # level notice or higher and anything of level err or
 243      # higher to the console.
 244      # Don't log private authentication messages!
 245      *.err;kern.*;auth.notice;authpriv.none  /dev/console
 246
 247      # Log anything (except mail) of level info or higher.
 248      # Don't log private authentication messages!
 249      *.info;mail.none;authpriv.none          /var/log/messages
 250
 251      # Same, in a different place.
 252      *.info;mail.none;authpriv.none          /dev/tty12
 253
 254      # The authpriv file has restricted access.
 255      authpriv.*                              /var/log/secure
 256
 257      # Log all the mail messages in one place.
 258      mail.*                                  /var/log/maillog
 259 ")
 260
 261   (mlet %store-monad
 262       ((syslog.conf (text-file "syslog.conf" contents)))
 263     (return
 264      (service
 265       (documentation "Run the syslog daemon (syslogd).")
 266       (provision '(syslogd))
 267       (requirement '(user-processes))
 268       (start
 269        #~(make-forkexec-constructor (string-append #$inetutils
 270                                                    "/libexec/syslogd")
 271                                     "--no-detach"
 272                                     "--rcfile" #$syslog.conf))
 273       (stop #~(make-kill-destructor))))))
 274
 275 (define* (guix-build-accounts count #:key
 276                               (group "guixbuild")
 277                               (first-uid 30001)
 278                               (shadow shadow))
 279   "Return a list of COUNT user accounts for Guix build users, with UIDs
 280 starting at FIRST-UID, and under GID."
 281   (with-monad %store-monad
 282     (return (unfold (cut > <> count)
 283                     (lambda (n)
 284                       (user-account
 285                        (name (format #f "guixbuilder~2,'0d" n))
 286                        (uid (+ first-uid n -1))
 287                        (group group)
 288                        (comment (format #f "Guix Build User ~2d" n))
 289                        (home-directory "/var/empty")
 290                        (shell #~(string-append #$shadow "/sbin/nologin"))))
 291                     1+
 292                     1))))
 293
 294 (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
 295                        (build-accounts 10))
 296   "Return a service that runs the build daemon from GUIX, and has
 297 BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
 298   (mlet %store-monad ((accounts (guix-build-accounts build-accounts
 299                                                      #:group builder-group)))
 300     (return (service
 301              (provision '(guix-daemon))
 302              (requirement '(user-processes))
 303              (start
 304               #~(make-forkexec-constructor (string-append #$guix
 305                                                           "/bin/guix-daemon")
 306                                            "--build-users-group"
 307                                            #$builder-group))
 308              (stop #~(make-kill-destructor))
 309              (user-accounts accounts)
 310              (user-groups (list (user-group
 311                                  (name builder-group)
 312                                  (members (map user-account-name
 313                                                user-accounts)))))))))
 314
 315 (define %base-services
 316   ;; Convenience variable holding the basic services.
 317   (let ((motd (text-file "motd" "
 318 This is the GNU operating system, welcome!\n\n")))
 319     (list (mingetty-service "tty1" #:motd motd)
 320           (mingetty-service "tty2" #:motd motd)
 321           (mingetty-service "tty3" #:motd motd)
 322           (mingetty-service "tty4" #:motd motd)
 323           (mingetty-service "tty5" #:motd motd)
 324           (mingetty-service "tty6" #:motd motd)
 325           (syslog-service)
 326           (guix-service)
 327           (nscd-service))))
 328
 329 ;;; base.scm ends here