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