gnu/system/dmd.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 system dmd)
  20   #:use-module (guix store)
  21   #:use-module (guix packages)
  22   #:use-module (guix derivations)
  23   #:use-module (guix records)
  24   #:use-module ((gnu packages base)
  25                 #:select (glibc-final guile-final))
  26   #:use-module ((gnu packages admin)
  27                 #:select (dmd mingetty inetutils shadow))
  28   #:use-module ((gnu packages package-management)
  29                 #:select (guix))
  30   #:use-module ((gnu packages linux)
  31                 #:select (net-tools))
  32   #:use-module (gnu packages xorg)
  33   #:use-module (gnu packages bash)
  34   #:use-module (gnu packages gl)
  35   #:use-module (gnu packages slim)
  36   #:use-module (gnu packages ratpoison)
  37
  38   #:use-module (gnu system shadow)                ; for user accounts/groups
  39   #:use-module (gnu system linux)                 ; for PAM services
  40   #:use-module (ice-9 match)
  41   #:use-module (ice-9 format)
  42   #:use-module (srfi srfi-1)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (guix monads)
  45   #:export (service?
  46             service
  47             service-provision
  48             service-requirement
  49             service-respawn?
  50             service-start
  51             service-stop
  52             service-inputs
  53             service-user-accounts
  54             service-user-groups
  55             service-pam-services
  56
  57             host-name-service
  58             syslog-service
  59             mingetty-service
  60             nscd-service
  61             guix-service
  62             static-networking-service
  63             xorg-start-command
  64             slim-service
  65
  66             dmd-configuration-file))
  67
  68 ;;; Commentary:
  69 ;;;
  70 ;;; System services as cajoled by dmd.
  71 ;;;
  72 ;;; Code:
  73
  74 (define-record-type* <service>
  75   service make-service
  76   service?
  77   (documentation service-documentation            ; string
  78                  (default "[No documentation.]"))
  79   (provision     service-provision)               ; list of symbols
  80   (requirement   service-requirement              ; list of symbols
  81                  (default '()))
  82   (respawn?      service-respawn?                 ; Boolean
  83                  (default #t))
  84   (start         service-start)                   ; expression
  85   (stop          service-stop                     ; expression
  86                  (default #f))
  87   (inputs        service-inputs                   ; list of inputs
  88                  (default '()))
  89   (user-accounts service-user-accounts            ; list of <user-account>
  90                  (default '()))
  91   (user-groups   service-user-groups              ; list of <user-groups>
  92                  (default '()))
  93   (pam-services  service-pam-services             ; list of <pam-service>
  94                  (default '())))
  95
  96 (define (host-name-service name)
  97   "Return a service that sets the host name to NAME."
  98   (with-monad %store-monad
  99     (return (service
 100              (documentation "Initialize the machine's host name.")
 101              (provision '(host-name))
 102              (start `(lambda _
 103                        (sethostname ,name)))
 104              (respawn? #f)))))
 105
 106 (define* (mingetty-service tty
 107                            #:key
 108                            (motd (text-file "motd" "Welcome.\n"))
 109                            (allow-empty-passwords? #t))
 110   "Return a service to run mingetty on TTY."
 111   (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty"))
 112                       (motd         motd))
 113     (return
 114      (service
 115       (documentation (string-append "Run mingetty on " tty "."))
 116       (provision (list (symbol-append 'term- (string->symbol tty))))
 117
 118       ;; Since the login prompt shows the host name, wait for the 'host-name'
 119       ;; service to be done.
 120       (requirement '(host-name))
 121
 122       (start  `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
 123       (stop   `(make-kill-destructor))
 124       (inputs `(("mingetty" ,mingetty)
 125                 ("motd" ,motd)))
 126
 127       (pam-services
 128        ;; Let 'login' be known to PAM.  All the mingetty services will have
 129        ;; that PAM service, but that's fine because they're all identical and
 130        ;; duplicates are removed.
 131        (list (unix-pam-service "login"
 132                                #:allow-empty-passwords? allow-empty-passwords?
 133                                #:motd motd)))))))
 134
 135 (define* (nscd-service #:key (glibc glibc-final))
 136   "Return a service that runs libc's name service cache daemon (nscd)."
 137   (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
 138     (return (service
 139              (documentation "Run libc's name service cache daemon (nscd).")
 140              (provision '(nscd))
 141              (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"
 142                                                 "--foreground"))
 143              (stop  `(make-kill-destructor))
 144
 145              (respawn? #f)
 146              (inputs `(("glibc" ,glibc)))))))
 147
 148 (define (syslog-service)
 149   "Return a service that runs 'syslogd' with reasonable default settings."
 150
 151   ;; Snippet adapted from the GNU inetutils manual.
 152   (define contents "
 153      # Log all kernel messages, authentication messages of
 154      # level notice or higher and anything of level err or
 155      # higher to the console.
 156      # Don't log private authentication messages!
 157      *.err;kern.*;auth.notice;authpriv.none  /dev/console
 158
 159      # Log anything (except mail) of level info or higher.
 160      # Don't log private authentication messages!
 161      *.info;mail.none;authpriv.none          /var/log/messages
 162
 163      # Same, in a different place.
 164      *.info;mail.none;authpriv.none          /dev/tty12
 165
 166      # The authpriv file has restricted access.
 167      authpriv.*                              /var/log/secure
 168
 169      # Log all the mail messages in one place.
 170      mail.*                                  /var/log/maillog
 171 ")
 172
 173   (mlet %store-monad
 174       ((syslog.conf (text-file "syslog.conf" contents))
 175        (syslogd     (package-file inetutils "libexec/syslogd")))
 176     (return
 177      (service
 178       (documentation "Run the syslog daemon (syslogd).")
 179       (provision '(syslogd))
 180       (start `(make-forkexec-constructor ,syslogd "--no-detach"
 181                                          "--rcfile" ,syslog.conf))
 182       (stop  `(make-kill-destructor))
 183       (inputs `(("inetutils" ,inetutils)
 184                 ("syslog.conf" ,syslog.conf)))))))
 185
 186 (define* (guix-build-accounts count #:key
 187                               (first-uid 30001)
 188                               (gid 30000)
 189                               (shadow shadow))
 190   "Return a list of COUNT user accounts for Guix build users, with UIDs
 191 starting at FIRST-UID, and under GID."
 192   (with-monad %store-monad
 193     (return (unfold (cut > <> count)
 194                     (lambda (n)
 195                       (user-account
 196                        (name (format #f "guixbuilder~2,'0d" n))
 197                        (password "!")
 198                        (uid (+ first-uid n -1))
 199                        (gid gid)
 200                        (comment (format #f "Guix Build User ~2d" n))
 201                        (home-directory "/var/empty")
 202                        (shell (package-file shadow "sbin/nologin"))
 203                        (inputs `(("shadow" ,shadow)))))
 204                     1+
 205                     1))))
 206
 207 (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
 208                        (build-user-gid 30000) (build-accounts 10))
 209   "Return a service that runs the build daemon from GUIX, and has
 210 BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
 211   (mlet %store-monad ((daemon   (package-file guix "bin/guix-daemon"))
 212                       (accounts (guix-build-accounts build-accounts
 213                                                      #:gid build-user-gid)))
 214     (return (service
 215              (provision '(guix-daemon))
 216              (start `(make-forkexec-constructor ,daemon
 217                                                 "--build-users-group"
 218                                                 ,builder-group))
 219              (stop  `(make-kill-destructor))
 220              (inputs `(("guix" ,guix)))
 221              (user-accounts accounts)
 222              (user-groups (list (user-group
 223                                  (name builder-group)
 224                                  (id build-user-gid)
 225                                  (members (map user-account-name
 226                                                user-accounts)))))))))
 227
 228 (define* (static-networking-service interface ip
 229                                     #:key
 230                                     gateway
 231                                     (name-servers '())
 232                                     (inetutils inetutils)
 233                                     (net-tools net-tools))
 234   "Return a service that starts INTERFACE with address IP.  If GATEWAY is
 235 true, it must be a string specifying the default network gateway."
 236
 237   ;; TODO: Eventually we should do this using Guile's networking procedures,
 238   ;; like 'configure-qemu-networking' does, but the patch that does this is
 239   ;; not yet in stock Guile.
 240   (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
 241                       (route    (package-file net-tools "sbin/route")))
 242     (return
 243      (service
 244       (documentation
 245        (string-append "Set up networking on the '" interface
 246                       "' interface using a static IP address."))
 247       (provision '(networking))
 248       (start `(lambda _
 249                 ;; Return #t if successfully started.
 250                 (and (zero? (system* ,ifconfig ,interface ,ip "up"))
 251                      ,(if gateway
 252                           `(zero? (system* ,route "add" "-net" "default"
 253                                            "gw" ,gateway))
 254                           #t)
 255                      ,(if (pair? name-servers)
 256                           `(call-with-output-file "/etc/resolv.conf"
 257                              (lambda (port)
 258                                (display
 259                                 "# Generated by 'static-networking-service'.\n"
 260                                 port)
 261                                (for-each (lambda (server)
 262                                            (format port "nameserver ~a~%"
 263                                                    server))
 264                                          ',name-servers)))
 265                           #t))))
 266       (stop  `(lambda _
 267                 ;; Return #f is successfully stopped.
 268                 (not (and (system* ,ifconfig ,interface "down")
 269                           (system* ,route "del" "-net" "default")))))
 270       (respawn? #f)
 271       (inputs `(("inetutils" ,inetutils)
 272                 ,@(if gateway
 273                       `(("net-tools" ,net-tools))
 274                       '())))))))
 275
 276 (define* (xorg-start-command #:key
 277                              (guile guile-final)
 278                              (xorg-server xorg-server))
 279   "Return a derivation that builds a GUILE script to start the X server from
 280 XORG-SERVER.  Usually the X server is started by a login manager."
 281
 282   (define (xserver.conf)
 283     (text-file* "xserver.conf" "
 284 Section \"Files\"
 285   FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\"
 286   ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\"
 287   ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\"
 288   ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\"
 289   ModulePath \"" xorg-server "/lib/xorg/modules\"
 290   ModulePath \"" xorg-server "/lib/xorg/modules/extensions\"
 291   ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\"
 292 EndSection
 293
 294 Section \"ServerFlags\"
 295   Option \"AllowMouseOpenFail\" \"on""
 296 EndSection
 297
 298 Section \"Monitor\"
 299   Identifier \"Monitor[0]\"
 300 EndSection
 301
 302 Section \"InputClass\"
 303   Identifier \"Generic keyboard\"
 304   MatchIsKeyboard \"on\"
 305   Option \"XkbRules\" \"base\"
 306   Option \"XkbModel\" \"pc104\"
 307 EndSection
 308
 309 Section \"ServerLayout\"
 310   Identifier \"Layout\"
 311   Screen \"Screen-vesa\"
 312 EndSection
 313
 314 Section \"Device\"
 315   Identifier \"Device-vesa\"
 316   Driver \"vesa\"
 317 EndSection
 318
 319 Section \"Screen\"
 320   Identifier \"Screen-vesa\"
 321   Device \"Device-vesa\"
 322 EndSection"))
 323
 324   (mlet %store-monad ((guile-bin   (package-file guile "bin/guile"))
 325                       (xorg-bin    (package-file xorg-server "bin/X"))
 326                       (dri         (package-file mesa "lib/dri"))
 327                       (xkbcomp-bin (package-file xkbcomp "bin"))
 328                       (xkb-dir     (package-file xkeyboard-config
 329                                                  "share/X11/xkb"))
 330                       (config      (xserver.conf)))
 331     (define builder
 332       ;; Write a small wrapper around the X server.
 333       `(let ((out (assoc-ref %outputs "out")))
 334          (call-with-output-file out
 335            (lambda (port)
 336              (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin)
 337              (write '(begin
 338                        (setenv "XORG_DRI_DRIVER_PATH" ,dri)
 339                        (setenv "XKB_BINDIR" ,xkbcomp-bin)
 340
 341                        (apply execl
 342
 343                               ,xorg-bin "-ac" "-logverbose" "-verbose"
 344                               "-xkbdir" ,xkb-dir
 345                               "-config" ,(derivation->output-path config)
 346                               "-nolisten" "tcp" "-terminate"
 347
 348                               ;; Note: SLiM and other display managers add the
 349                               ;; '-auth' flag by themselves.
 350                               (cdr (command-line))))
 351                     port)))
 352          (chmod out #o555)
 353          #t))
 354
 355     (mlet %store-monad ((inputs (lower-inputs
 356                                  `(("xorg" ,xorg-server)
 357                                    ("xkbcomp" ,xkbcomp)
 358                                    ("xkeyboard-config" ,xkeyboard-config)
 359                                    ("mesa" ,mesa)
 360                                    ("guile" ,guile)
 361                                    ("xorg.conf" ,config)))))
 362       (derivation-expression "start-xorg" builder
 363                              #:inputs inputs))))
 364
 365 (define* (slim-service #:key (slim slim)
 366                        (allow-empty-passwords? #t) auto-login?
 367                        (default-user "")
 368                        (xauth xauth) (dmd dmd) (bash bash)
 369                        startx)
 370   "Return a service that spawns the SLiM graphical login manager, which in
 371 turn start the X display server with STARTX, a command as returned by
 372 'xorg-start-command'.
 373
 374 When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password.
 375 When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER."
 376   (define (slim.cfg)
 377     ;; TODO: Run "bash -login ~/.xinitrc %session".
 378     (mlet %store-monad ((startx (or startx (xorg-start-command))))
 379       (text-file* "slim.cfg"  "
 380 default_path /run/current-system/bin
 381 default_xserver " startx "
 382 xserver_arguments :0 vt7
 383 xauth_path " xauth "/bin/xauth
 384 authfile /var/run/slim.auth
 385
 386 # The login command.  '%session' is replaced by the chosen session name, one
 387 # of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
 388 login_cmd  exec " ratpoison "/bin/ratpoison
 389
 390 halt_cmd " dmd "/sbin/halt
 391 reboot_cmd " dmd "/sbin/reboot
 392 " (if auto-login?
 393       (string-append "auto_login yes\ndefault_user " default-user)
 394       ""))))
 395
 396   (mlet %store-monad ((slim-bin (package-file slim "bin/slim"))
 397                       (bash-bin (package-file bash "bin/bash"))
 398                       (slim.cfg (slim.cfg)))
 399     (return
 400      (service
 401       (documentation "Xorg display server")
 402       (provision '(xorg-server))
 403       (requirement '(host-name))
 404       (start
 405        ;; XXX: Work around the inability to specify env. vars. directly.
 406        `(make-forkexec-constructor
 407          ,bash-bin "-c"
 408          ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg)
 409                          " " slim-bin
 410                          " -nodaemon")))
 411       (stop  `(make-kill-destructor))
 412       (inputs `(("slim" ,slim)
 413                 ("slim.cfg" ,slim.cfg)
 414                 ("bash" ,bash)))
 415       (respawn? #t)
 416       (pam-services
 417        ;; Tell PAM about 'slim'.
 418        (list (unix-pam-service
 419               "slim"
 420               #:allow-empty-passwords? allow-empty-passwords?)))))))
 421
 422 \f
 423 (define (dmd-configuration-file services etc)
 424   "Return the dmd configuration file for SERVICES, that initializes /etc from
 425 ETC on startup."
 426   (define config
 427     `(begin
 428        (use-modules (ice-9 ftw))
 429
 430        (register-services
 431         ,@(map (match-lambda
 432                 (($ <service> documentation provision requirement
 433                     respawn? start stop)
 434                  `(make <service>
 435                     #:docstring ,documentation
 436                     #:provides ',provision
 437                     #:requires ',requirement
 438                     #:respawn? ,respawn?
 439                     #:start ,start
 440                     #:stop ,stop)))
 441                services))
 442
 443        ;; /etc is a mixture of static and dynamic settings.  Here is where we
 444        ;; initialize it from the static part.
 445        (format #t "populating /etc from ~a...~%" ,etc)
 446        (let ((rm-f (lambda (f)
 447                      (false-if-exception (delete-file f)))))
 448          (rm-f "/etc/static")
 449          (symlink ,etc "/etc/static")
 450          (for-each (lambda (file)
 451                      ;; TODO: Handle 'shadow' specially so that changed
 452                      ;; password aren't lost.
 453                      (let ((target (string-append "/etc/" file))
 454                            (source (string-append "/etc/static/" file)))
 455                        (rm-f target)
 456                        (symlink source target)))
 457                    (scandir ,etc
 458                             (lambda (file)
 459                               (not (member file '("." ".."))))))
 460
 461          ;; Prevent ETC from being GC'd.
 462          (rm-f "/var/nix/gcroots/etc-directory")
 463          (symlink ,etc "/var/nix/gcroots/etc-directory"))
 464
 465        (format #t "starting services...~%")
 466        (for-each start ',(append-map service-provision services))))
 467
 468   (text-file "dmd.conf" (object->string config)))
 469
 470 ;;; dmd.scm ends here