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 key guix)
1503   "Return a gexp with code to register KEY, a file containing a 'guix archive'
1504 public key, with GUIX."
1505   #~(unless (file-exists? "/etc/guix/acl")
1506       (let ((pid (primitive-fork)))
1507         (case pid
1508           ((0)
1509            (let* ((key  #$key)
1510                   (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              (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
1523 (define %default-authorized-guix-keys
1524   ;; List of authorized substitute keys.
1525   (list (file-append guix "/share/guix/hydra.gnu.org.pub")
1526         (file-append guix "/share/guix/berlin.guixsd.org.pub")))
1527
1528 (define-record-type* <guix-configuration>
1529   guix-configuration make-guix-configuration
1530   guix-configuration?
1531   (guix             guix-configuration-guix       ;<package>
1532                     (default guix))
1533   (build-group      guix-configuration-build-group ;string
1534                     (default "guixbuild"))
1535   (build-accounts   guix-configuration-build-accounts ;integer
1536                     (default 10))
1537   (authorize-key?   guix-configuration-authorize-key? ;Boolean
1538                     (default #t))
1539   (authorized-keys  guix-configuration-authorized-keys ;list of gexps
1540                     (default %default-authorized-guix-keys))
1541   (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1542                     (default #t))
1543   (substitute-urls  guix-configuration-substitute-urls ;list of strings
1544                     (default %default-substitute-urls))
1545   (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1546                       (default '()))
1547   (max-silent-time  guix-configuration-max-silent-time ;integer
1548                     (default 0))
1549   (timeout          guix-configuration-timeout    ;integer
1550                     (default 0))
1551   (log-compression  guix-configuration-log-compression
1552                     (default 'bzip2))
1553   (extra-options    guix-configuration-extra-options ;list of strings
1554                     (default '()))
1555   (log-file         guix-configuration-log-file   ;string
1556                     (default "/var/log/guix-daemon.log"))
1557   (http-proxy       guix-http-proxy               ;string | #f
1558                     (default #f))
1559   (tmpdir           guix-tmpdir                   ;string | #f
1560                     (default #f)))
1561
1562 (define %default-guix-configuration
1563   (guix-configuration))
1564
1565 (define (guix-shepherd-service config)
1566   "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1567   (match-record config <guix-configuration>
1568     (guix build-group build-accounts authorize-key? authorized-keys
1569           use-substitutes? substitute-urls max-silent-time timeout
1570           log-compression extra-options log-file http-proxy tmpdir
1571           chroot-directories)
1572     (list (shepherd-service
1573            (documentation "Run the Guix daemon.")
1574            (provision '(guix-daemon))
1575            (requirement '(user-processes))
1576            (modules '((srfi srfi-1)))
1577            (start
1578             #~(make-forkexec-constructor
1579                (cons* #$(file-append guix "/bin/guix-daemon")
1580                       "--build-users-group" #$build-group
1581                       "--max-silent-time" #$(number->string max-silent-time)
1582                       "--timeout" #$(number->string timeout)
1583                       "--log-compression" #$(symbol->string log-compression)
1584                       #$@(if use-substitutes?
1585                              '()
1586                              '("--no-substitutes"))
1587                       "--substitute-urls" #$(string-join substitute-urls)
1588                       #$@extra-options
1589
1590                       ;; Add CHROOT-DIRECTORIES and all their dependencies (if
1591                       ;; these are store items) to the chroot.
1592                       (append-map (lambda (file)
1593                                     (append-map (lambda (directory)
1594                                                   (list "--chroot-directory"
1595                                                         directory))
1596                                                 (call-with-input-file file
1597                                                   read)))
1598                                   '#$(map references-file chroot-directories)))
1599
1600                #:environment-variables
1601                (list #$@(if http-proxy
1602                             (list (string-append "http_proxy=" http-proxy))
1603                             '())
1604                      #$@(if tmpdir
1605                             (list (string-append "TMPDIR=" tmpdir))
1606                             '()))
1607
1608                #:log-file #$log-file))
1609            (stop #~(make-kill-destructor))))))
1610
1611 (define (guix-accounts config)
1612   "Return the user accounts and user groups for CONFIG."
1613   (match config
1614     (($ <guix-configuration> _ build-group build-accounts)
1615      (cons (user-group
1616             (name build-group)
1617             (system? #t)
1618
1619             ;; Use a fixed GID so that we can create the store with the right
1620             ;; owner.
1621             (id 30000))
1622            (guix-build-accounts build-accounts
1623                                 #:group build-group)))))
1624
1625 (define (guix-activation config)
1626   "Return the activation gexp for CONFIG."
1627   (match config
1628     (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1629      ;; Assume that the store has BUILD-GROUP as its group.  We could
1630      ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1631      ;; chown leads to an entire copy of the tree, which is a bad idea.
1632
1633      ;; Optionally authorize substitute server keys.
1634      (if authorize-key?
1635          #~(begin
1636              #$@(map (cut hydra-key-authorization <> guix) keys))
1637          #~#f))))
1638
1639 (define* (references-file item #:optional (name "references"))
1640   "Return a file that contains the list of references of ITEM."
1641   (if (struct? item)                              ;lowerable object
1642       (computed-file name
1643                      (with-imported-modules (source-module-closure
1644                                              '((guix build store-copy)))
1645                        #~(begin
1646                            (use-modules (guix build store-copy))
1647
1648                            (call-with-output-file #$output
1649                              (lambda (port)
1650                                (write (map store-info-item
1651                                            (call-with-input-file "graph"
1652                                              read-reference-graph))
1653                                       port)))))
1654                      #:options `(#:local-build? #f
1655                                  #:references-graphs (("graph" ,item))))
1656       (plain-file name "()")))
1657
1658 (define guix-service-type
1659   (service-type
1660    (name 'guix)
1661    (extensions
1662     (list (service-extension shepherd-root-service-type guix-shepherd-service)
1663           (service-extension account-service-type guix-accounts)
1664           (service-extension activation-service-type guix-activation)
1665           (service-extension profile-service-type
1666                              (compose list guix-configuration-guix))))
1667
1668    ;; Extensions can specify extra directories to add to the build chroot.
1669    (compose concatenate)
1670    (extend (lambda (config directories)
1671              (guix-configuration
1672               (inherit config)
1673               (chroot-directories
1674                (append (guix-configuration-chroot-directories config)
1675                        directories)))))
1676
1677    (default-value (guix-configuration))
1678    (description
1679     "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1680
1681 (define* (guix-service #:optional (config %default-guix-configuration))
1682   "Return a service that runs the Guix build daemon according to
1683 @var{config}."
1684   (service guix-service-type config))
1685
1686
1687 (define-record-type* <guix-publish-configuration>
1688   guix-publish-configuration make-guix-publish-configuration
1689   guix-publish-configuration?
1690   (guix    guix-publish-configuration-guix        ;package
1691            (default guix))
1692   (port    guix-publish-configuration-port        ;number
1693            (default 80))
1694   (host    guix-publish-configuration-host        ;string
1695            (default "localhost"))
1696   (compression-level guix-publish-configuration-compression-level ;integer
1697                      (default 3))
1698   (nar-path    guix-publish-configuration-nar-path ;string
1699                (default "nar"))
1700   (cache       guix-publish-configuration-cache   ;#f | string
1701                (default #f))
1702   (workers     guix-publish-configuration-workers ;#f | integer
1703                (default #f))
1704   (ttl         guix-publish-configuration-ttl     ;#f | integer
1705                (default #f)))
1706
1707 (define guix-publish-shepherd-service
1708   (match-lambda
1709     (($ <guix-publish-configuration> guix port host compression
1710                                      nar-path cache workers ttl)
1711      (list (shepherd-service
1712             (provision '(guix-publish))
1713             (requirement '(guix-daemon))
1714             (start #~(make-forkexec-constructor
1715                       (list #$(file-append guix "/bin/guix")
1716                             "publish" "-u" "guix-publish"
1717                             "-p" #$(number->string port)
1718                             "-C" #$(number->string compression)
1719                             (string-append "--nar-path=" #$nar-path)
1720                             (string-append "--listen=" #$host)
1721                             #$@(if workers
1722                                    #~((string-append "--workers="
1723                                                      #$(number->string
1724                                                         workers)))
1725                                    #~())
1726                             #$@(if ttl
1727                                    #~((string-append "--ttl="
1728                                                      #$(number->string ttl)
1729                                                      "s"))
1730                                    #~())
1731                             #$@(if cache
1732                                    #~((string-append "--cache=" #$cache))
1733                                    #~()))
1734
1735                       ;; Make sure we run in a UTF-8 locale so we can produce
1736                       ;; nars for packages that contain UTF-8 file names such
1737                       ;; as 'nss-certs'.  See <https://bugs.gnu.org/26948>.
1738                       #:environment-variables
1739                       (list (string-append "GUIX_LOCPATH="
1740                                            #$glibc-utf8-locales "/lib/locale")
1741                             "LC_ALL=en_US.utf8")))
1742             (stop #~(make-kill-destructor)))))))
1743
1744 (define %guix-publish-accounts
1745   (list (user-group (name "guix-publish") (system? #t))
1746         (user-account
1747          (name "guix-publish")
1748          (group "guix-publish")
1749          (system? #t)
1750          (comment "guix publish user")
1751          (home-directory "/var/empty")
1752          (shell (file-append shadow "/sbin/nologin")))))
1753
1754 (define (guix-publish-activation config)
1755   (let ((cache (guix-publish-configuration-cache config)))
1756     (if cache
1757         (with-imported-modules '((guix build utils))
1758           #~(begin
1759               (use-modules (guix build utils))
1760
1761               (mkdir-p #$cache)
1762               (let* ((pw  (getpw "guix-publish"))
1763                      (uid (passwd:uid pw))
1764                      (gid (passwd:gid pw)))
1765                 (chown #$cache uid gid))))
1766         #t)))
1767
1768 (define guix-publish-service-type
1769   (service-type (name 'guix-publish)
1770                 (extensions
1771                  (list (service-extension shepherd-root-service-type
1772                                           guix-publish-shepherd-service)
1773                        (service-extension account-service-type
1774                                           (const %guix-publish-accounts))
1775                        (service-extension activation-service-type
1776                                           guix-publish-activation)))
1777                 (default-value (guix-publish-configuration))
1778                 (description
1779                  "Add a Shepherd service running @command{guix publish}, a
1780 command that allows you to share pre-built binaries with others over HTTP.")))
1781
1782 (define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1783   "Return a service that runs @command{guix publish} listening on @var{host}
1784 and @var{port} (@pxref{Invoking guix publish}).
1785
1786 This assumes that @file{/etc/guix} already contains a signing key pair as
1787 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1788 archive}).  If that is not the case, the service will fail to start."
1789   ;; Deprecated.
1790   (service guix-publish-service-type
1791            (guix-publish-configuration (guix guix) (port port) (host host))))
1792
1793 \f
1794 ;;;
1795 ;;; Udev.
1796 ;;;
1797
1798 (define-record-type* <udev-configuration>
1799   udev-configuration make-udev-configuration
1800   udev-configuration?
1801   (udev   udev-configuration-udev                 ;<package>
1802           (default udev))
1803   (rules  udev-configuration-rules                ;list of <package>
1804           (default '())))
1805
1806 (define (udev-rules-union packages)
1807   "Return the union of the @code{lib/udev/rules.d} directories found in each
1808 item of @var{packages}."
1809   (define build
1810     (with-imported-modules '((guix build union)
1811                              (guix build utils))
1812       #~(begin
1813           (use-modules (guix build union)
1814                        (guix build utils)
1815                        (srfi srfi-1)
1816                        (srfi srfi-26))
1817
1818           (define %standard-locations
1819             '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1820
1821           (define (rules-sub-directory directory)
1822             ;; Return the sub-directory of DIRECTORY containing udev rules, or
1823             ;; #f if none was found.
1824             (find directory-exists?
1825                   (map (cut string-append directory <>) %standard-locations)))
1826
1827           (mkdir-p (string-append #$output "/lib/udev"))
1828           (union-build (string-append #$output "/lib/udev/rules.d")
1829                        (filter-map rules-sub-directory '#$packages)))))
1830
1831   (computed-file "udev-rules" build))
1832
1833 (define (udev-rule file-name contents)
1834   "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1835   (computed-file file-name
1836                  (with-imported-modules '((guix build utils))
1837                    #~(begin
1838                        (use-modules (guix build utils))
1839
1840                        (define rules.d
1841                          (string-append #$output "/lib/udev/rules.d"))
1842
1843                        (mkdir-p rules.d)
1844                        (call-with-output-file
1845                            (string-append rules.d "/" #$file-name)
1846                          (lambda (port)
1847                            (display #$contents port)))))))
1848
1849 (define (file->udev-rule file-name file)
1850   "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1851   (computed-file file-name
1852                  (with-imported-modules '((guix build utils))
1853                    #~(begin
1854                        (use-modules (guix build utils))
1855
1856                        (define rules.d
1857                          (string-append #$output "/lib/udev/rules.d"))
1858
1859                        (define file-copy-dest
1860                          (string-append rules.d "/" #$file-name))
1861
1862                        (mkdir-p rules.d)
1863                        (copy-file #$file file-copy-dest)))))
1864
1865 (define kvm-udev-rule
1866   ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1867   ;; "kvm" and makes it #o660.  Apparently QEMU-KVM used to ship this rule,
1868   ;; but now we have to add it by ourselves.
1869
1870   ;; Build users are part of the "kvm" group, so we can fearlessly make
1871   ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1872   (udev-rule "90-kvm.rules"
1873              "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1874
1875 (define udev-shepherd-service
1876   ;; Return a <shepherd-service> for UDEV with RULES.
1877   (match-lambda
1878     (($ <udev-configuration> udev rules)
1879      (let* ((rules     (udev-rules-union (cons* udev kvm-udev-rule rules)))
1880             (udev.conf (computed-file "udev.conf"
1881                                       #~(call-with-output-file #$output
1882                                           (lambda (port)
1883                                             (format port
1884                                                     "udev_rules=\"~a/lib/udev/rules.d\"\n"
1885                                                     #$rules))))))
1886        (list
1887         (shepherd-service
1888          (provision '(udev))
1889
1890          ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1891          ;; be added: see
1892          ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1893          (requirement '(root-file-system))
1894
1895          (documentation "Populate the /dev directory, dynamically.")
1896          (start #~(lambda ()
1897                     (define udevd
1898                       ;; 'udevd' from eudev.
1899                       #$(file-append udev "/sbin/udevd"))
1900
1901                     (define (wait-for-udevd)
1902                       ;; Wait until someone's listening on udevd's control
1903                       ;; socket.
1904                       (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1905                         (let try ()
1906                           (catch 'system-error
1907                             (lambda ()
1908                               (connect sock PF_UNIX "/run/udev/control")
1909                               (close-port sock))
1910                             (lambda args
1911                               (format #t "waiting for udevd...~%")
1912                               (usleep 500000)
1913                               (try))))))
1914
1915                     ;; Allow udev to find the modules.
1916                     (setenv "LINUX_MODULE_DIRECTORY"
1917                             "/run/booted-system/kernel/lib/modules")
1918
1919                     ;; The first one is for udev, the second one for eudev.
1920                     (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1921                     (setenv "EUDEV_RULES_DIRECTORY"
1922                             #$(file-append rules "/lib/udev/rules.d"))
1923
1924                     (let* ((kernel-release
1925                             (utsname:release (uname)))
1926                            (linux-module-directory
1927                             (getenv "LINUX_MODULE_DIRECTORY"))
1928                            (directory
1929                             (string-append linux-module-directory "/"
1930                                            kernel-release))
1931                            (old-umask (umask #o022)))
1932                       ;; If we're in a container, DIRECTORY might not exist,
1933                       ;; for instance because the host runs a different
1934                       ;; kernel.  In that case, skip it; we'll just miss a few
1935                       ;; nodes like /dev/fuse.
1936                       (when (file-exists? directory)
1937                         (make-static-device-nodes directory))
1938                       (umask old-umask))
1939
1940                     (let ((pid (fork+exec-command (list udevd))))
1941                       ;; Wait until udevd is up and running.  This appears to
1942                       ;; be needed so that the events triggered below are
1943                       ;; actually handled.
1944                       (wait-for-udevd)
1945
1946                       ;; Trigger device node creation.
1947                       (system* #$(file-append udev "/bin/udevadm")
1948                                "trigger" "--action=add")
1949
1950                       ;; Wait for things to settle down.
1951                       (system* #$(file-append udev "/bin/udevadm")
1952                                "settle")
1953                       pid)))
1954          (stop #~(make-kill-destructor))
1955
1956          ;; When halting the system, 'udev' is actually killed by
1957          ;; 'user-processes', i.e., before its own 'stop' method was called.
1958          ;; Thus, make sure it is not respawned.
1959          (respawn? #f)
1960          ;; We need additional modules.
1961          (modules `((gnu build linux-boot)
1962                     ,@%default-modules))))))))
1963
1964 (define udev-service-type
1965   (service-type (name 'udev)
1966                 (extensions
1967                  (list (service-extension shepherd-root-service-type
1968                                           udev-shepherd-service)))
1969
1970                 (compose concatenate)           ;concatenate the list of rules
1971                 (extend (lambda (config rules)
1972                           (match config
1973                             (($ <udev-configuration> udev initial-rules)
1974                              (udev-configuration
1975                               (udev udev)
1976                               (rules (append initial-rules rules)))))))
1977                 (description
1978                  "Run @command{udev}, which populates the @file{/dev}
1979 directory dynamically.  Get extra rules from the packages listed in the
1980 @code{rules} field of its value, @code{udev-configuration} object.")))
1981
1982 (define* (udev-service #:key (udev eudev) (rules '()))
1983   "Run @var{udev}, which populates the @file{/dev} directory dynamically.  Get
1984 extra rules from the packages listed in @var{rules}."
1985   (service udev-service-type
1986            (udev-configuration (udev udev) (rules rules))))
1987
1988 (define swap-service-type
1989   (shepherd-service-type
1990    'swap
1991    (lambda (device)
1992      (define requirement
1993        (if (string-prefix? "/dev/mapper/" device)
1994            (list (symbol-append 'device-mapping-
1995                                 (string->symbol (basename device))))
1996            '()))
1997
1998      (shepherd-service
1999       (provision (list (symbol-append 'swap- (string->symbol device))))
2000       (requirement `(udev ,@requirement))
2001       (documentation "Enable the given swap device.")
2002       (start #~(lambda ()
2003                  (restart-on-EINTR (swapon #$device))
2004                  #t))
2005       (stop #~(lambda _
2006                 (restart-on-EINTR (swapoff #$device))
2007                 #f))
2008       (respawn? #f)))))
2009
2010 (define (swap-service device)
2011   "Return a service that uses @var{device} as a swap device."
2012   (service swap-service-type device))
2013
2014 (define %default-gpm-options
2015   ;; Default options for GPM.
2016   '("-m" "/dev/input/mice" "-t" "ps2"))
2017
2018 (define-record-type* <gpm-configuration>
2019   gpm-configuration make-gpm-configuration gpm-configuration?
2020   (gpm      gpm-configuration-gpm                 ;package
2021             (default gpm))
2022   (options  gpm-configuration-options             ;list of strings
2023             (default %default-gpm-options)))
2024
2025 (define gpm-shepherd-service
2026   (match-lambda
2027     (($ <gpm-configuration> gpm options)
2028      (list (shepherd-service
2029             (requirement '(udev))
2030             (provision '(gpm))
2031             (start #~(lambda ()
2032                        ;; 'gpm' runs in the background and sets a PID file.
2033                        ;; Note that it requires running as "root".
2034                        (false-if-exception (delete-file "/var/run/gpm.pid"))
2035                        (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2036                                                 #$@options))
2037
2038                        ;; Wait for the PID file to appear; declare failure if
2039                        ;; it doesn't show up.
2040                        (let loop ((i 3))
2041                          (or (file-exists? "/var/run/gpm.pid")
2042                              (if (zero? i)
2043                                  #f
2044                                  (begin
2045                                    (sleep 1)
2046                                    (loop (1- i))))))))
2047
2048             (stop #~(lambda (_)
2049                       ;; Return #f if successfully stopped.
2050                       (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2051                                            "-k"))))))))))
2052
2053 (define gpm-service-type
2054   (service-type (name 'gpm)
2055                 (extensions
2056                  (list (service-extension shepherd-root-service-type
2057                                           gpm-shepherd-service)))
2058                 (default-value (gpm-configuration))
2059                 (description
2060                  "Run GPM, the general-purpose mouse daemon, with the given
2061 command-line options.  GPM allows users to use the mouse in the console,
2062 notably to select, copy, and paste text.  The default options use the
2063 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2064
2065 (define* (gpm-service #:key (gpm gpm)             ;deprecated
2066                       (options %default-gpm-options))
2067   "Run @var{gpm}, the general-purpose mouse daemon, with the given
2068 command-line @var{options}.  GPM allows users to use the mouse in the console,
2069 notably to select, copy, and paste text.  The default value of @var{options}
2070 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2071
2072 This service is not part of @var{%base-services}."
2073   ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2074   ;; "info mice" and "mouse_set X" to use the right mouse.
2075   (service gpm-service-type
2076            (gpm-configuration (gpm gpm) (options options))))
2077
2078 (define-record-type* <kmscon-configuration>
2079   kmscon-configuration     make-kmscon-configuration
2080   kmscon-configuration?
2081   (kmscon                  kmscon-configuration-kmscon
2082                            (default kmscon))
2083   (virtual-terminal        kmscon-configuration-virtual-terminal)
2084   (login-program           kmscon-configuration-login-program
2085                            (default (file-append shadow "/bin/login")))
2086   (login-arguments         kmscon-configuration-login-arguments
2087                            (default '("-p")))
2088   (auto-login              kmscon-configuration-auto-login
2089                            (default #f))
2090   (hardware-acceleration?  kmscon-configuration-hardware-acceleration?
2091                            (default #f))) ; #t causes failure
2092
2093 (define kmscon-service-type
2094   (shepherd-service-type
2095    'kmscon
2096    (lambda (config)
2097      (let ((kmscon (kmscon-configuration-kmscon config))
2098            (virtual-terminal (kmscon-configuration-virtual-terminal config))
2099            (login-program (kmscon-configuration-login-program config))
2100            (login-arguments (kmscon-configuration-login-arguments config))
2101            (auto-login (kmscon-configuration-auto-login config))
2102            (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2103
2104        (define kmscon-command
2105          #~(list
2106             #$(file-append kmscon "/bin/kmscon") "--login"
2107             "--vt" #$virtual-terminal
2108             "--no-switchvt" ;Prevent a switch to the virtual terminal.
2109             #$@(if hardware-acceleration? '("--hwaccel") '())
2110             "--login" "--"
2111             #$login-program #$@login-arguments
2112             #$@(if auto-login
2113                    #~(#$auto-login)
2114                    #~())))
2115
2116        (shepherd-service
2117         (documentation "kmscon virtual terminal")
2118         (requirement '(user-processes udev dbus-system virtual-terminal))
2119         (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2120         (start #~(make-forkexec-constructor #$kmscon-command))
2121         (stop #~(make-kill-destructor)))))))
2122
2123 (define-record-type* <static-networking>
2124   static-networking make-static-networking
2125   static-networking?
2126   (interface static-networking-interface)
2127   (ip static-networking-ip)
2128   (netmask static-networking-netmask
2129            (default #f))
2130   (gateway static-networking-gateway              ;FIXME: doesn't belong here
2131            (default #f))
2132   (provision static-networking-provision
2133              (default #f))
2134   (requirement static-networking-requirement
2135                (default '()))
2136   (name-servers static-networking-name-servers    ;FIXME: doesn't belong here
2137                 (default '())))
2138
2139 (define static-networking-shepherd-service
2140   (match-lambda
2141     (($ <static-networking> interface ip netmask gateway provision
2142                             requirement name-servers)
2143      (let ((loopback? (and provision (memq 'loopback provision))))
2144        (shepherd-service
2145
2146         (documentation
2147          "Bring up the networking interface using a static IP address.")
2148         (requirement requirement)
2149         (provision (or provision
2150                        (list (symbol-append 'networking-
2151                                             (string->symbol interface)))))
2152
2153         (start #~(lambda _
2154                    ;; Return #t if successfully started.
2155                    (let* ((addr     (inet-pton AF_INET #$ip))
2156                           (sockaddr (make-socket-address AF_INET addr 0))
2157                           (mask     (and #$netmask
2158                                          (inet-pton AF_INET #$netmask)))
2159                           (maskaddr (and mask
2160                                          (make-socket-address AF_INET
2161                                                               mask 0)))
2162                           (gateway  (and #$gateway
2163                                          (inet-pton AF_INET #$gateway)))
2164                           (gatewayaddr (and gateway
2165                                             (make-socket-address AF_INET
2166                                                                  gateway 0))))
2167                      (configure-network-interface #$interface sockaddr
2168                                                   (logior IFF_UP
2169                                                           #$(if loopback?
2170                                                                 #~IFF_LOOPBACK
2171                                                                 0))
2172                                                   #:netmask maskaddr)
2173                      (when gateway
2174                        (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2175                          (add-network-route/gateway sock gatewayaddr)
2176                          (close-port sock))))))
2177         (stop #~(lambda _
2178                   ;; Return #f is successfully stopped.
2179                   (let ((sock (socket AF_INET SOCK_STREAM 0)))
2180                     (when #$gateway
2181                       (delete-network-route sock
2182                                             (make-socket-address
2183                                              AF_INET INADDR_ANY 0)))
2184                     (set-network-interface-flags sock #$interface 0)
2185                     (close-port sock)
2186                     #f)))
2187         (respawn? #f))))))
2188
2189 (define (static-networking-etc-files interfaces)
2190   "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2191   (match (delete-duplicates
2192           (append-map static-networking-name-servers
2193                       interfaces))
2194     (()
2195      '())
2196     ((name-servers ...)
2197      (let ((content (string-join
2198                      (map (cut string-append "nameserver " <>)
2199                           name-servers)
2200                      "\n" 'suffix)))
2201        `(("resolv.conf"
2202           ,(plain-file "resolv.conf"
2203                        (string-append "\
2204 # Generated by 'static-networking-service'.\n"
2205                                       content))))))))
2206
2207 (define (static-networking-shepherd-services interfaces)
2208   "Return the list of Shepherd services to bring up INTERFACES, a list of
2209 <static-networking> objects."
2210   (define (loopback? service)
2211     (memq 'loopback (shepherd-service-provision service)))
2212
2213   (let ((services (map static-networking-shepherd-service interfaces)))
2214     (match (remove loopback? services)
2215       (()
2216        ;; There's no interface other than 'loopback', so we assume that the
2217        ;; 'networking' service will be provided by dhclient or similar.
2218        services)
2219       ((non-loopback ...)
2220        ;; Assume we're providing all the interfaces, and thus, provide a
2221        ;; 'networking' service.
2222        (cons (shepherd-service
2223               (provision '(networking))
2224               (requirement (append-map shepherd-service-provision
2225                                        services))
2226               (start #~(const #t))
2227               (stop #~(const #f))
2228               (documentation "Bring up all the networking interfaces."))
2229              services)))))
2230
2231 (define static-networking-service-type
2232   ;; The service type for statically-defined network interfaces.
2233   (service-type (name 'static-networking)
2234                 (extensions
2235                  (list
2236                   (service-extension shepherd-root-service-type
2237                                      static-networking-shepherd-services)
2238                   (service-extension etc-service-type
2239                                      static-networking-etc-files)))
2240                 (compose concatenate)
2241                 (extend append)
2242                 (description
2243                  "Turn up the specified network interfaces upon startup,
2244 with the given IP address, gateway, netmask, and so on.  The value for
2245 services of this type is a list of @code{static-networking} objects, one per
2246 network interface.")))
2247
2248 (define* (static-networking-service interface ip
2249                                     #:key
2250                                     netmask gateway provision
2251                                     ;; Most interfaces require udev to be usable.
2252                                     (requirement '(udev))
2253                                     (name-servers '()))
2254   "Return a service that starts @var{interface} with address @var{ip}.  If
2255 @var{netmask} is true, use it as the network mask.  If @var{gateway} is true,
2256 it must be a string specifying the default network gateway.
2257
2258 This procedure can be called several times, one for each network
2259 interface of interest.  Behind the scenes what it does is extend
2260 @code{static-networking-service-type} with additional network interfaces
2261 to handle."
2262   (simple-service 'static-network-interface
2263                   static-networking-service-type
2264                   (list (static-networking (interface interface) (ip ip)
2265                                            (netmask netmask) (gateway gateway)
2266                                            (provision provision)
2267                                            (requirement requirement)
2268                                            (name-servers name-servers)))))
2269
2270 \f
2271 (define %base-services
2272   ;; Convenience variable holding the basic services.
2273   (list (login-service)
2274
2275         (service virtual-terminal-service-type)
2276         (service console-font-service-type
2277                  (map (lambda (tty)
2278                         (cons tty %default-console-font))
2279                       '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2280
2281         (agetty-service (agetty-configuration
2282                          (extra-options '("-L")) ; no carrier detect
2283                          (term "vt100")
2284                          (tty #f))) ; automatic
2285
2286         (mingetty-service (mingetty-configuration
2287                            (tty "tty1")))
2288         (mingetty-service (mingetty-configuration
2289                            (tty "tty2")))
2290         (mingetty-service (mingetty-configuration
2291                            (tty "tty3")))
2292         (mingetty-service (mingetty-configuration
2293                            (tty "tty4")))
2294         (mingetty-service (mingetty-configuration
2295                            (tty "tty5")))
2296         (mingetty-service (mingetty-configuration
2297                            (tty "tty6")))
2298
2299         (service static-networking-service-type
2300                  (list (static-networking (interface "lo")
2301                                           (ip "127.0.0.1")
2302                                           (requirement '())
2303                                           (provision '(loopback)))))
2304         (syslog-service)
2305         (service urandom-seed-service-type)
2306         (guix-service)
2307         (nscd-service)
2308
2309         ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2310         ;; used, so enable them by default.  The FUSE and ALSA rules are
2311         ;; less critical, but handy.
2312         (udev-service #:rules (list lvm2 fuse alsa-utils crda))
2313
2314         (service special-files-service-type
2315                  `(("/bin/sh" ,(file-append (canonical-package bash)
2316                                             "/bin/sh"))))))
2317
2318 ;;; base.scm ends here