gnu/services/base.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
  10 ;;;
  11 ;;; This file is part of GNU Guix.
  12 ;;;
  13 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  14 ;;; under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 3 of the License, or (at
  16 ;;; your option) any later version.
  17 ;;;
  18 ;;; GNU Guix is distributed in the hope that it will be useful, but
  19 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 (define-module (gnu services base)
  27   #:use-module (guix store)
  28   #:use-module (gnu services)
  29   #:use-module (gnu services shepherd)
  30   #:use-module (gnu system pam)
  31   #:use-module (gnu system shadow)                ; 'user-account', etc.
  32   #:use-module (gnu system uuid)
  33   #:use-module (gnu system file-systems)          ; 'file-system', etc.
  34   #:use-module (gnu system mapped-devices)
  35   #:use-module ((gnu system linux-initrd)
  36                 #:select (file-system-packages))
  37   #:use-module (gnu packages admin)
  38   #:use-module ((gnu packages linux)
  39                 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
  40   #:use-module ((gnu packages base)
  41                 #:select (canonical-package glibc glibc-utf8-locales))
  42   #:use-module (gnu packages bash)
  43   #:use-module (gnu packages package-management)
  44   #:use-module (gnu packages linux)
  45   #:use-module (gnu packages terminals)
  46   #:use-module ((gnu build file-systems)
  47                 #:select (mount-flags->bit-mask))
  48   #:use-module (guix gexp)
  49   #:use-module (guix records)
  50   #:use-module (guix modules)
  51   #:use-module (srfi srfi-1)
  52   #:use-module (srfi srfi-26)
  53   #:use-module (ice-9 match)
  54   #:use-module (ice-9 format)
  55   #:export (fstab-service-type
  56             root-file-system-service
  57             file-system-service-type
  58             swap-service
  59             user-processes-service-type
  60             host-name-service
  61             console-keymap-service
  62             %default-console-font
  63             console-font-service-type
  64             console-font-service
  65             virtual-terminal-service-type
  66
  67             static-networking
  68
  69             static-networking?
  70             static-networking-interface
  71             static-networking-ip
  72             static-networking-netmask
  73             static-networking-gateway
  74             static-networking-requirement
  75
  76             static-networking-service
  77             static-networking-service-type
  78
  79             udev-configuration
  80             udev-configuration?
  81             udev-configuration-rules
  82             udev-service-type
  83             udev-service
  84             udev-rule
  85             file->udev-rule
  86
  87             login-configuration
  88             login-configuration?
  89             login-service-type
  90             login-service
  91
  92             agetty-configuration
  93             agetty-configuration?
  94             agetty-service
  95             agetty-service-type
  96
  97             mingetty-configuration
  98             mingetty-configuration?
  99             mingetty-service
 100             mingetty-service-type
 101
 102             %nscd-default-caches
 103             %nscd-default-configuration
 104
 105             nscd-configuration
 106             nscd-configuration?
 107
 108             nscd-cache
 109             nscd-cache?
 110
 111             nscd-service-type
 112             nscd-service
 113
 114             syslog-configuration
 115             syslog-configuration?
 116             syslog-service
 117             syslog-service-type
 118             %default-syslog.conf
 119
 120             %default-authorized-guix-keys
 121             guix-configuration
 122             guix-configuration?
 123
 124             guix-configuration-guix
 125             guix-configuration-build-group
 126             guix-configuration-build-accounts
 127             guix-configuration-authorize-key?
 128             guix-configuration-authorized-keys
 129             guix-configuration-use-substitutes?
 130             guix-configuration-substitute-urls
 131             guix-configuration-extra-options
 132             guix-configuration-log-file
 133
 134             guix-service
 135             guix-service-type
 136             guix-publish-configuration
 137             guix-publish-configuration?
 138             guix-publish-configuration-guix
 139             guix-publish-configuration-port
 140             guix-publish-configuration-host
 141             guix-publish-configuration-compression-level
 142             guix-publish-configuration-nar-path
 143             guix-publish-configuration-cache
 144             guix-publish-configuration-ttl
 145             guix-publish-service
 146             guix-publish-service-type
 147
 148             gpm-configuration
 149             gpm-configuration?
 150             gpm-service-type
 151             gpm-service
 152
 153             urandom-seed-service-type
 154             urandom-seed-service
 155
 156             rngd-configuration
 157             rngd-configuration?
 158             rngd-service-type
 159             rngd-service
 160
 161             kmscon-configuration
 162             kmscon-configuration?
 163             kmscon-service-type
 164
 165             pam-limits-service-type
 166             pam-limits-service
 167
 168             %base-services))
 169
 170 ;;; Commentary:
 171 ;;;
 172 ;;; Base system services---i.e., services that 99% of the users will want to
 173 ;;; use.
 174 ;;;
 175 ;;; Code:
 176
 177
 178 \f
 179 ;;;
 180 ;;; User processes.
 181 ;;;
 182
 183 (define %do-not-kill-file
 184   ;; Name of the file listing PIDs of processes that must survive when halting
 185   ;; the system.  Typical example is user-space file systems.
 186   "/etc/shepherd/do-not-kill")
 187
 188 (define (user-processes-shepherd-service requirements)
 189   "Return the 'user-processes' Shepherd service with dependencies on
 190 REQUIREMENTS (a list of service names).
 191
 192 This is a synchronization point used to make sure user processes and daemons
 193 get started only after crucial initial services have been started---file
 194 system mounts, etc.  This is similar to the 'sysvinit' target in systemd."
 195   (define grace-delay
 196     ;; Delay after sending SIGTERM and before sending SIGKILL.
 197     4)
 198
 199   (list (shepherd-service
 200          (documentation "When stopped, terminate all user processes.")
 201          (provision '(user-processes))
 202          (requirement requirements)
 203          (start #~(const #t))
 204          (stop #~(lambda _
 205                    (define (kill-except omit signal)
 206                      ;; Kill all the processes with SIGNAL except those listed
 207                      ;; in OMIT and the current process.
 208                      (let ((omit (cons (getpid) omit)))
 209                        (for-each (lambda (pid)
 210                                    (unless (memv pid omit)
 211                                      (false-if-exception
 212                                       (kill pid signal))))
 213                                  (processes))))
 214
 215                    (define omitted-pids
 216                      ;; List of PIDs that must not be killed.
 217                      (if (file-exists? #$%do-not-kill-file)
 218                          (map string->number
 219                               (call-with-input-file #$%do-not-kill-file
 220                                 (compose string-tokenize
 221                                          (@ (ice-9 rdelim) read-string))))
 222                          '()))
 223
 224                    (define (now)
 225                      (car (gettimeofday)))
 226
 227                    (define (sleep* n)
 228                      ;; Really sleep N seconds.
 229                      ;; Work around <http://bugs.gnu.org/19581>.
 230                      (define start (now))
 231                      (let loop ((elapsed 0))
 232                        (when (> n elapsed)
 233                          (sleep (- n elapsed))
 234                          (loop (- (now) start)))))
 235
 236                    (define lset= (@ (srfi srfi-1) lset=))
 237
 238                    (display "sending all processes the TERM signal\n")
 239
 240                    (if (null? omitted-pids)
 241                        (begin
 242                          ;; Easy: terminate all of them.
 243                          (kill -1 SIGTERM)
 244                          (sleep* #$grace-delay)
 245                          (kill -1 SIGKILL))
 246                        (begin
 247                          ;; Kill them all except OMITTED-PIDS.  XXX: We would
 248                          ;; like to (kill -1 SIGSTOP) to get a fixed list of
 249                          ;; processes, like 'killall5' does, but that seems
 250                          ;; unreliable.
 251                          (kill-except omitted-pids SIGTERM)
 252                          (sleep* #$grace-delay)
 253                          (kill-except omitted-pids SIGKILL)
 254                          (delete-file #$%do-not-kill-file)))
 255
 256                    (let wait ()
 257                      ;; Reap children, if any, so that we don't end up with
 258                      ;; zombies and enter an infinite loop.
 259                      (let reap-children ()
 260                        (define result
 261                          (false-if-exception
 262                           (waitpid WAIT_ANY (if (null? omitted-pids)
 263                                                 0
 264                                                 WNOHANG))))
 265
 266                        (when (and (pair? result)
 267                                   (not (zero? (car result))))
 268                          (reap-children)))
 269
 270                      (let ((pids (processes)))
 271                        (unless (lset= = pids (cons 1 omitted-pids))
 272                          (format #t "waiting for process termination\
 273  (processes left: ~s)~%"
 274                                  pids)
 275                          (sleep* 2)
 276                          (wait))))
 277
 278                    (display "all processes have been terminated\n")
 279                    #f))
 280          (respawn? #f))))
 281
 282 (define user-processes-service-type
 283   (service-type
 284    (name 'user-processes)
 285    (extensions (list (service-extension shepherd-root-service-type
 286                                         user-processes-shepherd-service)))
 287    (compose concatenate)
 288    (extend append)
 289
 290    ;; The value is the list of Shepherd services 'user-processes' depends on.
 291    ;; Extensions can add new services to this list.
 292    (default-value '())
 293
 294    (description "The @code{user-processes} service is responsible for
 295 terminating all the processes so that the root file system can be re-mounted
 296 read-only, just before rebooting/halting.  Processes still running after a few
 297 seconds after @code{SIGTERM} has been sent are terminated with
 298 @code{SIGKILL}.")))
 299
 300 \f
 301 ;;;
 302 ;;; File systems.
 303 ;;;
 304
 305 (define (file-system->fstab-entry file-system)
 306   "Return a @file{/etc/fstab} entry for @var{file-system}."
 307   (string-append (match (file-system-device file-system)
 308                    ((? file-system-label? label)
 309                     (string-append "LABEL="
 310                                    (file-system-label->string label)))
 311                    ((? uuid? uuid)
 312                     (string-append "UUID=" (uuid->string uuid)))
 313                    ((? string? device)
 314                     device))
 315                  "\t"
 316                  (file-system-mount-point file-system) "\t"
 317                  (file-system-type file-system) "\t"
 318                  (or (file-system-options file-system) "defaults") "\t"
 319
 320                  ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
 321                  ;; don't have anything sensible to put in there.
 322                  ))
 323
 324 (define (file-systems->fstab file-systems)
 325   "Return a @file{/etc} entry for an @file{fstab} describing
 326 @var{file-systems}."
 327   `(("fstab" ,(plain-file "fstab"
 328                           (string-append
 329                            "\
 330 # This file was generated from your GuixSD configuration.  Any changes
 331 # will be lost upon reboot or reconfiguration.\n\n"
 332                            (string-join (map file-system->fstab-entry
 333                                              file-systems)
 334                                         "\n")
 335                            "\n")))))
 336
 337 (define fstab-service-type
 338   ;; The /etc/fstab service.
 339   (service-type (name 'fstab)
 340                 (extensions
 341                  (list (service-extension etc-service-type
 342                                           file-systems->fstab)))
 343                 (compose concatenate)
 344                 (extend append)
 345                 (description
 346                  "Populate the @file{/etc/fstab} based on the given file
 347 system objects.")))
 348
 349 (define %root-file-system-shepherd-service
 350   (shepherd-service
 351    (documentation "Take care of the root file system.")
 352    (provision '(root-file-system))
 353    (start #~(const #t))
 354    (stop #~(lambda _
 355              ;; Return #f if successfully stopped.
 356              (sync)
 357
 358              (call-with-blocked-asyncs
 359               (lambda ()
 360                 (let ((null (%make-void-port "w")))
 361                   ;; Close 'shepherd.log'.
 362                   (display "closing log\n")
 363                   ((@ (shepherd comm) stop-logging))
 364
 365                   ;; Redirect the default output ports..
 366                   (set-current-output-port null)
 367                   (set-current-error-port null)
 368
 369                   ;; Close /dev/console.
 370                   (for-each close-fdes '(0 1 2))
 371
 372                   ;; At this point, there are no open files left, so the
 373                   ;; root file system can be re-mounted read-only.
 374                   (mount #f "/" #f
 375                          (logior MS_REMOUNT MS_RDONLY)
 376                          #:update-mtab? #f)
 377
 378                   #f)))))
 379    (respawn? #f)))
 380
 381 (define root-file-system-service-type
 382   (shepherd-service-type 'root-file-system
 383                          (const %root-file-system-shepherd-service)))
 384
 385 (define (root-file-system-service)
 386   "Return a service whose sole purpose is to re-mount read-only the root file
 387 system upon shutdown (aka. cleanly \"umounting\" root.)
 388
 389 This service must be the root of the service dependency graph so that its
 390 'stop' action is invoked when shepherd is the only process left."
 391   (service root-file-system-service-type #f))
 392
 393 (define (file-system->shepherd-service-name file-system)
 394   "Return the symbol that denotes the service mounting and unmounting
 395 FILE-SYSTEM."
 396   (symbol-append 'file-system-
 397                  (string->symbol (file-system-mount-point file-system))))
 398
 399 (define (mapped-device->shepherd-service-name md)
 400   "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
 401   (symbol-append 'device-mapping-
 402                  (string->symbol (mapped-device-target md))))
 403
 404 (define dependency->shepherd-service-name
 405   (match-lambda
 406     ((? mapped-device? md)
 407      (mapped-device->shepherd-service-name md))
 408     ((? file-system? fs)
 409      (file-system->shepherd-service-name fs))))
 410
 411 (define (file-system-shepherd-service file-system)
 412   "Return the shepherd service for @var{file-system}, or @code{#f} if
 413 @var{file-system} is not auto-mounted upon boot."
 414   (let ((target  (file-system-mount-point file-system))
 415         (create? (file-system-create-mount-point? file-system))
 416         (dependencies (file-system-dependencies file-system))
 417         (packages (file-system-packages (list file-system))))
 418     (and (file-system-mount? file-system)
 419          (with-imported-modules (source-module-closure
 420                                  '((gnu build file-systems)))
 421            (shepherd-service
 422             (provision (list (file-system->shepherd-service-name file-system)))
 423             (requirement `(root-file-system udev
 424                            ,@(map dependency->shepherd-service-name dependencies)))
 425             (documentation "Check, mount, and unmount the given file system.")
 426             (start #~(lambda args
 427                        #$(if create?
 428                              #~(mkdir-p #$target)
 429                              #t)
 430
 431                        (let (($PATH (getenv "PATH")))
 432                          ;; Make sure fsck.ext2 & co. can be found.
 433                          (dynamic-wind
 434                            (lambda ()
 435                              ;; Don’t display the PATH settings.
 436                              (with-output-to-port (%make-void-port "w")
 437                                (lambda ()
 438                                  (set-path-environment-variable "PATH"
 439                                                                 '("bin" "sbin")
 440                                                                 '#$packages))))
 441                            (lambda ()
 442                              (mount-file-system
 443                               (spec->file-system
 444                                '#$(file-system->spec file-system))
 445                               #:root "/"))
 446                            (lambda ()
 447                              (setenv "PATH" $PATH)))
 448                          #t)))
 449             (stop #~(lambda args
 450                       ;; Normally there are no processes left at this point, so
 451                       ;; TARGET can be safely unmounted.
 452
 453                       ;; Make sure PID 1 doesn't keep TARGET busy.
 454                       (chdir "/")
 455
 456                       (umount #$target)
 457                       #f))
 458
 459             ;; We need additional modules.
 460             (modules `(((gnu build file-systems)
 461                         #:select (mount-file-system))
 462                        (gnu system file-systems)
 463                        ,@%default-modules)))))))
 464
 465 (define (file-system-shepherd-services file-systems)
 466   "Return the list of Shepherd services for FILE-SYSTEMS."
 467   (let* ((file-systems (filter file-system-mount? file-systems)))
 468     (define sink
 469       (shepherd-service
 470        (provision '(file-systems))
 471        (requirement (cons* 'root-file-system 'user-file-systems
 472                            (map file-system->shepherd-service-name
 473                                 file-systems)))
 474        (documentation "Target for all the initially-mounted file systems")
 475        (start #~(const #t))
 476        (stop #~(const #f))))
 477
 478     (define known-mount-points
 479       (map file-system-mount-point file-systems))
 480
 481     (define user-unmount
 482       (shepherd-service
 483        (documentation "Unmount manually-mounted file systems.")
 484        (provision '(user-file-systems))
 485        (start #~(const #t))
 486        (stop #~(lambda args
 487                  (define (known? mount-point)
 488                    (member mount-point
 489                            (cons* "/proc" "/sys" '#$known-mount-points)))
 490
 491                  ;; Make sure we don't keep the user's mount points busy.
 492                  (chdir "/")
 493
 494                  (for-each (lambda (mount-point)
 495                              (format #t "unmounting '~a'...~%" mount-point)
 496                              (catch 'system-error
 497                                (lambda ()
 498                                  (umount mount-point))
 499                                (lambda args
 500                                  (let ((errno (system-error-errno args)))
 501                                    (format #t "failed to unmount '~a': ~a~%"
 502                                            mount-point (strerror errno))))))
 503                            (filter (negate known?) (mount-points)))
 504                  #f))))
 505
 506     (cons* sink user-unmount
 507            (map file-system-shepherd-service file-systems))))
 508
 509 (define file-system-service-type
 510   (service-type (name 'file-systems)
 511                 (extensions
 512                  (list (service-extension shepherd-root-service-type
 513                                           file-system-shepherd-services)
 514                        (service-extension fstab-service-type
 515                                           identity)
 516
 517                        ;; Have 'user-processes' depend on 'file-systems'.
 518                        (service-extension user-processes-service-type
 519                                           (const '(file-systems)))))
 520                 (compose concatenate)
 521                 (extend append)
 522                 (description
 523                  "Provide Shepherd services to mount and unmount the given
 524 file systems, as well as corresponding @file{/etc/fstab} entries.")))
 525
 526
 527 \f
 528 ;;;
 529 ;;; Preserve entropy to seed /dev/urandom on boot.
 530 ;;;
 531
 532 (define %random-seed-file
 533   "/var/lib/random-seed")
 534
 535 (define (urandom-seed-shepherd-service _)
 536   "Return a shepherd service for the /dev/urandom seed."
 537   (list (shepherd-service
 538          (documentation "Preserve entropy across reboots for /dev/urandom.")
 539          (provision '(urandom-seed))
 540
 541          ;; Depend on udev so that /dev/hwrng is available.
 542          (requirement '(file-systems udev))
 543
 544          (start #~(lambda _
 545                     ;; On boot, write random seed into /dev/urandom.
 546                     (when (file-exists? #$%random-seed-file)
 547                       (call-with-input-file #$%random-seed-file
 548                         (lambda (seed)
 549                           (call-with-output-file "/dev/urandom"
 550                             (lambda (urandom)
 551                               (dump-port seed urandom))))))
 552
 553                     ;; Try writing from /dev/hwrng into /dev/urandom.
 554                     ;; It seems that the file /dev/hwrng always exists, even
 555                     ;; when there is no hardware random number generator
 556                     ;; available. So, we handle a failed read or any other error
 557                     ;; reported by the operating system.
 558                     (let ((buf (catch 'system-error
 559                                  (lambda ()
 560                                    (call-with-input-file "/dev/hwrng"
 561                                      (lambda (hwrng)
 562                                        (get-bytevector-n hwrng 512))))
 563                                  ;; Silence is golden...
 564                                  (const #f))))
 565                       (when buf
 566                         (call-with-output-file "/dev/urandom"
 567                           (lambda (urandom)
 568                             (put-bytevector urandom buf)))))
 569
 570                     ;; Immediately refresh the seed in case the system doesn't
 571                     ;; shut down cleanly.
 572                     (call-with-input-file "/dev/urandom"
 573                       (lambda (urandom)
 574                         (let ((previous-umask (umask #o077))
 575                               (buf (make-bytevector 512)))
 576                           (mkdir-p (dirname #$%random-seed-file))
 577                           (get-bytevector-n! urandom buf 0 512)
 578                           (call-with-output-file #$%random-seed-file
 579                             (lambda (seed)
 580                               (put-bytevector seed buf)))
 581                           (umask previous-umask))))
 582                     #t))
 583          (stop #~(lambda _
 584                    ;; During shutdown, write from /dev/urandom into random seed.
 585                    (let ((buf (make-bytevector 512)))
 586                      (call-with-input-file "/dev/urandom"
 587                        (lambda (urandom)
 588                          (let ((previous-umask (umask #o077)))
 589                            (get-bytevector-n! urandom buf 0 512)
 590                            (mkdir-p (dirname #$%random-seed-file))
 591                            (call-with-output-file #$%random-seed-file
 592                              (lambda (seed)
 593                                (put-bytevector seed buf)))
 594                            (umask previous-umask))
 595                          #t)))))
 596          (modules `((rnrs bytevectors)
 597                     (rnrs io ports)
 598                     ,@%default-modules)))))
 599
 600 (define urandom-seed-service-type
 601   (service-type (name 'urandom-seed)
 602                 (extensions
 603                  (list (service-extension shepherd-root-service-type
 604                                           urandom-seed-shepherd-service)
 605
 606                        ;; Have 'user-processes' depend on 'urandom-seed'.
 607                        ;; This ensures that user processes and daemons don't
 608                        ;; start until we have seeded the PRNG.
 609                        (service-extension user-processes-service-type
 610                                           (const '(urandom-seed)))))
 611                 (default-value #f)
 612                 (description
 613                  "Seed the @file{/dev/urandom} pseudo-random number
 614 generator (RNG) with the value recorded when the system was last shut
 615 down.")))
 616
 617 (define (urandom-seed-service)                    ;deprecated
 618   (service urandom-seed-service-type #f))
 619
 620
 621 ;;;
 622 ;;; Add hardware random number generator to entropy pool.
 623 ;;;
 624
 625 (define-record-type* <rngd-configuration>
 626   rngd-configuration make-rngd-configuration
 627   rngd-configuration?
 628   (rng-tools rngd-configuration-rng-tools)        ;package
 629   (device    rngd-configuration-device))          ;string
 630
 631 (define rngd-service-type
 632   (shepherd-service-type
 633     'rngd
 634     (lambda (config)
 635       (define rng-tools (rngd-configuration-rng-tools config))
 636       (define device (rngd-configuration-device config))
 637
 638       (define rngd-command
 639         (list (file-append rng-tools "/sbin/rngd")
 640               "-f" "-r" device))
 641
 642       (shepherd-service
 643         (documentation "Add TRNG to entropy pool.")
 644         (requirement '(udev))
 645         (provision '(trng))
 646         (start #~(make-forkexec-constructor #$@rngd-command))
 647         (stop #~(make-kill-destructor))))))
 648
 649 (define* (rngd-service #:key
 650                        (rng-tools rng-tools)
 651                        (device "/dev/hwrng"))
 652   "Return a service that runs the @command{rngd} program from @var{rng-tools}
 653 to add @var{device} to the kernel's entropy pool.  The service will fail if
 654 @var{device} does not exist."
 655   (service rngd-service-type
 656            (rngd-configuration
 657             (rng-tools rng-tools)
 658             (device device))))
 659
 660 \f
 661 ;;;
 662 ;;; Console & co.
 663 ;;;
 664
 665 (define host-name-service-type
 666   (shepherd-service-type
 667    'host-name
 668    (lambda (name)
 669      (shepherd-service
 670       (documentation "Initialize the machine's host name.")
 671       (provision '(host-name))
 672       (start #~(lambda _
 673                  (sethostname #$name)))
 674       (respawn? #f)))))
 675
 676 (define (host-name-service name)
 677   "Return a service that sets the host name to @var{name}."
 678   (service host-name-service-type name))
 679
 680 (define virtual-terminal-service-type
 681   ;; Ensure that virtual terminals run in UTF-8 mode.  This is the case by
 682   ;; default with recent Linux kernels, but this service allows us to ensure
 683   ;; this.  This service must start before any 'term-' service so that newly
 684   ;; created terminals inherit this property.  See
 685   ;; <https://bugs.gnu.org/30505> for a discussion.
 686   (shepherd-service-type
 687    'virtual-terminal
 688    (lambda (utf8?)
 689      (let ((knob "/sys/module/vt/parameters/default_utf8"))
 690        (shepherd-service
 691         (documentation "Set virtual terminals in UTF-8 module.")
 692         (provision '(virtual-terminal))
 693         (requirement '(root-file-system))
 694         (start #~(lambda _
 695                    ;; In containers /sys is read-only so don't insist on
 696                    ;; writing to this file.
 697                    (unless (= 1 (call-with-input-file #$knob read))
 698                      (call-with-output-file #$knob
 699                        (lambda (port)
 700                          (display 1 port))))
 701                    #t))
 702         (stop #~(const #f)))))
 703    #t))                                           ;default to UTF-8
 704
 705 (define console-keymap-service-type
 706   (shepherd-service-type
 707    'console-keymap
 708    (lambda (files)
 709      (shepherd-service
 710       (documentation (string-append "Load console keymap (loadkeys)."))
 711       (provision '(console-keymap))
 712       (start #~(lambda _
 713                  (zero? (system* #$(file-append kbd "/bin/loadkeys")
 714                                  #$@files))))
 715       (respawn? #f)))))
 716
 717 (define (console-keymap-service . files)
 718   "Return a service to load console keymaps from @var{files}."
 719   (service console-keymap-service-type files))
 720
 721 (define %default-console-font
 722   ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
 723   ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
 724   ;; codepoints notably found in the UTF-8 manual.
 725   "LatGrkCyr-8x16")
 726
 727 (define (console-font-shepherd-services tty+font)
 728   "Return a list of Shepherd services for each pair in TTY+FONT."
 729   (map (match-lambda
 730          ((tty . font)
 731           (let ((device (string-append "/dev/" tty)))
 732             (shepherd-service
 733              (documentation "Load a Unicode console font.")
 734              (provision (list (symbol-append 'console-font-
 735                                              (string->symbol tty))))
 736
 737              ;; Start after mingetty has been started on TTY, otherwise the settings
 738              ;; are ignored.
 739              (requirement (list (symbol-append 'term-
 740                                                (string->symbol tty))))
 741
 742              (start #~(lambda _
 743                         ;; It could be that mingetty is not fully ready yet,
 744                         ;; which we check by calling 'ttyname'.
 745                         (let loop ((i 10))
 746                           (unless (or (zero? i)
 747                                       (call-with-input-file #$device
 748                                         (lambda (port)
 749                                           (false-if-exception (ttyname port)))))
 750                             (usleep 500)
 751                             (loop (- i 1))))
 752
 753                         ;; Assume the VT is already in UTF-8 mode, thanks to
 754                         ;; the 'virtual-terminal' service.
 755                         ;;
 756                         ;; 'setfont' returns EX_OSERR (71) when an
 757                         ;; KDFONTOP ioctl fails, for example.  Like
 758                         ;; systemd's vconsole support, let's not treat
 759                         ;; this as an error.
 760                         (case (status:exit-val
 761                                (system* #$(file-append kbd "/bin/setfont")
 762                                         "-C" #$device #$font))
 763                           ((0 71) #t)
 764                           (else #f))))
 765              (stop #~(const #t))
 766              (respawn? #f)))))
 767        tty+font))
 768
 769 (define console-font-service-type
 770   (service-type (name 'console-fonts)
 771                 (extensions
 772                  (list (service-extension shepherd-root-service-type
 773                                           console-font-shepherd-services)))
 774                 (compose concatenate)
 775                 (extend append)
 776                 (description
 777                  "Install the given fonts on the specified ttys (fonts are per
 778 virtual console on GNU/Linux).  The value of this service is a list of
 779 tty/font pairs like:
 780
 781 @example
 782 '((\"tty1\" . \"LatGrkCyr-8x16\"))
 783 @end example\n")))
 784
 785 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
 786   "This procedure is deprecated in favor of @code{console-font-service-type}.
 787
 788 Return a service that sets up Unicode support in @var{tty} and loads
 789 @var{font} for that tty (fonts are per virtual console in Linux.)"
 790   (simple-service (symbol-append 'console-font- (string->symbol tty))
 791                   console-font-service-type `((,tty . ,font))))
 792
 793 (define %default-motd
 794   (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
 795
 796 (define-record-type* <login-configuration>
 797   login-configuration make-login-configuration
 798   login-configuration?
 799   (motd                   login-configuration-motd     ;file-like
 800                           (default %default-motd))
 801   ;; Allow empty passwords by default so that first-time users can log in when
 802   ;; the 'root' account has just been created.
 803   (allow-empty-passwords? login-configuration-allow-empty-passwords?
 804                           (default #t)))               ;Boolean
 805
 806 (define (login-pam-service config)
 807   "Return the list of PAM service needed for CONF."
 808   ;; Let 'login' be known to PAM.
 809   (list (unix-pam-service "login"
 810                           #:allow-empty-passwords?
 811                           (login-configuration-allow-empty-passwords? config)
 812                           #:motd
 813                           (login-configuration-motd config))))
 814
 815 (define login-service-type
 816   (service-type (name 'login)
 817                 (extensions (list (service-extension pam-root-service-type
 818                                                      login-pam-service)))
 819                 (description
 820                  "Provide a console log-in service as specified by its
 821 configuration value, a @code{login-configuration} object.")))
 822
 823 (define* (login-service #:optional (config (login-configuration)))
 824   "Return a service configure login according to @var{config}, which specifies
 825 the message of the day, among other things."
 826   (service login-service-type config))
 827
 828 (define-record-type* <agetty-configuration>
 829   agetty-configuration make-agetty-configuration
 830   agetty-configuration?
 831   (agetty           agetty-configuration-agetty   ;<package>
 832                     (default util-linux))
 833   (tty              agetty-configuration-tty)     ;string | #f
 834   (term             agetty-term                   ;string | #f
 835                     (default #f))
 836   (baud-rate        agetty-baud-rate              ;string | #f
 837                     (default #f))
 838   (auto-login       agetty-auto-login             ;list of strings | #f
 839                     (default #f))
 840   (login-program    agetty-login-program          ;gexp
 841                     (default (file-append shadow "/bin/login")))
 842   (login-pause?     agetty-login-pause?           ;Boolean
 843                     (default #f))
 844   (eight-bits?      agetty-eight-bits?            ;Boolean
 845                     (default #f))
 846   (no-reset?        agetty-no-reset?              ;Boolean
 847                     (default #f))
 848   (remote?          agetty-remote?                ;Boolean
 849                     (default #f))
 850   (flow-control?    agetty-flow-control?          ;Boolean
 851                     (default #f))
 852   (host             agetty-host                   ;string | #f
 853                     (default #f))
 854   (no-issue?        agetty-no-issue?              ;Boolean
 855                     (default #f))
 856   (init-string      agetty-init-string            ;string | #f
 857                     (default #f))
 858   (no-clear?        agetty-no-clear?              ;Boolean
 859                     (default #f))
 860   (local-line       agetty-local-line             ;always | never | auto
 861                     (default #f))
 862   (extract-baud?    agetty-extract-baud?          ;Boolean
 863                     (default #f))
 864   (skip-login?      agetty-skip-login?            ;Boolean
 865                     (default #f))
 866   (no-newline?      agetty-no-newline?            ;Boolean
 867                     (default #f))
 868   (login-options    agetty-login-options          ;string | #f
 869                     (default #f))
 870   (chroot           agetty-chroot                 ;string | #f
 871                     (default #f))
 872   (hangup?          agetty-hangup?                ;Boolean
 873                     (default #f))
 874   (keep-baud?       agetty-keep-baud?             ;Boolean
 875                     (default #f))
 876   (timeout          agetty-timeout                ;integer | #f
 877                     (default #f))
 878   (detect-case?     agetty-detect-case?           ;Boolean
 879                     (default #f))
 880   (wait-cr?         agetty-wait-cr?               ;Boolean
 881                     (default #f))
 882   (no-hints?        agetty-no-hints?              ;Boolean
 883                     (default #f))
 884   (no-hostname?     agetty-no hostname?           ;Boolean
 885                     (default #f))
 886   (long-hostname?   agetty-long-hostname?         ;Boolean
 887                     (default #f))
 888   (erase-characters agetty-erase-characters       ;string | #f
 889                     (default #f))
 890   (kill-characters  agetty-kill-characters        ;string | #f
 891                     (default #f))
 892   (chdir            agetty-chdir                  ;string | #f
 893                     (default #f))
 894   (delay            agetty-delay                  ;integer | #f
 895                     (default #f))
 896   (nice             agetty-nice                   ;integer | #f
 897                     (default #f))
 898   ;; "Escape hatch" for passing arbitrary command-line arguments.
 899   (extra-options    agetty-extra-options          ;list of strings
 900                     (default '()))
 901 ;;; XXX Unimplemented for now!
 902 ;;; (issue-file     agetty-issue-file             ;file-like
 903 ;;;                 (default #f))
 904   )
 905
 906 (define (default-serial-port)
 907   "Return a gexp that determines a reasonable default serial port
 908 to use as the tty.  This is primarily useful for headless systems."
 909   #~(begin
 910       ;; console=device,options
 911       ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
 912       ;; options: BBBBPNF. P n|o|e, N number of bits,
 913       ;; F flow control (r RTS)
 914       (let* ((not-comma (char-set-complement (char-set #\,)))
 915              (command (linux-command-line))
 916              (agetty-specs (find-long-options "agetty.tty" command))
 917              (console-specs (filter (lambda (spec)
 918                                      (and (string-prefix? "tty" spec)
 919                                           (not (or
 920                                                 (string-prefix? "tty0" spec)
 921                                                 (string-prefix? "tty1" spec)
 922                                                 (string-prefix? "tty2" spec)
 923                                                 (string-prefix? "tty3" spec)
 924                                                 (string-prefix? "tty4" spec)
 925                                                 (string-prefix? "tty5" spec)
 926                                                 (string-prefix? "tty6" spec)
 927                                                 (string-prefix? "tty7" spec)
 928                                                 (string-prefix? "tty8" spec)
 929                                                 (string-prefix? "tty9" spec)))))
 930                                     (find-long-options "console" command)))
 931              (specs (append agetty-specs console-specs)))
 932         (match specs
 933          (() #f)
 934          ((spec _ ...)
 935           ;; Extract device name from first spec.
 936           (match (string-tokenize spec not-comma)
 937            ((device-name _ ...)
 938             device-name)))))))
 939
 940 (define agetty-shepherd-service
 941   (match-lambda
 942     (($ <agetty-configuration> agetty tty term baud-rate auto-login
 943         login-program login-pause? eight-bits? no-reset? remote? flow-control?
 944         host no-issue? init-string no-clear? local-line extract-baud?
 945         skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
 946         detect-case? wait-cr? no-hints? no-hostname? long-hostname?
 947         erase-characters kill-characters chdir delay nice extra-options)
 948      (list
 949        (shepherd-service
 950          (modules '((ice-9 match) (gnu build linux-boot)))
 951          (documentation "Run agetty on a tty.")
 952          (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
 953
 954          ;; Since the login prompt shows the host name, wait for the 'host-name'
 955          ;; service to be done.  Also wait for udev essentially so that the tty
 956          ;; text is not lost in the middle of kernel messages (see also
 957          ;; mingetty-shepherd-service).
 958          (requirement '(user-processes host-name udev))
 959
 960          (start #~(lambda args
 961                     (let ((defaulted-tty #$(or tty (default-serial-port))))
 962                       (apply
 963                        (if defaulted-tty
 964                            (make-forkexec-constructor
 965                             (list #$(file-append util-linux "/sbin/agetty")
 966                                   #$@extra-options
 967                                   #$@(if eight-bits?
 968                                          #~("--8bits")
 969                                          #~())
 970                                   #$@(if no-reset?
 971                                          #~("--noreset")
 972                                          #~())
 973                                   #$@(if remote?
 974                                          #~("--remote")
 975                                          #~())
 976                                   #$@(if flow-control?
 977                                          #~("--flow-control")
 978                                          #~())
 979                                   #$@(if host
 980                                          #~("--host" #$host)
 981                                          #~())
 982                                   #$@(if no-issue?
 983                                          #~("--noissue")
 984                                          #~())
 985                                   #$@(if init-string
 986                                          #~("--init-string" #$init-string)
 987                                          #~())
 988                                   #$@(if no-clear?
 989                                          #~("--noclear")
 990                                          #~())
 991 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
 992 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
 993 ;;; option is selected, agetty never presents the login prompt, and the
 994 ;;; term-ttyS0 service respawns every few seconds.
 995                                   #$@(if local-line
 996                                          #~(#$(match local-line
 997                                                      ('auto "--local-line=auto")
 998                                                      ('always "--local-line=always")
 999                                                      ('never "-local-line=never")))
1000                                          #~())
1001                                   #$@(if tty
1002                                          #~()
1003                                          #~("--keep-baud"))
1004                                   #$@(if extract-baud?
1005                                          #~("--extract-baud")
1006                                          #~())
1007                                   #$@(if skip-login?
1008                                          #~("--skip-login")
1009                                          #~())
1010                                   #$@(if no-newline?
1011                                          #~("--nonewline")
1012                                          #~())
1013                                   #$@(if login-options
1014                                          #~("--login-options" #$login-options)
1015                                          #~())
1016                                   #$@(if chroot
1017                                          #~("--chroot" #$chroot)
1018                                          #~())
1019                                   #$@(if hangup?
1020                                          #~("--hangup")
1021                                          #~())
1022                                   #$@(if keep-baud?
1023                                          #~("--keep-baud")
1024                                          #~())
1025                                   #$@(if timeout
1026                                          #~("--timeout" #$(number->string timeout))
1027                                          #~())
1028                                   #$@(if detect-case?
1029                                          #~("--detect-case")
1030                                          #~())
1031                                   #$@(if wait-cr?
1032                                          #~("--wait-cr")
1033                                          #~())
1034                                   #$@(if no-hints?
1035                                          #~("--nohints?")
1036                                          #~())
1037                                   #$@(if no-hostname?
1038                                          #~("--nohostname")
1039                                          #~())
1040                                   #$@(if long-hostname?
1041                                          #~("--long-hostname")
1042                                          #~())
1043                                   #$@(if erase-characters
1044                                          #~("--erase-chars" #$erase-characters)
1045                                          #~())
1046                                   #$@(if kill-characters
1047                                          #~("--kill-chars" #$kill-characters)
1048                                          #~())
1049                                   #$@(if chdir
1050                                          #~("--chdir" #$chdir)
1051                                          #~())
1052                                   #$@(if delay
1053                                          #~("--delay" #$(number->string delay))
1054                                          #~())
1055                                   #$@(if nice
1056                                          #~("--nice" #$(number->string nice))
1057                                          #~())
1058                                   #$@(if auto-login
1059                                          (list "--autologin" auto-login)
1060                                          '())
1061                                   #$@(if login-program
1062                                          #~("--login-program" #$login-program)
1063                                          #~())
1064                                   #$@(if login-pause?
1065                                          #~("--login-pause")
1066                                          #~())
1067                                   defaulted-tty
1068                                   #$@(if baud-rate
1069                                          #~(#$baud-rate)
1070                                          #~())
1071                                   #$@(if term
1072                                          #~(#$term)
1073                                          #~())))
1074                            (const #f)) ; never start.
1075                        args))))
1076          (stop #~(make-kill-destructor)))))))
1077
1078 (define agetty-service-type
1079   (service-type (name 'agetty)
1080                 (extensions (list (service-extension shepherd-root-service-type
1081                                                      agetty-shepherd-service)))
1082                 (description
1083                  "Provide console login using the @command{agetty}
1084 program.")))
1085
1086 (define* (agetty-service config)
1087   "Return a service to run agetty according to @var{config}, which specifies
1088 the tty to run, among other things."
1089   (service agetty-service-type config))
1090
1091 (define-record-type* <mingetty-configuration>
1092   mingetty-configuration make-mingetty-configuration
1093   mingetty-configuration?
1094   (mingetty       mingetty-configuration-mingetty ;<package>
1095                   (default mingetty))
1096   (tty            mingetty-configuration-tty)     ;string
1097   (auto-login     mingetty-auto-login             ;string | #f
1098                   (default #f))
1099   (login-program  mingetty-login-program          ;gexp
1100                   (default #f))
1101   (login-pause?   mingetty-login-pause?           ;Boolean
1102                   (default #f)))
1103
1104 (define mingetty-shepherd-service
1105   (match-lambda
1106     (($ <mingetty-configuration> mingetty tty auto-login login-program
1107                                  login-pause?)
1108      (list
1109       (shepherd-service
1110        (documentation "Run mingetty on an tty.")
1111        (provision (list (symbol-append 'term- (string->symbol tty))))
1112
1113        ;; Since the login prompt shows the host name, wait for the 'host-name'
1114        ;; service to be done.  Also wait for udev essentially so that the tty
1115        ;; text is not lost in the middle of kernel messages (XXX).
1116        (requirement '(user-processes host-name udev virtual-terminal))
1117
1118        (start  #~(make-forkexec-constructor
1119                   (list #$(file-append mingetty "/sbin/mingetty")
1120                         "--noclear"
1121
1122                         ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1123                         ;; errors down the path where various ioctls get
1124                         ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1125                         ;; in Linux.
1126                         "--nohangup" #$tty
1127
1128                         #$@(if auto-login
1129                                #~("--autologin" #$auto-login)
1130                                #~())
1131                         #$@(if login-program
1132                                #~("--loginprog" #$login-program)
1133                                #~())
1134                         #$@(if login-pause?
1135                                #~("--loginpause")
1136                                #~()))))
1137        (stop   #~(make-kill-destructor)))))))
1138
1139 (define mingetty-service-type
1140   (service-type (name 'mingetty)
1141                 (extensions (list (service-extension shepherd-root-service-type
1142                                                      mingetty-shepherd-service)))
1143                 (description
1144                  "Provide console login using the @command{mingetty}
1145 program.")))
1146
1147 (define* (mingetty-service config)
1148   "Return a service to run mingetty according to @var{config}, which specifies
1149 the tty to run, among other things."
1150   (service mingetty-service-type config))
1151
1152 (define-record-type* <nscd-configuration> nscd-configuration
1153   make-nscd-configuration
1154   nscd-configuration?
1155   (log-file    nscd-configuration-log-file        ;string
1156                (default "/var/log/nscd.log"))
1157   (debug-level nscd-debug-level                   ;integer
1158                (default 0))
1159   ;; TODO: See nscd.conf in glibc for other options to add.
1160   (caches     nscd-configuration-caches           ;list of <nscd-cache>
1161               (default %nscd-default-caches))
1162   (name-services nscd-configuration-name-services ;list of <packages>
1163                  (default '()))
1164   (glibc      nscd-configuration-glibc            ;<package>
1165               (default (canonical-package glibc))))
1166
1167 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1168   nscd-cache?
1169   (database              nscd-cache-database)              ;symbol
1170   (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1171   (negative-time-to-live nscd-cache-negative-time-to-live
1172                          (default 20))             ;integer
1173   (suggested-size        nscd-cache-suggested-size ;integer ("default module
1174                                                    ;of hash table")
1175                          (default 211))
1176   (check-files?          nscd-cache-check-files?  ;Boolean
1177                          (default #t))
1178   (persistent?           nscd-cache-persistent?   ;Boolean
1179                          (default #t))
1180   (shared?               nscd-cache-shared?       ;Boolean
1181                          (default #t))
1182   (max-database-size     nscd-cache-max-database-size ;integer
1183                          (default (* 32 (expt 2 20))))
1184   (auto-propagate?       nscd-cache-auto-propagate? ;Boolean
1185                          (default #t)))
1186
1187 (define %nscd-default-caches
1188   ;; Caches that we want to enable by default.  Note that when providing an
1189   ;; empty nscd.conf, all caches are disabled.
1190   (list (nscd-cache (database 'hosts)
1191
1192                     ;; Aggressively cache the host name cache to improve
1193                     ;; privacy and resilience.
1194                     (positive-time-to-live (* 3600 12))
1195                     (negative-time-to-live 20)
1196                     (persistent? #t))
1197
1198         (nscd-cache (database 'services)
1199
1200                     ;; Services are unlikely to change, so we can be even more
1201                     ;; aggressive.
1202                     (positive-time-to-live (* 3600 24))
1203                     (negative-time-to-live 3600)
1204                     (check-files? #t)             ;check /etc/services changes
1205                     (persistent? #t))))
1206
1207 (define %nscd-default-configuration
1208   ;; Default nscd configuration.
1209   (nscd-configuration))
1210
1211 (define (nscd.conf-file config)
1212   "Return the @file{nscd.conf} configuration file for @var{config}, an
1213 @code{<nscd-configuration>} object."
1214   (define cache->config
1215     (match-lambda
1216       (($ <nscd-cache> (= symbol->string database)
1217                        positive-ttl negative-ttl size check-files?
1218                        persistent? shared? max-size propagate?)
1219        (string-append "\nenable-cache\t" database "\tyes\n"
1220
1221                       "positive-time-to-live\t" database "\t"
1222                       (number->string positive-ttl) "\n"
1223                       "negative-time-to-live\t" database "\t"
1224                       (number->string negative-ttl) "\n"
1225                       "suggested-size\t" database "\t"
1226                       (number->string size) "\n"
1227                       "check-files\t" database "\t"
1228                       (if check-files? "yes\n" "no\n")
1229                       "persistent\t" database "\t"
1230                       (if persistent? "yes\n" "no\n")
1231                       "shared\t" database "\t"
1232                       (if shared? "yes\n" "no\n")
1233                       "max-db-size\t" database "\t"
1234                       (number->string max-size) "\n"
1235                       "auto-propagate\t" database "\t"
1236                       (if propagate? "yes\n" "no\n")))))
1237
1238   (match config
1239     (($ <nscd-configuration> log-file debug-level caches)
1240      (plain-file "nscd.conf"
1241                  (string-append "\
1242 # Configuration of libc's name service cache daemon (nscd).\n\n"
1243                                 (if log-file
1244                                     (string-append "logfile\t" log-file)
1245                                     "")
1246                                 "\n"
1247                                 (if debug-level
1248                                     (string-append "debug-level\t"
1249                                                    (number->string debug-level))
1250                                     "")
1251                                 "\n"
1252                                 (string-concatenate
1253                                  (map cache->config caches)))))))
1254
1255 (define (nscd-action-procedure nscd config option)
1256   ;; XXX: This is duplicated from mcron; factorize.
1257   #~(lambda (_ . args)
1258       ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1259       ;; 'current-output-port', which at this stage is bound to the client
1260       ;; connection.
1261       (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1262                          "-f" #$config #$option args)))
1263         (let loop ()
1264           (match (read-line pipe 'concat)
1265             ((? eof-object?)
1266              (catch 'system-error
1267                (lambda ()
1268                  (zero? (close-pipe pipe)))
1269                (lambda args
1270                  ;; There's a race with the SIGCHLD handler, which could
1271                  ;; call 'waitpid' before 'close-pipe' above does.  If we
1272                  ;; get ECHILD, that means we lost the race, but that's
1273                  ;; fine.
1274                  (or (= ECHILD (system-error-errno args))
1275                      (apply throw args)))))
1276             (line
1277              (display line)
1278              (loop)))))))
1279
1280 (define (nscd-actions nscd config)
1281   "Return Shepherd actions for NSCD."
1282   ;; Make this functionality available as actions because that's a simple way
1283   ;; to run the right 'nscd' binary with the right config file.
1284   (list (shepherd-action
1285          (name 'statistics)
1286          (documentation "Display statistics about nscd usage.")
1287          (procedure (nscd-action-procedure nscd config "--statistics")))
1288         (shepherd-action
1289          (name 'invalidate)
1290          (documentation
1291           "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1292          (procedure (nscd-action-procedure nscd config "--invalidate")))))
1293
1294 (define (nscd-shepherd-service config)
1295   "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1296   (let ((nscd          (file-append (nscd-configuration-glibc config)
1297                                     "/sbin/nscd"))
1298         (nscd.conf     (nscd.conf-file config))
1299         (name-services (nscd-configuration-name-services config)))
1300     (list (shepherd-service
1301            (documentation "Run libc's name service cache daemon (nscd).")
1302            (provision '(nscd))
1303            (requirement '(user-processes))
1304            (start #~(make-forkexec-constructor
1305                      (list #$nscd "-f" #$nscd.conf "--foreground")
1306
1307                      ;; Wait for the PID file.  However, the PID file is
1308                      ;; written before nscd is actually listening on its
1309                      ;; socket (XXX).
1310                      #:pid-file "/var/run/nscd/nscd.pid"
1311
1312                      #:environment-variables
1313                      (list (string-append "LD_LIBRARY_PATH="
1314                                           (string-join
1315                                            (map (lambda (dir)
1316                                                   (string-append dir "/lib"))
1317                                                 (list #$@name-services))
1318                                            ":")))))
1319            (stop #~(make-kill-destructor))
1320            (modules `((ice-9 popen)               ;for the actions
1321                       (ice-9 rdelim)
1322                       (ice-9 match)
1323                       ,@%default-modules))
1324            (actions (nscd-actions nscd nscd.conf))))))
1325
1326 (define nscd-activation
1327   ;; Actions to take before starting nscd.
1328   #~(begin
1329       (use-modules (guix build utils))
1330       (mkdir-p "/var/run/nscd")
1331       (mkdir-p "/var/db/nscd")                    ;for the persistent cache
1332
1333       ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1334       ;; that file exists when it is started.  Thus create it here.  Note: on
1335       ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1336       ;; is a symlink, hence 'lstat'.
1337       (unless (false-if-exception (lstat "/etc/resolv.conf"))
1338         (call-with-output-file "/etc/resolv.conf"
1339           (lambda (port)
1340             (display "# This is a placeholder.\n" port))))))
1341
1342 (define nscd-service-type
1343   (service-type (name 'nscd)
1344                 (extensions
1345                  (list (service-extension activation-service-type
1346                                           (const nscd-activation))
1347                        (service-extension shepherd-root-service-type
1348                                           nscd-shepherd-service)))
1349
1350                 ;; This can be extended by providing additional name services
1351                 ;; such as nss-mdns.
1352                 (compose concatenate)
1353                 (extend (lambda (config name-services)
1354                           (nscd-configuration
1355                            (inherit config)
1356                            (name-services (append
1357                                            (nscd-configuration-name-services config)
1358                                            name-services)))))
1359                 (description
1360                  "Runs libc's @dfn{name service cache daemon} (nscd) with the
1361 given configuration---an @code{<nscd-configuration>} object.  @xref{Name
1362 Service Switch}, for an example.")))
1363
1364 (define* (nscd-service #:optional (config %nscd-default-configuration))
1365   "Return a service that runs libc's name service cache daemon (nscd) with the
1366 given @var{config}---an @code{<nscd-configuration>} object.  @xref{Name
1367 Service Switch}, for an example."
1368   (service nscd-service-type config))
1369
1370
1371 (define-record-type* <syslog-configuration>
1372   syslog-configuration  make-syslog-configuration
1373   syslog-configuration?
1374   (syslogd              syslog-configuration-syslogd
1375                         (default (file-append inetutils "/libexec/syslogd")))
1376   (config-file          syslog-configuration-config-file
1377                         (default %default-syslog.conf)))
1378
1379 (define syslog-service-type
1380   (shepherd-service-type
1381    'syslog
1382    (lambda (config)
1383      (shepherd-service
1384       (documentation "Run the syslog daemon (syslogd).")
1385       (provision '(syslogd))
1386       (requirement '(user-processes))
1387       (start #~(make-forkexec-constructor
1388                 (list #$(syslog-configuration-syslogd config)
1389                       "--rcfile" #$(syslog-configuration-config-file config))
1390                 #:pid-file "/var/run/syslog.pid"))
1391       (stop #~(make-kill-destructor))))))
1392
1393 ;; Snippet adapted from the GNU inetutils manual.
1394 (define %default-syslog.conf
1395   (plain-file "syslog.conf" "
1396      # Log all error messages, authentication messages of
1397      # level notice or higher and anything of level err or
1398      # higher to the console.
1399      # Don't log private authentication messages!
1400      *.alert;auth.notice;authpriv.none       /dev/console
1401
1402      # Log anything (except mail) of level info or higher.
1403      # Don't log private authentication messages!
1404      *.info;mail.none;authpriv.none          /var/log/messages
1405
1406      # Like /var/log/messages, but also including \"debug\"-level logs.
1407      *.debug;mail.none;authpriv.none         /var/log/debug
1408
1409      # Same, in a different place.
1410      *.info;mail.none;authpriv.none          /dev/tty12
1411
1412      # The authpriv file has restricted access.
1413      authpriv.*                              /var/log/secure
1414
1415      # Log all the mail messages in one place.
1416      mail.*                                  /var/log/maillog
1417 "))
1418
1419 (define* (syslog-service #:optional (config (syslog-configuration)))
1420   "Return a service that runs @command{syslogd} and takes
1421 @var{<syslog-configuration>} as a parameter.
1422
1423 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1424 information on the configuration file syntax."
1425   (service syslog-service-type config))
1426
1427
1428 (define pam-limits-service-type
1429   (let ((security-limits
1430          ;; Create /etc/security containing the provided "limits.conf" file.
1431          (lambda (limits-file)
1432            `(("security"
1433               ,(computed-file
1434                 "security"
1435                 #~(begin
1436                     (mkdir #$output)
1437                     (stat #$limits-file)
1438                     (symlink #$limits-file
1439                              (string-append #$output "/limits.conf"))))))))
1440         (pam-extension
1441          (lambda (pam)
1442            (let ((pam-limits (pam-entry
1443                               (control "required")
1444                               (module "pam_limits.so")
1445                               (arguments '("conf=/etc/security/limits.conf")))))
1446              (if (member (pam-service-name pam)
1447                          '("login" "su" "slim"))
1448                  (pam-service
1449                   (inherit pam)
1450                   (session (cons pam-limits
1451                                  (pam-service-session pam))))
1452                  pam)))))
1453     (service-type
1454      (name 'limits)
1455      (extensions
1456       (list (service-extension etc-service-type security-limits)
1457             (service-extension pam-root-service-type
1458                                (lambda _ (list pam-extension)))))
1459      (description
1460       "Install the specified resource usage limits by populating
1461 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1462 authentication module."))))
1463
1464 (define* (pam-limits-service #:optional (limits '()))
1465   "Return a service that makes selected programs respect the list of
1466 pam-limits-entry specified in LIMITS via pam_limits.so."
1467   (service pam-limits-service-type
1468            (plain-file "limits.conf"
1469                        (string-join (map pam-limits-entry->string limits)
1470                                     "\n"))))
1471
1472 \f
1473 ;;;
1474 ;;; Guix services.
1475 ;;;
1476
1477 (define* (guix-build-accounts count #:key
1478                               (group "guixbuild")
1479                               (first-uid 30001)
1480                               (shadow shadow))
1481   "Return a list of COUNT user accounts for Guix build users, with UIDs
1482 starting at FIRST-UID, and under GID."
1483   (unfold (cut > <> count)
1484           (lambda (n)
1485             (user-account
1486              (name (format #f "guixbuilder~2,'0d" n))
1487              (system? #t)
1488              (uid (+ first-uid n -1))
1489              (group group)
1490
1491              ;; guix-daemon expects GROUP to be listed as a
1492              ;; supplementary group too:
1493              ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1494              (supplementary-groups (list group "kvm"))
1495
1496              (comment (format #f "Guix Build User ~2d" n))
1497              (home-directory "/var/empty")
1498              (shell (file-append shadow "/sbin/nologin"))))
1499           1+
1500           1))
1501
1502 (define (hydra-key-authorization keys guix)
1503   "Return a gexp with code to register KEYS, a list of files containing 'guix
1504 archive' public keys, with GUIX."
1505   #~(unless (file-exists? "/etc/guix/acl")
1506       (for-each (lambda (key)
1507                   (let ((pid (primitive-fork)))
1508                     (case pid
1509                       ((0)
1510                        (let* ((port (open-file key "r0b")))
1511                          (format #t "registering public key '~a'...~%" key)
1512                          (close-port (current-input-port))
1513                          (dup port 0)
1514                          (execl #$(file-append guix "/bin/guix")
1515                                 "guix" "archive" "--authorize")
1516                          (primitive-exit 1)))
1517                       (else
1518                        (let ((status (cdr (waitpid pid))))
1519                          (unless (zero? status)
1520                            (format (current-error-port) "warning: \
1521 failed to register public key '~a': ~a~%" key status)))))))
1522                 '(#$@keys))))
1523
1524 (define %default-authorized-guix-keys
1525   ;; List of authorized substitute keys.
1526   (list (file-append guix "/share/guix/hydra.gnu.org.pub")
1527         (file-append guix "/share/guix/berlin.guixsd.org.pub")))
1528
1529 (define-record-type* <guix-configuration>
1530   guix-configuration make-guix-configuration
1531   guix-configuration?
1532   (guix             guix-configuration-guix       ;<package>
1533                     (default guix))
1534   (build-group      guix-configuration-build-group ;string
1535                     (default "guixbuild"))
1536   (build-accounts   guix-configuration-build-accounts ;integer
1537                     (default 10))
1538   (authorize-key?   guix-configuration-authorize-key? ;Boolean
1539                     (default #t))
1540   (authorized-keys  guix-configuration-authorized-keys ;list of gexps
1541                     (default %default-authorized-guix-keys))
1542   (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1543                     (default #t))
1544   (substitute-urls  guix-configuration-substitute-urls ;list of strings
1545                     (default %default-substitute-urls))
1546   (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1547                       (default '()))
1548   (max-silent-time  guix-configuration-max-silent-time ;integer
1549                     (default 0))
1550   (timeout          guix-configuration-timeout    ;integer
1551                     (default 0))
1552   (log-compression  guix-configuration-log-compression
1553                     (default 'bzip2))
1554   (extra-options    guix-configuration-extra-options ;list of strings
1555                     (default '()))
1556   (log-file         guix-configuration-log-file   ;string
1557                     (default "/var/log/guix-daemon.log"))
1558   (http-proxy       guix-http-proxy               ;string | #f
1559                     (default #f))
1560   (tmpdir           guix-tmpdir                   ;string | #f
1561                     (default #f)))
1562
1563 (define %default-guix-configuration
1564   (guix-configuration))
1565
1566 (define (guix-shepherd-service config)
1567   "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1568   (match-record config <guix-configuration>
1569     (guix build-group build-accounts authorize-key? authorized-keys
1570           use-substitutes? substitute-urls max-silent-time timeout
1571           log-compression extra-options log-file http-proxy tmpdir
1572           chroot-directories)
1573     (list (shepherd-service
1574            (documentation "Run the Guix daemon.")
1575            (provision '(guix-daemon))
1576            (requirement '(user-processes))
1577            (modules '((srfi srfi-1)))
1578            (start
1579             #~(make-forkexec-constructor
1580                (cons* #$(file-append guix "/bin/guix-daemon")
1581                       "--build-users-group" #$build-group
1582                       "--max-silent-time" #$(number->string max-silent-time)
1583                       "--timeout" #$(number->string timeout)
1584                       "--log-compression" #$(symbol->string log-compression)
1585                       #$@(if use-substitutes?
1586                              '()
1587                              '("--no-substitutes"))
1588                       "--substitute-urls" #$(string-join substitute-urls)
1589                       #$@extra-options
1590
1591                       ;; Add CHROOT-DIRECTORIES and all their dependencies (if
1592                       ;; these are store items) to the chroot.
1593                       (append-map (lambda (file)
1594                                     (append-map (lambda (directory)
1595                                                   (list "--chroot-directory"
1596                                                         directory))
1597                                                 (call-with-input-file file
1598                                                   read)))
1599                                   '#$(map references-file chroot-directories)))
1600
1601                #:environment-variables
1602                (list #$@(if http-proxy
1603                             (list (string-append "http_proxy=" http-proxy))
1604                             '())
1605                      #$@(if tmpdir
1606                             (list (string-append "TMPDIR=" tmpdir))
1607                             '())
1608
1609                      ;; Make sure we run in a UTF-8 locale so that 'guix
1610                      ;; offload' correctly restores nars that contain UTF-8
1611                      ;; file names such as 'nss-certs'.  See
1612                      ;; <https://bugs.gnu.org/32942>.
1613                      (string-append "GUIX_LOCPATH="
1614                                     #$glibc-utf8-locales "/lib/locale")
1615                      "LC_ALL=en_US.utf8")
1616
1617                #:log-file #$log-file))
1618            (stop #~(make-kill-destructor))))))
1619
1620 (define (guix-accounts config)
1621   "Return the user accounts and user groups for CONFIG."
1622   (match config
1623     (($ <guix-configuration> _ build-group build-accounts)
1624      (cons (user-group
1625             (name build-group)
1626             (system? #t)
1627
1628             ;; Use a fixed GID so that we can create the store with the right
1629             ;; owner.
1630             (id 30000))
1631            (guix-build-accounts build-accounts
1632                                 #:group build-group)))))
1633
1634 (define (guix-activation config)
1635   "Return the activation gexp for CONFIG."
1636   (match config
1637     (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1638      ;; Assume that the store has BUILD-GROUP as its group.  We could
1639      ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1640      ;; chown leads to an entire copy of the tree, which is a bad idea.
1641
1642      ;; Optionally authorize substitute server keys.
1643      (if authorize-key?
1644          (hydra-key-authorization keys guix)
1645          #~#f))))
1646
1647 (define* (references-file item #:optional (name "references"))
1648   "Return a file that contains the list of references of ITEM."
1649   (if (struct? item)                              ;lowerable object
1650       (computed-file name
1651                      (with-imported-modules (source-module-closure
1652                                              '((guix build store-copy)))
1653                        #~(begin
1654                            (use-modules (guix build store-copy))
1655
1656                            (call-with-output-file #$output
1657                              (lambda (port)
1658                                (write (map store-info-item
1659                                            (call-with-input-file "graph"
1660                                              read-reference-graph))
1661                                       port)))))
1662                      #:options `(#:local-build? #f
1663                                  #:references-graphs (("graph" ,item))))
1664       (plain-file name "()")))
1665
1666 (define guix-service-type
1667   (service-type
1668    (name 'guix)
1669    (extensions
1670     (list (service-extension shepherd-root-service-type guix-shepherd-service)
1671           (service-extension account-service-type guix-accounts)
1672           (service-extension activation-service-type guix-activation)
1673           (service-extension profile-service-type
1674                              (compose list guix-configuration-guix))))
1675
1676    ;; Extensions can specify extra directories to add to the build chroot.
1677    (compose concatenate)
1678    (extend (lambda (config directories)
1679              (guix-configuration
1680               (inherit config)
1681               (chroot-directories
1682                (append (guix-configuration-chroot-directories config)
1683                        directories)))))
1684
1685    (default-value (guix-configuration))
1686    (description
1687     "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1688
1689 (define* (guix-service #:optional (config %default-guix-configuration))
1690   "Return a service that runs the Guix build daemon according to
1691 @var{config}."
1692   (service guix-service-type config))
1693
1694
1695 (define-record-type* <guix-publish-configuration>
1696   guix-publish-configuration make-guix-publish-configuration
1697   guix-publish-configuration?
1698   (guix    guix-publish-configuration-guix        ;package
1699            (default guix))
1700   (port    guix-publish-configuration-port        ;number
1701            (default 80))
1702   (host    guix-publish-configuration-host        ;string
1703            (default "localhost"))
1704   (compression-level guix-publish-configuration-compression-level ;integer
1705                      (default 3))
1706   (nar-path    guix-publish-configuration-nar-path ;string
1707                (default "nar"))
1708   (cache       guix-publish-configuration-cache   ;#f | string
1709                (default #f))
1710   (workers     guix-publish-configuration-workers ;#f | integer
1711                (default #f))
1712   (ttl         guix-publish-configuration-ttl     ;#f | integer
1713                (default #f)))
1714
1715 (define guix-publish-shepherd-service
1716   (match-lambda
1717     (($ <guix-publish-configuration> guix port host compression
1718                                      nar-path cache workers ttl)
1719      (list (shepherd-service
1720             (provision '(guix-publish))
1721             (requirement '(guix-daemon))
1722             (start #~(make-forkexec-constructor
1723                       (list #$(file-append guix "/bin/guix")
1724                             "publish" "-u" "guix-publish"
1725                             "-p" #$(number->string port)
1726                             "-C" #$(number->string compression)
1727                             (string-append "--nar-path=" #$nar-path)
1728                             (string-append "--listen=" #$host)
1729                             #$@(if workers
1730                                    #~((string-append "--workers="
1731                                                      #$(number->string
1732                                                         workers)))
1733                                    #~())
1734                             #$@(if ttl
1735                                    #~((string-append "--ttl="
1736                                                      #$(number->string ttl)
1737                                                      "s"))
1738                                    #~())
1739                             #$@(if cache
1740                                    #~((string-append "--cache=" #$cache))
1741                                    #~()))
1742
1743                       ;; Make sure we run in a UTF-8 locale so we can produce
1744                       ;; nars for packages that contain UTF-8 file names such
1745                       ;; as 'nss-certs'.  See <https://bugs.gnu.org/26948>.
1746                       #:environment-variables
1747                       (list (string-append "GUIX_LOCPATH="
1748                                            #$glibc-utf8-locales "/lib/locale")
1749                             "LC_ALL=en_US.utf8")))
1750             (stop #~(make-kill-destructor)))))))
1751
1752 (define %guix-publish-accounts
1753   (list (user-group (name "guix-publish") (system? #t))
1754         (user-account
1755          (name "guix-publish")
1756          (group "guix-publish")
1757          (system? #t)
1758          (comment "guix publish user")
1759          (home-directory "/var/empty")
1760          (shell (file-append shadow "/sbin/nologin")))))
1761
1762 (define (guix-publish-activation config)
1763   (let ((cache (guix-publish-configuration-cache config)))
1764     (if cache
1765         (with-imported-modules '((guix build utils))
1766           #~(begin
1767               (use-modules (guix build utils))
1768
1769               (mkdir-p #$cache)
1770               (let* ((pw  (getpw "guix-publish"))
1771                      (uid (passwd:uid pw))
1772                      (gid (passwd:gid pw)))
1773                 (chown #$cache uid gid))))
1774         #t)))
1775
1776 (define guix-publish-service-type
1777   (service-type (name 'guix-publish)
1778                 (extensions
1779                  (list (service-extension shepherd-root-service-type
1780                                           guix-publish-shepherd-service)
1781                        (service-extension account-service-type
1782                                           (const %guix-publish-accounts))
1783                        (service-extension activation-service-type
1784                                           guix-publish-activation)))
1785                 (default-value (guix-publish-configuration))
1786                 (description
1787                  "Add a Shepherd service running @command{guix publish}, a
1788 command that allows you to share pre-built binaries with others over HTTP.")))
1789
1790 (define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1791   "Return a service that runs @command{guix publish} listening on @var{host}
1792 and @var{port} (@pxref{Invoking guix publish}).
1793
1794 This assumes that @file{/etc/guix} already contains a signing key pair as
1795 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1796 archive}).  If that is not the case, the service will fail to start."
1797   ;; Deprecated.
1798   (service guix-publish-service-type
1799            (guix-publish-configuration (guix guix) (port port) (host host))))
1800
1801 \f
1802 ;;;
1803 ;;; Udev.
1804 ;;;
1805
1806 (define-record-type* <udev-configuration>
1807   udev-configuration make-udev-configuration
1808   udev-configuration?
1809   (udev   udev-configuration-udev                 ;<package>
1810           (default udev))
1811   (rules  udev-configuration-rules                ;list of <package>
1812           (default '())))
1813
1814 (define (udev-rules-union packages)
1815   "Return the union of the @code{lib/udev/rules.d} directories found in each
1816 item of @var{packages}."
1817   (define build
1818     (with-imported-modules '((guix build union)
1819                              (guix build utils))
1820       #~(begin
1821           (use-modules (guix build union)
1822                        (guix build utils)
1823                        (srfi srfi-1)
1824                        (srfi srfi-26))
1825
1826           (define %standard-locations
1827             '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1828
1829           (define (rules-sub-directory directory)
1830             ;; Return the sub-directory of DIRECTORY containing udev rules, or
1831             ;; #f if none was found.
1832             (find directory-exists?
1833                   (map (cut string-append directory <>) %standard-locations)))
1834
1835           (mkdir-p (string-append #$output "/lib/udev"))
1836           (union-build (string-append #$output "/lib/udev/rules.d")
1837                        (filter-map rules-sub-directory '#$packages)))))
1838
1839   (computed-file "udev-rules" build))
1840
1841 (define (udev-rule file-name contents)
1842   "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1843   (computed-file file-name
1844                  (with-imported-modules '((guix build utils))
1845                    #~(begin
1846                        (use-modules (guix build utils))
1847
1848                        (define rules.d
1849                          (string-append #$output "/lib/udev/rules.d"))
1850
1851                        (mkdir-p rules.d)
1852                        (call-with-output-file
1853                            (string-append rules.d "/" #$file-name)
1854                          (lambda (port)
1855                            (display #$contents port)))))))
1856
1857 (define (file->udev-rule file-name file)
1858   "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1859   (computed-file file-name
1860                  (with-imported-modules '((guix build utils))
1861                    #~(begin
1862                        (use-modules (guix build utils))
1863
1864                        (define rules.d
1865                          (string-append #$output "/lib/udev/rules.d"))
1866
1867                        (define file-copy-dest
1868                          (string-append rules.d "/" #$file-name))
1869
1870                        (mkdir-p rules.d)
1871                        (copy-file #$file file-copy-dest)))))
1872
1873 (define kvm-udev-rule
1874   ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1875   ;; "kvm" and makes it #o660.  Apparently QEMU-KVM used to ship this rule,
1876   ;; but now we have to add it by ourselves.
1877
1878   ;; Build users are part of the "kvm" group, so we can fearlessly make
1879   ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1880   (udev-rule "90-kvm.rules"
1881              "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1882
1883 (define udev-shepherd-service
1884   ;; Return a <shepherd-service> for UDEV with RULES.
1885   (match-lambda
1886     (($ <udev-configuration> udev rules)
1887      (let* ((rules     (udev-rules-union (cons* udev kvm-udev-rule rules)))
1888             (udev.conf (computed-file "udev.conf"
1889                                       #~(call-with-output-file #$output
1890                                           (lambda (port)
1891                                             (format port
1892                                                     "udev_rules=\"~a/lib/udev/rules.d\"\n"
1893                                                     #$rules))))))
1894        (list
1895         (shepherd-service
1896          (provision '(udev))
1897
1898          ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1899          ;; be added: see
1900          ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1901          (requirement '(root-file-system))
1902
1903          (documentation "Populate the /dev directory, dynamically.")
1904          (start #~(lambda ()
1905                     (define udevd
1906                       ;; 'udevd' from eudev.
1907                       #$(file-append udev "/sbin/udevd"))
1908
1909                     (define (wait-for-udevd)
1910                       ;; Wait until someone's listening on udevd's control
1911                       ;; socket.
1912                       (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1913                         (let try ()
1914                           (catch 'system-error
1915                             (lambda ()
1916                               (connect sock PF_UNIX "/run/udev/control")
1917                               (close-port sock))
1918                             (lambda args
1919                               (format #t "waiting for udevd...~%")
1920                               (usleep 500000)
1921                               (try))))))
1922
1923                     ;; Allow udev to find the modules.
1924                     (setenv "LINUX_MODULE_DIRECTORY"
1925                             "/run/booted-system/kernel/lib/modules")
1926
1927                     ;; The first one is for udev, the second one for eudev.
1928                     (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1929                     (setenv "EUDEV_RULES_DIRECTORY"
1930                             #$(file-append rules "/lib/udev/rules.d"))
1931
1932                     (let* ((kernel-release
1933                             (utsname:release (uname)))
1934                            (linux-module-directory
1935                             (getenv "LINUX_MODULE_DIRECTORY"))
1936                            (directory
1937                             (string-append linux-module-directory "/"
1938                                            kernel-release))
1939                            (old-umask (umask #o022)))
1940                       ;; If we're in a container, DIRECTORY might not exist,
1941                       ;; for instance because the host runs a different
1942                       ;; kernel.  In that case, skip it; we'll just miss a few
1943                       ;; nodes like /dev/fuse.
1944                       (when (file-exists? directory)
1945                         (make-static-device-nodes directory))
1946                       (umask old-umask))
1947
1948                     (let ((pid (fork+exec-command (list udevd))))
1949                       ;; Wait until udevd is up and running.  This appears to
1950                       ;; be needed so that the events triggered below are
1951                       ;; actually handled.
1952                       (wait-for-udevd)
1953
1954                       ;; Trigger device node creation.
1955                       (system* #$(file-append udev "/bin/udevadm")
1956                                "trigger" "--action=add")
1957
1958                       ;; Wait for things to settle down.
1959                       (system* #$(file-append udev "/bin/udevadm")
1960                                "settle")
1961                       pid)))
1962          (stop #~(make-kill-destructor))
1963
1964          ;; When halting the system, 'udev' is actually killed by
1965          ;; 'user-processes', i.e., before its own 'stop' method was called.
1966          ;; Thus, make sure it is not respawned.
1967          (respawn? #f)
1968          ;; We need additional modules.
1969          (modules `((gnu build linux-boot)
1970                     ,@%default-modules))
1971
1972          (actions (list (shepherd-action
1973                          (name 'rules)
1974                          (documentation "Display the directory containing
1975 the udev rules in use.")
1976                          (procedure #~(lambda (_)
1977                                         (display #$rules)
1978                                         (newline))))))))))))
1979
1980 (define udev-service-type
1981   (service-type (name 'udev)
1982                 (extensions
1983                  (list (service-extension shepherd-root-service-type
1984                                           udev-shepherd-service)))
1985
1986                 (compose concatenate)           ;concatenate the list of rules
1987                 (extend (lambda (config rules)
1988                           (match config
1989                             (($ <udev-configuration> udev initial-rules)
1990                              (udev-configuration
1991                               (udev udev)
1992                               (rules (append initial-rules rules)))))))
1993                 (description
1994                  "Run @command{udev}, which populates the @file{/dev}
1995 directory dynamically.  Get extra rules from the packages listed in the
1996 @code{rules} field of its value, @code{udev-configuration} object.")))
1997
1998 (define* (udev-service #:key (udev eudev) (rules '()))
1999   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
2000 extra rules from the packages listed in @var{rules}."
2001   (service udev-service-type
2002            (udev-configuration (udev udev) (rules rules))))
2003
2004 (define swap-service-type
2005   (shepherd-service-type
2006    'swap
2007    (lambda (device)
2008      (define requirement
2009        (if (string-prefix? "/dev/mapper/" device)
2010            (list (symbol-append 'device-mapping-
2011                                 (string->symbol (basename device))))
2012            '()))
2013
2014      (shepherd-service
2015       (provision (list (symbol-append 'swap- (string->symbol device))))
2016       (requirement `(udev ,@requirement))
2017       (documentation "Enable the given swap device.")
2018       (start #~(lambda ()
2019                  (restart-on-EINTR (swapon #$device))
2020                  #t))
2021       (stop #~(lambda _
2022                 (restart-on-EINTR (swapoff #$device))
2023                 #f))
2024       (respawn? #f)))))
2025
2026 (define (swap-service device)
2027   "Return a service that uses @var{device} as a swap device."
2028   (service swap-service-type device))
2029
2030 (define %default-gpm-options
2031   ;; Default options for GPM.
2032   '("-m" "/dev/input/mice" "-t" "ps2"))
2033
2034 (define-record-type* <gpm-configuration>
2035   gpm-configuration make-gpm-configuration gpm-configuration?
2036   (gpm      gpm-configuration-gpm                 ;package
2037             (default gpm))
2038   (options  gpm-configuration-options             ;list of strings
2039             (default %default-gpm-options)))
2040
2041 (define gpm-shepherd-service
2042   (match-lambda
2043     (($ <gpm-configuration> gpm options)
2044      (list (shepherd-service
2045             (requirement '(udev))
2046             (provision '(gpm))
2047             (start #~(lambda ()
2048                        ;; 'gpm' runs in the background and sets a PID file.
2049                        ;; Note that it requires running as "root".
2050                        (false-if-exception (delete-file "/var/run/gpm.pid"))
2051                        (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2052                                                 #$@options))
2053
2054                        ;; Wait for the PID file to appear; declare failure if
2055                        ;; it doesn't show up.
2056                        (let loop ((i 3))
2057                          (or (file-exists? "/var/run/gpm.pid")
2058                              (if (zero? i)
2059                                  #f
2060                                  (begin
2061                                    (sleep 1)
2062                                    (loop (1- i))))))))
2063
2064             (stop #~(lambda (_)
2065                       ;; Return #f if successfully stopped.
2066                       (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2067                                            "-k"))))))))))
2068
2069 (define gpm-service-type
2070   (service-type (name 'gpm)
2071                 (extensions
2072                  (list (service-extension shepherd-root-service-type
2073                                           gpm-shepherd-service)))
2074                 (default-value (gpm-configuration))
2075                 (description
2076                  "Run GPM, the general-purpose mouse daemon, with the given
2077 command-line options.  GPM allows users to use the mouse in the console,
2078 notably to select, copy, and paste text.  The default options use the
2079 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2080
2081 (define* (gpm-service #:key (gpm gpm)             ;deprecated
2082                       (options %default-gpm-options))
2083   "Run @var{gpm}, the general-purpose mouse daemon, with the given
2084 command-line @var{options}.  GPM allows users to use the mouse in the console,
2085 notably to select, copy, and paste text.  The default value of @var{options}
2086 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2087
2088 This service is not part of @var{%base-services}."
2089   ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2090   ;; "info mice" and "mouse_set X" to use the right mouse.
2091   (service gpm-service-type
2092            (gpm-configuration (gpm gpm) (options options))))
2093
2094 (define-record-type* <kmscon-configuration>
2095   kmscon-configuration     make-kmscon-configuration
2096   kmscon-configuration?
2097   (kmscon                  kmscon-configuration-kmscon
2098                            (default kmscon))
2099   (virtual-terminal        kmscon-configuration-virtual-terminal)
2100   (login-program           kmscon-configuration-login-program
2101                            (default (file-append shadow "/bin/login")))
2102   (login-arguments         kmscon-configuration-login-arguments
2103                            (default '("-p")))
2104   (auto-login              kmscon-configuration-auto-login
2105                            (default #f))
2106   (hardware-acceleration?  kmscon-configuration-hardware-acceleration?
2107                            (default #f))) ; #t causes failure
2108
2109 (define kmscon-service-type
2110   (shepherd-service-type
2111    'kmscon
2112    (lambda (config)
2113      (let ((kmscon (kmscon-configuration-kmscon config))
2114            (virtual-terminal (kmscon-configuration-virtual-terminal config))
2115            (login-program (kmscon-configuration-login-program config))
2116            (login-arguments (kmscon-configuration-login-arguments config))
2117            (auto-login (kmscon-configuration-auto-login config))
2118            (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2119
2120        (define kmscon-command
2121          #~(list
2122             #$(file-append kmscon "/bin/kmscon") "--login"
2123             "--vt" #$virtual-terminal
2124             "--no-switchvt" ;Prevent a switch to the virtual terminal.
2125             #$@(if hardware-acceleration? '("--hwaccel") '())
2126             "--login" "--"
2127             #$login-program #$@login-arguments
2128             #$@(if auto-login
2129                    #~(#$auto-login)
2130                    #~())))
2131
2132        (shepherd-service
2133         (documentation "kmscon virtual terminal")
2134         (requirement '(user-processes udev dbus-system virtual-terminal))
2135         (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2136         (start #~(make-forkexec-constructor #$kmscon-command))
2137         (stop #~(make-kill-destructor)))))))
2138
2139 (define-record-type* <static-networking>
2140   static-networking make-static-networking
2141   static-networking?
2142   (interface static-networking-interface)
2143   (ip static-networking-ip)
2144   (netmask static-networking-netmask
2145            (default #f))
2146   (gateway static-networking-gateway              ;FIXME: doesn't belong here
2147            (default #f))
2148   (provision static-networking-provision
2149              (default #f))
2150   (requirement static-networking-requirement
2151                (default '()))
2152   (name-servers static-networking-name-servers    ;FIXME: doesn't belong here
2153                 (default '())))
2154
2155 (define static-networking-shepherd-service
2156   (match-lambda
2157     (($ <static-networking> interface ip netmask gateway provision
2158                             requirement name-servers)
2159      (let ((loopback? (and provision (memq 'loopback provision))))
2160        (shepherd-service
2161
2162         (documentation
2163          "Bring up the networking interface using a static IP address.")
2164         (requirement requirement)
2165         (provision (or provision
2166                        (list (symbol-append 'networking-
2167                                             (string->symbol interface)))))
2168
2169         (start #~(lambda _
2170                    ;; Return #t if successfully started.
2171                    (let* ((addr     (inet-pton AF_INET #$ip))
2172                           (sockaddr (make-socket-address AF_INET addr 0))
2173                           (mask     (and #$netmask
2174                                          (inet-pton AF_INET #$netmask)))
2175                           (maskaddr (and mask
2176                                          (make-socket-address AF_INET
2177                                                               mask 0)))
2178                           (gateway  (and #$gateway
2179                                          (inet-pton AF_INET #$gateway)))
2180                           (gatewayaddr (and gateway
2181                                             (make-socket-address AF_INET
2182                                                                  gateway 0))))
2183                      (configure-network-interface #$interface sockaddr
2184                                                   (logior IFF_UP
2185                                                           #$(if loopback?
2186                                                                 #~IFF_LOOPBACK
2187                                                                 0))
2188                                                   #:netmask maskaddr)
2189                      (when gateway
2190                        (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2191                          (add-network-route/gateway sock gatewayaddr)
2192                          (close-port sock))))))
2193         (stop #~(lambda _
2194                   ;; Return #f is successfully stopped.
2195                   (let ((sock (socket AF_INET SOCK_STREAM 0)))
2196                     (when #$gateway
2197                       (delete-network-route sock
2198                                             (make-socket-address
2199                                              AF_INET INADDR_ANY 0)))
2200                     (set-network-interface-flags sock #$interface 0)
2201                     (close-port sock)
2202                     #f)))
2203         (respawn? #f))))))
2204
2205 (define (static-networking-etc-files interfaces)
2206   "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2207   (match (delete-duplicates
2208           (append-map static-networking-name-servers
2209                       interfaces))
2210     (()
2211      '())
2212     ((name-servers ...)
2213      (let ((content (string-join
2214                      (map (cut string-append "nameserver " <>)
2215                           name-servers)
2216                      "\n" 'suffix)))
2217        `(("resolv.conf"
2218           ,(plain-file "resolv.conf"
2219                        (string-append "\
2220 # Generated by 'static-networking-service'.\n"
2221                                       content))))))))
2222
2223 (define (static-networking-shepherd-services interfaces)
2224   "Return the list of Shepherd services to bring up INTERFACES, a list of
2225 <static-networking> objects."
2226   (define (loopback? service)
2227     (memq 'loopback (shepherd-service-provision service)))
2228
2229   (let ((services (map static-networking-shepherd-service interfaces)))
2230     (match (remove loopback? services)
2231       (()
2232        ;; There's no interface other than 'loopback', so we assume that the
2233        ;; 'networking' service will be provided by dhclient or similar.
2234        services)
2235       ((non-loopback ...)
2236        ;; Assume we're providing all the interfaces, and thus, provide a
2237        ;; 'networking' service.
2238        (cons (shepherd-service
2239               (provision '(networking))
2240               (requirement (append-map shepherd-service-provision
2241                                        services))
2242               (start #~(const #t))
2243               (stop #~(const #f))
2244               (documentation "Bring up all the networking interfaces."))
2245              services)))))
2246
2247 (define static-networking-service-type
2248   ;; The service type for statically-defined network interfaces.
2249   (service-type (name 'static-networking)
2250                 (extensions
2251                  (list
2252                   (service-extension shepherd-root-service-type
2253                                      static-networking-shepherd-services)
2254                   (service-extension etc-service-type
2255                                      static-networking-etc-files)))
2256                 (compose concatenate)
2257                 (extend append)
2258                 (description
2259                  "Turn up the specified network interfaces upon startup,
2260 with the given IP address, gateway, netmask, and so on.  The value for
2261 services of this type is a list of @code{static-networking} objects, one per
2262 network interface.")))
2263
2264 (define* (static-networking-service interface ip
2265                                     #:key
2266                                     netmask gateway provision
2267                                     ;; Most interfaces require udev to be usable.
2268                                     (requirement '(udev))
2269                                     (name-servers '()))
2270   "Return a service that starts @var{interface} with address @var{ip}.  If
2271 @var{netmask} is true, use it as the network mask.  If @var{gateway} is true,
2272 it must be a string specifying the default network gateway.
2273
2274 This procedure can be called several times, one for each network
2275 interface of interest.  Behind the scenes what it does is extend
2276 @code{static-networking-service-type} with additional network interfaces
2277 to handle."
2278   (simple-service 'static-network-interface
2279                   static-networking-service-type
2280                   (list (static-networking (interface interface) (ip ip)
2281                                            (netmask netmask) (gateway gateway)
2282                                            (provision provision)
2283                                            (requirement requirement)
2284                                            (name-servers name-servers)))))
2285
2286 \f
2287 (define %base-services
2288   ;; Convenience variable holding the basic services.
2289   (list (login-service)
2290
2291         (service virtual-terminal-service-type)
2292         (service console-font-service-type
2293                  (map (lambda (tty)
2294                         (cons tty %default-console-font))
2295                       '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2296
2297         (agetty-service (agetty-configuration
2298                          (extra-options '("-L")) ; no carrier detect
2299                          (term "vt100")
2300                          (tty #f))) ; automatic
2301
2302         (mingetty-service (mingetty-configuration
2303                            (tty "tty1")))
2304         (mingetty-service (mingetty-configuration
2305                            (tty "tty2")))
2306         (mingetty-service (mingetty-configuration
2307                            (tty "tty3")))
2308         (mingetty-service (mingetty-configuration
2309                            (tty "tty4")))
2310         (mingetty-service (mingetty-configuration
2311                            (tty "tty5")))
2312         (mingetty-service (mingetty-configuration
2313                            (tty "tty6")))
2314
2315         (service static-networking-service-type
2316                  (list (static-networking (interface "lo")
2317                                           (ip "127.0.0.1")
2318                                           (requirement '())
2319                                           (provision '(loopback)))))
2320         (syslog-service)
2321         (service urandom-seed-service-type)
2322         (guix-service)
2323         (nscd-service)
2324
2325         ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2326         ;; used, so enable them by default.  The FUSE and ALSA rules are
2327         ;; less critical, but handy.
2328         (udev-service #:rules (list lvm2 fuse alsa-utils crda))
2329
2330         (service special-files-service-type
2331                  `(("/bin/sh" ,(file-append (canonical-package bash)
2332                                             "/bin/sh"))))))
2333
2334 ;;; base.scm ends here