gnu/services/base.scm

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