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