gnu/services/base.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
   4 ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
   5 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
   6 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
   7 ;;; Copyright © 2016 David Craven <david@craven.ch>
   8 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (gnu services base)
  26   #:use-module (guix store)
  27   #:use-module (gnu services)
  28   #:use-module (gnu services shepherd)
  29   #:use-module (gnu services networking)
  30   #:use-module (gnu system pam)
  31   #:use-module (gnu system shadow)                ; 'user-account', etc.
  32   #:use-module (gnu system file-systems)          ; 'file-system', etc.
  33   #:use-module (gnu system mapped-devices)
  34   #:use-module (gnu packages admin)
  35   #:use-module ((gnu packages linux)
  36                 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
  37   #:use-module ((gnu packages base)
  38                 #:select (canonical-package glibc))
  39   #:use-module (gnu packages bash)
  40   #:use-module (gnu packages package-management)
  41   #:use-module (gnu packages linux)
  42   #:use-module (gnu packages lsof)
  43   #:use-module (gnu packages terminals)
  44   #:use-module ((gnu build file-systems)
  45                 #:select (mount-flags->bit-mask))
  46   #:use-module (guix gexp)
  47   #:use-module (guix records)
  48   #:use-module (srfi srfi-1)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (ice-9 match)
  51   #:use-module (ice-9 format)
  52   #:export (fstab-service-type
  53             root-file-system-service
  54             file-system-service-type
  55             user-unmount-service
  56             swap-service
  57             user-processes-service
  58             session-environment-service
  59             session-environment-service-type
  60             host-name-service
  61             console-keymap-service
  62             %default-console-font
  63             console-font-service-type
  64             console-font-service
  65
  66             udev-configuration
  67             udev-configuration?
  68             udev-configuration-rules
  69             udev-service-type
  70             udev-service
  71             udev-rule
  72
  73             login-configuration
  74             login-configuration?
  75             login-service-type
  76             login-service
  77
  78             agetty-configuration
  79             agetty-configuration?
  80             agetty-service
  81             agetty-service-type
  82
  83             mingetty-configuration
  84             mingetty-configuration?
  85             mingetty-service
  86             mingetty-service-type
  87
  88             %nscd-default-caches
  89             %nscd-default-configuration
  90
  91             nscd-configuration
  92             nscd-configuration?
  93
  94             nscd-cache
  95             nscd-cache?
  96
  97             nscd-service-type
  98             nscd-service
  99
 100             syslog-configuration
 101             syslog-configuration?
 102             syslog-service
 103             syslog-service-type
 104             %default-syslog.conf
 105
 106             %default-authorized-guix-keys
 107             guix-configuration
 108             guix-configuration?
 109
 110             guix-configuration-guix
 111             guix-configuration-build-group
 112             guix-configuration-build-accounts
 113             guix-configuration-authorize-key?
 114             guix-configuration-authorized-keys
 115             guix-configuration-use-substitutes?
 116             guix-configuration-substitute-urls
 117             guix-configuration-extra-options
 118             guix-configuration-log-file
 119             guix-configuration-lsof
 120
 121             guix-service
 122             guix-service-type
 123             guix-publish-configuration
 124             guix-publish-configuration?
 125             guix-publish-service
 126             guix-publish-service-type
 127
 128             gpm-configuration
 129             gpm-configuration?
 130             gpm-service-type
 131             gpm-service
 132
 133             urandom-seed-service-type
 134             urandom-seed-service
 135
 136             rngd-configuration
 137             rngd-configuration?
 138             rngd-service-type
 139             rngd-service
 140
 141             kmscon-configuration
 142             kmscon-configuration?
 143             kmscon-service-type
 144
 145             pam-limits-service-type
 146             pam-limits-service
 147
 148             %base-services))
 149
 150 ;;; Commentary:
 151 ;;;
 152 ;;; Base system services---i.e., services that 99% of the users will want to
 153 ;;; use.
 154 ;;;
 155 ;;; Code:
 156
 157 \f
 158 ;;;
 159 ;;; File systems.
 160 ;;;
 161
 162 (define (file-system->fstab-entry file-system)
 163   "Return a @file{/etc/fstab} entry for @var{file-system}."
 164   (string-append (case (file-system-title file-system)
 165                    ((label)
 166                     (string-append "LABEL=" (file-system-device file-system)))
 167                    ((uuid)
 168                     (string-append
 169                      "UUID="
 170                      (uuid->string (file-system-device file-system))))
 171                    (else
 172                     (file-system-device file-system)))
 173                  "\t"
 174                  (file-system-mount-point file-system) "\t"
 175                  (file-system-type file-system) "\t"
 176                  (or (file-system-options file-system) "defaults") "\t"
 177
 178                  ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
 179                  ;; don't have anything sensible to put in there.
 180                  ))
 181
 182 (define (file-systems->fstab file-systems)
 183   "Return a @file{/etc} entry for an @file{fstab} describing
 184 @var{file-systems}."
 185   `(("fstab" ,(plain-file "fstab"
 186                           (string-append
 187                            "\
 188 # This file was generated from your GuixSD configuration.  Any changes
 189 # will be lost upon reboot or reconfiguration.\n\n"
 190                            (string-join (map file-system->fstab-entry
 191                                              file-systems)
 192                                         "\n")
 193                            "\n")))))
 194
 195 (define fstab-service-type
 196   ;; The /etc/fstab service.
 197   (service-type (name 'fstab)
 198                 (extensions
 199                  (list (service-extension etc-service-type
 200                                           file-systems->fstab)))
 201                 (compose concatenate)
 202                 (extend append)))
 203
 204 (define %root-file-system-shepherd-service
 205   (shepherd-service
 206    (documentation "Take care of the root file system.")
 207    (provision '(root-file-system))
 208    (start #~(const #t))
 209    (stop #~(lambda _
 210              ;; Return #f if successfully stopped.
 211              (sync)
 212
 213              (call-with-blocked-asyncs
 214               (lambda ()
 215                 (let ((null (%make-void-port "w")))
 216                   ;; Close 'shepherd.log'.
 217                   (display "closing log\n")
 218                   ((@ (shepherd comm) stop-logging))
 219
 220                   ;; Redirect the default output ports..
 221                   (set-current-output-port null)
 222                   (set-current-error-port null)
 223
 224                   ;; Close /dev/console.
 225                   (for-each close-fdes '(0 1 2))
 226
 227                   ;; At this point, there are no open files left, so the
 228                   ;; root file system can be re-mounted read-only.
 229                   (mount #f "/" #f
 230                          (logior MS_REMOUNT MS_RDONLY)
 231                          #:update-mtab? #f)
 232
 233                   #f)))))
 234    (respawn? #f)))
 235
 236 (define root-file-system-service-type
 237   (shepherd-service-type 'root-file-system
 238                          (const %root-file-system-shepherd-service)))
 239
 240 (define (root-file-system-service)
 241   "Return a service whose sole purpose is to re-mount read-only the root file
 242 system upon shutdown (aka. cleanly \"umounting\" root.)
 243
 244 This service must be the root of the service dependency graph so that its
 245 'stop' action is invoked when shepherd is the only process left."
 246   (service root-file-system-service-type #f))
 247
 248 (define (file-system->shepherd-service-name file-system)
 249   "Return the symbol that denotes the service mounting and unmounting
 250 FILE-SYSTEM."
 251   (symbol-append 'file-system-
 252                  (string->symbol (file-system-mount-point file-system))))
 253
 254 (define (mapped-device->shepherd-service-name md)
 255   "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
 256   (symbol-append 'device-mapping-
 257                  (string->symbol (mapped-device-target md))))
 258
 259 (define dependency->shepherd-service-name
 260   (match-lambda
 261     ((? mapped-device? md)
 262      (mapped-device->shepherd-service-name md))
 263     ((? file-system? fs)
 264      (file-system->shepherd-service-name fs))))
 265
 266 (define (file-system-shepherd-service file-system)
 267   "Return the shepherd service for @var{file-system}, or @code{#f} if
 268 @var{file-system} is not auto-mounted upon boot."
 269   (let ((target  (file-system-mount-point file-system))
 270         (device  (file-system-device file-system))
 271         (type    (file-system-type file-system))
 272         (title   (file-system-title file-system))
 273         (flags   (file-system-flags file-system))
 274         (options (file-system-options file-system))
 275         (check?  (file-system-check? file-system))
 276         (create? (file-system-create-mount-point? file-system))
 277         (dependencies (file-system-dependencies file-system))
 278         (packages (file-system-packages (list file-system))))
 279     (and (file-system-mount? file-system)
 280          (with-imported-modules '((gnu build file-systems)
 281                                   (guix build bournish))
 282            (shepherd-service
 283             (provision (list (file-system->shepherd-service-name file-system)))
 284             (requirement `(root-file-system
 285                            ,@(map dependency->shepherd-service-name dependencies)))
 286             (documentation "Check, mount, and unmount the given file system.")
 287             (start #~(lambda args
 288                        #$(if create?
 289                              #~(mkdir-p #$target)
 290                              #t)
 291
 292                        (let (($PATH (getenv "PATH")))
 293                          ;; Make sure fsck.ext2 & co. can be found.
 294                          (dynamic-wind
 295                            (lambda ()
 296                              ;; Don’t display the PATH settings.
 297                              (with-output-to-port (%make-void-port "w")
 298                                (lambda ()
 299                                  (set-path-environment-variable "PATH"
 300                                                                 '("bin" "sbin")
 301                                                                 '#$packages))))
 302                            (lambda ()
 303                              (mount-file-system
 304                               `(#$device #$title #$target #$type #$flags
 305                                          #$options #$check?)
 306                               #:root "/"))
 307                            (lambda ()
 308                              (setenv "PATH" $PATH)))
 309                          #t)))
 310             (stop #~(lambda args
 311                       ;; Normally there are no processes left at this point, so
 312                       ;; TARGET can be safely unmounted.
 313
 314                       ;; Make sure PID 1 doesn't keep TARGET busy.
 315                       (chdir "/")
 316
 317                       (umount #$target)
 318                       #f))
 319
 320             ;; We need an additional module.
 321             (modules `(((gnu build file-systems)
 322                         #:select (mount-file-system))
 323                        ,@%default-modules)))))))
 324
 325 (define (file-system-shepherd-services file-systems)
 326   "Return the list of Shepherd services for FILE-SYSTEMS."
 327   (let* ((file-systems (filter file-system-mount? file-systems)))
 328     (define sink
 329       (shepherd-service
 330        (provision '(file-systems))
 331        (requirement (cons* 'root-file-system 'user-file-systems
 332                            (map file-system->shepherd-service-name
 333                                 file-systems)))
 334        (documentation "Target for all the initially-mounted file systems")
 335        (start #~(const #t))
 336        (stop #~(const #f))))
 337
 338     (cons sink (map file-system-shepherd-service file-systems))))
 339
 340 (define file-system-service-type
 341   (service-type (name 'file-systems)
 342                 (extensions
 343                  (list (service-extension shepherd-root-service-type
 344                                           file-system-shepherd-services)
 345                        (service-extension fstab-service-type
 346                                           identity)))
 347                 (compose concatenate)
 348                 (extend append)))
 349
 350 (define user-unmount-service-type
 351   (shepherd-service-type
 352    'user-file-systems
 353    (lambda (known-mount-points)
 354      (shepherd-service
 355       (documentation "Unmount manually-mounted file systems.")
 356       (provision '(user-file-systems))
 357       (start #~(const #t))
 358       (stop #~(lambda args
 359                 (define (known? mount-point)
 360                   (member mount-point
 361                           (cons* "/proc" "/sys" '#$known-mount-points)))
 362
 363                 ;; Make sure we don't keep the user's mount points busy.
 364                 (chdir "/")
 365
 366                 (for-each (lambda (mount-point)
 367                             (format #t "unmounting '~a'...~%" mount-point)
 368                             (catch 'system-error
 369                               (lambda ()
 370                                 (umount mount-point))
 371                               (lambda args
 372                                 (let ((errno (system-error-errno args)))
 373                                   (format #t "failed to unmount '~a': ~a~%"
 374                                           mount-point (strerror errno))))))
 375                           (filter (negate known?) (mount-points)))
 376                 #f))))))
 377
 378 (define (user-unmount-service known-mount-points)
 379   "Return a service whose sole purpose is to unmount file systems not listed
 380 in KNOWN-MOUNT-POINTS when it is stopped."
 381   (service user-unmount-service-type known-mount-points))
 382
 383 (define %do-not-kill-file
 384   ;; Name of the file listing PIDs of processes that must survive when halting
 385   ;; the system.  Typical example is user-space file systems.
 386   "/etc/shepherd/do-not-kill")
 387
 388 (define user-processes-service-type
 389   (shepherd-service-type
 390    'user-processes
 391    (lambda (grace-delay)
 392      (shepherd-service
 393       (documentation "When stopped, terminate all user processes.")
 394       (provision '(user-processes))
 395       (requirement '(file-systems))
 396       (start #~(const #t))
 397       (stop #~(lambda _
 398                 (define (kill-except omit signal)
 399                   ;; Kill all the processes with SIGNAL except those listed
 400                   ;; in OMIT and the current process.
 401                   (let ((omit (cons (getpid) omit)))
 402                     (for-each (lambda (pid)
 403                                 (unless (memv pid omit)
 404                                   (false-if-exception
 405                                    (kill pid signal))))
 406                               (processes))))
 407
 408                 (define omitted-pids
 409                   ;; List of PIDs that must not be killed.
 410                   (if (file-exists? #$%do-not-kill-file)
 411                       (map string->number
 412                            (call-with-input-file #$%do-not-kill-file
 413                              (compose string-tokenize
 414                                       (@ (ice-9 rdelim) read-string))))
 415                       '()))
 416
 417                 (define (now)
 418                   (car (gettimeofday)))
 419
 420                 (define (sleep* n)
 421                   ;; Really sleep N seconds.
 422                   ;; Work around <http://bugs.gnu.org/19581>.
 423                   (define start (now))
 424                   (let loop ((elapsed 0))
 425                     (when (> n elapsed)
 426                       (sleep (- n elapsed))
 427                       (loop (- (now) start)))))
 428
 429                 (define lset= (@ (srfi srfi-1) lset=))
 430
 431                 (display "sending all processes the TERM signal\n")
 432
 433                 (if (null? omitted-pids)
 434                     (begin
 435                       ;; Easy: terminate all of them.
 436                       (kill -1 SIGTERM)
 437                       (sleep* #$grace-delay)
 438                       (kill -1 SIGKILL))
 439                     (begin
 440                       ;; Kill them all except OMITTED-PIDS.  XXX: We would
 441                       ;; like to (kill -1 SIGSTOP) to get a fixed list of
 442                       ;; processes, like 'killall5' does, but that seems
 443                       ;; unreliable.
 444                       (kill-except omitted-pids SIGTERM)
 445                       (sleep* #$grace-delay)
 446                       (kill-except omitted-pids SIGKILL)
 447                       (delete-file #$%do-not-kill-file)))
 448
 449                 (let wait ()
 450                   (let ((pids (processes)))
 451                     (unless (lset= = pids (cons 1 omitted-pids))
 452                       (format #t "waiting for process termination\
 453  (processes left: ~s)~%"
 454                               pids)
 455                       (sleep* 2)
 456                       (wait))))
 457
 458                 (display "all processes have been terminated\n")
 459                 #f))
 460       (respawn? #f)))))
 461
 462 (define* (user-processes-service #:key (grace-delay 4))
 463   "Return the service that is responsible for terminating all the processes so
 464 that the root file system can be re-mounted read-only, just before
 465 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 466 has been sent are terminated with SIGKILL.
 467
 468 The returned service will depend on 'file-systems', meaning that it is
 469 considered started after all the auto-mount file systems have been mounted.
 470
 471 All the services that spawn processes must depend on this one so that they are
 472 stopped before 'kill' is called."
 473   (service user-processes-service-type grace-delay))
 474
 475 \f
 476 ;;;
 477 ;;; Preserve entropy to seed /dev/urandom on boot.
 478 ;;;
 479
 480 (define %random-seed-file
 481   "/var/lib/random-seed")
 482
 483 (define (urandom-seed-shepherd-service _)
 484   "Return a shepherd service for the /dev/urandom seed."
 485   (list (shepherd-service
 486          (documentation "Preserve entropy across reboots for /dev/urandom.")
 487          (provision '(urandom-seed))
 488          (requirement '(user-processes))
 489          (start #~(lambda _
 490                     ;; On boot, write random seed into /dev/urandom.
 491                     (when (file-exists? #$%random-seed-file)
 492                       (call-with-input-file #$%random-seed-file
 493                         (lambda (seed)
 494                           (call-with-output-file "/dev/urandom"
 495                             (lambda (urandom)
 496                               (dump-port seed urandom))))))
 497                     ;; Immediately refresh the seed in case the system doesn't
 498                     ;; shut down cleanly.
 499                     (call-with-input-file "/dev/urandom"
 500                       (lambda (urandom)
 501                         (let ((previous-umask (umask #o077))
 502                               (buf (make-bytevector 512)))
 503                           (mkdir-p (dirname #$%random-seed-file))
 504                           (get-bytevector-n! urandom buf 0 512)
 505                           (call-with-output-file #$%random-seed-file
 506                             (lambda (seed)
 507                               (put-bytevector seed buf)))
 508                           (umask previous-umask))))
 509                     #t))
 510          (stop #~(lambda _
 511                    ;; During shutdown, write from /dev/urandom into random seed.
 512                    (let ((buf (make-bytevector 512)))
 513                      (call-with-input-file "/dev/urandom"
 514                        (lambda (urandom)
 515                          (let ((previous-umask (umask #o077)))
 516                            (get-bytevector-n! urandom buf 0 512)
 517                            (mkdir-p (dirname #$%random-seed-file))
 518                            (call-with-output-file #$%random-seed-file
 519                              (lambda (seed)
 520                                (put-bytevector seed buf)))
 521                            (umask previous-umask))
 522                          #t)))))
 523          (modules `((rnrs bytevectors)
 524                     (rnrs io ports)
 525                     ,@%default-modules)))))
 526
 527 (define urandom-seed-service-type
 528   (service-type (name 'urandom-seed)
 529                 (extensions
 530                  (list (service-extension shepherd-root-service-type
 531                                           urandom-seed-shepherd-service)))))
 532
 533 (define (urandom-seed-service)
 534   (service urandom-seed-service-type #f))
 535
 536
 537 ;;;
 538 ;;; Add hardware random number generator to entropy pool.
 539 ;;;
 540
 541 (define-record-type* <rngd-configuration>
 542   rngd-configuration make-rngd-configuration
 543   rngd-configuration?
 544   (rng-tools rngd-configuration-rng-tools)        ;package
 545   (device    rngd-configuration-device))          ;string
 546
 547 (define rngd-service-type
 548   (shepherd-service-type
 549     'rngd
 550     (lambda (config)
 551       (define rng-tools (rngd-configuration-rng-tools config))
 552       (define device (rngd-configuration-device config))
 553
 554       (define rngd-command
 555         (list (file-append rng-tools "/sbin/rngd")
 556               "-f" "-r" device))
 557
 558       (shepherd-service
 559         (documentation "Add TRNG to entropy pool.")
 560         (requirement '(udev))
 561         (provision '(trng))
 562         (start #~(make-forkexec-constructor #$@rngd-command))
 563         (stop #~(make-kill-destructor))))))
 564
 565 (define* (rngd-service #:key
 566                        (rng-tools rng-tools)
 567                        (device "/dev/hwrng"))
 568   "Return a service that runs the @command{rngd} program from @var{rng-tools}
 569 to add @var{device} to the kernel's entropy pool.  The service will fail if
 570 @var{device} does not exist."
 571   (service rngd-service-type
 572            (rngd-configuration
 573             (rng-tools rng-tools)
 574             (device device))))
 575
 576
 577 ;;;
 578 ;;; System-wide environment variables.
 579 ;;;
 580
 581 (define (environment-variables->environment-file vars)
 582   "Return a file for pam_env(8) that contains environment variables VARS."
 583   (apply mixed-text-file "environment"
 584          (append-map (match-lambda
 585                        ((key . value)
 586                         (list key "=" value "\n")))
 587                      vars)))
 588
 589 (define session-environment-service-type
 590   (service-type
 591    (name 'session-environment)
 592    (extensions
 593     (list (service-extension
 594            etc-service-type
 595            (lambda (vars)
 596              (list `("environment"
 597                      ,(environment-variables->environment-file vars)))))))
 598    (compose concatenate)
 599    (extend append)))
 600
 601 (define (session-environment-service vars)
 602   "Return a service that builds the @file{/etc/environment}, which can be read
 603 by PAM-aware applications to set environment variables for sessions.
 604
 605 VARS should be an association list in which both the keys and the values are
 606 strings or string-valued gexps."
 607   (service session-environment-service-type vars))
 608
 609 \f
 610 ;;;
 611 ;;; Console & co.
 612 ;;;
 613
 614 (define host-name-service-type
 615   (shepherd-service-type
 616    'host-name
 617    (lambda (name)
 618      (shepherd-service
 619       (documentation "Initialize the machine's host name.")
 620       (provision '(host-name))
 621       (start #~(lambda _
 622                  (sethostname #$name)))
 623       (respawn? #f)))))
 624
 625 (define (host-name-service name)
 626   "Return a service that sets the host name to @var{name}."
 627   (service host-name-service-type name))
 628
 629 (define (unicode-start tty)
 630   "Return a gexp to start Unicode support on @var{tty}."
 631
 632   ;; We have to run 'unicode_start' in a pipe so that when it invokes the
 633   ;; 'tty' command, that command returns TTY.
 634   #~(begin
 635       (let ((pid (primitive-fork)))
 636         (case pid
 637           ((0)
 638            (close-fdes 0)
 639            (dup2 (open-fdes #$tty O_RDONLY) 0)
 640            (close-fdes 1)
 641            (dup2 (open-fdes #$tty O_WRONLY) 1)
 642            (execl #$(file-append kbd "/bin/unicode_start")
 643                   "unicode_start"))
 644           (else
 645            (zero? (cdr (waitpid pid))))))))
 646
 647 (define console-keymap-service-type
 648   (shepherd-service-type
 649    'console-keymap
 650    (lambda (files)
 651      (shepherd-service
 652       (documentation (string-append "Load console keymap (loadkeys)."))
 653       (provision '(console-keymap))
 654       (start #~(lambda _
 655                  (zero? (system* #$(file-append kbd "/bin/loadkeys")
 656                                  #$@files))))
 657       (respawn? #f)))))
 658
 659 (define (console-keymap-service . files)
 660   "Return a service to load console keymaps from @var{files}."
 661   (service console-keymap-service-type files))
 662
 663 (define %default-console-font
 664   ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
 665   ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
 666   ;; codepoints notably found in the UTF-8 manual.
 667   "LatGrkCyr-8x16")
 668
 669 (define (console-font-shepherd-services tty+font)
 670   "Return a list of Shepherd services for each pair in TTY+FONT."
 671   (map (match-lambda
 672          ((tty . font)
 673           (let ((device (string-append "/dev/" tty)))
 674             (shepherd-service
 675              (documentation "Load a Unicode console font.")
 676              (provision (list (symbol-append 'console-font-
 677                                              (string->symbol tty))))
 678
 679              ;; Start after mingetty has been started on TTY, otherwise the settings
 680              ;; are ignored.
 681              (requirement (list (symbol-append 'term-
 682                                                (string->symbol tty))))
 683
 684              (start #~(lambda _
 685                         (and #$(unicode-start device)
 686                              (zero?
 687                               (system* #$(file-append kbd "/bin/setfont")
 688                                        "-C" #$device #$font)))))
 689              (stop #~(const #t))
 690              (respawn? #f)))))
 691        tty+font))
 692
 693 (define console-font-service-type
 694   (service-type (name 'console-fonts)
 695                 (extensions
 696                  (list (service-extension shepherd-root-service-type
 697                                           console-font-shepherd-services)))
 698                 (compose concatenate)
 699                 (extend append)))
 700
 701 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
 702   "This procedure is deprecated in favor of @code{console-font-service-type}.
 703
 704 Return a service that sets up Unicode support in @var{tty} and loads
 705 @var{font} for that tty (fonts are per virtual console in Linux.)"
 706   (simple-service (symbol-append 'console-font- (string->symbol tty))
 707                   console-font-service-type `((,tty . ,font))))
 708
 709 (define %default-motd
 710   (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
 711
 712 (define-record-type* <login-configuration>
 713   login-configuration make-login-configuration
 714   login-configuration?
 715   (motd                   login-configuration-motd     ;file-like
 716                           (default %default-motd))
 717   ;; Allow empty passwords by default so that first-time users can log in when
 718   ;; the 'root' account has just been created.
 719   (allow-empty-passwords? login-configuration-allow-empty-passwords?
 720                           (default #t)))               ;Boolean
 721
 722 (define (login-pam-service config)
 723   "Return the list of PAM service needed for CONF."
 724   ;; Let 'login' be known to PAM.
 725   (list (unix-pam-service "login"
 726                           #:allow-empty-passwords?
 727                           (login-configuration-allow-empty-passwords? config)
 728                           #:motd
 729                           (login-configuration-motd config))))
 730
 731 (define login-service-type
 732   (service-type (name 'login)
 733                 (extensions (list (service-extension pam-root-service-type
 734                                                      login-pam-service)))))
 735
 736 (define* (login-service #:optional (config (login-configuration)))
 737   "Return a service configure login according to @var{config}, which specifies
 738 the message of the day, among other things."
 739   (service login-service-type config))
 740
 741 (define-record-type* <agetty-configuration>
 742   agetty-configuration make-agetty-configuration
 743   agetty-configuration?
 744   (agetty           agetty-configuration-agetty   ;<package>
 745                     (default util-linux))
 746   (tty              agetty-configuration-tty)     ;string
 747   (term             agetty-term                   ;string | #f
 748                     (default #f))
 749   (baud-rate        agetty-baud-rate              ;string | #f
 750                     (default #f))
 751   (auto-login       agetty-auto-login             ;list of strings | #f
 752                     (default #f))
 753   (login-program    agetty-login-program          ;gexp
 754                     (default (file-append shadow "/bin/login")))
 755   (login-pause?     agetty-login-pause?           ;Boolean
 756                     (default #f))
 757   (eight-bits?      agetty-eight-bits?            ;Boolean
 758                     (default #f))
 759   (no-reset?        agetty-no-reset?              ;Boolean
 760                     (default #f))
 761   (remote?          agetty-remote?                ;Boolean
 762                     (default #f))
 763   (flow-control?    agetty-flow-control?          ;Boolean
 764                     (default #f))
 765   (host             agetty-host                   ;string | #f
 766                     (default #f))
 767   (no-issue?        agetty-no-issue?              ;Boolean
 768                     (default #f))
 769   (init-string      agetty-init-string            ;string | #f
 770                     (default #f))
 771   (no-clear?        agetty-no-clear?              ;Boolean
 772                     (default #f))
 773   (local-line       agetty-local-line             ;always | never | auto
 774                     (default #f))
 775   (extract-baud?    agetty-extract-baud?          ;Boolean
 776                     (default #f))
 777   (skip-login?      agetty-skip-login?            ;Boolean
 778                     (default #f))
 779   (no-newline?      agetty-no-newline?            ;Boolean
 780                     (default #f))
 781   (login-options    agetty-login-options          ;string | #f
 782                     (default #f))
 783   (chroot           agetty-chroot                 ;string | #f
 784                     (default #f))
 785   (hangup?          agetty-hangup?                ;Boolean
 786                     (default #f))
 787   (keep-baud?       agetty-keep-baud?             ;Boolean
 788                     (default #f))
 789   (timeout          agetty-timeout                ;integer | #f
 790                     (default #f))
 791   (detect-case?     agetty-detect-case?           ;Boolean
 792                     (default #f))
 793   (wait-cr?         agetty-wait-cr?               ;Boolean
 794                     (default #f))
 795   (no-hints?        agetty-no-hints?              ;Boolean
 796                     (default #f))
 797   (no-hostname?     agetty-no hostname?           ;Boolean
 798                     (default #f))
 799   (long-hostname?   agetty-long-hostname?         ;Boolean
 800                     (default #f))
 801   (erase-characters agetty-erase-characters       ;string | #f
 802                     (default #f))
 803   (kill-characters  agetty-kill-characters        ;string | #f
 804                     (default #f))
 805   (chdir            agetty-chdir                  ;string | #f
 806                     (default #f))
 807   (delay            agetty-delay                  ;integer | #f
 808                     (default #f))
 809   (nice             agetty-nice                   ;integer | #f
 810                     (default #f))
 811   ;; "Escape hatch" for passing arbitrary command-line arguments.
 812   (extra-options    agetty-extra-options          ;list of strings
 813                     (default '()))
 814 ;;; XXX Unimplemented for now!
 815 ;;; (issue-file     agetty-issue-file             ;file-like
 816 ;;;                 (default #f))
 817   )
 818
 819 (define agetty-shepherd-service
 820   (match-lambda
 821     (($ <agetty-configuration> agetty tty term baud-rate auto-login
 822         login-program login-pause? eight-bits? no-reset? remote? flow-control?
 823         host no-issue? init-string no-clear? local-line extract-baud?
 824         skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
 825         detect-case? wait-cr? no-hints? no-hostname? long-hostname?
 826         erase-characters kill-characters chdir delay nice extra-options)
 827      (list
 828        (shepherd-service
 829          (documentation "Run agetty on a tty.")
 830          (provision (list (symbol-append 'term- (string->symbol tty))))
 831
 832          ;; Since the login prompt shows the host name, wait for the 'host-name'
 833          ;; service to be done.  Also wait for udev essentially so that the tty
 834          ;; text is not lost in the middle of kernel messages (see also
 835          ;; mingetty-shepherd-service).
 836          (requirement '(user-processes host-name udev))
 837
 838          (start #~(make-forkexec-constructor
 839                     (list #$(file-append util-linux "/sbin/agetty")
 840                           #$@extra-options
 841                           #$@(if eight-bits?
 842                                  #~("--8bits")
 843                                  #~())
 844                           #$@(if no-reset?
 845                                  #~("--noreset")
 846                                  #~())
 847                           #$@(if remote?
 848                                  #~("--remote")
 849                                  #~())
 850                           #$@(if flow-control?
 851                                  #~("--flow-control")
 852                                  #~())
 853                           #$@(if host
 854                                  #~("--host" #$host)
 855                                  #~())
 856                           #$@(if no-issue?
 857                                  #~("--noissue")
 858                                  #~())
 859                           #$@(if init-string
 860                                  #~("--init-string" #$init-string)
 861                                  #~())
 862                           #$@(if no-clear?
 863                                  #~("--noclear")
 864                                  #~())
 865 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
 866 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
 867 ;;; option is selected, agetty never presents the login prompt, and the
 868 ;;; term-ttyS0 service respawns every few seconds.
 869                           #$@(if local-line
 870                                  #~(#$(match local-line
 871                                         ('auto "--local-line=auto")
 872                                         ('always "--local-line=always")
 873                                         ('never "-local-line=never")))
 874                                  #~())
 875                           #$@(if extract-baud?
 876                                  #~("--extract-baud")
 877                                  #~())
 878                           #$@(if skip-login?
 879                                  #~("--skip-login")
 880                                  #~())
 881                           #$@(if no-newline?
 882                                  #~("--nonewline")
 883                                  #~())
 884                           #$@(if login-options
 885                                  #~("--login-options" #$login-options)
 886                                  #~())
 887                           #$@(if chroot
 888                                  #~("--chroot" #$chroot)
 889                                  #~())
 890                           #$@(if hangup?
 891                                  #~("--hangup")
 892                                  #~())
 893                           #$@(if keep-baud?
 894                                  #~("--keep-baud")
 895                                  #~())
 896                           #$@(if timeout
 897                                  #~("--timeout" #$(number->string timeout))
 898                                  #~())
 899                           #$@(if detect-case?
 900                                  #~("--detect-case")
 901                                  #~())
 902                           #$@(if wait-cr?
 903                                  #~("--wait-cr")
 904                                  #~())
 905                           #$@(if no-hints?
 906                                  #~("--nohints?")
 907                                  #~())
 908                           #$@(if no-hostname?
 909                                  #~("--nohostname")
 910                                  #~())
 911                           #$@(if long-hostname?
 912                                  #~("--long-hostname")
 913                                  #~())
 914                           #$@(if erase-characters
 915                                  #~("--erase-chars" #$erase-characters)
 916                                  #~())
 917                           #$@(if kill-characters
 918                                  #~("--kill-chars" #$kill-characters)
 919                                  #~())
 920                           #$@(if chdir
 921                                  #~("--chdir" #$chdir)
 922                                  #~())
 923                           #$@(if delay
 924                                  #~("--delay" #$(number->string delay))
 925                                  #~())
 926                           #$@(if nice
 927                                  #~("--nice" #$(number->string nice))
 928                                  #~())
 929                           #$@(if auto-login
 930                                  (list "--autologin" auto-login)
 931                                  '())
 932                           #$@(if login-program
 933                                  #~("--login-program" #$login-program)
 934                                  #~())
 935                           #$@(if login-pause?
 936                                  #~("--login-pause")
 937                                  #~())
 938                           #$tty
 939                           #$@(if baud-rate
 940                                  #~(#$baud-rate)
 941                                  #~())
 942                           #$@(if term
 943                                  #~(#$term)
 944                                  #~()))))
 945          (stop #~(make-kill-destructor)))))))
 946
 947 (define agetty-service-type
 948   (service-type (name 'agetty)
 949                 (extensions (list (service-extension shepherd-root-service-type
 950                                                      agetty-shepherd-service)))))
 951
 952 (define* (agetty-service config)
 953   "Return a service to run agetty according to @var{config}, which specifies
 954 the tty to run, among other things."
 955   (service agetty-service-type config))
 956
 957 (define-record-type* <mingetty-configuration>
 958   mingetty-configuration make-mingetty-configuration
 959   mingetty-configuration?
 960   (mingetty       mingetty-configuration-mingetty ;<package>
 961                   (default mingetty))
 962   (tty            mingetty-configuration-tty)     ;string
 963   (auto-login     mingetty-auto-login             ;string | #f
 964                   (default #f))
 965   (login-program  mingetty-login-program          ;gexp
 966                   (default #f))
 967   (login-pause?   mingetty-login-pause?           ;Boolean
 968                   (default #f)))
 969
 970 (define mingetty-shepherd-service
 971   (match-lambda
 972     (($ <mingetty-configuration> mingetty tty auto-login login-program
 973                                  login-pause?)
 974      (list
 975       (shepherd-service
 976        (documentation "Run mingetty on an tty.")
 977        (provision (list (symbol-append 'term- (string->symbol tty))))
 978
 979        ;; Since the login prompt shows the host name, wait for the 'host-name'
 980        ;; service to be done.  Also wait for udev essentially so that the tty
 981        ;; text is not lost in the middle of kernel messages (XXX).
 982        (requirement '(user-processes host-name udev))
 983
 984        (start  #~(make-forkexec-constructor
 985                   (list #$(file-append mingetty "/sbin/mingetty")
 986                         "--noclear" #$tty
 987                         #$@(if auto-login
 988                                #~("--autologin" #$auto-login)
 989                                #~())
 990                         #$@(if login-program
 991                                #~("--loginprog" #$login-program)
 992                                #~())
 993                         #$@(if login-pause?
 994                                #~("--loginpause")
 995                                #~()))))
 996        (stop   #~(make-kill-destructor)))))))
 997
 998 (define mingetty-service-type
 999   (service-type (name 'mingetty)
1000                 (extensions (list (service-extension shepherd-root-service-type
1001                                                      mingetty-shepherd-service)))))
1002
1003 (define* (mingetty-service config)
1004   "Return a service to run mingetty according to @var{config}, which specifies
1005 the tty to run, among other things."
1006   (service mingetty-service-type config))
1007
1008 (define-record-type* <nscd-configuration> nscd-configuration
1009   make-nscd-configuration
1010   nscd-configuration?
1011   (log-file    nscd-configuration-log-file        ;string
1012                (default "/var/log/nscd.log"))
1013   (debug-level nscd-debug-level                   ;integer
1014                (default 0))
1015   ;; TODO: See nscd.conf in glibc for other options to add.
1016   (caches     nscd-configuration-caches           ;list of <nscd-cache>
1017               (default %nscd-default-caches))
1018   (name-services nscd-configuration-name-services ;list of <packages>
1019                  (default '()))
1020   (glibc      nscd-configuration-glibc            ;<package>
1021               (default (canonical-package glibc))))
1022
1023 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1024   nscd-cache?
1025   (database              nscd-cache-database)              ;symbol
1026   (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1027   (negative-time-to-live nscd-cache-negative-time-to-live
1028                          (default 20))             ;integer
1029   (suggested-size        nscd-cache-suggested-size ;integer ("default module
1030                                                    ;of hash table")
1031                          (default 211))
1032   (check-files?          nscd-cache-check-files?  ;Boolean
1033                          (default #t))
1034   (persistent?           nscd-cache-persistent?   ;Boolean
1035                          (default #t))
1036   (shared?               nscd-cache-shared?       ;Boolean
1037                          (default #t))
1038   (max-database-size     nscd-cache-max-database-size ;integer
1039                          (default (* 32 (expt 2 20))))
1040   (auto-propagate?       nscd-cache-auto-propagate? ;Boolean
1041                          (default #t)))
1042
1043 (define %nscd-default-caches
1044   ;; Caches that we want to enable by default.  Note that when providing an
1045   ;; empty nscd.conf, all caches are disabled.
1046   (list (nscd-cache (database 'hosts)
1047
1048                     ;; Aggressively cache the host name cache to improve
1049                     ;; privacy and resilience.
1050                     (positive-time-to-live (* 3600 12))
1051                     (negative-time-to-live 20)
1052                     (persistent? #t))
1053
1054         (nscd-cache (database 'services)
1055
1056                     ;; Services are unlikely to change, so we can be even more
1057                     ;; aggressive.
1058                     (positive-time-to-live (* 3600 24))
1059                     (negative-time-to-live 3600)
1060                     (check-files? #t)             ;check /etc/services changes
1061                     (persistent? #t))))
1062
1063 (define %nscd-default-configuration
1064   ;; Default nscd configuration.
1065   (nscd-configuration))
1066
1067 (define (nscd.conf-file config)
1068   "Return the @file{nscd.conf} configuration file for @var{config}, an
1069 @code{<nscd-configuration>} object."
1070   (define cache->config
1071     (match-lambda
1072       (($ <nscd-cache> (= symbol->string database)
1073                        positive-ttl negative-ttl size check-files?
1074                        persistent? shared? max-size propagate?)
1075        (string-append "\nenable-cache\t" database "\tyes\n"
1076
1077                       "positive-time-to-live\t" database "\t"
1078                       (number->string positive-ttl) "\n"
1079                       "negative-time-to-live\t" database "\t"
1080                       (number->string negative-ttl) "\n"
1081                       "suggested-size\t" database "\t"
1082                       (number->string size) "\n"
1083                       "check-files\t" database "\t"
1084                       (if check-files? "yes\n" "no\n")
1085                       "persistent\t" database "\t"
1086                       (if persistent? "yes\n" "no\n")
1087                       "shared\t" database "\t"
1088                       (if shared? "yes\n" "no\n")
1089                       "max-db-size\t" database "\t"
1090                       (number->string max-size) "\n"
1091                       "auto-propagate\t" database "\t"
1092                       (if propagate? "yes\n" "no\n")))))
1093
1094   (match config
1095     (($ <nscd-configuration> log-file debug-level caches)
1096      (plain-file "nscd.conf"
1097                  (string-append "\
1098 # Configuration of libc's name service cache daemon (nscd).\n\n"
1099                                 (if log-file
1100                                     (string-append "logfile\t" log-file)
1101                                     "")
1102                                 "\n"
1103                                 (if debug-level
1104                                     (string-append "debug-level\t"
1105                                                    (number->string debug-level))
1106                                     "")
1107                                 "\n"
1108                                 (string-concatenate
1109                                  (map cache->config caches)))))))
1110
1111 (define (nscd-shepherd-service config)
1112   "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1113   (let ((nscd.conf     (nscd.conf-file config))
1114         (name-services (nscd-configuration-name-services config)))
1115     (list (shepherd-service
1116            (documentation "Run libc's name service cache daemon (nscd).")
1117            (provision '(nscd))
1118            (requirement '(user-processes))
1119            (start #~(make-forkexec-constructor
1120                      (list #$(file-append (nscd-configuration-glibc config)
1121                                           "/sbin/nscd")
1122                            "-f" #$nscd.conf "--foreground")
1123
1124                      ;; Wait for the PID file.  However, the PID file is
1125                      ;; written before nscd is actually listening on its
1126                      ;; socket (XXX).
1127                      #:pid-file "/var/run/nscd/nscd.pid"
1128
1129                      #:environment-variables
1130                      (list (string-append "LD_LIBRARY_PATH="
1131                                           (string-join
1132                                            (map (lambda (dir)
1133                                                   (string-append dir "/lib"))
1134                                                 (list #$@name-services))
1135                                            ":")))))
1136            (stop #~(make-kill-destructor))))))
1137
1138 (define nscd-activation
1139   ;; Actions to take before starting nscd.
1140   #~(begin
1141       (use-modules (guix build utils))
1142       (mkdir-p "/var/run/nscd")
1143       (mkdir-p "/var/db/nscd")))                  ;for the persistent cache
1144
1145 (define nscd-service-type
1146   (service-type (name 'nscd)
1147                 (extensions
1148                  (list (service-extension activation-service-type
1149                                           (const nscd-activation))
1150                        (service-extension shepherd-root-service-type
1151                                           nscd-shepherd-service)))
1152
1153                 ;; This can be extended by providing additional name services
1154                 ;; such as nss-mdns.
1155                 (compose concatenate)
1156                 (extend (lambda (config name-services)
1157                           (nscd-configuration
1158                            (inherit config)
1159                            (name-services (append
1160                                            (nscd-configuration-name-services config)
1161                                            name-services)))))))
1162
1163 (define* (nscd-service #:optional (config %nscd-default-configuration))
1164   "Return a service that runs libc's name service cache daemon (nscd) with the
1165 given @var{config}---an @code{<nscd-configuration>} object.  @xref{Name
1166 Service Switch}, for an example."
1167   (service nscd-service-type config))
1168
1169
1170 (define-record-type* <syslog-configuration>
1171   syslog-configuration  make-syslog-configuration
1172   syslog-configuration?
1173   (syslogd              syslog-configuration-syslogd
1174                         (default (file-append inetutils "/libexec/syslogd")))
1175   (config-file          syslog-configuration-config-file
1176                         (default %default-syslog.conf)))
1177
1178 (define syslog-service-type
1179   (shepherd-service-type
1180    'syslog
1181    (lambda (config)
1182      (shepherd-service
1183       (documentation "Run the syslog daemon (syslogd).")
1184       (provision '(syslogd))
1185       (requirement '(user-processes))
1186       (start #~(make-forkexec-constructor
1187                 (list #$(syslog-configuration-syslogd config)
1188                       "--rcfile" #$(syslog-configuration-config-file config))
1189                 #:pid-file "/var/run/syslog.pid"))
1190       (stop #~(make-kill-destructor))))))
1191
1192 ;; Snippet adapted from the GNU inetutils manual.
1193 (define %default-syslog.conf
1194   (plain-file "syslog.conf" "
1195      # Log all error messages, authentication messages of
1196      # level notice or higher and anything of level err or
1197      # higher to the console.
1198      # Don't log private authentication messages!
1199      *.alert;auth.notice;authpriv.none       /dev/console
1200
1201      # Log anything (except mail) of level info or higher.
1202      # Don't log private authentication messages!
1203      *.info;mail.none;authpriv.none          /var/log/messages
1204
1205      # Same, in a different place.
1206      *.info;mail.none;authpriv.none          /dev/tty12
1207
1208      # The authpriv file has restricted access.
1209      authpriv.*                              /var/log/secure
1210
1211      # Log all the mail messages in one place.
1212      mail.*                                  /var/log/maillog
1213 "))
1214
1215 (define* (syslog-service #:optional (config (syslog-configuration)))
1216   "Return a service that runs @command{syslogd} and takes
1217 @var{<syslog-configuration>} as a parameter.
1218
1219 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1220 information on the configuration file syntax."
1221   (service syslog-service-type config))
1222
1223
1224 (define pam-limits-service-type
1225   (let ((security-limits
1226          ;; Create /etc/security containing the provided "limits.conf" file.
1227          (lambda (limits-file)
1228            `(("security"
1229               ,(computed-file
1230                 "security"
1231                 #~(begin
1232                     (mkdir #$output)
1233                     (stat #$limits-file)
1234                     (symlink #$limits-file
1235                              (string-append #$output "/limits.conf"))))))))
1236         (pam-extension
1237          (lambda (pam)
1238            (let ((pam-limits (pam-entry
1239                               (control "required")
1240                               (module "pam_limits.so")
1241                               (arguments '("conf=/etc/security/limits.conf")))))
1242              (if (member (pam-service-name pam)
1243                          '("login" "su" "slim"))
1244                  (pam-service
1245                   (inherit pam)
1246                   (session (cons pam-limits
1247                                  (pam-service-session pam))))
1248                  pam)))))
1249     (service-type
1250      (name 'limits)
1251      (extensions
1252       (list (service-extension etc-service-type security-limits)
1253             (service-extension pam-root-service-type
1254                                (lambda _ (list pam-extension))))))))
1255
1256 (define* (pam-limits-service #:optional (limits '()))
1257   "Return a service that makes selected programs respect the list of
1258 pam-limits-entry specified in LIMITS via pam_limits.so."
1259   (service pam-limits-service-type
1260            (plain-file "limits.conf"
1261                        (string-join (map pam-limits-entry->string limits)
1262                                     "\n"))))
1263
1264 \f
1265 ;;;
1266 ;;; Guix services.
1267 ;;;
1268
1269 (define* (guix-build-accounts count #:key
1270                               (group "guixbuild")
1271                               (first-uid 30001)
1272                               (shadow shadow))
1273   "Return a list of COUNT user accounts for Guix build users, with UIDs
1274 starting at FIRST-UID, and under GID."
1275   (unfold (cut > <> count)
1276           (lambda (n)
1277             (user-account
1278              (name (format #f "guixbuilder~2,'0d" n))
1279              (system? #t)
1280              (uid (+ first-uid n -1))
1281              (group group)
1282
1283              ;; guix-daemon expects GROUP to be listed as a
1284              ;; supplementary group too:
1285              ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1286              (supplementary-groups (list group "kvm"))
1287
1288              (comment (format #f "Guix Build User ~2d" n))
1289              (home-directory "/var/empty")
1290              (shell (file-append shadow "/sbin/nologin"))))
1291           1+
1292           1))
1293
1294 (define (hydra-key-authorization key guix)
1295   "Return a gexp with code to register KEY, a file containing a 'guix archive'
1296 public key, with GUIX."
1297   #~(unless (file-exists? "/etc/guix/acl")
1298       (let ((pid (primitive-fork)))
1299         (case pid
1300           ((0)
1301            (let* ((key  #$key)
1302                   (port (open-file key "r0b")))
1303              (format #t "registering public key '~a'...~%" key)
1304              (close-port (current-input-port))
1305              (dup port 0)
1306              (execl #$(file-append guix "/bin/guix")
1307                     "guix" "archive" "--authorize")
1308              (exit 1)))
1309           (else
1310            (let ((status (cdr (waitpid pid))))
1311              (unless (zero? status)
1312                (format (current-error-port) "warning: \
1313 failed to register hydra.gnu.org public key: ~a~%" status))))))))
1314
1315 (define %default-authorized-guix-keys
1316   ;; List of authorized substitute keys.
1317   (list (file-append guix "/share/guix/hydra.gnu.org.pub")))
1318
1319 (define-record-type* <guix-configuration>
1320   guix-configuration make-guix-configuration
1321   guix-configuration?
1322   (guix             guix-configuration-guix       ;<package>
1323                     (default guix))
1324   (build-group      guix-configuration-build-group ;string
1325                     (default "guixbuild"))
1326   (build-accounts   guix-configuration-build-accounts ;integer
1327                     (default 10))
1328   (authorize-key?   guix-configuration-authorize-key? ;Boolean
1329                     (default #t))
1330   (authorized-keys  guix-configuration-authorized-keys ;list of gexps
1331                     (default %default-authorized-guix-keys))
1332   (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1333                     (default #t))
1334   (substitute-urls  guix-configuration-substitute-urls ;list of strings
1335                     (default %default-substitute-urls))
1336   (extra-options    guix-configuration-extra-options ;list of strings
1337                     (default '()))
1338   (log-file         guix-configuration-log-file   ;string
1339                     (default "/var/log/guix-daemon.log"))
1340   (lsof             guix-configuration-lsof       ;<package>
1341                     (default lsof))
1342   (http-proxy       guix-http-proxy               ;string | #f
1343                     (default #f))
1344   (tmpdir           guix-tmpdir                   ;string | #f
1345                     (default #f)))
1346
1347 (define %default-guix-configuration
1348   (guix-configuration))
1349
1350 (define (guix-shepherd-service config)
1351   "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1352   (match config
1353     (($ <guix-configuration> guix build-group build-accounts
1354                              authorize-key? keys
1355                              use-substitutes? substitute-urls extra-options
1356                              log-file lsof http-proxy tmpdir)
1357      (list (shepherd-service
1358             (documentation "Run the Guix daemon.")
1359             (provision '(guix-daemon))
1360             (requirement '(user-processes))
1361             (start
1362              #~(make-forkexec-constructor
1363                 (list #$(file-append guix "/bin/guix-daemon")
1364                       "--build-users-group" #$build-group
1365                       #$@(if use-substitutes?
1366                              '()
1367                              '("--no-substitutes"))
1368                       "--substitute-urls" #$(string-join substitute-urls)
1369                       #$@extra-options)
1370
1371                 ;; Add 'lsof' (for the GC) to the daemon's $PATH.
1372                 #:environment-variables
1373                 (list (string-append "PATH=" #$lsof "/bin")
1374                       #$@(if http-proxy
1375                              (list (string-append "http_proxy=" http-proxy))
1376                              '())
1377                       #$@(if tmpdir
1378                              (list (string-append "TMPDIR=" tmpdir))
1379                              '()))
1380
1381                 #:log-file #$log-file))
1382             (stop #~(make-kill-destructor)))))))
1383
1384 (define (guix-accounts config)
1385   "Return the user accounts and user groups for CONFIG."
1386   (match config
1387     (($ <guix-configuration> _ build-group build-accounts)
1388      (cons (user-group
1389             (name build-group)
1390             (system? #t)
1391
1392             ;; Use a fixed GID so that we can create the store with the right
1393             ;; owner.
1394             (id 30000))
1395            (guix-build-accounts build-accounts
1396                                 #:group build-group)))))
1397
1398 (define (guix-activation config)
1399   "Return the activation gexp for CONFIG."
1400   (match config
1401     (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1402      ;; Assume that the store has BUILD-GROUP as its group.  We could
1403      ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
1404      ;; chown leads to an entire copy of the tree, which is a bad idea.
1405
1406      ;; Optionally authorize hydra.gnu.org's key.
1407      (if authorize-key?
1408          #~(begin
1409              #$@(map (cut hydra-key-authorization <> guix) keys))
1410          #~#f))))
1411
1412 (define guix-service-type
1413   (service-type
1414    (name 'guix)
1415    (extensions
1416     (list (service-extension shepherd-root-service-type guix-shepherd-service)
1417           (service-extension account-service-type guix-accounts)
1418           (service-extension activation-service-type guix-activation)
1419           (service-extension profile-service-type
1420                              (compose list guix-configuration-guix))))))
1421
1422 (define* (guix-service #:optional (config %default-guix-configuration))
1423   "Return a service that runs the Guix build daemon according to
1424 @var{config}."
1425   (service guix-service-type config))
1426
1427
1428 (define-record-type* <guix-publish-configuration>
1429   guix-publish-configuration make-guix-publish-configuration
1430   guix-publish-configuration?
1431   (guix    guix-publish-configuration-guix        ;package
1432            (default guix))
1433   (port    guix-publish-configuration-port        ;number
1434            (default 80))
1435   (host    guix-publish-configuration-host        ;string
1436            (default "localhost")))
1437
1438 (define guix-publish-shepherd-service
1439   (match-lambda
1440     (($ <guix-publish-configuration> guix port host)
1441      (list (shepherd-service
1442             (provision '(guix-publish))
1443             (requirement '(guix-daemon))
1444             (start #~(make-forkexec-constructor
1445                       (list #$(file-append guix "/bin/guix")
1446                             "publish" "-u" "guix-publish"
1447                             "-p" #$(number->string port)
1448                             (string-append "--listen=" #$host))))
1449             (stop #~(make-kill-destructor)))))))
1450
1451 (define %guix-publish-accounts
1452   (list (user-group (name "guix-publish") (system? #t))
1453         (user-account
1454          (name "guix-publish")
1455          (group "guix-publish")
1456          (system? #t)
1457          (comment "guix publish user")
1458          (home-directory "/var/empty")
1459          (shell (file-append shadow "/sbin/nologin")))))
1460
1461 (define guix-publish-service-type
1462   (service-type (name 'guix-publish)
1463                 (extensions
1464                  (list (service-extension shepherd-root-service-type
1465                                           guix-publish-shepherd-service)
1466                        (service-extension account-service-type
1467                                           (const %guix-publish-accounts))))))
1468
1469 (define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1470   "Return a service that runs @command{guix publish} listening on @var{host}
1471 and @var{port} (@pxref{Invoking guix publish}).
1472
1473 This assumes that @file{/etc/guix} already contains a signing key pair as
1474 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1475 archive}).  If that is not the case, the service will fail to start."
1476   (service guix-publish-service-type
1477            (guix-publish-configuration (guix guix) (port port) (host host))))
1478
1479 \f
1480 ;;;
1481 ;;; Udev.
1482 ;;;
1483
1484 (define-record-type* <udev-configuration>
1485   udev-configuration make-udev-configuration
1486   udev-configuration?
1487   (udev   udev-configuration-udev                 ;<package>
1488           (default udev))
1489   (rules  udev-configuration-rules                ;list of <package>
1490           (default '())))
1491
1492 (define (udev-rules-union packages)
1493   "Return the union of the @code{lib/udev/rules.d} directories found in each
1494 item of @var{packages}."
1495   (define build
1496     (with-imported-modules '((guix build union)
1497                              (guix build utils))
1498       #~(begin
1499           (use-modules (guix build union)
1500                        (guix build utils)
1501                        (srfi srfi-1)
1502                        (srfi srfi-26))
1503
1504           (define %standard-locations
1505             '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1506
1507           (define (rules-sub-directory directory)
1508             ;; Return the sub-directory of DIRECTORY containing udev rules, or
1509             ;; #f if none was found.
1510             (find directory-exists?
1511                   (map (cut string-append directory <>) %standard-locations)))
1512
1513           (mkdir-p (string-append #$output "/lib/udev"))
1514           (union-build (string-append #$output "/lib/udev/rules.d")
1515                        (filter-map rules-sub-directory '#$packages)))))
1516
1517   (computed-file "udev-rules" build))
1518
1519 (define (udev-rule file-name contents)
1520   "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1521   (computed-file file-name
1522                  (with-imported-modules '((guix build utils))
1523                    #~(begin
1524                        (use-modules (guix build utils))
1525
1526                        (define rules.d
1527                          (string-append #$output "/lib/udev/rules.d"))
1528
1529                        (mkdir-p rules.d)
1530                        (call-with-output-file
1531                            (string-append rules.d "/" #$file-name)
1532                          (lambda (port)
1533                            (display #$contents port)))))))
1534
1535 (define kvm-udev-rule
1536   ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1537   ;; "kvm" and makes it #o660.  Apparently QEMU-KVM used to ship this rule,
1538   ;; but now we have to add it by ourselves.
1539
1540   ;; Build users are part of the "kvm" group, so we can fearlessly make
1541   ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1542   (udev-rule "90-kvm.rules"
1543              "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1544
1545 (define udev-shepherd-service
1546   ;; Return a <shepherd-service> for UDEV with RULES.
1547   (match-lambda
1548     (($ <udev-configuration> udev rules)
1549      (let* ((rules     (udev-rules-union (cons* udev kvm-udev-rule rules)))
1550             (udev.conf (computed-file "udev.conf"
1551                                       #~(call-with-output-file #$output
1552                                           (lambda (port)
1553                                             (format port
1554                                                     "udev_rules=\"~a/lib/udev/rules.d\"\n"
1555                                                     #$rules))))))
1556        (list
1557         (shepherd-service
1558          (provision '(udev))
1559
1560          ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1561          ;; be added: see
1562          ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1563          (requirement '(root-file-system))
1564
1565          (documentation "Populate the /dev directory, dynamically.")
1566          (start #~(lambda ()
1567                     (define find
1568                       (@ (srfi srfi-1) find))
1569
1570                     (define udevd
1571                       ;; Choose the right 'udevd'.
1572                       (find file-exists?
1573                             (map (lambda (suffix)
1574                                    (string-append #$udev suffix))
1575                                  '("/libexec/udev/udevd" ;udev
1576                                    "/sbin/udevd"))))     ;eudev
1577
1578                     (define (wait-for-udevd)
1579                       ;; Wait until someone's listening on udevd's control
1580                       ;; socket.
1581                       (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1582                         (let try ()
1583                           (catch 'system-error
1584                             (lambda ()
1585                               (connect sock PF_UNIX "/run/udev/control")
1586                               (close-port sock))
1587                             (lambda args
1588                               (format #t "waiting for udevd...~%")
1589                               (usleep 500000)
1590                               (try))))))
1591
1592                     ;; Allow udev to find the modules.
1593                     (setenv "LINUX_MODULE_DIRECTORY"
1594                             "/run/booted-system/kernel/lib/modules")
1595
1596                     ;; The first one is for udev, the second one for eudev.
1597                     (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1598                     (setenv "EUDEV_RULES_DIRECTORY"
1599                             #$(file-append rules "/lib/udev/rules.d"))
1600
1601                     (let ((pid (primitive-fork)))
1602                       (case pid
1603                         ((0)
1604                          (exec-command (list udevd)))
1605                         (else
1606                          ;; Wait until udevd is up and running.  This
1607                          ;; appears to be needed so that the events
1608                          ;; triggered below are actually handled.
1609                          (wait-for-udevd)
1610
1611                          ;; Trigger device node creation.
1612                          (system* #$(file-append udev "/bin/udevadm")
1613                                   "trigger" "--action=add")
1614
1615                          ;; Wait for things to settle down.
1616                          (system* #$(file-append udev "/bin/udevadm")
1617                                   "settle")
1618                          pid)))))
1619          (stop #~(make-kill-destructor))
1620
1621          ;; When halting the system, 'udev' is actually killed by
1622          ;; 'user-processes', i.e., before its own 'stop' method was called.
1623          ;; Thus, make sure it is not respawned.
1624          (respawn? #f)))))))
1625
1626 (define udev-service-type
1627   (service-type (name 'udev)
1628                 (extensions
1629                  (list (service-extension shepherd-root-service-type
1630                                           udev-shepherd-service)))
1631
1632                 (compose concatenate)           ;concatenate the list of rules
1633                 (extend (lambda (config rules)
1634                           (match config
1635                             (($ <udev-configuration> udev initial-rules)
1636                              (udev-configuration
1637                               (udev udev)
1638                               (rules (append initial-rules rules)))))))))
1639
1640 (define* (udev-service #:key (udev eudev) (rules '()))
1641   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
1642 extra rules from the packages listed in @var{rules}."
1643   (service udev-service-type
1644            (udev-configuration (udev udev) (rules rules))))
1645
1646 (define swap-service-type
1647   (shepherd-service-type
1648    'swap
1649    (lambda (device)
1650      (define requirement
1651        (if (string-prefix? "/dev/mapper/" device)
1652            (list (symbol-append 'device-mapping-
1653                                 (string->symbol (basename device))))
1654            '()))
1655
1656      (shepherd-service
1657       (provision (list (symbol-append 'swap- (string->symbol device))))
1658       (requirement `(udev ,@requirement))
1659       (documentation "Enable the given swap device.")
1660       (start #~(lambda ()
1661                  (restart-on-EINTR (swapon #$device))
1662                  #t))
1663       (stop #~(lambda _
1664                 (restart-on-EINTR (swapoff #$device))
1665                 #f))
1666       (respawn? #f)))))
1667
1668 (define (swap-service device)
1669   "Return a service that uses @var{device} as a swap device."
1670   (service swap-service-type device))
1671
1672 (define-record-type* <gpm-configuration>
1673   gpm-configuration make-gpm-configuration gpm-configuration?
1674   (gpm      gpm-configuration-gpm)                ;package
1675   (options  gpm-configuration-options))           ;list of strings
1676
1677 (define gpm-shepherd-service
1678   (match-lambda
1679     (($ <gpm-configuration> gpm options)
1680      (list (shepherd-service
1681             (requirement '(udev))
1682             (provision '(gpm))
1683             (start #~(lambda ()
1684                        ;; 'gpm' runs in the background and sets a PID file.
1685                        ;; Note that it requires running as "root".
1686                        (false-if-exception (delete-file "/var/run/gpm.pid"))
1687                        (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
1688                                                 #$@options))
1689
1690                        ;; Wait for the PID file to appear; declare failure if
1691                        ;; it doesn't show up.
1692                        (let loop ((i 3))
1693                          (or (file-exists? "/var/run/gpm.pid")
1694                              (if (zero? i)
1695                                  #f
1696                                  (begin
1697                                    (sleep 1)
1698                                    (loop (1- i))))))))
1699
1700             (stop #~(lambda (_)
1701                       ;; Return #f if successfully stopped.
1702                       (not (zero? (system* #$(file-append gpm "/sbin/gpm")
1703                                            "-k"))))))))))
1704
1705 (define gpm-service-type
1706   (service-type (name 'gpm)
1707                 (extensions
1708                  (list (service-extension shepherd-root-service-type
1709                                           gpm-shepherd-service)))))
1710
1711 (define* (gpm-service #:key (gpm gpm)
1712                       (options '("-m" "/dev/input/mice" "-t" "ps2")))
1713   "Run @var{gpm}, the general-purpose mouse daemon, with the given
1714 command-line @var{options}.  GPM allows users to use the mouse in the console,
1715 notably to select, copy, and paste text.  The default value of @var{options}
1716 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
1717
1718 This service is not part of @var{%base-services}."
1719   ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
1720   ;; "info mice" and "mouse_set X" to use the right mouse.
1721   (service gpm-service-type
1722            (gpm-configuration (gpm gpm) (options options))))
1723
1724 (define-record-type* <kmscon-configuration>
1725   kmscon-configuration     make-kmscon-configuration
1726   kmscon-configuration?
1727   (kmscon                  kmscon-configuration-kmscon
1728                            (default kmscon))
1729   (virtual-terminal        kmscon-configuration-virtual-terminal)
1730   (login-program           kmscon-configuration-login-program
1731                            (default (file-append shadow "/bin/login")))
1732   (login-arguments         kmscon-configuration-login-arguments
1733                            (default '("-p")))
1734   (hardware-acceleration?  kmscon-configuration-hardware-acceleration?
1735                            (default #f))) ; #t causes failure
1736
1737 (define kmscon-service-type
1738   (shepherd-service-type
1739    'kmscon
1740    (lambda (config)
1741      (let ((kmscon (kmscon-configuration-kmscon config))
1742            (virtual-terminal (kmscon-configuration-virtual-terminal config))
1743            (login-program (kmscon-configuration-login-program config))
1744            (login-arguments (kmscon-configuration-login-arguments config))
1745            (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
1746
1747        (define kmscon-command
1748          #~(list
1749             #$(file-append kmscon "/bin/kmscon") "--login"
1750             "--vt" #$virtual-terminal
1751             #$@(if hardware-acceleration? '("--hwaccel") '())
1752             "--" #$login-program #$@login-arguments))
1753
1754        (shepherd-service
1755         (documentation "kmscon virtual terminal")
1756         (requirement '(user-processes udev dbus-system))
1757         (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
1758         (start #~(make-forkexec-constructor #$kmscon-command))
1759         (stop #~(make-kill-destructor)))))))
1760
1761 \f
1762 (define %base-services
1763   ;; Convenience variable holding the basic services.
1764   (list (login-service)
1765
1766         (service console-font-service-type
1767                  (map (lambda (tty)
1768                         (cons tty %default-console-font))
1769                       '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
1770
1771         (mingetty-service (mingetty-configuration
1772                            (tty "tty1")))
1773         (mingetty-service (mingetty-configuration
1774                            (tty "tty2")))
1775         (mingetty-service (mingetty-configuration
1776                            (tty "tty3")))
1777         (mingetty-service (mingetty-configuration
1778                            (tty "tty4")))
1779         (mingetty-service (mingetty-configuration
1780                            (tty "tty5")))
1781         (mingetty-service (mingetty-configuration
1782                            (tty "tty6")))
1783
1784         (service static-networking-service-type
1785                  (list (static-networking (interface "lo")
1786                                           (ip "127.0.0.1")
1787                                           (provision '(loopback)))))
1788         (syslog-service)
1789         (urandom-seed-service)
1790         (guix-service)
1791         (nscd-service)
1792
1793         ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
1794         ;; used, so enable them by default.  The FUSE and ALSA rules are
1795         ;; less critical, but handy.
1796         (udev-service #:rules (list lvm2 fuse alsa-utils crda))
1797
1798         (service special-files-service-type
1799                  `(("/bin/sh" ,(file-append (canonical-package bash)
1800                                             "/bin/sh"))))))
1801
1802 ;;; base.scm ends here