gnu/services/networking.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
   5 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
   6 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
   7 ;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
   8 ;;; Copyright © 2017, 2018 Marius Bakke <mbakke@fastmail.com>
   9 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
  11 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
  12 ;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de>
  13 ;;; Copyright © 2019, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  14 ;;; Copyright © 2019 Sou Bunnbu <iyzsong@member.fsf.org>
  15 ;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
  16 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
  17 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
  18 ;;; Copyright © 2021 Christine Lemmer-Webber <cwebber@dustycloud.org>
  19 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
  20 ;;; Copyright © 2021 Guillaume Le Vaillant <glv@posteo.net>
  21 ;;;
  22 ;;; This file is part of GNU Guix.
  23 ;;;
  24 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  25 ;;; under the terms of the GNU General Public License as published by
  26 ;;; the Free Software Foundation; either version 3 of the License, or (at
  27 ;;; your option) any later version.
  28 ;;;
  29 ;;; GNU Guix is distributed in the hope that it will be useful, but
  30 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  31 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  32 ;;; GNU General Public License for more details.
  33 ;;;
  34 ;;; You should have received a copy of the GNU General Public License
  35 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  36
  37 (define-module (gnu services networking)
  38   #:use-module (gnu services)
  39   #:use-module (gnu services base)
  40   #:use-module (gnu services configuration)
  41   #:use-module (gnu services linux)
  42   #:use-module (gnu services shepherd)
  43   #:use-module (gnu services dbus)
  44   #:use-module (gnu services admin)
  45   #:use-module (gnu system shadow)
  46   #:use-module (gnu system pam)
  47   #:use-module ((gnu system file-systems) #:select (file-system-mapping))
  48   #:use-module (gnu packages admin)
  49   #:use-module (gnu packages base)
  50   #:use-module (gnu packages bash)
  51   #:use-module (gnu packages cluster)
  52   #:use-module (gnu packages connman)
  53   #:use-module (gnu packages freedesktop)
  54   #:use-module (gnu packages linux)
  55   #:use-module (gnu packages tor)
  56   #:use-module (gnu packages usb-modeswitch)
  57   #:use-module (gnu packages messaging)
  58   #:use-module (gnu packages networking)
  59   #:use-module (gnu packages ntp)
  60   #:use-module (gnu packages gnome)
  61   #:use-module (gnu packages ipfs)
  62   #:use-module (gnu build linux-container)
  63   #:autoload   (guix least-authority) (least-authority-wrapper)
  64   #:use-module (guix gexp)
  65   #:use-module (guix records)
  66   #:use-module (guix modules)
  67   #:use-module (guix packages)
  68   #:use-module (guix deprecation)
  69   #:use-module (guix diagnostics)
  70   #:autoload   (guix ui) (display-hint)
  71   #:use-module (guix i18n)
  72   #:use-module (rnrs enums)
  73   #:use-module (srfi srfi-1)
  74   #:use-module (srfi srfi-9)
  75   #:use-module (srfi srfi-26)
  76   #:use-module (srfi srfi-43)
  77   #:use-module (ice-9 match)
  78   #:use-module (json)
  79   #:re-export (static-networking-service
  80                static-networking-service-type)
  81   #:export (%facebook-host-aliases
  82             dhcp-client-service-type
  83             dhcp-client-configuration
  84             dhcp-client-configuration?
  85             dhcp-client-configuration-package
  86             dhcp-client-configuration-interfaces
  87
  88             dhcpd-service-type
  89             dhcpd-configuration
  90             dhcpd-configuration?
  91             dhcpd-configuration-package
  92             dhcpd-configuration-config-file
  93             dhcpd-configuration-version
  94             dhcpd-configuration-run-directory
  95             dhcpd-configuration-lease-file
  96             dhcpd-configuration-pid-file
  97             dhcpd-configuration-interfaces
  98
  99             ntp-configuration
 100             ntp-configuration?
 101             ntp-configuration-ntp
 102             ntp-configuration-servers
 103             ntp-allow-large-adjustment?
 104
 105             %ntp-servers
 106             ntp-server
 107             ntp-server-type
 108             ntp-server-address
 109             ntp-server-options
 110
 111             ntp-service-type
 112
 113             %openntpd-servers
 114             openntpd-configuration
 115             openntpd-configuration?
 116             openntpd-service-type
 117
 118             inetd-configuration
 119             inetd-entry
 120             inetd-service-type
 121
 122             opendht-configuration
 123             opendht-configuration-peer-discovery?
 124             opendht-configuration-verbose?
 125             opendht-configuration-bootstrap-host
 126             opendht-configuration-port
 127             opendht-configuration-proxy-server-port
 128             opendht-configuration-proxy-server-port-tls
 129             opendht-configuration->command-line-arguments
 130
 131             opendht-shepherd-service
 132             opendht-service-type
 133
 134             tor-configuration
 135             tor-configuration?
 136             tor-hidden-service
 137             tor-service-type
 138
 139             network-manager-configuration
 140             network-manager-configuration?
 141             network-manager-configuration-dns
 142             network-manager-configuration-vpn-plugins
 143             network-manager-service-type
 144
 145             connman-configuration
 146             connman-configuration?
 147             connman-service-type
 148
 149             modem-manager-configuration
 150             modem-manager-configuration?
 151             modem-manager-service-type
 152
 153             usb-modeswitch-configuration
 154             usb-modeswitch-configuration?
 155             usb-modeswitch-configuration-usb-modeswitch
 156             usb-modeswitch-configuration-usb-modeswitch-data
 157             usb-modeswitch-service-type
 158
 159             wpa-supplicant-configuration
 160             wpa-supplicant-configuration?
 161             wpa-supplicant-configuration-wpa-supplicant
 162             wpa-supplicant-configuration-requirement
 163             wpa-supplicant-configuration-pid-file
 164             wpa-supplicant-configuration-dbus?
 165             wpa-supplicant-configuration-interface
 166             wpa-supplicant-configuration-config-file
 167             wpa-supplicant-configuration-extra-options
 168             wpa-supplicant-service-type
 169
 170             hostapd-configuration
 171             hostapd-configuration?
 172             hostapd-configuration-package
 173             hostapd-configuration-interface
 174             hostapd-configuration-ssid
 175             hostapd-configuration-broadcast-ssid?
 176             hostapd-configuration-channel
 177             hostapd-configuration-driver
 178             hostapd-service-type
 179
 180             simulated-wifi-service-type
 181
 182             openvswitch-service-type
 183             openvswitch-configuration
 184
 185             iptables-configuration
 186             iptables-configuration?
 187             iptables-configuration-iptables
 188             iptables-configuration-ipv4-rules
 189             iptables-configuration-ipv6-rules
 190             iptables-service-type
 191
 192             nftables-service-type
 193             nftables-configuration
 194             nftables-configuration?
 195             nftables-configuration-package
 196             nftables-configuration-ruleset
 197             %default-nftables-ruleset
 198
 199             pagekite-service-type
 200             pagekite-configuration
 201             pagekite-configuration?
 202             pagekite-configuration-package
 203             pagekite-configuration-kitename
 204             pagekite-configuration-kitesecret
 205             pagekite-configuration-frontend
 206             pagekite-configuration-kites
 207             pagekite-configuration-extra-file
 208
 209             yggdrasil-service-type
 210             yggdrasil-configuration
 211             yggdrasil-configuration?
 212             yggdrasil-configuration-autoconf?
 213             yggdrasil-configuration-config-file
 214             yggdrasil-configuration-log-level
 215             yggdrasil-configuration-log-to
 216             yggdrasil-configuration-json-config
 217             yggdrasil-configuration-package
 218
 219             ipfs-service-type
 220             ipfs-configuration
 221             ipfs-configuration?
 222             ipfs-configuration-package
 223             ipfs-configuration-gateway
 224             ipfs-configuration-api
 225
 226             keepalived-configuration
 227             keepalived-configuration?
 228             keepalived-service-type))
 229
 230 ;;; Commentary:
 231 ;;;
 232 ;;; Networking services.
 233 ;;;
 234 ;;; Code:
 235
 236 (define %facebook-host-aliases
 237   ;; This is the list of known Facebook hosts to be added to /etc/hosts if you
 238   ;; are to block it.
 239   "\
 240 # Block Facebook IPv4.
 241 127.0.0.1   www.facebook.com
 242 127.0.0.1   facebook.com
 243 127.0.0.1   login.facebook.com
 244 127.0.0.1   www.login.facebook.com
 245 127.0.0.1   fbcdn.net
 246 127.0.0.1   www.fbcdn.net
 247 127.0.0.1   fbcdn.com
 248 127.0.0.1   www.fbcdn.com
 249 127.0.0.1   static.ak.fbcdn.net
 250 127.0.0.1   static.ak.connect.facebook.com
 251 127.0.0.1   connect.facebook.net
 252 127.0.0.1   www.connect.facebook.net
 253 127.0.0.1   apps.facebook.com
 254
 255 # Block Facebook IPv6.
 256 fe80::1%lo0 facebook.com
 257 fe80::1%lo0 login.facebook.com
 258 fe80::1%lo0 www.login.facebook.com
 259 fe80::1%lo0 fbcdn.net
 260 fe80::1%lo0 www.fbcdn.net
 261 fe80::1%lo0 fbcdn.com
 262 fe80::1%lo0 www.fbcdn.com
 263 fe80::1%lo0 static.ak.fbcdn.net
 264 fe80::1%lo0 static.ak.connect.facebook.com
 265 fe80::1%lo0 connect.facebook.net
 266 fe80::1%lo0 www.connect.facebook.net
 267 fe80::1%lo0 apps.facebook.com\n")
 268
 269
 270 (define-record-type* <dhcp-client-configuration>
 271   dhcp-client-configuration make-dhcp-client-configuration
 272   dhcp-client-configuration?
 273   (package      dhcp-client-configuration-package ;file-like
 274                 (default isc-dhcp))
 275   (interfaces   dhcp-client-configuration-interfaces
 276                 (default 'all)))                  ;'all | list of strings
 277
 278 (define dhcp-client-shepherd-service
 279   (match-lambda
 280     (($ <dhcp-client-configuration> package interfaces)
 281      (let ((pid-file "/var/run/dhclient.pid"))
 282        (list (shepherd-service
 283               (documentation "Set up networking via DHCP.")
 284               (requirement '(user-processes udev))
 285
 286               ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
 287               ;; networking is unavailable, but also means that the interface is not up
 288               ;; yet when 'start' completes.  To wait for the interface to be ready, one
 289               ;; should instead monitor udev events.
 290               (provision '(networking))
 291
 292               (start #~(lambda _
 293                          (define dhclient
 294                            (string-append #$package "/sbin/dhclient"))
 295
 296                          ;; When invoked without any arguments, 'dhclient' discovers all
 297                          ;; non-loopback interfaces *that are up*.  However, the relevant
 298                          ;; interfaces are typically down at this point.  Thus we perform
 299                          ;; our own interface discovery here.
 300                          (define valid?
 301                            (lambda (interface)
 302                              (and (arp-network-interface? interface)
 303                                   (not (loopback-network-interface? interface))
 304                                   ;; XXX: Make sure the interfaces are up so that
 305                                   ;; 'dhclient' can actually send/receive over them.
 306                                   ;; Ignore those that cannot be activated.
 307                                   (false-if-exception
 308                                    (set-network-interface-up interface)))))
 309                          (define ifaces
 310                            (filter valid?
 311                                    #$(match interfaces
 312                                        ('all
 313                                         #~(all-network-interface-names))
 314                                        (_
 315                                         #~'#$interfaces))))
 316
 317                          (false-if-exception (delete-file #$pid-file))
 318                          (let ((pid (fork+exec-command
 319                                      (cons* dhclient "-nw"
 320                                             "-pf" #$pid-file ifaces))))
 321                            (and (zero? (cdr (waitpid pid)))
 322                                 (read-pid-file #$pid-file)))))
 323               (stop #~(make-kill-destructor))))))
 324     (package
 325      (warning (G_ "'dhcp-client' service now expects a \
 326 'dhcp-client-configuration' record~%"))
 327      (display-hint (G_ "The value associated with instances of
 328 @code{dhcp-client-service-type} must now be a @code{dhcp-client-configuration}
 329 record instead of a package.  Please adjust your configuration accordingly."))
 330      (dhcp-client-shepherd-service
 331       (dhcp-client-configuration
 332        (package package))))))
 333
 334 (define dhcp-client-service-type
 335   (service-type (name 'dhcp-client)
 336                 (extensions
 337                  (list (service-extension shepherd-root-service-type
 338                                           dhcp-client-shepherd-service)))
 339                 (default-value (dhcp-client-configuration))
 340                 (description "Run @command{dhcp}, a Dynamic Host Configuration
 341 Protocol (DHCP) client, on all the non-loopback network interfaces.")))
 342
 343 (define-record-type* <dhcpd-configuration>
 344   dhcpd-configuration make-dhcpd-configuration
 345   dhcpd-configuration?
 346   (package   dhcpd-configuration-package ;file-like
 347              (default isc-dhcp))
 348   (config-file   dhcpd-configuration-config-file ;file-like
 349                  (default #f))
 350   (version dhcpd-configuration-version ;"4", "6", or "4o6"
 351               (default "4"))
 352   (run-directory dhcpd-configuration-run-directory
 353                  (default "/run/dhcpd"))
 354   (lease-file dhcpd-configuration-lease-file
 355               (default "/var/db/dhcpd.leases"))
 356   (pid-file dhcpd-configuration-pid-file
 357             (default "/run/dhcpd/dhcpd.pid"))
 358   ;; list of strings, e.g. (list "enp0s25")
 359   (interfaces dhcpd-configuration-interfaces
 360               (default '())))
 361
 362 (define dhcpd-shepherd-service
 363   (match-lambda
 364     (($ <dhcpd-configuration> package config-file version run-directory
 365                               lease-file pid-file interfaces)
 366      (unless config-file
 367        (error "Must supply a config-file"))
 368      (list (shepherd-service
 369             ;; Allow users to easily run multiple versions simultaneously.
 370             (provision (list (string->symbol
 371                               (string-append "dhcpv" version "-daemon"))))
 372             (documentation (string-append "Run the DHCPv" version " daemon"))
 373             (requirement '(networking))
 374             (start #~(make-forkexec-constructor
 375                       '(#$(file-append package "/sbin/dhcpd")
 376                         #$(string-append "-" version)
 377                         "-lf" #$lease-file
 378                         "-pf" #$pid-file
 379                         "-cf" #$config-file
 380                         #$@interfaces)
 381                       #:pid-file #$pid-file))
 382             (stop #~(make-kill-destructor)))))))
 383
 384 (define dhcpd-activation
 385   (match-lambda
 386     (($ <dhcpd-configuration> package config-file version run-directory
 387                               lease-file pid-file interfaces)
 388      (with-imported-modules '((guix build utils))
 389        #~(begin
 390            (unless (file-exists? #$run-directory)
 391              (mkdir #$run-directory))
 392            ;; According to the DHCP manual (man dhcpd.leases), the lease
 393            ;; database must be present for dhcpd to start successfully.
 394            (unless (file-exists? #$lease-file)
 395              (with-output-to-file #$lease-file
 396                (lambda _ (display ""))))
 397            ;; Validate the config.
 398            (invoke/quiet
 399             #$(file-append package "/sbin/dhcpd")
 400             #$(string-append "-" version)
 401             "-t" "-cf" #$config-file))))))
 402
 403 (define dhcpd-service-type
 404   (service-type
 405    (name 'dhcpd)
 406    (extensions
 407     (list (service-extension shepherd-root-service-type dhcpd-shepherd-service)
 408           (service-extension activation-service-type dhcpd-activation)))
 409    (description "Run a DHCP (Dynamic Host Configuration Protocol) daemon.  The
 410 daemon is responsible for allocating IP addresses to its client.")))
 411
 412 \f
 413 ;;;
 414 ;;; NTP.
 415 ;;;
 416
 417
 418 (define %ntp-log-rotation
 419   (list (log-rotation
 420          (files '("/var/log/ntpd.log")))))
 421
 422 (define ntp-server-types (make-enumeration
 423                           '(pool
 424                             server
 425                             peer
 426                             broadcast
 427                             manycastclient)))
 428
 429 (define-record-type* <ntp-server>
 430   ntp-server make-ntp-server
 431   ntp-server?
 432   ;; The type can be one of the symbols of the NTP-SERVER-TYPE? enumeration.
 433   (type ntp-server-type
 434         (default 'server))
 435   (address ntp-server-address)    ; a string
 436   ;; The list of options can contain single option names or tuples in the form
 437   ;; '(name value).
 438   (options ntp-server-options
 439            (default '())))
 440
 441 (define (ntp-server->string ntp-server)
 442   ;; Serialize the NTP server object as a string, ready to use in the NTP
 443   ;; configuration file.
 444   (define (flatten lst)
 445     (reverse
 446      (let loop ((x lst)
 447                 (res '()))
 448        (if (list? x)
 449            (fold loop res x)
 450            (cons (format #f "~a" x) res)))))
 451
 452   (match ntp-server
 453     (($ <ntp-server> type address options)
 454      ;; XXX: It'd be neater if fields were validated at the syntax level (for
 455      ;; static ones at least).  Perhaps the Guix record type could support a
 456      ;; predicate property on a field?
 457      (unless (enum-set-member? type ntp-server-types)
 458        (error "Invalid NTP server type" type))
 459      (string-join (cons* (symbol->string type)
 460                          address
 461                          (flatten options))))))
 462
 463 (define %ntp-servers
 464   ;; Default set of NTP servers. These URLs are managed by the NTP Pool project.
 465   ;; Within Guix, Leo Famulari <leo@famulari.name> is the administrative contact
 466   ;; for this NTP pool "zone".
 467   ;; The full list of available URLs are 0.guix.pool.ntp.org,
 468   ;; 1.guix.pool.ntp.org, 2.guix.pool.ntp.org, and 3.guix.pool.ntp.org.
 469   (list
 470    (ntp-server
 471     (type 'pool)
 472     (address "0.guix.pool.ntp.org")
 473     (options '("iburst")))))               ;as recommended in the ntpd manual
 474
 475 (define-record-type* <ntp-configuration>
 476   ntp-configuration make-ntp-configuration
 477   ntp-configuration?
 478   (ntp      ntp-configuration-ntp
 479             (default ntp))
 480   (servers  %ntp-configuration-servers   ;list of <ntp-server> objects
 481             (default %ntp-servers))
 482   (allow-large-adjustment? ntp-allow-large-adjustment?
 483                            (default #t))) ;as recommended in the ntpd manual
 484
 485 (define (ntp-configuration-servers ntp-configuration)
 486   ;; A wrapper to support the deprecated form of this field.
 487   (let ((ntp-servers (%ntp-configuration-servers ntp-configuration)))
 488     (match ntp-servers
 489       (((? string?) (? string?) ...)
 490        (format (current-error-port) "warning: Defining NTP servers as strings is \
 491 deprecated.  Please use <ntp-server> records instead.\n")
 492        (map (lambda (addr)
 493               (ntp-server
 494                (type 'server)
 495                (address addr)
 496                (options '()))) ntp-servers))
 497       ((($ <ntp-server>) ($ <ntp-server>) ...)
 498        ntp-servers))))
 499
 500 (define ntp-shepherd-service
 501   (lambda (config)
 502     (match config
 503       (($ <ntp-configuration> ntp servers allow-large-adjustment?)
 504        (let ((servers (ntp-configuration-servers config)))
 505          ;; TODO: Add authentication support.
 506          (define config
 507            (string-append "driftfile /var/run/ntpd/ntp.drift\n"
 508                           (string-join (map ntp-server->string servers)
 509                                        "\n")
 510                           "
 511 # Disable status queries as a workaround for CVE-2013-5211:
 512 # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
 513 restrict default kod nomodify notrap nopeer noquery limited
 514 restrict -6 default kod nomodify notrap nopeer noquery limited
 515
 516 # Yet, allow use of the local 'ntpq'.
 517 restrict 127.0.0.1
 518 restrict -6 ::1
 519
 520 # This is required to use servers from a pool directive when using the 'nopeer'
 521 # option by default, as documented in the 'ntp.conf' manual.
 522 restrict source notrap nomodify noquery\n"))
 523
 524          (define ntpd.conf
 525            (plain-file "ntpd.conf" config))
 526
 527          (list (shepherd-service
 528                 (provision '(ntpd))
 529                 (documentation "Run the Network Time Protocol (NTP) daemon.")
 530                 (requirement '(user-processes networking))
 531                 (start #~(make-forkexec-constructor
 532                           (list (string-append #$ntp "/bin/ntpd") "-n"
 533                                 "-c" #$ntpd.conf "-u" "ntpd"
 534                                 #$@(if allow-large-adjustment?
 535                                        '("-g")
 536                                        '()))
 537                           #:log-file "/var/log/ntpd.log"))
 538                 (stop #~(make-kill-destructor)))))))))
 539
 540 (define %ntp-accounts
 541   (list (user-account
 542          (name "ntpd")
 543          (group "nogroup")
 544          (system? #t)
 545          (comment "NTP daemon user")
 546          (home-directory "/var/empty")
 547          (shell (file-append shadow "/sbin/nologin")))))
 548
 549
 550 (define (ntp-service-activation config)
 551   "Return the activation gexp for CONFIG."
 552   (with-imported-modules '((guix build utils))
 553     #~(begin
 554         (use-modules (guix build utils))
 555         (define %user
 556           (getpw "ntpd"))
 557
 558         (let ((directory "/var/run/ntpd"))
 559           (mkdir-p directory)
 560           (chown directory (passwd:uid %user) (passwd:gid %user))))))
 561
 562 (define ntp-service-type
 563   (service-type (name 'ntp)
 564                 (extensions
 565                  (list (service-extension shepherd-root-service-type
 566                                           ntp-shepherd-service)
 567                        (service-extension account-service-type
 568                                           (const %ntp-accounts))
 569                        (service-extension activation-service-type
 570                                           ntp-service-activation)
 571                        (service-extension rottlog-service-type
 572                                           (const %ntp-log-rotation))))
 573                 (description
 574                  "Run the @command{ntpd}, the Network Time Protocol (NTP)
 575 daemon of the @uref{http://www.ntp.org, Network Time Foundation}.  The daemon
 576 will keep the system clock synchronized with that of the given servers.")
 577                 (default-value (ntp-configuration))))
 578
 579 \f
 580 ;;;
 581 ;;; OpenNTPD.
 582 ;;;
 583
 584 (define %openntpd-servers
 585   (map ntp-server-address %ntp-servers))
 586
 587 (define-record-type* <openntpd-configuration>
 588   openntpd-configuration make-openntpd-configuration
 589   openntpd-configuration?
 590   (openntpd                openntpd-configuration-openntpd
 591                            (default openntpd))
 592   (listen-on               openntpd-listen-on
 593                            (default '("127.0.0.1"
 594                                       "::1")))
 595   (query-from              openntpd-query-from
 596                            (default '()))
 597   (sensor                  openntpd-sensor
 598                            (default '()))
 599   (server                  openntpd-server
 600                            (default '()))
 601   (servers                 openntpd-servers
 602                            (default %openntpd-servers))
 603   (constraint-from         openntpd-constraint-from
 604                            (default '()))
 605   (constraints-from        openntpd-constraints-from
 606                            (default '())))
 607
 608 (define (openntpd-configuration->string config)
 609
 610   (define (quote-field? name)
 611     (member name '("constraints from")))
 612
 613   (match-record config <openntpd-configuration>
 614     (listen-on query-from sensor server servers constraint-from
 615                constraints-from)
 616     (string-append
 617      (string-join
 618       (concatenate
 619        (filter-map (lambda (field values)
 620                      (match values
 621                        (() #f)          ;discard entry with filter-map
 622                        ((val ...)       ;validate value type
 623                         (map (lambda (value)
 624                                (if (quote-field? field)
 625                                    (format #f "~a \"~a\"" field value)
 626                                    (format #f "~a ~a" field value)))
 627                              values))))
 628                    ;; The entry names.
 629                    '("listen on" "query from" "sensor" "server" "servers"
 630                      "constraint from" "constraints from")
 631                    ;; The corresponding entry values.
 632                    (list listen-on query-from sensor server servers
 633                          constraint-from constraints-from)))
 634       "\n")
 635      "\n")))                              ;add a trailing newline
 636
 637 (define (openntpd-shepherd-service config)
 638   (let ((openntpd (openntpd-configuration-openntpd config)))
 639
 640     (define ntpd.conf
 641       (plain-file "ntpd.conf" (openntpd-configuration->string config)))
 642
 643     (list (shepherd-service
 644            (provision '(ntpd))
 645            (documentation "Run the Network Time Protocol (NTP) daemon.")
 646            (requirement '(user-processes networking))
 647            (start #~(make-forkexec-constructor
 648                      (list (string-append #$openntpd "/sbin/ntpd")
 649                            "-f" #$ntpd.conf
 650                            "-d") ;; don't daemonize
 651                      ;; When ntpd is daemonized it repeatedly tries to respawn
 652                      ;; while running, leading shepherd to disable it.  To
 653                      ;; prevent spamming stderr, redirect output to logfile.
 654                      #:log-file "/var/log/ntpd.log"))
 655            (stop #~(make-kill-destructor))
 656            (actions (list (shepherd-configuration-action ntpd.conf)))))))
 657
 658 (define (openntpd-service-activation config)
 659   "Return the activation gexp for CONFIG."
 660   (with-imported-modules '((guix build utils))
 661     #~(begin
 662         (use-modules (guix build utils))
 663
 664         (mkdir-p "/var/db")
 665         (mkdir-p "/var/run")
 666         (unless (file-exists? "/var/db/ntpd.drift")
 667           (with-output-to-file "/var/db/ntpd.drift"
 668                                (lambda _
 669                                  (format #t "0.0")))))))
 670
 671 (define openntpd-service-type
 672   (service-type (name 'openntpd)
 673                 (extensions
 674                  (list (service-extension shepherd-root-service-type
 675                                           openntpd-shepherd-service)
 676                        (service-extension account-service-type
 677                                           (const %ntp-accounts))
 678                        (service-extension profile-service-type
 679                                           (compose list openntpd-configuration-openntpd))
 680                        (service-extension activation-service-type
 681                                           openntpd-service-activation)
 682                        (service-extension rottlog-service-type
 683                                           (const %ntp-log-rotation))))
 684                 (default-value (openntpd-configuration))
 685                 (description
 686                  "Run the @command{ntpd}, the Network Time Protocol (NTP)
 687 daemon, as implemented by @uref{http://www.openntpd.org, OpenNTPD}.  The
 688 daemon will keep the system clock synchronized with that of the given servers.")))
 689
 690 \f
 691 ;;;
 692 ;;; Inetd.
 693 ;;;
 694
 695 (define-record-type* <inetd-configuration> inetd-configuration
 696   make-inetd-configuration
 697   inetd-configuration?
 698   (program           inetd-configuration-program   ;file-like
 699                      (default (file-append inetutils "/libexec/inetd")))
 700   (entries           inetd-configuration-entries   ;list of <inetd-entry>
 701                      (default '())))
 702
 703 (define-record-type* <inetd-entry> inetd-entry make-inetd-entry
 704   inetd-entry?
 705   (node              inetd-entry-node         ;string or #f
 706                      (default #f))
 707   (name              inetd-entry-name)        ;string, from /etc/services
 708
 709   (socket-type       inetd-entry-socket-type) ;stream | dgram | raw |
 710                                               ;rdm | seqpacket
 711   (protocol          inetd-entry-protocol)    ;string, from /etc/protocols
 712
 713   (wait?             inetd-entry-wait?        ;Boolean
 714                      (default #t))
 715   (user              inetd-entry-user)        ;string
 716
 717   (program           inetd-entry-program      ;string or file-like object
 718                      (default "internal"))
 719   (arguments         inetd-entry-arguments    ;list of strings or file-like objects
 720                      (default '())))
 721
 722 (define (inetd-config-file entries)
 723   (apply mixed-text-file "inetd.conf"
 724          (map
 725           (lambda (entry)
 726             (let* ((node (inetd-entry-node entry))
 727                    (name (inetd-entry-name entry))
 728                    (socket
 729                     (if node (string-append node ":" name) name))
 730                    (type
 731                     (match (inetd-entry-socket-type entry)
 732                       ((or 'stream 'dgram 'raw 'rdm 'seqpacket)
 733                        (symbol->string (inetd-entry-socket-type entry)))))
 734                    (protocol (inetd-entry-protocol entry))
 735                    (wait (if (inetd-entry-wait? entry) "wait" "nowait"))
 736                    (user (inetd-entry-user entry))
 737                    (program (inetd-entry-program entry))
 738                    (args (inetd-entry-arguments entry)))
 739               #~(string-append
 740                  (string-join
 741                   (list #$@(list socket type protocol wait user program) #$@args)
 742                   " ") "\n")))
 743           entries)))
 744
 745 (define inetd-shepherd-service
 746   (match-lambda
 747     (($ <inetd-configuration> program ()) '()) ; empty list of entries -> do nothing
 748     (($ <inetd-configuration> program entries)
 749      (list
 750       (shepherd-service
 751        (documentation "Run inetd.")
 752        (provision '(inetd))
 753        (requirement '(user-processes networking syslogd))
 754        (start #~(make-forkexec-constructor
 755                  (list #$program #$(inetd-config-file entries))
 756                  #:pid-file "/var/run/inetd.pid"))
 757        (stop #~(make-kill-destructor)))))))
 758
 759 (define-public inetd-service-type
 760   (service-type
 761    (name 'inetd)
 762    (extensions
 763     (list (service-extension shepherd-root-service-type
 764                              inetd-shepherd-service)))
 765
 766    ;; The service can be extended with additional lists of entries.
 767    (compose concatenate)
 768    (extend (lambda (config entries)
 769              (inetd-configuration
 770               (inherit config)
 771               (entries (append (inetd-configuration-entries config)
 772                                entries)))))
 773    (description
 774     "Start @command{inetd}, the @dfn{Internet superserver}.  It is responsible
 775 for listening on Internet sockets and spawning the corresponding services on
 776 demand.")))
 777
 778 \f
 779 ;;;
 780 ;;; OpenDHT, the distributed hash table network used by Jami
 781 ;;;
 782
 783 (define-maybe/no-serialization number)
 784 (define-maybe/no-serialization string)
 785
 786 ;;; To generate the documentation of the following configuration record, you
 787 ;;; can evaluate: (configuration->documentation 'opendht-configuration)
 788 (define-configuration/no-serialization opendht-configuration
 789   (opendht
 790    (file-like opendht)
 791    "The @code{opendht} package to use.")
 792   (peer-discovery?
 793    (boolean #false)
 794    "Whether to enable the multicast local peer discovery mechanism.")
 795   (enable-logging?
 796    (boolean #false)
 797    "Whether to enable logging messages to syslog.  It is disabled by default
 798 as it is rather verbose.")
 799   (debug?
 800    (boolean #false)
 801    "Whether to enable debug-level logging messages.  This has no effect if
 802 logging is disabled.")
 803   (bootstrap-host
 804    (maybe-string "bootstrap.jami.net:4222")
 805    "The node host name that is used to make the first connection to the
 806 network.  A specific port value can be provided by appending the @code{:PORT}
 807 suffix.  By default, it uses the Jami bootstrap nodes, but any host can be
 808 specified here.  It's also possible to disable bootstrapping by explicitly
 809 setting this field to @code{%unset-value}.")
 810   (port
 811    (maybe-number 4222)
 812    "The UDP port to bind to.  When left unspecified, an available port is
 813 automatically selected.")
 814   (proxy-server-port
 815    maybe-number
 816    "Spawn a proxy server listening on the specified port.")
 817   (proxy-server-port-tls
 818    maybe-number
 819    "Spawn a proxy server listening to TLS connections on the specified
 820 port."))
 821
 822 (define %opendht-accounts
 823   ;; User account and groups for Tor.
 824   (list (user-group (name "opendht") (system? #t))
 825         (user-account
 826          (name "opendht")
 827          (group "opendht")
 828          (system? #t)
 829          (comment "OpenDHT daemon user")
 830          (home-directory "/var/empty")
 831          (shell (file-append shadow "/sbin/nologin")))))
 832
 833 (define (opendht-configuration->command-line-arguments config)
 834   "Derive the command line arguments used to launch the OpenDHT daemon from
 835 CONFIG, an <opendht-configuration> object."
 836   (match-record config <opendht-configuration>
 837     (opendht bootstrap-host enable-logging? port debug? peer-discovery?
 838              proxy-server-port proxy-server-port-tls)
 839     (let ((dhtnode (least-authority-wrapper
 840                     ;; XXX: Work around lack of support for multiple outputs
 841                     ;; in 'file-append'.
 842                     (computed-file "dhtnode"
 843                                    #~(symlink
 844                                       (string-append #$opendht:tools
 845                                                      "/bin/dhtnode")
 846                                       #$output))
 847                     #:name "dhtnode"
 848                     #:mappings (list (file-system-mapping
 849                                       (source "/dev/log") ;for syslog
 850                                       (target source)))
 851                     #:namespaces (delq 'net %namespaces))))
 852       `(,dhtnode
 853         "--service"                     ;non-forking mode
 854         ,@(if (string? bootstrap-host)
 855               (list "--bootstrap" bootstrap-host))
 856         ,@(if enable-logging?
 857               (list "--syslog")
 858               '())
 859         ,@(if (number? port)
 860               (list "--port" (number->string port))
 861               '())
 862         ,@(if debug?
 863               (list "--verbose")
 864               '())
 865         ,@(if peer-discovery?
 866               (list "--peer-discovery")
 867               '())
 868         ,@(if (number? proxy-server-port)
 869               (list "--proxyserver" (number->string proxy-server-port))
 870               '())
 871         ,@(if (number? proxy-server-port-tls)
 872               (list "--proxyserverssl" (number->string proxy-server-port-tls))
 873               '())))))
 874
 875 (define (opendht-shepherd-service config)
 876   "Return a <shepherd-service> running OpenDHT."
 877   (shepherd-service
 878    (documentation "Run an OpenDHT node.")
 879    (provision '(opendht dhtnode dhtproxy))
 880    (requirement '(networking syslogd))
 881    (start #~(make-forkexec-constructor
 882              (list #$@(opendht-configuration->command-line-arguments config))
 883              #:user "opendht"
 884              #:group "opendht"))
 885    (stop #~(make-kill-destructor))))
 886
 887 (define opendht-service-type
 888   (service-type
 889    (name 'opendht)
 890    (default-value (opendht-configuration))
 891    (extensions
 892     (list (service-extension shepherd-root-service-type
 893                              (compose list opendht-shepherd-service))
 894           (service-extension account-service-type
 895                              (const %opendht-accounts))))
 896    (description "Run the OpenDHT @command{dhtnode} command that allows
 897 participating in the distributed hash table based OpenDHT network.  The
 898 service can be configured to act as a proxy to the distributed network, which
 899 can be useful for portable devices where minimizing energy consumption is
 900 paramount.  OpenDHT was originally based on Kademlia and adapted for
 901 applications in communication.  It is used by Jami, for example.")))
 902
 903 \f
 904 ;;;
 905 ;;; Tor.
 906 ;;;
 907
 908 (define-record-type* <tor-configuration>
 909   tor-configuration make-tor-configuration
 910   tor-configuration?
 911   (tor              tor-configuration-tor
 912                     (default tor))
 913   (config-file      tor-configuration-config-file
 914                     (default (plain-file "empty" "")))
 915   (hidden-services  tor-configuration-hidden-services
 916                     (default '()))
 917   (socks-socket-type tor-configuration-socks-socket-type ; 'tcp or 'unix
 918                      (default 'tcp))
 919   (control-socket?  tor-control-socket-path
 920                     (default #f)))
 921
 922 (define %tor-accounts
 923   ;; User account and groups for Tor.
 924   (list (user-group (name "tor") (system? #t))
 925         (user-account
 926          (name "tor")
 927          (group "tor")
 928          (system? #t)
 929          (comment "Tor daemon user")
 930          (home-directory "/var/empty")
 931          (shell (file-append shadow "/sbin/nologin")))))
 932
 933 (define-record-type <hidden-service>
 934   (hidden-service name mapping)
 935   hidden-service?
 936   (name    hidden-service-name)                   ;string
 937   (mapping hidden-service-mapping))               ;list of port/address tuples
 938
 939 (define (tor-configuration->torrc config)
 940   "Return a 'torrc' file for CONFIG."
 941   (match config
 942     (($ <tor-configuration> tor config-file services
 943                             socks-socket-type control-socket?)
 944      (computed-file
 945       "torrc"
 946       (with-imported-modules '((guix build utils))
 947         #~(begin
 948             (use-modules (guix build utils)
 949                          (ice-9 match))
 950
 951             (call-with-output-file #$output
 952               (lambda (port)
 953                 (display "\
 954 ### These lines were generated from your system configuration:
 955 DataDirectory /var/lib/tor
 956 Log notice syslog\n" port)
 957                 (when (eq? 'unix '#$socks-socket-type)
 958                   (display "\
 959 SocksPort unix:/var/run/tor/socks-sock
 960 UnixSocksGroupWritable 1\n" port))
 961                 (when #$control-socket?
 962                   (display "\
 963 ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck
 964 ControlSocketsGroupWritable 1\n"
 965                            port))
 966
 967                 (for-each (match-lambda
 968                             ((service (ports hosts) ...)
 969                              (format port "\
 970 HiddenServiceDir /var/lib/tor/hidden-services/~a~%"
 971                                      service)
 972                              (for-each (lambda (tcp-port host)
 973                                          (format port "\
 974 HiddenServicePort ~a ~a~%"
 975                                                  tcp-port host))
 976                                        ports hosts)))
 977                           '#$(map (match-lambda
 978                                     (($ <hidden-service> name mapping)
 979                                      (cons name mapping)))
 980                                   services))
 981
 982                 (display "\
 983 ### End of automatically generated lines.\n\n" port)
 984
 985                 ;; Append the user's config file.
 986                 (call-with-input-file #$config-file
 987                   (lambda (input)
 988                     (dump-port input port)))
 989                 #t))))))))
 990
 991 (define (tor-shepherd-service config)
 992   "Return a <shepherd-service> running Tor."
 993   (match config
 994     (($ <tor-configuration> tor)
 995      (let* ((torrc (tor-configuration->torrc config))
 996             (tor   (least-authority-wrapper
 997                     (file-append tor "/bin/tor")
 998                     #:name "tor"
 999                     #:mappings (list (file-system-mapping
1000                                       (source "/var/lib/tor")
1001                                       (target source)
1002                                       (writable? #t))
1003                                      (file-system-mapping
1004                                       (source "/dev/log") ;for syslog
1005                                       (target source))
1006                                      (file-system-mapping
1007                                       (source "/var/run/tor")
1008                                       (target source)
1009                                       (writable? #t))
1010                                      (file-system-mapping
1011                                       (source torrc)
1012                                       (target source)))
1013                     #:namespaces (delq 'net %namespaces))))
1014        (with-imported-modules (source-module-closure
1015                                '((gnu build shepherd)
1016                                  (gnu system file-systems)))
1017          (list (shepherd-service
1018                 (provision '(tor))
1019
1020                 ;; Tor needs at least one network interface to be up, hence the
1021                 ;; dependency on 'loopback'.
1022                 (requirement '(user-processes loopback syslogd))
1023
1024                 (modules '((gnu build shepherd)
1025                            (gnu system file-systems)))
1026
1027                 ;; XXX: #:pid-file won't work because the wrapped 'tor'
1028                 ;; program would print its PID within the user namespace
1029                 ;; instead of its actual PID outside.  There's no inetd or
1030                 ;; systemd socket activation support either (there's
1031                 ;; 'sd_notify' though), so we're stuck with that.
1032                 (start #~(make-forkexec-constructor
1033                           (list #$tor "-f" #$torrc)
1034                           #:user "tor" #:group "tor"))
1035                 (stop #~(make-kill-destructor))
1036                 (actions (list (shepherd-configuration-action torrc)))
1037                 (documentation "Run the Tor anonymous network overlay."))))))))
1038
1039 (define (tor-activation config)
1040   "Set up directories for Tor and its hidden services, if any."
1041   #~(begin
1042       (use-modules (guix build utils))
1043
1044       (define %user
1045         (getpw "tor"))
1046
1047       (define (initialize service)
1048         (let ((directory (string-append "/var/lib/tor/hidden-services/"
1049                                         service)))
1050           (mkdir-p directory)
1051           (chown directory (passwd:uid %user) (passwd:gid %user))
1052
1053           ;; The daemon bails out if we give wider permissions.
1054           (chmod directory #o700)))
1055
1056       ;; Allow Tor to write its PID file.
1057       (mkdir-p "/var/run/tor")
1058       (chown "/var/run/tor" (passwd:uid %user) (passwd:gid %user))
1059       ;; Set the group permissions to rw so that if the system administrator
1060       ;; has specified UnixSocksGroupWritable=1 in their torrc file, members
1061       ;; of the "tor" group will be able to use the SOCKS socket.
1062       (chmod "/var/run/tor" #o750)
1063
1064       ;; Allow Tor to access the hidden services' directories.
1065       (mkdir-p "/var/lib/tor")
1066       (chown "/var/lib/tor" (passwd:uid %user) (passwd:gid %user))
1067       (chmod "/var/lib/tor" #o700)
1068
1069       ;; Make sure /var/lib is accessible to the 'tor' user.
1070       (chmod "/var/lib" #o755)
1071
1072       (for-each initialize
1073                 '#$(map hidden-service-name
1074                         (tor-configuration-hidden-services config)))))
1075
1076 (define tor-service-type
1077   (service-type (name 'tor)
1078                 (extensions
1079                  (list (service-extension shepherd-root-service-type
1080                                           tor-shepherd-service)
1081                        (service-extension account-service-type
1082                                           (const %tor-accounts))
1083                        (service-extension activation-service-type
1084                                           tor-activation)))
1085
1086                 ;; This can be extended with hidden services.
1087                 (compose concatenate)
1088                 (extend (lambda (config services)
1089                           (tor-configuration
1090                            (inherit config)
1091                            (hidden-services
1092                             (append (tor-configuration-hidden-services config)
1093                                     services)))))
1094                 (default-value (tor-configuration))
1095                 (description
1096                  "Run the @uref{https://torproject.org, Tor} anonymous
1097 networking daemon.")))
1098
1099 (define tor-hidden-service-type
1100   ;; A type that extends Tor with hidden services.
1101   (service-type (name 'tor-hidden-service)
1102                 (extensions
1103                  (list (service-extension tor-service-type list)))
1104                 (description
1105                  "Define a new Tor @dfn{hidden service}.")))
1106
1107 (define (tor-hidden-service name mapping)
1108   "Define a new Tor @dfn{hidden service} called @var{name} and implementing
1109 @var{mapping}.  @var{mapping} is a list of port/host tuples, such as:
1110
1111 @example
1112  '((22 \"127.0.0.1:22\")
1113    (80 \"127.0.0.1:8080\"))
1114 @end example
1115
1116 In this example, port 22 of the hidden service is mapped to local port 22, and
1117 port 80 is mapped to local port 8080.
1118
1119 This creates a @file{/var/lib/tor/hidden-services/@var{name}} directory, where
1120 the @file{hostname} file contains the @code{.onion} host name for the hidden
1121 service.
1122
1123 See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor
1124 project's documentation} for more information."
1125   (service tor-hidden-service-type
1126            (hidden-service name mapping)))
1127
1128 \f
1129 ;;;
1130 ;;; ModemManager
1131 ;;;
1132
1133 (define-record-type* <modem-manager-configuration>
1134   modem-manager-configuration make-modem-manager-configuration
1135   modem-manager-configuration?
1136   (modem-manager modem-manager-configuration-modem-manager
1137                    (default modem-manager)))
1138
1139 \f
1140 ;;;
1141 ;;; NetworkManager
1142 ;;;
1143
1144 (define-record-type* <network-manager-configuration>
1145   network-manager-configuration make-network-manager-configuration
1146   network-manager-configuration?
1147   (network-manager network-manager-configuration-network-manager
1148                    (default network-manager))
1149   (dns network-manager-configuration-dns
1150        (default "default"))
1151   (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like
1152                (default '())))
1153
1154 (define network-manager-activation
1155   ;; Activation gexp for NetworkManager
1156   (match-lambda
1157     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1158      #~(begin
1159          (use-modules (guix build utils))
1160          (mkdir-p "/etc/NetworkManager/system-connections")
1161          #$@(if (equal? dns "dnsmasq")
1162                 ;; create directory to store dnsmasq lease file
1163                 '((mkdir-p "/var/lib/misc"))
1164                 '())))))
1165
1166 (define (vpn-plugin-directory plugins)
1167   "Return a directory containing PLUGINS, the NM VPN plugins."
1168   (directory-union "network-manager-vpn-plugins" plugins))
1169
1170 (define (network-manager-accounts config)
1171   "Return the list of <user-account> and <user-group> for CONFIG."
1172   (define nologin
1173     (file-append shadow "/sbin/nologin"))
1174
1175   (define accounts
1176     (append-map (lambda (package)
1177                   (map (lambda (name)
1178                          (user-account (system? #t)
1179                                        (name name)
1180                                        (group "network-manager")
1181                                        (comment "NetworkManager helper")
1182                                        (home-directory "/var/empty")
1183                                        (create-home-directory? #f)
1184                                        (shell nologin)))
1185                        (or (assoc-ref (package-properties package)
1186                                       'user-accounts)
1187                            '())))
1188                 (network-manager-configuration-vpn-plugins config)))
1189
1190   (match accounts
1191     (()
1192      '())
1193     (_
1194      (cons (user-group (name "network-manager") (system? #t))
1195            accounts))))
1196
1197 (define network-manager-environment
1198   (match-lambda
1199     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1200      ;; Define this variable in the global environment such that
1201      ;; "nmcli connection import type openvpn file foo.ovpn" works.
1202      `(("NM_VPN_PLUGIN_DIR"
1203         . ,(file-append (vpn-plugin-directory vpn-plugins)
1204                         "/lib/NetworkManager/VPN"))))))
1205
1206 (define network-manager-shepherd-service
1207   (match-lambda
1208     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1209      (let ((conf (plain-file "NetworkManager.conf"
1210                              (string-append "[main]\ndns=" dns "\n")))
1211            (vpn  (vpn-plugin-directory vpn-plugins)))
1212        (list (shepherd-service
1213               (documentation "Run the NetworkManager.")
1214               (provision '(networking))
1215               (requirement '(user-processes dbus-system wpa-supplicant loopback))
1216               (start #~(make-forkexec-constructor
1217                         (list (string-append #$network-manager
1218                                              "/sbin/NetworkManager")
1219                               (string-append "--config=" #$conf)
1220                               "--no-daemon")
1221                         #:environment-variables
1222                         (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn
1223                                              "/lib/NetworkManager/VPN")
1224                               ;; Override non-existent default users
1225                               "NM_OPENVPN_USER="
1226                               "NM_OPENVPN_GROUP=")))
1227               (stop #~(make-kill-destructor))))))))
1228
1229 (define network-manager-service-type
1230   (let
1231       ((config->packages
1232         (match-lambda
1233          (($ <network-manager-configuration> network-manager _ vpn-plugins)
1234           `(,network-manager ,@vpn-plugins)))))
1235
1236     (service-type
1237      (name 'network-manager)
1238      (extensions
1239       (list (service-extension shepherd-root-service-type
1240                                network-manager-shepherd-service)
1241             (service-extension dbus-root-service-type config->packages)
1242             (service-extension polkit-service-type
1243                                (compose
1244                                 list
1245                                 network-manager-configuration-network-manager))
1246             (service-extension account-service-type
1247                                network-manager-accounts)
1248             (service-extension activation-service-type
1249                                network-manager-activation)
1250             (service-extension session-environment-service-type
1251                                network-manager-environment)
1252             ;; Add network-manager to the system profile.
1253             (service-extension profile-service-type config->packages)))
1254      (default-value (network-manager-configuration))
1255      (description
1256       "Run @uref{https://wiki.gnome.org/Projects/NetworkManager,
1257 NetworkManager}, a network management daemon that aims to simplify wired and
1258 wireless networking."))))
1259
1260 \f
1261 ;;;
1262 ;;; Connman
1263 ;;;
1264
1265 (define-record-type* <connman-configuration>
1266   connman-configuration make-connman-configuration
1267   connman-configuration?
1268   (connman      connman-configuration-connman
1269                 (default connman))
1270   (disable-vpn? connman-configuration-disable-vpn?
1271                 (default #f)))
1272
1273 (define (connman-activation config)
1274   (let ((disable-vpn? (connman-configuration-disable-vpn? config)))
1275     (with-imported-modules '((guix build utils))
1276       #~(begin
1277           (use-modules (guix build utils))
1278           (mkdir-p "/var/lib/connman/")
1279           (unless #$disable-vpn?
1280             (mkdir-p "/var/lib/connman-vpn/"))))))
1281
1282 (define (connman-shepherd-service config)
1283   "Return a shepherd service for Connman"
1284   (and
1285    (connman-configuration? config)
1286    (let ((connman      (connman-configuration-connman config))
1287          (disable-vpn? (connman-configuration-disable-vpn? config)))
1288      (list (shepherd-service
1289             (documentation "Run Connman")
1290             (provision '(networking))
1291             (requirement
1292              '(user-processes dbus-system loopback wpa-supplicant))
1293             (start #~(make-forkexec-constructor
1294                       (list (string-append #$connman
1295                                            "/sbin/connmand")
1296                             "--nodaemon"
1297                             "--nodnsproxy"
1298                             #$@(if disable-vpn? '("--noplugin=vpn") '()))
1299
1300                       ;; As connman(8) notes, when passing '-n', connman
1301                       ;; "directs log output to the controlling terminal in
1302                       ;; addition to syslog."  Redirect stdout and stderr
1303                       ;; to avoid spamming the console (XXX: for some reason
1304                       ;; redirecting to /dev/null doesn't work.)
1305                       #:log-file "/var/log/connman.log"))
1306             (stop #~(make-kill-destructor)))))))
1307
1308 (define %connman-log-rotation
1309   (list (log-rotation
1310          (files '("/var/log/connman.log")))))
1311
1312 (define connman-service-type
1313   (let ((connman-package (compose list connman-configuration-connman)))
1314     (service-type (name 'connman)
1315                   (extensions
1316                    (list (service-extension shepherd-root-service-type
1317                                             connman-shepherd-service)
1318                          (service-extension polkit-service-type
1319                                             connman-package)
1320                          (service-extension dbus-root-service-type
1321                                             connman-package)
1322                          (service-extension activation-service-type
1323                                             connman-activation)
1324                          ;; Add connman to the system profile.
1325                          (service-extension profile-service-type
1326                                             connman-package)
1327                          (service-extension rottlog-service-type
1328                                             (const %connman-log-rotation))))
1329                   (default-value (connman-configuration))
1330                   (description
1331                    "Run @url{https://01.org/connman,Connman},
1332 a network connection manager."))))
1333
1334 \f
1335 ;;;
1336 ;;; Modem manager
1337 ;;;
1338
1339 (define modem-manager-service-type
1340   (let ((config->package
1341          (match-lambda
1342           (($ <modem-manager-configuration> modem-manager)
1343            (list modem-manager)))))
1344     (service-type (name 'modem-manager)
1345                   (extensions
1346                    (list (service-extension dbus-root-service-type
1347                                             config->package)
1348                          (service-extension udev-service-type
1349                                             config->package)
1350                          (service-extension polkit-service-type
1351                                             config->package)))
1352                   (default-value (modem-manager-configuration))
1353                   (description
1354                    "Run @uref{https://wiki.gnome.org/Projects/ModemManager,
1355 ModemManager}, a modem management daemon that aims to simplify dialup
1356 networking."))))
1357
1358 \f
1359 ;;;
1360 ;;; USB_ModeSwitch
1361 ;;;
1362
1363 (define-record-type* <usb-modeswitch-configuration>
1364   usb-modeswitch-configuration make-usb-modeswitch-configuration
1365   usb-modeswitch-configuration?
1366   (usb-modeswitch      usb-modeswitch-configuration-usb-modeswitch
1367                        (default usb-modeswitch))
1368   (usb-modeswitch-data usb-modeswitch-configuration-usb-modeswitch-data
1369                        (default usb-modeswitch-data))
1370   (config-file         usb-modeswitch-configuration-config-file
1371                        (default #~(string-append #$usb-modeswitch:dispatcher
1372                                                  "/etc/usb_modeswitch.conf"))))
1373
1374 (define (usb-modeswitch-sh usb-modeswitch config-file)
1375   "Build a copy of usb_modeswitch.sh located in package USB-MODESWITCH,
1376 modified to pass the CONFIG-FILE in its calls to usb_modeswitch_dispatcher,
1377 and wrap it to actually find the dispatcher in USB-MODESWITCH.  The script
1378 will be run by USB_ModeSwitch’s udev rules file when a modeswitchable USB
1379 device is detected."
1380   (computed-file
1381    "usb_modeswitch-sh"
1382    (with-imported-modules '((guix build utils))
1383      #~(begin
1384          (use-modules (guix build utils))
1385          (let ((cfg-param
1386                 #$(if config-file
1387                       #~(string-append " --config-file=" #$config-file)
1388                       "")))
1389            (mkdir #$output)
1390            (install-file (string-append #$usb-modeswitch:dispatcher
1391                                         "/lib/udev/usb_modeswitch")
1392                          #$output)
1393
1394            ;; insert CFG-PARAM into usb_modeswitch_dispatcher command-lines
1395            (substitute* (string-append #$output "/usb_modeswitch")
1396              (("(exec usb_modeswitch_dispatcher .*)( 2>>)" _ left right)
1397               (string-append left cfg-param right))
1398              (("(exec usb_modeswitch_dispatcher .*)( &)" _ left right)
1399               (string-append left cfg-param right)))
1400
1401            ;; wrap-program needs bash in PATH:
1402            (putenv (string-append "PATH=" #$bash "/bin"))
1403            (wrap-program (string-append #$output "/usb_modeswitch")
1404              `("PATH" ":" = (,(string-append #$coreutils "/bin")
1405                              ,(string-append
1406                                #$usb-modeswitch:dispatcher
1407                                "/bin")))))))))
1408
1409 (define (usb-modeswitch-configuration->udev-rules config)
1410   "Build a rules file for extending udev-service-type from the rules in the
1411 usb-modeswitch package specified in CONFIG.  The rules file will invoke
1412 usb_modeswitch.sh from the usb-modeswitch package, modified to pass the right
1413 config file."
1414   (match config
1415     (($ <usb-modeswitch-configuration> usb-modeswitch data config-file)
1416      (computed-file
1417       "usb_modeswitch.rules"
1418       (with-imported-modules '((guix build utils))
1419         #~(begin
1420             (use-modules (guix build utils))
1421             (let ((in (string-append #$data "/udev/40-usb_modeswitch.rules"))
1422                   (out (string-append #$output "/lib/udev/rules.d"))
1423                   (script #$(usb-modeswitch-sh usb-modeswitch config-file)))
1424               (mkdir-p out)
1425               (chdir out)
1426               (install-file in out)
1427               (substitute* "40-usb_modeswitch.rules"
1428                 (("PROGRAM=\"usb_modeswitch")
1429                  (string-append "PROGRAM=\"" script "/usb_modeswitch"))
1430                 (("RUN\\+=\"usb_modeswitch")
1431                  (string-append "RUN+=\"" script "/usb_modeswitch"))))))))))
1432
1433 (define usb-modeswitch-service-type
1434   (service-type
1435    (name 'usb-modeswitch)
1436    (extensions
1437     (list
1438      (service-extension
1439       udev-service-type
1440       (lambda (config)
1441         (let ((rules (usb-modeswitch-configuration->udev-rules config)))
1442           (list rules))))))
1443    (default-value (usb-modeswitch-configuration))
1444    (description "Run @uref{http://www.draisberghof.de/usb_modeswitch/,
1445 USB_ModeSwitch}, a mode switching tool for controlling USB devices with
1446 multiple @dfn{modes}.  When plugged in for the first time many USB
1447 devices (primarily high-speed WAN modems) act like a flash storage containing
1448 installers for Windows drivers.  USB_ModeSwitch replays the sequence the
1449 Windows drivers would send to switch their mode from storage to modem (or
1450 whatever the thing is supposed to do).")))
1451
1452 \f
1453 ;;;
1454 ;;; WPA supplicant
1455 ;;;
1456
1457 (define-record-type* <wpa-supplicant-configuration>
1458   wpa-supplicant-configuration make-wpa-supplicant-configuration
1459   wpa-supplicant-configuration?
1460   (wpa-supplicant     wpa-supplicant-configuration-wpa-supplicant ;file-like
1461                       (default wpa-supplicant))
1462   (requirement        wpa-supplicant-configuration-requirement    ;list of symbols
1463                       (default '(user-processes loopback syslogd)))
1464   (pid-file           wpa-supplicant-configuration-pid-file       ;string
1465                       (default "/var/run/wpa_supplicant.pid"))
1466   (dbus?              wpa-supplicant-configuration-dbus?          ;Boolean
1467                       (default #t))
1468   (interface          wpa-supplicant-configuration-interface      ;#f | string
1469                       (default #f))
1470   (config-file        wpa-supplicant-configuration-config-file    ;#f | <file-like>
1471                       (default #f))
1472   (extra-options      wpa-supplicant-configuration-extra-options  ;list of strings
1473                       (default '())))
1474
1475 (define wpa-supplicant-shepherd-service
1476   (match-lambda
1477     (($ <wpa-supplicant-configuration> wpa-supplicant requirement pid-file dbus?
1478                                        interface config-file extra-options)
1479      (list (shepherd-service
1480             (documentation "Run the WPA supplicant daemon")
1481             (provision '(wpa-supplicant))
1482             (requirement (if dbus?
1483                              (cons 'dbus-system requirement)
1484                              requirement))
1485             (start #~(make-forkexec-constructor
1486                       (list (string-append #$wpa-supplicant
1487                                            "/sbin/wpa_supplicant")
1488                             (string-append "-P" #$pid-file)
1489                             "-B"        ;run in background
1490                             "-s"        ;log to syslogd
1491                             #$@(if dbus?
1492                                    #~("-u")
1493                                    #~())
1494                             #$@(if interface
1495                                    #~((string-append "-i" #$interface))
1496                                    #~())
1497                             #$@(if config-file
1498                                    #~((string-append "-c" #$config-file))
1499                                    #~())
1500                             #$@extra-options)
1501                       #:pid-file #$pid-file))
1502             (stop #~(make-kill-destructor)))))))
1503
1504 (define wpa-supplicant-service-type
1505   (let ((config->package
1506          (match-lambda
1507            (($ <wpa-supplicant-configuration> wpa-supplicant)
1508             (list wpa-supplicant)))))
1509     (service-type (name 'wpa-supplicant)
1510                   (extensions
1511                    (list (service-extension shepherd-root-service-type
1512                                             wpa-supplicant-shepherd-service)
1513                          (service-extension dbus-root-service-type config->package)
1514                          (service-extension profile-service-type config->package)))
1515                   (description "Run the WPA Supplicant daemon, a service that
1516 implements authentication, key negotiation and more for wireless networks.")
1517                   (default-value (wpa-supplicant-configuration)))))
1518
1519 \f
1520 ;;;
1521 ;;; Hostapd.
1522 ;;;
1523
1524 (define-record-type* <hostapd-configuration>
1525   hostapd-configuration make-hostapd-configuration
1526   hostapd-configuration?
1527   (package           hostapd-configuration-package
1528                      (default hostapd))
1529   (interface         hostapd-configuration-interface ;string
1530                      (default "wlan0"))
1531   (ssid              hostapd-configuration-ssid)  ;string
1532   (broadcast-ssid?   hostapd-configuration-broadcast-ssid? ;Boolean
1533                      (default #t))
1534   (channel           hostapd-configuration-channel ;integer
1535                      (default 1))
1536   (driver            hostapd-configuration-driver ;string
1537                      (default "nl80211"))
1538   ;; See <https://w1.fi/cgit/hostap/plain/hostapd/hostapd.conf> for a list of
1539   ;; additional options we could add.
1540   (extra-settings    hostapd-configuration-extra-settings ;string
1541                      (default "")))
1542
1543 (define (hostapd-configuration-file config)
1544   "Return the configuration file for CONFIG, a <hostapd-configuration>."
1545   (match-record config <hostapd-configuration>
1546     (interface ssid broadcast-ssid? channel driver extra-settings)
1547     (plain-file "hostapd.conf"
1548                 (string-append "\
1549 # Generated from your Guix configuration.
1550
1551 interface=" interface "
1552 ssid=" ssid "
1553 ignore_broadcast_ssid=" (if broadcast-ssid? "0" "1") "
1554 channel=" (number->string channel) "\n"
1555 extra-settings "\n"))))
1556
1557 (define* (hostapd-shepherd-services config #:key (requirement '()))
1558   "Return Shepherd services for hostapd."
1559   (list (shepherd-service
1560          (provision '(hostapd))
1561          (requirement `(user-processes ,@requirement))
1562          (documentation "Run the hostapd WiFi access point daemon.")
1563          (start #~(make-forkexec-constructor
1564                    (list #$(file-append (hostapd-configuration-package config)
1565                                         "/sbin/hostapd")
1566                          #$(hostapd-configuration-file config))
1567                    #:log-file "/var/log/hostapd.log"))
1568          (stop #~(make-kill-destructor)))))
1569
1570 (define %hostapd-log-rotation
1571   (list (log-rotation
1572          (files '("/var/log/hostapd.log")))))
1573
1574 (define hostapd-service-type
1575   (service-type
1576    (name 'hostapd)
1577    (extensions
1578     (list (service-extension shepherd-root-service-type
1579                              hostapd-shepherd-services)
1580           (service-extension rottlog-service-type
1581                              (const %hostapd-log-rotation))))
1582    (description
1583     "Run the @uref{https://w1.fi/hostapd/, hostapd} daemon for Wi-Fi access
1584 points and authentication servers.")))
1585
1586 (define (simulated-wifi-shepherd-services config)
1587   "Return Shepherd services to run hostapd with CONFIG, a
1588 <hostapd-configuration>, as well as services to set up WiFi hardware
1589 simulation."
1590   (append (hostapd-shepherd-services config
1591                                      #:requirement
1592                                      '(unblocked-wifi
1593                                        kernel-module-loader))
1594           (list (shepherd-service
1595                  (provision '(unblocked-wifi))
1596                  (requirement '(file-systems kernel-module-loader))
1597                  (documentation
1598                   "Unblock WiFi devices for use by mac80211_hwsim.")
1599                  (start #~(lambda _
1600                             (invoke #$(file-append util-linux "/sbin/rfkill")
1601                                     "unblock" "0")
1602                             (invoke #$(file-append util-linux "/sbin/rfkill")
1603                                     "unblock" "1")))
1604                  (one-shot? #t)))))
1605
1606 (define simulated-wifi-service-type
1607   (service-type
1608    (name 'simulated-wifi)
1609    (extensions
1610     (list (service-extension shepherd-root-service-type
1611                              simulated-wifi-shepherd-services)
1612           (service-extension kernel-module-loader-service-type
1613                              (const '("mac80211_hwsim")))))
1614    (default-value (hostapd-configuration
1615                    (interface "wlan1")
1616                    (ssid "Test Network")))
1617    (description "Run hostapd to simulate WiFi connectivity.")))
1618
1619 \f
1620 ;;;
1621 ;;; Open vSwitch
1622 ;;;
1623
1624 (define-record-type* <openvswitch-configuration>
1625   openvswitch-configuration make-openvswitch-configuration
1626   openvswitch-configuration?
1627   (package openvswitch-configuration-package
1628            (default openvswitch)))
1629
1630 (define openvswitch-activation
1631   (match-lambda
1632     (($ <openvswitch-configuration> package)
1633      (let ((ovsdb-tool (file-append package "/bin/ovsdb-tool")))
1634        (with-imported-modules '((guix build utils))
1635          #~(begin
1636              (use-modules (guix build utils))
1637              (mkdir-p "/var/run/openvswitch")
1638              (mkdir-p "/var/lib/openvswitch")
1639              (let ((conf.db "/var/lib/openvswitch/conf.db"))
1640                (unless (file-exists? conf.db)
1641                  (system* #$ovsdb-tool "create" conf.db)))))))))
1642
1643 (define openvswitch-shepherd-service
1644   (match-lambda
1645     (($ <openvswitch-configuration> package)
1646      (let ((ovsdb-server (file-append package "/sbin/ovsdb-server"))
1647            (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd")))
1648        (list
1649         (shepherd-service
1650          (provision '(ovsdb))
1651          (documentation "Run the Open vSwitch database server.")
1652          (start #~(make-forkexec-constructor
1653                    (list #$ovsdb-server "--pidfile"
1654                          "--remote=punix:/var/run/openvswitch/db.sock")
1655                    #:pid-file "/var/run/openvswitch/ovsdb-server.pid"))
1656          (stop #~(make-kill-destructor)))
1657         (shepherd-service
1658          (provision '(vswitchd))
1659          (requirement '(ovsdb))
1660          (documentation "Run the Open vSwitch daemon.")
1661          (start #~(make-forkexec-constructor
1662                    (list #$ovs-vswitchd "--pidfile")
1663                    #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid"))
1664          (stop #~(make-kill-destructor))))))))
1665
1666 (define openvswitch-service-type
1667   (service-type
1668    (name 'openvswitch)
1669    (extensions
1670     (list (service-extension activation-service-type
1671                              openvswitch-activation)
1672           (service-extension profile-service-type
1673                              (compose list openvswitch-configuration-package))
1674           (service-extension shepherd-root-service-type
1675                              openvswitch-shepherd-service)))
1676    (description
1677     "Run @uref{http://www.openvswitch.org, Open vSwitch}, a multilayer virtual
1678 switch designed to enable massive network automation through programmatic
1679 extension.")
1680    (default-value (openvswitch-configuration))))
1681
1682 ;;;
1683 ;;; iptables
1684 ;;;
1685
1686 (define %iptables-accept-all-rules
1687   (plain-file "iptables-accept-all.rules"
1688               "*filter
1689 :INPUT ACCEPT
1690 :FORWARD ACCEPT
1691 :OUTPUT ACCEPT
1692 COMMIT
1693 "))
1694
1695 (define-record-type* <iptables-configuration>
1696   iptables-configuration make-iptables-configuration iptables-configuration?
1697   (iptables iptables-configuration-iptables
1698             (default iptables))
1699   (ipv4-rules iptables-configuration-ipv4-rules
1700               (default %iptables-accept-all-rules))
1701   (ipv6-rules iptables-configuration-ipv6-rules
1702               (default %iptables-accept-all-rules)))
1703
1704 (define iptables-shepherd-service
1705   (match-lambda
1706     (($ <iptables-configuration> iptables ipv4-rules ipv6-rules)
1707      (let ((iptables-restore (file-append iptables "/sbin/iptables-restore"))
1708            (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore")))
1709        (shepherd-service
1710         (documentation "Packet filtering framework")
1711         (provision '(iptables))
1712         (start #~(lambda _
1713                    (invoke #$iptables-restore #$ipv4-rules)
1714                    (invoke #$ip6tables-restore #$ipv6-rules)))
1715         (stop #~(lambda _
1716                   (invoke #$iptables-restore #$%iptables-accept-all-rules)
1717                   (invoke #$ip6tables-restore #$%iptables-accept-all-rules))))))))
1718
1719 (define iptables-service-type
1720   (service-type
1721    (name 'iptables)
1722    (description
1723     "Run @command{iptables-restore}, setting up the specified rules.")
1724    (extensions
1725     (list (service-extension shepherd-root-service-type
1726                              (compose list iptables-shepherd-service))))))
1727
1728 ;;;
1729 ;;; nftables
1730 ;;;
1731
1732 (define %default-nftables-ruleset
1733   (plain-file "nftables.conf"
1734               "# A simple and safe firewall
1735 table inet filter {
1736   chain input {
1737     type filter hook input priority 0; policy drop;
1738
1739     # early drop of invalid connections
1740     ct state invalid drop
1741
1742     # allow established/related connections
1743     ct state { established, related } accept
1744
1745     # allow from loopback
1746     iifname lo accept
1747
1748     # allow icmp
1749     ip protocol icmp accept
1750     ip6 nexthdr icmpv6 accept
1751
1752     # allow ssh
1753     tcp dport ssh accept
1754
1755     # reject everything else
1756     reject with icmpx type port-unreachable
1757   }
1758   chain forward {
1759     type filter hook forward priority 0; policy drop;
1760   }
1761   chain output {
1762     type filter hook output priority 0; policy accept;
1763   }
1764 }
1765 "))
1766
1767 (define-record-type* <nftables-configuration>
1768   nftables-configuration
1769   make-nftables-configuration
1770   nftables-configuration?
1771   (package nftables-configuration-package
1772            (default nftables))
1773   (ruleset nftables-configuration-ruleset ; file-like object
1774            (default %default-nftables-ruleset)))
1775
1776 (define nftables-shepherd-service
1777   (match-lambda
1778     (($ <nftables-configuration> package ruleset)
1779      (let ((nft (file-append package "/sbin/nft")))
1780        (shepherd-service
1781         (documentation "Packet filtering and classification")
1782         (provision '(nftables))
1783         (start #~(lambda _
1784                    (invoke #$nft "--file" #$ruleset)))
1785         (stop #~(lambda _
1786                   (invoke #$nft "flush" "ruleset"))))))))
1787
1788 (define nftables-service-type
1789   (service-type
1790    (name 'nftables)
1791    (description
1792     "Run @command{nft}, setting up the specified ruleset.")
1793    (extensions
1794     (list (service-extension shepherd-root-service-type
1795                              (compose list nftables-shepherd-service))
1796           (service-extension profile-service-type
1797                              (compose list nftables-configuration-package))))
1798    (default-value (nftables-configuration))))
1799
1800 \f
1801 ;;;
1802 ;;; PageKite
1803 ;;;
1804
1805 (define-record-type* <pagekite-configuration>
1806   pagekite-configuration
1807   make-pagekite-configuration
1808   pagekite-configuration?
1809   (package pagekite-configuration-package
1810            (default pagekite))
1811   (kitename pagekite-configuration-kitename
1812             (default #f))
1813   (kitesecret pagekite-configuration-kitesecret
1814               (default #f))
1815   (frontend pagekite-configuration-frontend
1816             (default #f))
1817   (kites pagekite-configuration-kites
1818          (default '("http:@kitename:localhost:80:@kitesecret")))
1819   (extra-file pagekite-configuration-extra-file
1820               (default #f)))
1821
1822 (define (pagekite-configuration-file config)
1823   (match-record config <pagekite-configuration>
1824     (package kitename kitesecret frontend kites extra-file)
1825     (mixed-text-file "pagekite.rc"
1826                      (if extra-file
1827                          (string-append "optfile = " extra-file "\n")
1828                          "")
1829                      (if kitename
1830                          (string-append "kitename = " kitename "\n")
1831                          "")
1832                      (if kitesecret
1833                          (string-append "kitesecret = " kitesecret "\n")
1834                          "")
1835                      (if frontend
1836                          (string-append "frontend = " frontend "\n")
1837                          "defaults\n")
1838                      (string-join (map (lambda (kite)
1839                                          (string-append "service_on = " kite))
1840                                        kites)
1841                                   "\n"
1842                                   'suffix))))
1843
1844 (define (pagekite-shepherd-service config)
1845   (match-record config <pagekite-configuration>
1846     (package kitename kitesecret frontend kites extra-file)
1847     (with-imported-modules (source-module-closure
1848                             '((gnu build shepherd)
1849                               (gnu system file-systems)))
1850       (shepherd-service
1851        (documentation "Run the PageKite service.")
1852        (provision '(pagekite))
1853        (requirement '(networking))
1854        (modules '((gnu build shepherd)
1855                   (gnu system file-systems)))
1856        (start #~(make-forkexec-constructor/container
1857                  (list #$(file-append package "/bin/pagekite")
1858                        "--clean"
1859                        "--nullui"
1860                        "--nocrashreport"
1861                        "--runas=pagekite:pagekite"
1862                        (string-append "--optfile="
1863                                       #$(pagekite-configuration-file config)))
1864                  #:log-file "/var/log/pagekite.log"
1865                  #:mappings #$(if extra-file
1866                                   #~(list (file-system-mapping
1867                                            (source #$extra-file)
1868                                            (target source)))
1869                                   #~'())))
1870        ;; SIGTERM doesn't always work for some reason.
1871        (stop #~(make-kill-destructor SIGINT))))))
1872
1873 (define %pagekite-log-rotation
1874   (list (log-rotation
1875          (files '("/var/log/pagekite.log")))))
1876
1877 (define %pagekite-accounts
1878   (list (user-group (name "pagekite") (system? #t))
1879         (user-account
1880          (name "pagekite")
1881          (group "pagekite")
1882          (system? #t)
1883          (comment "PageKite user")
1884          (home-directory "/var/empty")
1885          (shell (file-append shadow "/sbin/nologin")))))
1886
1887 (define pagekite-service-type
1888   (service-type
1889    (name 'pagekite)
1890    (default-value (pagekite-configuration))
1891    (extensions
1892     (list (service-extension shepherd-root-service-type
1893                              (compose list pagekite-shepherd-service))
1894           (service-extension account-service-type
1895                              (const %pagekite-accounts))
1896           (service-extension rottlog-service-type
1897                              (const %pagekite-log-rotation))))
1898    (description
1899     "Run @url{https://pagekite.net/,PageKite}, a tunneling solution to make
1900 local servers publicly accessible on the web, even behind NATs and firewalls.")))
1901
1902 \f
1903 ;;;
1904 ;;; Yggdrasil
1905 ;;;
1906
1907 (define-record-type* <yggdrasil-configuration>
1908   yggdrasil-configuration
1909   make-yggdrasil-configuration
1910   yggdrasil-configuration?
1911   (package yggdrasil-configuration-package
1912            (default yggdrasil))
1913   (json-config yggdrasil-configuration-json-config
1914                (default '()))
1915   (config-file yggdrasil-config-file
1916                (default "/etc/yggdrasil-private.conf"))
1917   (autoconf? yggdrasil-configuration-autoconf?
1918              (default #f))
1919   (log-level yggdrasil-configuration-log-level
1920              (default 'info))
1921   (log-to yggdrasil-configuration-log-to
1922           (default 'stdout)))
1923
1924 (define (yggdrasil-configuration-file config)
1925   (define (scm->yggdrasil-json x)
1926     (define key-value?
1927       dotted-list?)
1928     (define (param->camel str)
1929       (string-concatenate
1930        (map
1931         string-capitalize
1932         (string-split str (cut eqv? <> #\-)))))
1933     (cond
1934      ((key-value? x)
1935       (let ((k (car x))
1936             (v (cdr x)))
1937         (cons
1938          (if (symbol? k)
1939              (param->camel (symbol->string k))
1940              k)
1941          v)))
1942      ((list? x) (map scm->yggdrasil-json x))
1943      ((vector? x) (vector-map scm->yggdrasil-json x))
1944      (else x)))
1945   (computed-file
1946    "yggdrasil.conf"
1947    #~(call-with-output-file #$output
1948        (lambda (port)
1949          ;; it's HJSON, so comments are a-okay
1950          (display "# Generated by yggdrasil-service\n" port)
1951          (display #$(scm->json-string
1952                      (scm->yggdrasil-json
1953                       (yggdrasil-configuration-json-config config)))
1954                   port)))))
1955
1956 (define (yggdrasil-shepherd-service config)
1957   "Return a <shepherd-service> for yggdrasil with CONFIG."
1958   (define yggdrasil-command
1959     #~(append
1960        (list (string-append
1961               #$(yggdrasil-configuration-package config)
1962               "/bin/yggdrasil")
1963              "-useconffile"
1964              #$(yggdrasil-configuration-file config))
1965        (if #$(yggdrasil-configuration-autoconf? config)
1966            '("-autoconf")
1967            '())
1968        (let ((extraconf #$(yggdrasil-config-file config)))
1969          (if extraconf
1970              (list "-extraconffile" extraconf)
1971              '()))
1972        (list "-loglevel"
1973              #$(symbol->string
1974                 (yggdrasil-configuration-log-level config))
1975              "-logto"
1976              #$(symbol->string
1977                 (yggdrasil-configuration-log-to config)))))
1978   (list (shepherd-service
1979          (documentation "Connect to the Yggdrasil mesh network")
1980          (provision '(yggdrasil))
1981          (requirement '(networking))
1982          (start #~(make-forkexec-constructor
1983                    #$yggdrasil-command
1984                    #:log-file "/var/log/yggdrasil.log"
1985                    #:group "yggdrasil"))
1986          (stop #~(make-kill-destructor)))))
1987
1988 (define %yggdrasil-log-rotation
1989   (list (log-rotation
1990          (files '("/var/log/yggdrasil.log")))))
1991
1992 (define %yggdrasil-accounts
1993   (list (user-group (name "yggdrasil") (system? #t))))
1994
1995 (define yggdrasil-service-type
1996   (service-type
1997    (name 'yggdrasil)
1998    (description
1999     "Connect to the Yggdrasil mesh network.
2000 See @command{yggdrasil -genconf} for config options.")
2001    (extensions
2002     (list (service-extension shepherd-root-service-type
2003                              yggdrasil-shepherd-service)
2004           (service-extension account-service-type
2005                              (const %yggdrasil-accounts))
2006           (service-extension profile-service-type
2007                              (compose list yggdrasil-configuration-package))
2008           (service-extension rottlog-service-type
2009                              (const %yggdrasil-log-rotation))))))
2010
2011 \f
2012 ;;;
2013 ;;; IPFS
2014 ;;;
2015
2016 (define-record-type* <ipfs-configuration>
2017   ipfs-configuration
2018   make-ipfs-configuration
2019   ipfs-configuration?
2020   (package ipfs-configuration-package
2021            (default go-ipfs))
2022   (gateway ipfs-configuration-gateway
2023            (default "/ip4/127.0.0.1/tcp/8082"))
2024   (api     ipfs-configuration-api
2025            (default "/ip4/127.0.0.1/tcp/5001")))
2026
2027 (define %ipfs-home "/var/lib/ipfs")
2028
2029 (define %ipfs-accounts
2030   (list (user-account
2031          (name "ipfs")
2032          (group "ipfs")
2033          (system? #t)
2034          (comment "IPFS daemon user")
2035          (home-directory "/var/lib/ipfs")
2036          (shell (file-append shadow "/sbin/nologin")))
2037         (user-group
2038          (name "ipfs")
2039          (system? #t))))
2040
2041 (define (ipfs-binary config)
2042   (define command
2043     (file-append (ipfs-configuration-package config) "/bin/ipfs"))
2044
2045   (least-authority-wrapper
2046    command
2047    #:name "ipfs"
2048    #:mappings (list %ipfs-home-mapping)
2049    #:namespaces (delq 'net %namespaces)))
2050
2051 (define %ipfs-home-mapping
2052   (file-system-mapping
2053    (source %ipfs-home)
2054    (target %ipfs-home)
2055    (writable? #t)))
2056
2057 (define %ipfs-environment
2058   #~(list #$(string-append "HOME=" %ipfs-home)))
2059
2060 (define (ipfs-shepherd-service config)
2061   "Return a <shepherd-service> for IPFS with CONFIG."
2062   (define ipfs-daemon-command
2063     #~(list #$(ipfs-binary config) "daemon"))
2064
2065   (list (shepherd-service
2066          (provision '(ipfs))
2067          ;; While IPFS is most useful when the machine is connected
2068          ;; to the network, only loopback is required for starting
2069          ;; the service.
2070          (requirement '(loopback))
2071          (documentation "Connect to the IPFS network")
2072          (start #~(make-forkexec-constructor
2073                    #$ipfs-daemon-command
2074                    #:log-file "/var/log/ipfs.log"
2075                    #:user "ipfs" #:group "ipfs"
2076                    #:environment-variables #$%ipfs-environment))
2077          (stop #~(make-kill-destructor)))))
2078
2079 (define %ipfs-log-rotation
2080   (list (log-rotation
2081          (files '("/var/log/ipfs.log")))))
2082
2083 (define (%ipfs-activation config)
2084   "Return an activation gexp for IPFS with CONFIG"
2085   (define (exec-command . args)
2086     ;; Exec the given ifps command with the right authority.
2087     #~(let ((pid (primitive-fork)))
2088         (if (zero? pid)
2089             (dynamic-wind
2090               (const #t)
2091               (lambda ()
2092                 ;; Run ipfs init and ipfs config from a container,
2093                 ;; in case the IPFS daemon was compromised at some point
2094                 ;; and ~/.ipfs is now a symlink to somewhere outside
2095                 ;; %ipfs-home.
2096                 (let ((pw (getpwnam "ipfs")))
2097                   (setgroups '#())
2098                   (setgid (passwd:gid pw))
2099                   (setuid (passwd:uid pw))
2100                   (environ #$%ipfs-environment)
2101                   (execl #$(ipfs-binary config) #$@args)))
2102               (lambda ()
2103                 (primitive-exit 127)))
2104             (waitpid pid))))
2105
2106   (define settings
2107     `(("Addresses.API" ,(ipfs-configuration-api config))
2108       ("Addresses.Gateway" ,(ipfs-configuration-gateway config))))
2109
2110   (define inner-gexp
2111     #~(begin
2112         (umask #o077)
2113         ;; Create $HOME/.ipfs structure
2114         #$(exec-command "ipfs" "init")
2115         ;; Apply settings
2116         #$@(map (match-lambda
2117                   ((setting value)
2118                    (exec-command "ipfs" "config" setting value)))
2119                 settings)))
2120
2121   (define inner-script
2122     (program-file "ipfs-activation-inner" inner-gexp))
2123
2124   ;; The activation may happen from the initrd, which uses
2125   ;; a statically-linked guile, while the guix container
2126   ;; procedures require a working dynamic-link.
2127   #~(system* #$inner-script))
2128
2129 (define ipfs-service-type
2130   (service-type
2131    (name 'ipfs)
2132    (extensions
2133     (list (service-extension account-service-type
2134                              (const %ipfs-accounts))
2135           (service-extension activation-service-type
2136                              %ipfs-activation)
2137           (service-extension shepherd-root-service-type
2138                              ipfs-shepherd-service)
2139           (service-extension rottlog-service-type
2140                              (const %ipfs-log-rotation))))
2141    (default-value (ipfs-configuration))
2142    (description
2143     "Run @command{ipfs daemon}, the reference implementation
2144 of the IPFS peer-to-peer storage network.")))
2145
2146 \f
2147 ;;;
2148 ;;; Keepalived
2149 ;;;
2150
2151 (define-record-type* <keepalived-configuration>
2152   keepalived-configuration make-keepalived-configuration
2153   keepalived-configuration?
2154   (keepalived  keepalived-configuration-keepalived  ;file-like
2155                (default keepalived))
2156   (config-file keepalived-configuration-config-file ;file-like
2157                (default #f)))
2158
2159 (define keepalived-shepherd-service
2160   (match-lambda
2161     (($ <keepalived-configuration> keepalived config-file)
2162      (list
2163       (shepherd-service
2164        (provision '(keepalived))
2165        (documentation "Run keepalived.")
2166        (requirement '(loopback))
2167        (start #~(make-forkexec-constructor
2168                  (list (string-append #$keepalived "/sbin/keepalived")
2169                        "--dont-fork" "--log-console" "--log-detail"
2170                        "--pid=/var/run/keepalived.pid"
2171                        (string-append "--use-file=" #$config-file))
2172                  #:pid-file "/var/run/keepalived.pid"
2173                  #:log-file "/var/log/keepalived.log"))
2174        (respawn? #f)
2175        (stop #~(make-kill-destructor)))))))
2176
2177 (define %keepalived-log-rotation
2178   (list (log-rotation
2179          (files '("/var/log/keepalived.log")))))
2180
2181 (define keepalived-service-type
2182   (service-type (name 'keepalived)
2183                 (extensions (list (service-extension shepherd-root-service-type
2184                                                      keepalived-shepherd-service)
2185                                   (service-extension rottlog-service-type
2186                                                      (const %keepalived-log-rotation))))
2187                 (description
2188                  "Run @uref{https://www.keepalived.org/, Keepalived}
2189 routing software.")))
2190
2191 ;;; networking.scm ends here