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
 657 (define (openntpd-service-activation config)
 658   "Return the activation gexp for CONFIG."
 659   (with-imported-modules '((guix build utils))
 660     #~(begin
 661         (use-modules (guix build utils))
 662
 663         (mkdir-p "/var/db")
 664         (mkdir-p "/var/run")
 665         (unless (file-exists? "/var/db/ntpd.drift")
 666           (with-output-to-file "/var/db/ntpd.drift"
 667                                (lambda _
 668                                  (format #t "0.0")))))))
 669
 670 (define openntpd-service-type
 671   (service-type (name 'openntpd)
 672                 (extensions
 673                  (list (service-extension shepherd-root-service-type
 674                                           openntpd-shepherd-service)
 675                        (service-extension account-service-type
 676                                           (const %ntp-accounts))
 677                        (service-extension profile-service-type
 678                                           (compose list openntpd-configuration-openntpd))
 679                        (service-extension activation-service-type
 680                                           openntpd-service-activation)
 681                        (service-extension rottlog-service-type
 682                                           (const %ntp-log-rotation))))
 683                 (default-value (openntpd-configuration))
 684                 (description
 685                  "Run the @command{ntpd}, the Network Time Protocol (NTP)
 686 daemon, as implemented by @uref{http://www.openntpd.org, OpenNTPD}.  The
 687 daemon will keep the system clock synchronized with that of the given servers.")))
 688
 689 \f
 690 ;;;
 691 ;;; Inetd.
 692 ;;;
 693
 694 (define-record-type* <inetd-configuration> inetd-configuration
 695   make-inetd-configuration
 696   inetd-configuration?
 697   (program           inetd-configuration-program   ;file-like
 698                      (default (file-append inetutils "/libexec/inetd")))
 699   (entries           inetd-configuration-entries   ;list of <inetd-entry>
 700                      (default '())))
 701
 702 (define-record-type* <inetd-entry> inetd-entry make-inetd-entry
 703   inetd-entry?
 704   (node              inetd-entry-node         ;string or #f
 705                      (default #f))
 706   (name              inetd-entry-name)        ;string, from /etc/services
 707
 708   (socket-type       inetd-entry-socket-type) ;stream | dgram | raw |
 709                                               ;rdm | seqpacket
 710   (protocol          inetd-entry-protocol)    ;string, from /etc/protocols
 711
 712   (wait?             inetd-entry-wait?        ;Boolean
 713                      (default #t))
 714   (user              inetd-entry-user)        ;string
 715
 716   (program           inetd-entry-program      ;string or file-like object
 717                      (default "internal"))
 718   (arguments         inetd-entry-arguments    ;list of strings or file-like objects
 719                      (default '())))
 720
 721 (define (inetd-config-file entries)
 722   (apply mixed-text-file "inetd.conf"
 723          (map
 724           (lambda (entry)
 725             (let* ((node (inetd-entry-node entry))
 726                    (name (inetd-entry-name entry))
 727                    (socket
 728                     (if node (string-append node ":" name) name))
 729                    (type
 730                     (match (inetd-entry-socket-type entry)
 731                       ((or 'stream 'dgram 'raw 'rdm 'seqpacket)
 732                        (symbol->string (inetd-entry-socket-type entry)))))
 733                    (protocol (inetd-entry-protocol entry))
 734                    (wait (if (inetd-entry-wait? entry) "wait" "nowait"))
 735                    (user (inetd-entry-user entry))
 736                    (program (inetd-entry-program entry))
 737                    (args (inetd-entry-arguments entry)))
 738               #~(string-append
 739                  (string-join
 740                   (list #$@(list socket type protocol wait user program) #$@args)
 741                   " ") "\n")))
 742           entries)))
 743
 744 (define inetd-shepherd-service
 745   (match-lambda
 746     (($ <inetd-configuration> program ()) '()) ; empty list of entries -> do nothing
 747     (($ <inetd-configuration> program entries)
 748      (list
 749       (shepherd-service
 750        (documentation "Run inetd.")
 751        (provision '(inetd))
 752        (requirement '(user-processes networking syslogd))
 753        (start #~(make-forkexec-constructor
 754                  (list #$program #$(inetd-config-file entries))
 755                  #:pid-file "/var/run/inetd.pid"))
 756        (stop #~(make-kill-destructor)))))))
 757
 758 (define-public inetd-service-type
 759   (service-type
 760    (name 'inetd)
 761    (extensions
 762     (list (service-extension shepherd-root-service-type
 763                              inetd-shepherd-service)))
 764
 765    ;; The service can be extended with additional lists of entries.
 766    (compose concatenate)
 767    (extend (lambda (config entries)
 768              (inetd-configuration
 769               (inherit config)
 770               (entries (append (inetd-configuration-entries config)
 771                                entries)))))
 772    (description
 773     "Start @command{inetd}, the @dfn{Internet superserver}.  It is responsible
 774 for listening on Internet sockets and spawning the corresponding services on
 775 demand.")))
 776
 777 \f
 778 ;;;
 779 ;;; OpenDHT, the distributed hash table network used by Jami
 780 ;;;
 781
 782 (define-maybe/no-serialization number)
 783 (define-maybe/no-serialization string)
 784
 785 ;;; To generate the documentation of the following configuration record, you
 786 ;;; can evaluate: (configuration->documentation 'opendht-configuration)
 787 (define-configuration/no-serialization opendht-configuration
 788   (opendht
 789    (file-like opendht)
 790    "The @code{opendht} package to use.")
 791   (peer-discovery?
 792    (boolean #false)
 793    "Whether to enable the multicast local peer discovery mechanism.")
 794   (enable-logging?
 795    (boolean #false)
 796    "Whether to enable logging messages to syslog.  It is disabled by default
 797 as it is rather verbose.")
 798   (debug?
 799    (boolean #false)
 800    "Whether to enable debug-level logging messages.  This has no effect if
 801 logging is disabled.")
 802   (bootstrap-host
 803    (maybe-string "bootstrap.jami.net:4222")
 804    "The node host name that is used to make the first connection to the
 805 network.  A specific port value can be provided by appending the @code{:PORT}
 806 suffix.  By default, it uses the Jami bootstrap nodes, but any host can be
 807 specified here.  It's also possible to disable bootstrapping by explicitly
 808 setting this field to @code{%unset-value}.")
 809   (port
 810    (maybe-number 4222)
 811    "The UDP port to bind to.  When left unspecified, an available port is
 812 automatically selected.")
 813   (proxy-server-port
 814    maybe-number
 815    "Spawn a proxy server listening on the specified port.")
 816   (proxy-server-port-tls
 817    maybe-number
 818    "Spawn a proxy server listening to TLS connections on the specified
 819 port."))
 820
 821 (define %opendht-accounts
 822   ;; User account and groups for Tor.
 823   (list (user-group (name "opendht") (system? #t))
 824         (user-account
 825          (name "opendht")
 826          (group "opendht")
 827          (system? #t)
 828          (comment "OpenDHT daemon user")
 829          (home-directory "/var/empty")
 830          (shell (file-append shadow "/sbin/nologin")))))
 831
 832 (define (opendht-configuration->command-line-arguments config)
 833   "Derive the command line arguments used to launch the OpenDHT daemon from
 834 CONFIG, an <opendht-configuration> object."
 835   (match-record config <opendht-configuration>
 836     (opendht bootstrap-host enable-logging? port debug? peer-discovery?
 837              proxy-server-port proxy-server-port-tls)
 838     (let ((dhtnode (least-authority-wrapper
 839                     ;; XXX: Work around lack of support for multiple outputs
 840                     ;; in 'file-append'.
 841                     (computed-file "dhtnode"
 842                                    #~(symlink
 843                                       (string-append #$opendht:tools
 844                                                      "/bin/dhtnode")
 845                                       #$output))
 846                     #:name "dhtnode"
 847                     #:mappings (list (file-system-mapping
 848                                       (source "/dev/log") ;for syslog
 849                                       (target source)))
 850                     #:namespaces (delq 'net %namespaces))))
 851       `(,dhtnode
 852         "--service"                     ;non-forking mode
 853         ,@(if (string? bootstrap-host)
 854               (list "--bootstrap" bootstrap-host))
 855         ,@(if enable-logging?
 856               (list "--syslog")
 857               '())
 858         ,@(if (number? port)
 859               (list "--port" (number->string port))
 860               '())
 861         ,@(if debug?
 862               (list "--verbose")
 863               '())
 864         ,@(if peer-discovery?
 865               (list "--peer-discovery")
 866               '())
 867         ,@(if (number? proxy-server-port)
 868               (list "--proxyserver" (number->string proxy-server-port))
 869               '())
 870         ,@(if (number? proxy-server-port-tls)
 871               (list "--proxyserverssl" (number->string proxy-server-port-tls))
 872               '())))))
 873
 874 (define (opendht-shepherd-service config)
 875   "Return a <shepherd-service> running OpenDHT."
 876   (shepherd-service
 877    (documentation "Run an OpenDHT node.")
 878    (provision '(opendht dhtnode dhtproxy))
 879    (requirement '(networking syslogd))
 880    (start #~(make-forkexec-constructor
 881              (list #$@(opendht-configuration->command-line-arguments config))
 882              #:user "opendht"
 883              #:group "opendht"))
 884    (stop #~(make-kill-destructor))))
 885
 886 (define opendht-service-type
 887   (service-type
 888    (name 'opendht)
 889    (default-value (opendht-configuration))
 890    (extensions
 891     (list (service-extension shepherd-root-service-type
 892                              (compose list opendht-shepherd-service))
 893           (service-extension account-service-type
 894                              (const %opendht-accounts))))
 895    (description "Run the OpenDHT @command{dhtnode} command that allows
 896 participating in the distributed hash table based OpenDHT network.  The
 897 service can be configured to act as a proxy to the distributed network, which
 898 can be useful for portable devices where minimizing energy consumption is
 899 paramount.  OpenDHT was originally based on Kademlia and adapted for
 900 applications in communication.  It is used by Jami, for example.")))
 901
 902 \f
 903 ;;;
 904 ;;; Tor.
 905 ;;;
 906
 907 (define-record-type* <tor-configuration>
 908   tor-configuration make-tor-configuration
 909   tor-configuration?
 910   (tor              tor-configuration-tor
 911                     (default tor))
 912   (config-file      tor-configuration-config-file
 913                     (default (plain-file "empty" "")))
 914   (hidden-services  tor-configuration-hidden-services
 915                     (default '()))
 916   (socks-socket-type tor-configuration-socks-socket-type ; 'tcp or 'unix
 917                      (default 'tcp))
 918   (control-socket?  tor-control-socket-path
 919                     (default #f)))
 920
 921 (define %tor-accounts
 922   ;; User account and groups for Tor.
 923   (list (user-group (name "tor") (system? #t))
 924         (user-account
 925          (name "tor")
 926          (group "tor")
 927          (system? #t)
 928          (comment "Tor daemon user")
 929          (home-directory "/var/empty")
 930          (shell (file-append shadow "/sbin/nologin")))))
 931
 932 (define-record-type <hidden-service>
 933   (hidden-service name mapping)
 934   hidden-service?
 935   (name    hidden-service-name)                   ;string
 936   (mapping hidden-service-mapping))               ;list of port/address tuples
 937
 938 (define (tor-configuration->torrc config)
 939   "Return a 'torrc' file for CONFIG."
 940   (match config
 941     (($ <tor-configuration> tor config-file services
 942                             socks-socket-type control-socket?)
 943      (computed-file
 944       "torrc"
 945       (with-imported-modules '((guix build utils))
 946         #~(begin
 947             (use-modules (guix build utils)
 948                          (ice-9 match))
 949
 950             (call-with-output-file #$output
 951               (lambda (port)
 952                 (display "\
 953 ### These lines were generated from your system configuration:
 954 DataDirectory /var/lib/tor
 955 Log notice syslog\n" port)
 956                 (when (eq? 'unix '#$socks-socket-type)
 957                   (display "\
 958 SocksPort unix:/var/run/tor/socks-sock
 959 UnixSocksGroupWritable 1\n" port))
 960                 (when #$control-socket?
 961                   (display "\
 962 ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck
 963 ControlSocketsGroupWritable 1\n"
 964                            port))
 965
 966                 (for-each (match-lambda
 967                             ((service (ports hosts) ...)
 968                              (format port "\
 969 HiddenServiceDir /var/lib/tor/hidden-services/~a~%"
 970                                      service)
 971                              (for-each (lambda (tcp-port host)
 972                                          (format port "\
 973 HiddenServicePort ~a ~a~%"
 974                                                  tcp-port host))
 975                                        ports hosts)))
 976                           '#$(map (match-lambda
 977                                     (($ <hidden-service> name mapping)
 978                                      (cons name mapping)))
 979                                   services))
 980
 981                 (display "\
 982 ### End of automatically generated lines.\n\n" port)
 983
 984                 ;; Append the user's config file.
 985                 (call-with-input-file #$config-file
 986                   (lambda (input)
 987                     (dump-port input port)))
 988                 #t))))))))
 989
 990 (define (tor-shepherd-service config)
 991   "Return a <shepherd-service> running Tor."
 992   (match config
 993     (($ <tor-configuration> tor)
 994      (let* ((torrc (tor-configuration->torrc config))
 995             (tor   (least-authority-wrapper
 996                     (file-append tor "/bin/tor")
 997                     #:name "tor"
 998                     #:mappings (list (file-system-mapping
 999                                       (source "/var/lib/tor")
1000                                       (target source)
1001                                       (writable? #t))
1002                                      (file-system-mapping
1003                                       (source "/dev/log") ;for syslog
1004                                       (target source))
1005                                      (file-system-mapping
1006                                       (source "/var/run/tor")
1007                                       (target source)
1008                                       (writable? #t))
1009                                      (file-system-mapping
1010                                       (source torrc)
1011                                       (target source)))
1012                     #:namespaces (delq 'net %namespaces))))
1013        (with-imported-modules (source-module-closure
1014                                '((gnu build shepherd)
1015                                  (gnu system file-systems)))
1016          (list (shepherd-service
1017                 (provision '(tor))
1018
1019                 ;; Tor needs at least one network interface to be up, hence the
1020                 ;; dependency on 'loopback'.
1021                 (requirement '(user-processes loopback syslogd))
1022
1023                 (modules '((gnu build shepherd)
1024                            (gnu system file-systems)))
1025
1026                 ;; XXX: #:pid-file won't work because the wrapped 'tor'
1027                 ;; program would print its PID within the user namespace
1028                 ;; instead of its actual PID outside.  There's no inetd or
1029                 ;; systemd socket activation support either (there's
1030                 ;; 'sd_notify' though), so we're stuck with that.
1031                 (start #~(make-forkexec-constructor
1032                           (list #$tor "-f" #$torrc)
1033                           #:user "tor" #:group "tor"))
1034                 (stop #~(make-kill-destructor))
1035                 (documentation "Run the Tor anonymous network overlay."))))))))
1036
1037 (define (tor-activation config)
1038   "Set up directories for Tor and its hidden services, if any."
1039   #~(begin
1040       (use-modules (guix build utils))
1041
1042       (define %user
1043         (getpw "tor"))
1044
1045       (define (initialize service)
1046         (let ((directory (string-append "/var/lib/tor/hidden-services/"
1047                                         service)))
1048           (mkdir-p directory)
1049           (chown directory (passwd:uid %user) (passwd:gid %user))
1050
1051           ;; The daemon bails out if we give wider permissions.
1052           (chmod directory #o700)))
1053
1054       ;; Allow Tor to write its PID file.
1055       (mkdir-p "/var/run/tor")
1056       (chown "/var/run/tor" (passwd:uid %user) (passwd:gid %user))
1057       ;; Set the group permissions to rw so that if the system administrator
1058       ;; has specified UnixSocksGroupWritable=1 in their torrc file, members
1059       ;; of the "tor" group will be able to use the SOCKS socket.
1060       (chmod "/var/run/tor" #o750)
1061
1062       ;; Allow Tor to access the hidden services' directories.
1063       (mkdir-p "/var/lib/tor")
1064       (chown "/var/lib/tor" (passwd:uid %user) (passwd:gid %user))
1065       (chmod "/var/lib/tor" #o700)
1066
1067       ;; Make sure /var/lib is accessible to the 'tor' user.
1068       (chmod "/var/lib" #o755)
1069
1070       (for-each initialize
1071                 '#$(map hidden-service-name
1072                         (tor-configuration-hidden-services config)))))
1073
1074 (define tor-service-type
1075   (service-type (name 'tor)
1076                 (extensions
1077                  (list (service-extension shepherd-root-service-type
1078                                           tor-shepherd-service)
1079                        (service-extension account-service-type
1080                                           (const %tor-accounts))
1081                        (service-extension activation-service-type
1082                                           tor-activation)))
1083
1084                 ;; This can be extended with hidden services.
1085                 (compose concatenate)
1086                 (extend (lambda (config services)
1087                           (tor-configuration
1088                            (inherit config)
1089                            (hidden-services
1090                             (append (tor-configuration-hidden-services config)
1091                                     services)))))
1092                 (default-value (tor-configuration))
1093                 (description
1094                  "Run the @uref{https://torproject.org, Tor} anonymous
1095 networking daemon.")))
1096
1097 (define tor-hidden-service-type
1098   ;; A type that extends Tor with hidden services.
1099   (service-type (name 'tor-hidden-service)
1100                 (extensions
1101                  (list (service-extension tor-service-type list)))
1102                 (description
1103                  "Define a new Tor @dfn{hidden service}.")))
1104
1105 (define (tor-hidden-service name mapping)
1106   "Define a new Tor @dfn{hidden service} called @var{name} and implementing
1107 @var{mapping}.  @var{mapping} is a list of port/host tuples, such as:
1108
1109 @example
1110  '((22 \"127.0.0.1:22\")
1111    (80 \"127.0.0.1:8080\"))
1112 @end example
1113
1114 In this example, port 22 of the hidden service is mapped to local port 22, and
1115 port 80 is mapped to local port 8080.
1116
1117 This creates a @file{/var/lib/tor/hidden-services/@var{name}} directory, where
1118 the @file{hostname} file contains the @code{.onion} host name for the hidden
1119 service.
1120
1121 See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor
1122 project's documentation} for more information."
1123   (service tor-hidden-service-type
1124            (hidden-service name mapping)))
1125
1126 \f
1127 ;;;
1128 ;;; ModemManager
1129 ;;;
1130
1131 (define-record-type* <modem-manager-configuration>
1132   modem-manager-configuration make-modem-manager-configuration
1133   modem-manager-configuration?
1134   (modem-manager modem-manager-configuration-modem-manager
1135                    (default modem-manager)))
1136
1137 \f
1138 ;;;
1139 ;;; NetworkManager
1140 ;;;
1141
1142 (define-record-type* <network-manager-configuration>
1143   network-manager-configuration make-network-manager-configuration
1144   network-manager-configuration?
1145   (network-manager network-manager-configuration-network-manager
1146                    (default network-manager))
1147   (dns network-manager-configuration-dns
1148        (default "default"))
1149   (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like
1150                (default '())))
1151
1152 (define network-manager-activation
1153   ;; Activation gexp for NetworkManager
1154   (match-lambda
1155     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1156      #~(begin
1157          (use-modules (guix build utils))
1158          (mkdir-p "/etc/NetworkManager/system-connections")
1159          #$@(if (equal? dns "dnsmasq")
1160                 ;; create directory to store dnsmasq lease file
1161                 '((mkdir-p "/var/lib/misc"))
1162                 '())))))
1163
1164 (define (vpn-plugin-directory plugins)
1165   "Return a directory containing PLUGINS, the NM VPN plugins."
1166   (directory-union "network-manager-vpn-plugins" plugins))
1167
1168 (define (network-manager-accounts config)
1169   "Return the list of <user-account> and <user-group> for CONFIG."
1170   (define nologin
1171     (file-append shadow "/sbin/nologin"))
1172
1173   (define accounts
1174     (append-map (lambda (package)
1175                   (map (lambda (name)
1176                          (user-account (system? #t)
1177                                        (name name)
1178                                        (group "network-manager")
1179                                        (comment "NetworkManager helper")
1180                                        (home-directory "/var/empty")
1181                                        (create-home-directory? #f)
1182                                        (shell nologin)))
1183                        (or (assoc-ref (package-properties package)
1184                                       'user-accounts)
1185                            '())))
1186                 (network-manager-configuration-vpn-plugins config)))
1187
1188   (match accounts
1189     (()
1190      '())
1191     (_
1192      (cons (user-group (name "network-manager") (system? #t))
1193            accounts))))
1194
1195 (define network-manager-environment
1196   (match-lambda
1197     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1198      ;; Define this variable in the global environment such that
1199      ;; "nmcli connection import type openvpn file foo.ovpn" works.
1200      `(("NM_VPN_PLUGIN_DIR"
1201         . ,(file-append (vpn-plugin-directory vpn-plugins)
1202                         "/lib/NetworkManager/VPN"))))))
1203
1204 (define network-manager-shepherd-service
1205   (match-lambda
1206     (($ <network-manager-configuration> network-manager dns vpn-plugins)
1207      (let ((conf (plain-file "NetworkManager.conf"
1208                              (string-append "[main]\ndns=" dns "\n")))
1209            (vpn  (vpn-plugin-directory vpn-plugins)))
1210        (list (shepherd-service
1211               (documentation "Run the NetworkManager.")
1212               (provision '(networking))
1213               (requirement '(user-processes dbus-system wpa-supplicant loopback))
1214               (start #~(make-forkexec-constructor
1215                         (list (string-append #$network-manager
1216                                              "/sbin/NetworkManager")
1217                               (string-append "--config=" #$conf)
1218                               "--no-daemon")
1219                         #:environment-variables
1220                         (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn
1221                                              "/lib/NetworkManager/VPN")
1222                               ;; Override non-existent default users
1223                               "NM_OPENVPN_USER="
1224                               "NM_OPENVPN_GROUP=")))
1225               (stop #~(make-kill-destructor))))))))
1226
1227 (define network-manager-service-type
1228   (let
1229       ((config->packages
1230         (match-lambda
1231          (($ <network-manager-configuration> network-manager _ vpn-plugins)
1232           `(,network-manager ,@vpn-plugins)))))
1233
1234     (service-type
1235      (name 'network-manager)
1236      (extensions
1237       (list (service-extension shepherd-root-service-type
1238                                network-manager-shepherd-service)
1239             (service-extension dbus-root-service-type config->packages)
1240             (service-extension polkit-service-type
1241                                (compose
1242                                 list
1243                                 network-manager-configuration-network-manager))
1244             (service-extension account-service-type
1245                                network-manager-accounts)
1246             (service-extension activation-service-type
1247                                network-manager-activation)
1248             (service-extension session-environment-service-type
1249                                network-manager-environment)
1250             ;; Add network-manager to the system profile.
1251             (service-extension profile-service-type config->packages)))
1252      (default-value (network-manager-configuration))
1253      (description
1254       "Run @uref{https://wiki.gnome.org/Projects/NetworkManager,
1255 NetworkManager}, a network management daemon that aims to simplify wired and
1256 wireless networking."))))
1257
1258 \f
1259 ;;;
1260 ;;; Connman
1261 ;;;
1262
1263 (define-record-type* <connman-configuration>
1264   connman-configuration make-connman-configuration
1265   connman-configuration?
1266   (connman      connman-configuration-connman
1267                 (default connman))
1268   (disable-vpn? connman-configuration-disable-vpn?
1269                 (default #f)))
1270
1271 (define (connman-activation config)
1272   (let ((disable-vpn? (connman-configuration-disable-vpn? config)))
1273     (with-imported-modules '((guix build utils))
1274       #~(begin
1275           (use-modules (guix build utils))
1276           (mkdir-p "/var/lib/connman/")
1277           (unless #$disable-vpn?
1278             (mkdir-p "/var/lib/connman-vpn/"))))))
1279
1280 (define (connman-shepherd-service config)
1281   "Return a shepherd service for Connman"
1282   (and
1283    (connman-configuration? config)
1284    (let ((connman      (connman-configuration-connman config))
1285          (disable-vpn? (connman-configuration-disable-vpn? config)))
1286      (list (shepherd-service
1287             (documentation "Run Connman")
1288             (provision '(networking))
1289             (requirement
1290              '(user-processes dbus-system loopback wpa-supplicant))
1291             (start #~(make-forkexec-constructor
1292                       (list (string-append #$connman
1293                                            "/sbin/connmand")
1294                             "--nodaemon"
1295                             "--nodnsproxy"
1296                             #$@(if disable-vpn? '("--noplugin=vpn") '()))
1297
1298                       ;; As connman(8) notes, when passing '-n', connman
1299                       ;; "directs log output to the controlling terminal in
1300                       ;; addition to syslog."  Redirect stdout and stderr
1301                       ;; to avoid spamming the console (XXX: for some reason
1302                       ;; redirecting to /dev/null doesn't work.)
1303                       #:log-file "/var/log/connman.log"))
1304             (stop #~(make-kill-destructor)))))))
1305
1306 (define %connman-log-rotation
1307   (list (log-rotation
1308          (files '("/var/log/connman.log")))))
1309
1310 (define connman-service-type
1311   (let ((connman-package (compose list connman-configuration-connman)))
1312     (service-type (name 'connman)
1313                   (extensions
1314                    (list (service-extension shepherd-root-service-type
1315                                             connman-shepherd-service)
1316                          (service-extension polkit-service-type
1317                                             connman-package)
1318                          (service-extension dbus-root-service-type
1319                                             connman-package)
1320                          (service-extension activation-service-type
1321                                             connman-activation)
1322                          ;; Add connman to the system profile.
1323                          (service-extension profile-service-type
1324                                             connman-package)
1325                          (service-extension rottlog-service-type
1326                                             (const %connman-log-rotation))))
1327                   (default-value (connman-configuration))
1328                   (description
1329                    "Run @url{https://01.org/connman,Connman},
1330 a network connection manager."))))
1331
1332 \f
1333 ;;;
1334 ;;; Modem manager
1335 ;;;
1336
1337 (define modem-manager-service-type
1338   (let ((config->package
1339          (match-lambda
1340           (($ <modem-manager-configuration> modem-manager)
1341            (list modem-manager)))))
1342     (service-type (name 'modem-manager)
1343                   (extensions
1344                    (list (service-extension dbus-root-service-type
1345                                             config->package)
1346                          (service-extension udev-service-type
1347                                             config->package)
1348                          (service-extension polkit-service-type
1349                                             config->package)))
1350                   (default-value (modem-manager-configuration))
1351                   (description
1352                    "Run @uref{https://wiki.gnome.org/Projects/ModemManager,
1353 ModemManager}, a modem management daemon that aims to simplify dialup
1354 networking."))))
1355
1356 \f
1357 ;;;
1358 ;;; USB_ModeSwitch
1359 ;;;
1360
1361 (define-record-type* <usb-modeswitch-configuration>
1362   usb-modeswitch-configuration make-usb-modeswitch-configuration
1363   usb-modeswitch-configuration?
1364   (usb-modeswitch      usb-modeswitch-configuration-usb-modeswitch
1365                        (default usb-modeswitch))
1366   (usb-modeswitch-data usb-modeswitch-configuration-usb-modeswitch-data
1367                        (default usb-modeswitch-data))
1368   (config-file         usb-modeswitch-configuration-config-file
1369                        (default #~(string-append #$usb-modeswitch:dispatcher
1370                                                  "/etc/usb_modeswitch.conf"))))
1371
1372 (define (usb-modeswitch-sh usb-modeswitch config-file)
1373   "Build a copy of usb_modeswitch.sh located in package USB-MODESWITCH,
1374 modified to pass the CONFIG-FILE in its calls to usb_modeswitch_dispatcher,
1375 and wrap it to actually find the dispatcher in USB-MODESWITCH.  The script
1376 will be run by USB_ModeSwitch’s udev rules file when a modeswitchable USB
1377 device is detected."
1378   (computed-file
1379    "usb_modeswitch-sh"
1380    (with-imported-modules '((guix build utils))
1381      #~(begin
1382          (use-modules (guix build utils))
1383          (let ((cfg-param
1384                 #$(if config-file
1385                       #~(string-append " --config-file=" #$config-file)
1386                       "")))
1387            (mkdir #$output)
1388            (install-file (string-append #$usb-modeswitch:dispatcher
1389                                         "/lib/udev/usb_modeswitch")
1390                          #$output)
1391
1392            ;; insert CFG-PARAM into usb_modeswitch_dispatcher command-lines
1393            (substitute* (string-append #$output "/usb_modeswitch")
1394              (("(exec usb_modeswitch_dispatcher .*)( 2>>)" _ left right)
1395               (string-append left cfg-param right))
1396              (("(exec usb_modeswitch_dispatcher .*)( &)" _ left right)
1397               (string-append left cfg-param right)))
1398
1399            ;; wrap-program needs bash in PATH:
1400            (putenv (string-append "PATH=" #$bash "/bin"))
1401            (wrap-program (string-append #$output "/usb_modeswitch")
1402              `("PATH" ":" = (,(string-append #$coreutils "/bin")
1403                              ,(string-append
1404                                #$usb-modeswitch:dispatcher
1405                                "/bin")))))))))
1406
1407 (define (usb-modeswitch-configuration->udev-rules config)
1408   "Build a rules file for extending udev-service-type from the rules in the
1409 usb-modeswitch package specified in CONFIG.  The rules file will invoke
1410 usb_modeswitch.sh from the usb-modeswitch package, modified to pass the right
1411 config file."
1412   (match config
1413     (($ <usb-modeswitch-configuration> usb-modeswitch data config-file)
1414      (computed-file
1415       "usb_modeswitch.rules"
1416       (with-imported-modules '((guix build utils))
1417         #~(begin
1418             (use-modules (guix build utils))
1419             (let ((in (string-append #$data "/udev/40-usb_modeswitch.rules"))
1420                   (out (string-append #$output "/lib/udev/rules.d"))
1421                   (script #$(usb-modeswitch-sh usb-modeswitch config-file)))
1422               (mkdir-p out)
1423               (chdir out)
1424               (install-file in out)
1425               (substitute* "40-usb_modeswitch.rules"
1426                 (("PROGRAM=\"usb_modeswitch")
1427                  (string-append "PROGRAM=\"" script "/usb_modeswitch"))
1428                 (("RUN\\+=\"usb_modeswitch")
1429                  (string-append "RUN+=\"" script "/usb_modeswitch"))))))))))
1430
1431 (define usb-modeswitch-service-type
1432   (service-type
1433    (name 'usb-modeswitch)
1434    (extensions
1435     (list
1436      (service-extension
1437       udev-service-type
1438       (lambda (config)
1439         (let ((rules (usb-modeswitch-configuration->udev-rules config)))
1440           (list rules))))))
1441    (default-value (usb-modeswitch-configuration))
1442    (description "Run @uref{http://www.draisberghof.de/usb_modeswitch/,
1443 USB_ModeSwitch}, a mode switching tool for controlling USB devices with
1444 multiple @dfn{modes}.  When plugged in for the first time many USB
1445 devices (primarily high-speed WAN modems) act like a flash storage containing
1446 installers for Windows drivers.  USB_ModeSwitch replays the sequence the
1447 Windows drivers would send to switch their mode from storage to modem (or
1448 whatever the thing is supposed to do).")))
1449
1450 \f
1451 ;;;
1452 ;;; WPA supplicant
1453 ;;;
1454
1455 (define-record-type* <wpa-supplicant-configuration>
1456   wpa-supplicant-configuration make-wpa-supplicant-configuration
1457   wpa-supplicant-configuration?
1458   (wpa-supplicant     wpa-supplicant-configuration-wpa-supplicant ;file-like
1459                       (default wpa-supplicant))
1460   (requirement        wpa-supplicant-configuration-requirement    ;list of symbols
1461                       (default '(user-processes loopback syslogd)))
1462   (pid-file           wpa-supplicant-configuration-pid-file       ;string
1463                       (default "/var/run/wpa_supplicant.pid"))
1464   (dbus?              wpa-supplicant-configuration-dbus?          ;Boolean
1465                       (default #t))
1466   (interface          wpa-supplicant-configuration-interface      ;#f | string
1467                       (default #f))
1468   (config-file        wpa-supplicant-configuration-config-file    ;#f | <file-like>
1469                       (default #f))
1470   (extra-options      wpa-supplicant-configuration-extra-options  ;list of strings
1471                       (default '())))
1472
1473 (define wpa-supplicant-shepherd-service
1474   (match-lambda
1475     (($ <wpa-supplicant-configuration> wpa-supplicant requirement pid-file dbus?
1476                                        interface config-file extra-options)
1477      (list (shepherd-service
1478             (documentation "Run the WPA supplicant daemon")
1479             (provision '(wpa-supplicant))
1480             (requirement (if dbus?
1481                              (cons 'dbus-system requirement)
1482                              requirement))
1483             (start #~(make-forkexec-constructor
1484                       (list (string-append #$wpa-supplicant
1485                                            "/sbin/wpa_supplicant")
1486                             (string-append "-P" #$pid-file)
1487                             "-B"        ;run in background
1488                             "-s"        ;log to syslogd
1489                             #$@(if dbus?
1490                                    #~("-u")
1491                                    #~())
1492                             #$@(if interface
1493                                    #~((string-append "-i" #$interface))
1494                                    #~())
1495                             #$@(if config-file
1496                                    #~((string-append "-c" #$config-file))
1497                                    #~())
1498                             #$@extra-options)
1499                       #:pid-file #$pid-file))
1500             (stop #~(make-kill-destructor)))))))
1501
1502 (define wpa-supplicant-service-type
1503   (let ((config->package
1504          (match-lambda
1505            (($ <wpa-supplicant-configuration> wpa-supplicant)
1506             (list wpa-supplicant)))))
1507     (service-type (name 'wpa-supplicant)
1508                   (extensions
1509                    (list (service-extension shepherd-root-service-type
1510                                             wpa-supplicant-shepherd-service)
1511                          (service-extension dbus-root-service-type config->package)
1512                          (service-extension profile-service-type config->package)))
1513                   (description "Run the WPA Supplicant daemon, a service that
1514 implements authentication, key negotiation and more for wireless networks.")
1515                   (default-value (wpa-supplicant-configuration)))))
1516
1517 \f
1518 ;;;
1519 ;;; Hostapd.
1520 ;;;
1521
1522 (define-record-type* <hostapd-configuration>
1523   hostapd-configuration make-hostapd-configuration
1524   hostapd-configuration?
1525   (package           hostapd-configuration-package
1526                      (default hostapd))
1527   (interface         hostapd-configuration-interface ;string
1528                      (default "wlan0"))
1529   (ssid              hostapd-configuration-ssid)  ;string
1530   (broadcast-ssid?   hostapd-configuration-broadcast-ssid? ;Boolean
1531                      (default #t))
1532   (channel           hostapd-configuration-channel ;integer
1533                      (default 1))
1534   (driver            hostapd-configuration-driver ;string
1535                      (default "nl80211"))
1536   ;; See <https://w1.fi/cgit/hostap/plain/hostapd/hostapd.conf> for a list of
1537   ;; additional options we could add.
1538   (extra-settings    hostapd-configuration-extra-settings ;string
1539                      (default "")))
1540
1541 (define (hostapd-configuration-file config)
1542   "Return the configuration file for CONFIG, a <hostapd-configuration>."
1543   (match-record config <hostapd-configuration>
1544     (interface ssid broadcast-ssid? channel driver extra-settings)
1545     (plain-file "hostapd.conf"
1546                 (string-append "\
1547 # Generated from your Guix configuration.
1548
1549 interface=" interface "
1550 ssid=" ssid "
1551 ignore_broadcast_ssid=" (if broadcast-ssid? "0" "1") "
1552 channel=" (number->string channel) "\n"
1553 extra-settings "\n"))))
1554
1555 (define* (hostapd-shepherd-services config #:key (requirement '()))
1556   "Return Shepherd services for hostapd."
1557   (list (shepherd-service
1558          (provision '(hostapd))
1559          (requirement `(user-processes ,@requirement))
1560          (documentation "Run the hostapd WiFi access point daemon.")
1561          (start #~(make-forkexec-constructor
1562                    (list #$(file-append (hostapd-configuration-package config)
1563                                         "/sbin/hostapd")
1564                          #$(hostapd-configuration-file config))
1565                    #:log-file "/var/log/hostapd.log"))
1566          (stop #~(make-kill-destructor)))))
1567
1568 (define %hostapd-log-rotation
1569   (list (log-rotation
1570          (files '("/var/log/hostapd.log")))))
1571
1572 (define hostapd-service-type
1573   (service-type
1574    (name 'hostapd)
1575    (extensions
1576     (list (service-extension shepherd-root-service-type
1577                              hostapd-shepherd-services)
1578           (service-extension rottlog-service-type
1579                              (const %hostapd-log-rotation))))
1580    (description
1581     "Run the @uref{https://w1.fi/hostapd/, hostapd} daemon for Wi-Fi access
1582 points and authentication servers.")))
1583
1584 (define (simulated-wifi-shepherd-services config)
1585   "Return Shepherd services to run hostapd with CONFIG, a
1586 <hostapd-configuration>, as well as services to set up WiFi hardware
1587 simulation."
1588   (append (hostapd-shepherd-services config
1589                                      #:requirement
1590                                      '(unblocked-wifi
1591                                        kernel-module-loader))
1592           (list (shepherd-service
1593                  (provision '(unblocked-wifi))
1594                  (requirement '(file-systems kernel-module-loader))
1595                  (documentation
1596                   "Unblock WiFi devices for use by mac80211_hwsim.")
1597                  (start #~(lambda _
1598                             (invoke #$(file-append util-linux "/sbin/rfkill")
1599                                     "unblock" "0")
1600                             (invoke #$(file-append util-linux "/sbin/rfkill")
1601                                     "unblock" "1")))
1602                  (one-shot? #t)))))
1603
1604 (define simulated-wifi-service-type
1605   (service-type
1606    (name 'simulated-wifi)
1607    (extensions
1608     (list (service-extension shepherd-root-service-type
1609                              simulated-wifi-shepherd-services)
1610           (service-extension kernel-module-loader-service-type
1611                              (const '("mac80211_hwsim")))))
1612    (default-value (hostapd-configuration
1613                    (interface "wlan1")
1614                    (ssid "Test Network")))
1615    (description "Run hostapd to simulate WiFi connectivity.")))
1616
1617 \f
1618 ;;;
1619 ;;; Open vSwitch
1620 ;;;
1621
1622 (define-record-type* <openvswitch-configuration>
1623   openvswitch-configuration make-openvswitch-configuration
1624   openvswitch-configuration?
1625   (package openvswitch-configuration-package
1626            (default openvswitch)))
1627
1628 (define openvswitch-activation
1629   (match-lambda
1630     (($ <openvswitch-configuration> package)
1631      (let ((ovsdb-tool (file-append package "/bin/ovsdb-tool")))
1632        (with-imported-modules '((guix build utils))
1633          #~(begin
1634              (use-modules (guix build utils))
1635              (mkdir-p "/var/run/openvswitch")
1636              (mkdir-p "/var/lib/openvswitch")
1637              (let ((conf.db "/var/lib/openvswitch/conf.db"))
1638                (unless (file-exists? conf.db)
1639                  (system* #$ovsdb-tool "create" conf.db)))))))))
1640
1641 (define openvswitch-shepherd-service
1642   (match-lambda
1643     (($ <openvswitch-configuration> package)
1644      (let ((ovsdb-server (file-append package "/sbin/ovsdb-server"))
1645            (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd")))
1646        (list
1647         (shepherd-service
1648          (provision '(ovsdb))
1649          (documentation "Run the Open vSwitch database server.")
1650          (start #~(make-forkexec-constructor
1651                    (list #$ovsdb-server "--pidfile"
1652                          "--remote=punix:/var/run/openvswitch/db.sock")
1653                    #:pid-file "/var/run/openvswitch/ovsdb-server.pid"))
1654          (stop #~(make-kill-destructor)))
1655         (shepherd-service
1656          (provision '(vswitchd))
1657          (requirement '(ovsdb))
1658          (documentation "Run the Open vSwitch daemon.")
1659          (start #~(make-forkexec-constructor
1660                    (list #$ovs-vswitchd "--pidfile")
1661                    #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid"))
1662          (stop #~(make-kill-destructor))))))))
1663
1664 (define openvswitch-service-type
1665   (service-type
1666    (name 'openvswitch)
1667    (extensions
1668     (list (service-extension activation-service-type
1669                              openvswitch-activation)
1670           (service-extension profile-service-type
1671                              (compose list openvswitch-configuration-package))
1672           (service-extension shepherd-root-service-type
1673                              openvswitch-shepherd-service)))
1674    (description
1675     "Run @uref{http://www.openvswitch.org, Open vSwitch}, a multilayer virtual
1676 switch designed to enable massive network automation through programmatic
1677 extension.")
1678    (default-value (openvswitch-configuration))))
1679
1680 ;;;
1681 ;;; iptables
1682 ;;;
1683
1684 (define %iptables-accept-all-rules
1685   (plain-file "iptables-accept-all.rules"
1686               "*filter
1687 :INPUT ACCEPT
1688 :FORWARD ACCEPT
1689 :OUTPUT ACCEPT
1690 COMMIT
1691 "))
1692
1693 (define-record-type* <iptables-configuration>
1694   iptables-configuration make-iptables-configuration iptables-configuration?
1695   (iptables iptables-configuration-iptables
1696             (default iptables))
1697   (ipv4-rules iptables-configuration-ipv4-rules
1698               (default %iptables-accept-all-rules))
1699   (ipv6-rules iptables-configuration-ipv6-rules
1700               (default %iptables-accept-all-rules)))
1701
1702 (define iptables-shepherd-service
1703   (match-lambda
1704     (($ <iptables-configuration> iptables ipv4-rules ipv6-rules)
1705      (let ((iptables-restore (file-append iptables "/sbin/iptables-restore"))
1706            (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore")))
1707        (shepherd-service
1708         (documentation "Packet filtering framework")
1709         (provision '(iptables))
1710         (start #~(lambda _
1711                    (invoke #$iptables-restore #$ipv4-rules)
1712                    (invoke #$ip6tables-restore #$ipv6-rules)))
1713         (stop #~(lambda _
1714                   (invoke #$iptables-restore #$%iptables-accept-all-rules)
1715                   (invoke #$ip6tables-restore #$%iptables-accept-all-rules))))))))
1716
1717 (define iptables-service-type
1718   (service-type
1719    (name 'iptables)
1720    (description
1721     "Run @command{iptables-restore}, setting up the specified rules.")
1722    (extensions
1723     (list (service-extension shepherd-root-service-type
1724                              (compose list iptables-shepherd-service))))))
1725
1726 ;;;
1727 ;;; nftables
1728 ;;;
1729
1730 (define %default-nftables-ruleset
1731   (plain-file "nftables.conf"
1732               "# A simple and safe firewall
1733 table inet filter {
1734   chain input {
1735     type filter hook input priority 0; policy drop;
1736
1737     # early drop of invalid connections
1738     ct state invalid drop
1739
1740     # allow established/related connections
1741     ct state { established, related } accept
1742
1743     # allow from loopback
1744     iifname lo accept
1745
1746     # allow icmp
1747     ip protocol icmp accept
1748     ip6 nexthdr icmpv6 accept
1749
1750     # allow ssh
1751     tcp dport ssh accept
1752
1753     # reject everything else
1754     reject with icmpx type port-unreachable
1755   }
1756   chain forward {
1757     type filter hook forward priority 0; policy drop;
1758   }
1759   chain output {
1760     type filter hook output priority 0; policy accept;
1761   }
1762 }
1763 "))
1764
1765 (define-record-type* <nftables-configuration>
1766   nftables-configuration
1767   make-nftables-configuration
1768   nftables-configuration?
1769   (package nftables-configuration-package
1770            (default nftables))
1771   (ruleset nftables-configuration-ruleset ; file-like object
1772            (default %default-nftables-ruleset)))
1773
1774 (define nftables-shepherd-service
1775   (match-lambda
1776     (($ <nftables-configuration> package ruleset)
1777      (let ((nft (file-append package "/sbin/nft")))
1778        (shepherd-service
1779         (documentation "Packet filtering and classification")
1780         (provision '(nftables))
1781         (start #~(lambda _
1782                    (invoke #$nft "--file" #$ruleset)))
1783         (stop #~(lambda _
1784                   (invoke #$nft "flush" "ruleset"))))))))
1785
1786 (define nftables-service-type
1787   (service-type
1788    (name 'nftables)
1789    (description
1790     "Run @command{nft}, setting up the specified ruleset.")
1791    (extensions
1792     (list (service-extension shepherd-root-service-type
1793                              (compose list nftables-shepherd-service))
1794           (service-extension profile-service-type
1795                              (compose list nftables-configuration-package))))
1796    (default-value (nftables-configuration))))
1797
1798 \f
1799 ;;;
1800 ;;; PageKite
1801 ;;;
1802
1803 (define-record-type* <pagekite-configuration>
1804   pagekite-configuration
1805   make-pagekite-configuration
1806   pagekite-configuration?
1807   (package pagekite-configuration-package
1808            (default pagekite))
1809   (kitename pagekite-configuration-kitename
1810             (default #f))
1811   (kitesecret pagekite-configuration-kitesecret
1812               (default #f))
1813   (frontend pagekite-configuration-frontend
1814             (default #f))
1815   (kites pagekite-configuration-kites
1816          (default '("http:@kitename:localhost:80:@kitesecret")))
1817   (extra-file pagekite-configuration-extra-file
1818               (default #f)))
1819
1820 (define (pagekite-configuration-file config)
1821   (match-record config <pagekite-configuration>
1822     (package kitename kitesecret frontend kites extra-file)
1823     (mixed-text-file "pagekite.rc"
1824                      (if extra-file
1825                          (string-append "optfile = " extra-file "\n")
1826                          "")
1827                      (if kitename
1828                          (string-append "kitename = " kitename "\n")
1829                          "")
1830                      (if kitesecret
1831                          (string-append "kitesecret = " kitesecret "\n")
1832                          "")
1833                      (if frontend
1834                          (string-append "frontend = " frontend "\n")
1835                          "defaults\n")
1836                      (string-join (map (lambda (kite)
1837                                          (string-append "service_on = " kite))
1838                                        kites)
1839                                   "\n"
1840                                   'suffix))))
1841
1842 (define (pagekite-shepherd-service config)
1843   (match-record config <pagekite-configuration>
1844     (package kitename kitesecret frontend kites extra-file)
1845     (with-imported-modules (source-module-closure
1846                             '((gnu build shepherd)
1847                               (gnu system file-systems)))
1848       (shepherd-service
1849        (documentation "Run the PageKite service.")
1850        (provision '(pagekite))
1851        (requirement '(networking))
1852        (modules '((gnu build shepherd)
1853                   (gnu system file-systems)))
1854        (start #~(make-forkexec-constructor/container
1855                  (list #$(file-append package "/bin/pagekite")
1856                        "--clean"
1857                        "--nullui"
1858                        "--nocrashreport"
1859                        "--runas=pagekite:pagekite"
1860                        (string-append "--optfile="
1861                                       #$(pagekite-configuration-file config)))
1862                  #:log-file "/var/log/pagekite.log"
1863                  #:mappings #$(if extra-file
1864                                   #~(list (file-system-mapping
1865                                            (source #$extra-file)
1866                                            (target source)))
1867                                   #~'())))
1868        ;; SIGTERM doesn't always work for some reason.
1869        (stop #~(make-kill-destructor SIGINT))))))
1870
1871 (define %pagekite-log-rotation
1872   (list (log-rotation
1873          (files '("/var/log/pagekite.log")))))
1874
1875 (define %pagekite-accounts
1876   (list (user-group (name "pagekite") (system? #t))
1877         (user-account
1878          (name "pagekite")
1879          (group "pagekite")
1880          (system? #t)
1881          (comment "PageKite user")
1882          (home-directory "/var/empty")
1883          (shell (file-append shadow "/sbin/nologin")))))
1884
1885 (define pagekite-service-type
1886   (service-type
1887    (name 'pagekite)
1888    (default-value (pagekite-configuration))
1889    (extensions
1890     (list (service-extension shepherd-root-service-type
1891                              (compose list pagekite-shepherd-service))
1892           (service-extension account-service-type
1893                              (const %pagekite-accounts))
1894           (service-extension rottlog-service-type
1895                              (const %pagekite-log-rotation))))
1896    (description
1897     "Run @url{https://pagekite.net/,PageKite}, a tunneling solution to make
1898 local servers publicly accessible on the web, even behind NATs and firewalls.")))
1899
1900 \f
1901 ;;;
1902 ;;; Yggdrasil
1903 ;;;
1904
1905 (define-record-type* <yggdrasil-configuration>
1906   yggdrasil-configuration
1907   make-yggdrasil-configuration
1908   yggdrasil-configuration?
1909   (package yggdrasil-configuration-package
1910            (default yggdrasil))
1911   (json-config yggdrasil-configuration-json-config
1912                (default '()))
1913   (config-file yggdrasil-config-file
1914                (default "/etc/yggdrasil-private.conf"))
1915   (autoconf? yggdrasil-configuration-autoconf?
1916              (default #f))
1917   (log-level yggdrasil-configuration-log-level
1918              (default 'info))
1919   (log-to yggdrasil-configuration-log-to
1920           (default 'stdout)))
1921
1922 (define (yggdrasil-configuration-file config)
1923   (define (scm->yggdrasil-json x)
1924     (define key-value?
1925       dotted-list?)
1926     (define (param->camel str)
1927       (string-concatenate
1928        (map
1929         string-capitalize
1930         (string-split str (cut eqv? <> #\-)))))
1931     (cond
1932      ((key-value? x)
1933       (let ((k (car x))
1934             (v (cdr x)))
1935         (cons
1936          (if (symbol? k)
1937              (param->camel (symbol->string k))
1938              k)
1939          v)))
1940      ((list? x) (map scm->yggdrasil-json x))
1941      ((vector? x) (vector-map scm->yggdrasil-json x))
1942      (else x)))
1943   (computed-file
1944    "yggdrasil.conf"
1945    #~(call-with-output-file #$output
1946        (lambda (port)
1947          ;; it's HJSON, so comments are a-okay
1948          (display "# Generated by yggdrasil-service\n" port)
1949          (display #$(scm->json-string
1950                      (scm->yggdrasil-json
1951                       (yggdrasil-configuration-json-config config)))
1952                   port)))))
1953
1954 (define (yggdrasil-shepherd-service config)
1955   "Return a <shepherd-service> for yggdrasil with CONFIG."
1956   (define yggdrasil-command
1957     #~(append
1958        (list (string-append
1959               #$(yggdrasil-configuration-package config)
1960               "/bin/yggdrasil")
1961              "-useconffile"
1962              #$(yggdrasil-configuration-file config))
1963        (if #$(yggdrasil-configuration-autoconf? config)
1964            '("-autoconf")
1965            '())
1966        (let ((extraconf #$(yggdrasil-config-file config)))
1967          (if extraconf
1968              (list "-extraconffile" extraconf)
1969              '()))
1970        (list "-loglevel"
1971              #$(symbol->string
1972                 (yggdrasil-configuration-log-level config))
1973              "-logto"
1974              #$(symbol->string
1975                 (yggdrasil-configuration-log-to config)))))
1976   (list (shepherd-service
1977          (documentation "Connect to the Yggdrasil mesh network")
1978          (provision '(yggdrasil))
1979          (requirement '(networking))
1980          (start #~(make-forkexec-constructor
1981                    #$yggdrasil-command
1982                    #:log-file "/var/log/yggdrasil.log"
1983                    #:group "yggdrasil"))
1984          (stop #~(make-kill-destructor)))))
1985
1986 (define %yggdrasil-log-rotation
1987   (list (log-rotation
1988          (files '("/var/log/yggdrasil.log")))))
1989
1990 (define %yggdrasil-accounts
1991   (list (user-group (name "yggdrasil") (system? #t))))
1992
1993 (define yggdrasil-service-type
1994   (service-type
1995    (name 'yggdrasil)
1996    (description
1997     "Connect to the Yggdrasil mesh network.
1998 See @command{yggdrasil -genconf} for config options.")
1999    (extensions
2000     (list (service-extension shepherd-root-service-type
2001                              yggdrasil-shepherd-service)
2002           (service-extension account-service-type
2003                              (const %yggdrasil-accounts))
2004           (service-extension profile-service-type
2005                              (compose list yggdrasil-configuration-package))
2006           (service-extension rottlog-service-type
2007                              (const %yggdrasil-log-rotation))))))
2008
2009 \f
2010 ;;;
2011 ;;; IPFS
2012 ;;;
2013
2014 (define-record-type* <ipfs-configuration>
2015   ipfs-configuration
2016   make-ipfs-configuration
2017   ipfs-configuration?
2018   (package ipfs-configuration-package
2019            (default go-ipfs))
2020   (gateway ipfs-configuration-gateway
2021            (default "/ip4/127.0.0.1/tcp/8082"))
2022   (api     ipfs-configuration-api
2023            (default "/ip4/127.0.0.1/tcp/5001")))
2024
2025 (define %ipfs-home "/var/lib/ipfs")
2026
2027 (define %ipfs-accounts
2028   (list (user-account
2029          (name "ipfs")
2030          (group "ipfs")
2031          (system? #t)
2032          (comment "IPFS daemon user")
2033          (home-directory "/var/lib/ipfs")
2034          (shell (file-append shadow "/sbin/nologin")))
2035         (user-group
2036          (name "ipfs")
2037          (system? #t))))
2038
2039 (define (ipfs-binary config)
2040   (define command
2041     (file-append (ipfs-configuration-package config) "/bin/ipfs"))
2042
2043   (least-authority-wrapper
2044    command
2045    #:name "ipfs"
2046    #:mappings (list %ipfs-home-mapping)
2047    #:namespaces (delq 'net %namespaces)))
2048
2049 (define %ipfs-home-mapping
2050   (file-system-mapping
2051    (source %ipfs-home)
2052    (target %ipfs-home)
2053    (writable? #t)))
2054
2055 (define %ipfs-environment
2056   #~(list #$(string-append "HOME=" %ipfs-home)))
2057
2058 (define (ipfs-shepherd-service config)
2059   "Return a <shepherd-service> for IPFS with CONFIG."
2060   (define ipfs-daemon-command
2061     #~(list #$(ipfs-binary config) "daemon"))
2062
2063   (list (shepherd-service
2064          (provision '(ipfs))
2065          ;; While IPFS is most useful when the machine is connected
2066          ;; to the network, only loopback is required for starting
2067          ;; the service.
2068          (requirement '(loopback))
2069          (documentation "Connect to the IPFS network")
2070          (start #~(make-forkexec-constructor
2071                    #$ipfs-daemon-command
2072                    #:log-file "/var/log/ipfs.log"
2073                    #:user "ipfs" #:group "ipfs"
2074                    #:environment-variables #$%ipfs-environment))
2075          (stop #~(make-kill-destructor)))))
2076
2077 (define %ipfs-log-rotation
2078   (list (log-rotation
2079          (files '("/var/log/ipfs.log")))))
2080
2081 (define (%ipfs-activation config)
2082   "Return an activation gexp for IPFS with CONFIG"
2083   (define (exec-command . args)
2084     ;; Exec the given ifps command with the right authority.
2085     #~(let ((pid (primitive-fork)))
2086         (if (zero? pid)
2087             (dynamic-wind
2088               (const #t)
2089               (lambda ()
2090                 ;; Run ipfs init and ipfs config from a container,
2091                 ;; in case the IPFS daemon was compromised at some point
2092                 ;; and ~/.ipfs is now a symlink to somewhere outside
2093                 ;; %ipfs-home.
2094                 (let ((pw (getpwnam "ipfs")))
2095                   (setgroups '#())
2096                   (setgid (passwd:gid pw))
2097                   (setuid (passwd:uid pw))
2098                   (environ #$%ipfs-environment)
2099                   (execl #$(ipfs-binary config) #$@args)))
2100               (lambda ()
2101                 (primitive-exit 127)))
2102             (waitpid pid))))
2103
2104   (define settings
2105     `(("Addresses.API" ,(ipfs-configuration-api config))
2106       ("Addresses.Gateway" ,(ipfs-configuration-gateway config))))
2107
2108   (define inner-gexp
2109     #~(begin
2110         (umask #o077)
2111         ;; Create $HOME/.ipfs structure
2112         #$(exec-command "ipfs" "init")
2113         ;; Apply settings
2114         #$@(map (match-lambda
2115                   ((setting value)
2116                    (exec-command "ipfs" "config" setting value)))
2117                 settings)))
2118
2119   (define inner-script
2120     (program-file "ipfs-activation-inner" inner-gexp))
2121
2122   ;; The activation may happen from the initrd, which uses
2123   ;; a statically-linked guile, while the guix container
2124   ;; procedures require a working dynamic-link.
2125   #~(system* #$inner-script))
2126
2127 (define ipfs-service-type
2128   (service-type
2129    (name 'ipfs)
2130    (extensions
2131     (list (service-extension account-service-type
2132                              (const %ipfs-accounts))
2133           (service-extension activation-service-type
2134                              %ipfs-activation)
2135           (service-extension shepherd-root-service-type
2136                              ipfs-shepherd-service)
2137           (service-extension rottlog-service-type
2138                              (const %ipfs-log-rotation))))
2139    (default-value (ipfs-configuration))
2140    (description
2141     "Run @command{ipfs daemon}, the reference implementation
2142 of the IPFS peer-to-peer storage network.")))
2143
2144 \f
2145 ;;;
2146 ;;; Keepalived
2147 ;;;
2148
2149 (define-record-type* <keepalived-configuration>
2150   keepalived-configuration make-keepalived-configuration
2151   keepalived-configuration?
2152   (keepalived  keepalived-configuration-keepalived  ;file-like
2153                (default keepalived))
2154   (config-file keepalived-configuration-config-file ;file-like
2155                (default #f)))
2156
2157 (define keepalived-shepherd-service
2158   (match-lambda
2159     (($ <keepalived-configuration> keepalived config-file)
2160      (list
2161       (shepherd-service
2162        (provision '(keepalived))
2163        (documentation "Run keepalived.")
2164        (requirement '(loopback))
2165        (start #~(make-forkexec-constructor
2166                  (list (string-append #$keepalived "/sbin/keepalived")
2167                        "--dont-fork" "--log-console" "--log-detail"
2168                        "--pid=/var/run/keepalived.pid"
2169                        (string-append "--use-file=" #$config-file))
2170                  #:pid-file "/var/run/keepalived.pid"
2171                  #:log-file "/var/log/keepalived.log"))
2172        (respawn? #f)
2173        (stop #~(make-kill-destructor)))))))
2174
2175 (define %keepalived-log-rotation
2176   (list (log-rotation
2177          (files '("/var/log/keepalived.log")))))
2178
2179 (define keepalived-service-type
2180   (service-type (name 'keepalived)
2181                 (extensions (list (service-extension shepherd-root-service-type
2182                                                      keepalived-shepherd-service)
2183                                   (service-extension rottlog-service-type
2184                                                      (const %keepalived-log-rotation))))
2185                 (description
2186                  "Run @uref{https://www.keepalived.org/, Keepalived}
2187 routing software.")))
2188
2189 ;;; networking.scm ends here