;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018–2022 Tobias Geerinckx-Rice ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2020 Brice Waegeneire ;;; Copyright © 2021 Evgeny Pisemsky ;;; Copyright © 2021 Léo Le Bouter ;;; Copyright © 2021 Denis Carikli ;;; Copyright © 2021, 2022 Petr Hodina ;;; Copyright © 2021 Raghav Gururajan ;;; Copyright © 2021 Vinicius Monego ;;; Copyright © 2021, 2022 John Kehayias ;;; Copyright © 2022 Zhu Zihao ;;; Copyright © 2022 Maxime Devos ;;; Copyright © 2022 Marius Bakke ;;; Copyright © 2022 Marcel Kupiec ;;; Copyright © 2022 Maxim Cournoyer ;;; Copyright ©
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017, 2018 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2019, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2019 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2021 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2022, 2023 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2023 Declan Tsien <declantsien@riseup.net>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;; Copyright © 2023 muradm <mail@muradm.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services networking)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services linux)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services dbus)
  #:use-module (gnu services admin)
  #:use-module (gnu system shadow)
  #:use-module (gnu system pam)
  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages cluster)
  #:use-module (gnu packages connman)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages tor)
  #:use-module (gnu packages usb-modeswitch)
  #:use-module (gnu packages messaging)
  #:use-module (gnu packages networking)
  #:use-module (gnu packages ntp)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages ipfs)
  #:use-module (gnu build linux-container)
  #:autoload   (guix least-authority) (least-authority-wrapper)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix deprecation)
  #:use-module (guix diagnostics)
  #:autoload   (guix ui) (display-hint)
  #:use-module (guix i18n)
  #:use-module (rnrs enums)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 string-fun)
  #:use-module (json)
  #:re-export (static-networking-service
               static-networking-service-type)
  #:export (%facebook-host-aliases ;deprecated
            block-facebook-hosts-service-type

            dhcp-client-service-type
            dhcp-client-configuration
            dhcp-client-configuration?
            dhcp-client-configuration-package
            dhcp-client-configuration-interfaces
            dhcp-client-configuration-config-file
            dhcp-client-configuration-shepherd-provision
            dhcp-client-configuration-shepherd-requirement

            dhcpd-service-type
            dhcpd-configuration
            dhcpd-configuration?
            dhcpd-configuration-package
            dhcpd-configuration-config-file
            dhcpd-configuration-version
            dhcpd-configuration-run-directory
            dhcpd-configuration-lease-file
            dhcpd-configuration-pid-file
            dhcpd-configuration-interfaces

            ntp-configuration
            ntp-configuration?
            ntp-configuration-ntp
            ntp-configuration-servers
            ntp-allow-large-adjustment?

            %ntp-servers
            ntp-server
            ntp-server-type
            ntp-server-address
            ntp-server-options

            ntp-service-type

            %openntpd-servers
            openntpd-configuration
            openntpd-configuration?
            openntpd-service-type

            inetd-configuration
            inetd-configuration?
            inetd-configuration-program
            inetd-configuration-entries
            inetd-entry
            inetd-entry?
            inetd-entry-node
            inetd-entry-name
            inetd-entry-socket-type
            inetd-entry-protocol
            inetd-entry-wait?
            inetd-entry-user
            inetd-entry-program
            inetd-entry-arguments
            inetd-service-type

            opendht-configuration
            opendht-configuration-peer-discovery?
            opendht-configuration-verbose?
            opendht-configuration-bootstrap-host
            opendht-configuration-port
            opendht-configuration-proxy-server-port
            opendht-configuration-proxy-server-port-tls
            opendht-configuration->command-line-arguments

            opendht-shepherd-service
            opendht-service-type

            tor-configuration
            tor-configuration?
            tor-configuration-tor
            tor-configuration-config-file
            tor-configuration-hidden-services
            tor-configuration-socks-socket-type
            tor-configuration-control-socket-path
            tor-onion-service-configuration
            tor-onion-service-configuration?
            tor-onion-service-configuration-name
            tor-onion-service-configuration-mapping
            tor-hidden-service  ; deprecated
            tor-service-type

            network-manager-configuration
            network-manager-configuration?
            network-manager-configuration-shepherd-requirement
            network-manager-configuration-dns
            network-manager-configuration-vpn-plugins
            network-manager-service-type

            connman-general-configuration
            connman-general-configuration?
            connman-configuration
            connman-configuration?
            connman-configuration-connman
            connman-configuration-shepherd-requirement
            connman-configuration-disable-vpn?
            connman-configuration-iwd?
            connman-service-type

            modem-manager-configuration
            modem-manager-configuration?
            modem-manager-service-type

            usb-modeswitch-configuration
            usb-modeswitch-configuration?
            usb-modeswitch-configuration-usb-modeswitch
            usb-modeswitch-configuration-usb-modeswitch-data
            usb-modeswitch-service-type

            wpa-supplicant-configuration
            wpa-supplicant-configuration?
            wpa-supplicant-configuration-wpa-supplicant
            wpa-supplicant-configuration-requirement
            wpa-supplicant-configuration-pid-file
            wpa-supplicant-configuration-dbus?
            wpa-supplicant-configuration-interface
            wpa-supplicant-configuration-config-file
            wpa-supplicant-configuration-extra-options
            wpa-supplicant-service-type

            hostapd-configuration
            hostapd-configuration?
            hostapd-configuration-package
            hostapd-configuration-interface
            hostapd-configuration-ssid
            hostapd-configuration-broadcast-ssid?
            hostapd-configuration-channel
            hostapd-configuration-driver
            hostapd-service-type

            simulated-wifi-service-type

            openvswitch-service-type
            openvswitch-configuration

            iptables-configuration
            iptables-configuration?
            iptables-configuration-iptables
            iptables-configuration-ipv4-rules
            iptables-configuration-ipv6-rules
            iptables-service-type

            nftables-service-type
            nftables-configuration
            nftables-configuration?
            nftables-configuration-package
            nftables-configuration-ruleset
            %default-nftables-ruleset

            pagekite-service-type
            pagekite-configuration
            pagekite-configuration?
            pagekite-configuration-package
            pagekite-configuration-kitename
            pagekite-configuration-kitesecret
            pagekite-configuration-frontend
            pagekite-configuration-kites
            pagekite-configuration-extra-file

            yggdrasil-service-type
            yggdrasil-configuration
            yggdrasil-configuration?
            yggdrasil-configuration-autoconf?
            yggdrasil-configuration-config-file
            yggdrasil-configuration-log-level
            yggdrasil-configuration-log-to
            yggdrasil-configuration-json-config
            yggdrasil-configuration-package

            ipfs-service-type
            ipfs-configuration
            ipfs-configuration?
            ipfs-configuration-package
            ipfs-configuration-gateway
            ipfs-configuration-api

            keepalived-configuration
            keepalived-configuration?
            keepalived-service-type))

;;; Commentary:
;;;
;;; Networking services.
;;;
;;; Code:

(define %unroutable-ipv4
  ;; Unroutable address, as per <https://www.rfc-editor.org/rfc/rfc5737>.
  "203.0.113.1")

(define %unroutable-ipv6
  ;; Unroutable address, as per <https://www.rfc-editor.org/rfc/rfc6666>.
  "0100::")

(define facebook-host-aliases
  ;; This is the list of known Facebook hosts to be added to /etc/hosts if you
  ;; are to block it.
  (let ((domains '("facebook.com" "www.facebook.com"
                   "login.facebook.com" "www.login.facebook.com"
                   "fbcdn.net" "www.fbcdn.net" "fbcdn.com" "www.fbcdn.com"
                   "static.ak.fbcdn.net" "static.ak.connect.facebook.com"
                   "connect.facebook.net" "www.connect.facebook.net"
                   "apps.facebook.com")))
    (append-map (lambda (name)
                  (map (lambda (addr)
                         (host addr name))
                       (list %unroutable-ipv4 %unroutable-ipv6)))
                domains)))

(define-deprecated %facebook-host-aliases
  block-facebook-hosts-service-type
  (string-join
   (map (lambda (x)
          (string-append (host-address x) "\t"
                         (host-canonical-name x) "\n"))
        facebook-host-aliases)))

(define block-facebook-hosts-service-type
  (service-type
   (name 'block-facebook-hosts)
   (extensions
    (list (service-extension hosts-service-type
                             (const facebook-host-aliases))))
   (default-value #f)
   (description "Add a list of known Facebook hosts to @file{/etc/hosts}")))

(define-record-type* <dhcp-client-configuration>
  dhcp-client-configuration make-dhcp-client-configuration
  dhcp-client-configuration?
  (package      dhcp-client-configuration-package ;file-like
                (default isc-dhcp))
  (shepherd-requirement dhcp-client-configuration-shepherd-requirement
                        (default '()))
  (shepherd-provision   dhcp-client-configuration-shepherd-provision
                        (default '(networking)))
  (config-file dhcp-client-configuration-config-file
               (default #f))
  (interfaces   dhcp-client-configuration-interfaces
                (default 'all)))                  ;'all | list of strings

(define dhcp-client-shepherd-service
  (match-lambda
    ((? dhcp-client-configuration? config)
     (let ((package (dhcp-client-configuration-package config))
           (requirement (dhcp-client-configuration-shepherd-requirement config))
           (provision (dhcp-client-configuration-shepherd-provision config))
           (interfaces (dhcp-client-configuration-interfaces config))
           (config-file (dhcp-client-configuration-config-file config))
           (pid-file "/var/run/dhclient.pid"))
       (list (shepherd-service
              (documentation "Set up networking via DHCP.")
              (requirement `(user-processes udev ,@requirement))
              (provision provision)

              ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
              ;; networking is unavailable, but also means that the interface is not up
              ;; yet when 'start' completes.  To wait for the interface to be ready, one
              ;; should instead monitor udev events.
              (start #~(lambda _
                         (define dhclient
                           (string-append #$package "/sbin/dhclient"))

                         ;; When invoked without any arguments, 'dhclient' discovers all
                         ;; non-loopback interfaces *that are up*.  However, the relevant
                         ;; interfaces are typically down at this point.  Thus we perform
                         ;; our own interface discovery here.
                         (define valid?
                           (lambda (interface)
                             (and (arp-network-interface? interface)
                                  (not (loopback-network-interface? interface))
                                  ;; XXX: Make sure the interfaces are up so that
                                  ;; 'dhclient' can actually send/receive over them.
                                  ;; Ignore those that cannot be activated.
                                  (false-if-exception
                                   (set-network-interface-up interface)))))
                         (define ifaces
                           (filter valid?
                                   #$(match interfaces
                                       ('all
                                        #~(all-network-interface-names))
                                       (_
                                        #~'#$interfaces))))

                         (define config-file-args
                           (if #$config-file
                               (list "-cf" #$config-file)
                               '()))

                         (false-if-exception (delete-file #$pid-file))
                         (let ((pid (fork+exec-command
                                     ;; By default dhclient uses a
                                     ;; pre-standardization implementation of
                                     ;; DDNS, which is incompatable with
                                     ;; non-ISC DHCP servers; thus, pass '-I'.
                                     ;; <https://kb.isc.org/docs/aa-01091>.
                                     `(,dhclient "-nw" "-I"
                                                 "-pf" ,#$pid-file
                                                 ,@config-file-args
                                                 ,@ifaces))))
                           (and (zero? (cdr (waitpid pid)))
                                (read-pid-file #$pid-file)))))
              (stop #~(make-kill-destructor))))))
    (package
     (warning (G_ "'dhcp-client' service now expects a \
'dhcp-client-configuration' record~%"))
     (display-hint (G_ "The value associated with instances of
@code{dhcp-client-service-type} must now be a @code{dhcp-client-configuration}
record instead of a package.  Please adjust your configuration accordingly."))
     (dhcp-client-shepherd-service
      (dhcp-client-configuration
       (package package))))))

(define dhcp-client-service-type
  (service-type (name 'dhcp-client)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          dhcp-client-shepherd-service)))
                (default-value (dhcp-client-configuration))
                (description "Run @command{dhcp}, a Dynamic Host Configuration
Protocol (DHCP) client, on all the non-loopback network interfaces.")))

(define-record-type* <dhcpd-configuration>
  dhcpd-configuration make-dhcpd-configuration
  dhcpd-configuration?
  (package   dhcpd-configuration-package ;file-like
             (default isc-dhcp))
  (config-file   dhcpd-configuration-config-file ;file-like
                 (default #f))
  (version dhcpd-configuration-version ;"4", "6", or "4o6"
              (default "4"))
  (run-directory dhcpd-configuration-run-directory
                 (default "/run/dhcpd"))
  (lease-file dhcpd-configuration-lease-file
              (default "/var/db/dhcpd.leases"))
  (pid-file dhcpd-configuration-pid-file
            (default "/run/dhcpd/dhcpd.pid"))
  ;; list of strings, e.g. (list "enp0s25")
  (interfaces dhcpd-configuration-interfaces
              (default '())))

(define (dhcpd-shepherd-service config)
  (match-record config <dhcpd-configuration>
    (package config-file version run-directory
             lease-file pid-file interfaces)
    (unless config-file
      (error "Must supply a config-file"))
    (list (shepherd-service
           ;; Allow users to easily run multiple versions simultaneously.
           (provision (list (string->symbol
                             (string-append "dhcpv" version "-daemon"))))
           (documentation (string-append "Run the DHCPv" version " daemon"))
           (requirement '(networking))
           (start #~(make-forkexec-constructor
                     '(#$(file-append package "/sbin/dhcpd")
                       #$(string-append "-" version)
                       "-lf" #$lease-file
                       "-pf" #$pid-file
                       "-cf" #$config-file
                       #$@interfaces)
                     #:pid-file #$pid-file))
           (stop #~(make-kill-destructor))))))

(define (dhcpd-activation config)
  (match-record config <dhcpd-configuration>
    (package config-file version run-directory
             lease-file pid-file interfaces)
    (with-imported-modules '((guix build utils))
      #~(begin
          (unless (file-exists? #$run-directory)
            (mkdir #$run-directory))
          ;; According to the DHCP manual (man dhcpd.leases), the lease
          ;; database must be present for dhcpd to start successfully.
          (unless (file-exists? #$lease-file)
            (with-output-to-file #$lease-file
              (lambda _ (display ""))))
          ;; Validate the config.
          (invoke/quiet
           #$(file-append package "/sbin/dhcpd")
           #$(string-append "-" version)
           "-t" "-cf" #$config-file)))))

(define dhcpd-service-type
  (service-type
   (name 'dhcpd)
   (extensions
    (list (service-extension shepherd-root-service-type dhcpd-shepherd-service)
          (service-extension activation-service-type dhcpd-activation)))
   (description "Run a DHCP (Dynamic Host Configuration Protocol) daemon.  The
daemon is responsible for allocating IP addresses to its client.")))


;;;
;;; NTP.
;;;


(define %ntp-log-rotation
  (list (log-rotation
         (files '("/var/log/ntpd.log")))))

(define ntp-server-types (make-enumeration
                          '(pool
                            server
                            peer
                            broadcast
                            manycastclient)))

(define-record-type* <ntp-server>
  ntp-server make-ntp-server
  ntp-server?
  ;; The type can be one of the symbols of the NTP-SERVER-TYPE? enumeration.
  (type ntp-server-type
        (default 'server))
  (address ntp-server-address)    ; a string
  ;; The list of options can contain single option names or tuples in the form
  ;; '(name value).
  (options ntp-server-options
           (default '())))

(define (ntp-server->string ntp-server)
  ;; Serialize the NTP server object as a string, ready to use in the NTP
  ;; configuration file.
  (define (flatten lst)
    (reverse
     (let loop ((x lst)
                (res '()))
       (if (list? x)
           (fold loop res x)
           (cons (format #f "~a" x) res)))))

  (match-record ntp-server <ntp-server>
    (type address options)
    ;; XXX: It'd be neater if fields were validated at the syntax level (for
    ;; static ones at least).  Perhaps the Guix record type could support a
    ;; predicate property on a field?
    (unless (enum-set-member? type ntp-server-types)
      (error "Invalid NTP server type" type))
    (string-join (cons* (symbol->string type)
                        address
                        (flatten options)))))

(define %ntp-servers
  ;; Default set of NTP servers. These URLs are managed by the NTP Pool project.
  ;; Within Guix, Leo Famulari <leo@famulari.name> is the administrative contact
  ;; for this NTP pool "zone".
  ;; The full list of available URLs are 0.guix.pool.ntp.org,
  ;; 1.guix.pool.ntp.org, 2.guix.pool.ntp.org, and 3.guix.pool.ntp.org.
  (list
   (ntp-server
    (type 'pool)
    (address "0.guix.pool.ntp.org")
    (options '("iburst")))))               ;as recommended in the ntpd manual

(define-record-type* <ntp-configuration>
  ntp-configuration make-ntp-configuration
  ntp-configuration?
  (ntp      ntp-configuration-ntp
            (default ntp))
  (servers  ntp-configuration-servers     ;list of <ntp-server> objects
            (default %ntp-servers))
  (allow-large-adjustment? ntp-allow-large-adjustment?
                           (default #t))) ;as recommended in the ntpd manual

(define (ntp-shepherd-service config)
  (match-record config <ntp-configuration>
    (ntp servers allow-large-adjustment?)
    ;; TODO: Add authentication support.
    (define config
      (string-append "driftfile /var/run/ntpd/ntp.drift\n"
                     (string-join (map ntp-server->string servers) "\n")
                     "
# Disable status queries as a workaround for CVE-2013-5211:
# <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
restrict default kod nomodify notrap nopeer noquery limited
restrict -6 default kod nomodify notrap nopeer noquery limited

# Yet, allow use of the local 'ntpq'.
restrict 127.0.0.1
restrict -6 ::1

# This is required to use servers from a pool directive when using the 'nopeer'
# option by default, as documented in the 'ntp.conf' manual.
restrict source notrap nomodify noquery\n"))

    (define ntpd.conf
      (plain-file "ntpd.conf" config))

    (list (shepherd-service
           (provision '(ntpd))
           (documentation "Run the Network Time Protocol (NTP) daemon.")
           (requirement '(user-processes networking))
           (actions (list (shepherd-configuration-action ntpd.conf)))
           (start #~(make-forkexec-constructor
                     (list (string-append #$ntp "/bin/ntpd") "-n"
                           "-c" #$ntpd.conf "-u" "ntpd"
                           #$@(if allow-large-adjustment?
                                  '("-g")
                                  '()))
                     #:log-file "/var/log/ntpd.log"))
           (stop #~(make-kill-destructor))))))

(define %ntp-accounts
  (list (user-account
         (name "ntpd")
         (group "nogroup")
         (system? #t)
         (comment "NTP daemon user")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))


(define (ntp-service-activation config)
  "Return the activation gexp for CONFIG."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        (define %user
          (getpw "ntpd"))

        (let ((directory "/var/run/ntpd"))
          (mkdir-p directory)
          (chown directory (passwd:uid %user) (passwd:gid %user))))))

(define ntp-service-type
  (service-type (name 'ntp)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          ntp-shepherd-service)
                       (service-extension account-service-type
                                          (const %ntp-accounts))
                       (service-extension activation-service-type
                                          ntp-service-activation)
                       (service-extension rottlog-service-type
                                          (const %ntp-log-rotation))))
                (description
                 "Run the @command{ntpd}, the Network Time Protocol (NTP)
daemon of the @uref{http://www.ntp.org, Network Time Foundation}.  The daemon
will keep the system clock synchronized with that of the given servers.")
                (default-value (ntp-configuration))))


;;;
;;; OpenNTPD.
;;;

(define %openntpd-servers
  (map ntp-server-address %ntp-servers))

(define-record-type* <openntpd-configuration>
  openntpd-configuration make-openntpd-configuration
  openntpd-configuration?
  (openntpd                openntpd-configuration-openntpd
                           (default openntpd))
  (listen-on               openntpd-listen-on
                           (default '("127.0.0.1"
                                      "::1")))
  (query-from              openntpd-query-from
                           (default '()))
  (sensor                  openntpd-sensor
                           (default '()))
  (server                  openntpd-server
                           (default '()))
  (servers                 openntpd-servers
                           (default %openntpd-servers))
  (constraint-from         openntpd-constraint-from
                           (default '()))
  (constraints-from        openntpd-constraints-from
                           (default '())))

(define (openntpd-configuration->string config)

  (define (quote-field? name)
    (member name '("constraints from")))

  (match-record config <openntpd-configuration>
    (listen-on query-from sensor server servers constraint-from
               constraints-from)
    (string-append
     (string-join
      (concatenate
       (filter-map (lambda (field values)
                     (match values
                       (() #f)          ;discard entry with filter-map
                       ((val ...)       ;validate value type
                        (map (lambda (value)
                               (if (quote-field? field)
                                   (format #f "~a \"~a\"" field value)
                                   (format #f "~a ~a" field value)))
                             values))))
                   ;; The entry names.
                   '("listen on" "query from" "sensor" "server" "servers"
                     "constraint from" "constraints from")
                   ;; The corresponding entry values.
                   (list listen-on query-from sensor server servers
                         constraint-from constraints-from)))
      "\n")
     "\n")))                              ;add a trailing newline

(define (openntpd-shepherd-service config)
  (let ((openntpd (openntpd-configuration-openntpd config)))

    (define ntpd.conf
      (plain-file "ntpd.conf" (openntpd-configuration->string config)))

    (list (shepherd-service
           (provision '(ntpd))
           (documentation "Run the Network Time Protocol (NTP) daemon.")
           (requirement '(user-processes networking))
           (start #~(make-forkexec-constructor
                     (list (string-append #$openntpd "/sbin/ntpd")
                           "-f" #$ntpd.conf
                           "-d") ;; don't daemonize
                     ;; When ntpd is daemonized it repeatedly tries to respawn
                     ;; while running, leading shepherd to disable it.  To
                     ;; prevent spamming stderr, redirect output to logfile.
                     #:log-file "/var/log/ntpd.log"))
           (stop #~(make-kill-destructor))
           (actions (list (shepherd-configuration-action ntpd.conf)))))))

(define (openntpd-service-activation config)
  "Return the activation gexp for CONFIG."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        (mkdir-p "/var/db")
        (mkdir-p "/var/run")
        (unless (file-exists? "/var/db/ntpd.drift")
          (with-output-to-file "/var/db/ntpd.drift"
                               (lambda _
                                 (format #t "0.0")))))))

(define openntpd-service-type
  (service-type (name 'openntpd)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          openntpd-shepherd-service)
                       (service-extension account-service-type
                                          (const %ntp-accounts))
                       (service-extension profile-service-type
                                          (compose list openntpd-configuration-openntpd))
                       (service-extension activation-service-type
                                          openntpd-service-activation)
                       (service-extension rottlog-service-type
                                          (const %ntp-log-rotation))))
                (default-value (openntpd-configuration))
                (description
                 "Run the @command{ntpd}, the Network Time Protocol (NTP)
daemon, as implemented by @uref{http://www.openntpd.org, OpenNTPD}.  The
daemon will keep the system clock synchronized with that of the given servers.")))


;;;
;;; Inetd.
;;;

(define-record-type* <inetd-configuration> inetd-configuration
  make-inetd-configuration
  inetd-configuration?
  (program           inetd-configuration-program   ;file-like
                     (default (file-append inetutils "/libexec/inetd")))
  (entries           inetd-configuration-entries   ;list of <inetd-entry>
                     (default '())))

(define-record-type* <inetd-entry> inetd-entry make-inetd-entry
  inetd-entry?
  (node              inetd-entry-node         ;string or #f
                     (default #f))
  (name              inetd-entry-name)        ;string, from /etc/services

  (socket-type       inetd-entry-socket-type) ;stream | dgram | raw |
                                              ;rdm | seqpacket
  (protocol          inetd-entry-protocol)    ;string, from /etc/protocols

  (wait?             inetd-entry-wait?        ;Boolean
                     (default #t))
  (user              inetd-entry-user)        ;string

  (program           inetd-entry-program      ;string or file-like object
                     (default "internal"))
  (arguments         inetd-entry-arguments    ;list of strings or file-like objects
                     (default '())))

(define (inetd-config-file entries)
  (apply mixed-text-file "inetd.conf"
         (map
          (lambda (entry)
            (let* ((node (inetd-entry-node entry))
                   (name (inetd-entry-name entry))
                   (socket
                    (if node (string-append node ":" name) name))
                   (type
                    (match (inetd-entry-socket-type entry)
                      ((or 'stream 'dgram 'raw 'rdm 'seqpacket)
                       (symbol->string (inetd-entry-socket-type entry)))))
                   (protocol (inetd-entry-protocol entry))
                   (wait (if (inetd-entry-wait? entry) "wait" "nowait"))
                   (user (inetd-entry-user entry))
                   (program (inetd-entry-program entry))
                   (args (inetd-entry-arguments entry)))
              #~(string-append
                 (string-join
                  (list #$@(list socket type protocol wait user program) #$@args)
                  " ") "\n")))
          entries)))

(define (inetd-shepherd-service config)
  (let ((entries (inetd-configuration-entries config)))
    (if (null? entries)
        '()                                       ;do nothing
        (let ((program (inetd-configuration-program config)))
          (list (shepherd-service
                 (documentation "Run inetd.")
                 (provision '(inetd))
                 (requirement '(user-processes networking syslogd))
                 (start #~(make-forkexec-constructor
                           (list #$program #$(inetd-config-file entries))
                           #:pid-file "/var/run/inetd.pid"))
                 (stop #~(make-kill-destructor))))))))

(define-public inetd-service-type
  (service-type
   (name 'inetd)
   (extensions
    (list (service-extension shepherd-root-service-type
                             inetd-shepherd-service)))

   ;; The service can be extended with additional lists of entries.
   (compose concatenate)
   (extend (lambda (config entries)
             (inetd-configuration
              (inherit config)
              (entries (append (inetd-configuration-entries config)
                               entries)))))
   (description
    "Start @command{inetd}, the @dfn{Internet superserver}.  It is responsible
for listening on Internet sockets and spawning the corresponding services on
demand.")))


;;;
;;; OpenDHT, the distributed hash table network used by Jami
;;;

(define-maybe/no-serialization number)
(define-maybe/no-serialization string)

;;; To generate the documentation of the following configuration record, you
;;; can evaluate: (configuration->documentation 'opendht-configuration)
(define-configuration/no-serialization opendht-configuration
  (opendht
   (file-like opendht)
   "The @code{opendht} package to use.")
  (peer-discovery?
   (boolean #false)
   "Whether to enable the multicast local peer discovery mechanism.")
  (enable-logging?
   (boolean #false)
   "Whether to enable logging messages to syslog.  It is disabled by default
as it is rather verbose.")
  (debug?
   (boolean #false)
   "Whether to enable debug-level logging messages.  This has no effect if
logging is disabled.")
  (bootstrap-host
   (maybe-string "bootstrap.jami.net:4222")
   "The node host name that is used to make the first connection to the
network.  A specific port value can be provided by appending the @code{:PORT}
suffix.  By default, it uses the Jami bootstrap nodes, but any host can be
specified here.  It's also possible to disable bootstrapping by explicitly
setting this field to @code{%unset-value}.")
  (port
   (maybe-number 4222)
   "The UDP port to bind to.  When left unspecified, an available port is
automatically selected.")
  (proxy-server-port
   maybe-number
   "Spawn a proxy server listening on the specified port.")
  (proxy-server-port-tls
   maybe-number
   "Spawn a proxy server listening to TLS connections on the specified
port."))

(define %opendht-accounts
  ;; User account and groups for Tor.
  (list (user-group (name "opendht") (system? #t))
        (user-account
         (name "opendht")
         (group "opendht")
         (system? #t)
         (comment "OpenDHT daemon user")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))

(define (opendht-configuration->command-line-arguments config)
  "Derive the command line arguments used to launch the OpenDHT daemon from
CONFIG, an <opendht-configuration> object."
  (match-record config <opendht-configuration>
    (opendht bootstrap-host enable-logging? port debug? peer-discovery?
             proxy-server-port proxy-server-port-tls)
    (let ((dhtnode (least-authority-wrapper
                    ;; XXX: Work around lack of support for multiple outputs
                    ;; in 'file-append'.
                    (computed-file "dhtnode"
                                   #~(symlink
                                      (string-append #$opendht:tools
                                                     "/bin/dhtnode")
                                      #$output))
                    #:name "dhtnode"
                    #:mappings (list (file-system-mapping
                                      (source "/dev/log") ;for syslog
                                      (target source)))
                    #:namespaces (delq 'net %namespaces))))
      `(,dhtnode
        "--service"                     ;non-forking mode
        ,@(if (string? bootstrap-host)
              (list "--bootstrap" bootstrap-host))
        ,@(if enable-logging?
              (list "--syslog")
              '())
        ,@(if (number? port)
              (list "--port" (number->string port))
              '())
        ,@(if debug?
              (list "--verbose")
              '())
        ,@(if peer-discovery?
              (list "--peer-discovery")
              '())
        ,@(if (number? proxy-server-port)
              (list "--proxyserver" (number->string proxy-server-port))
              '())
        ,@(if (number? proxy-server-port-tls)
              (list "--proxyserverssl" (number->string proxy-server-port-tls))
              '())))))

(define (opendht-shepherd-service config)
  "Return a <shepherd-service> running OpenDHT."
  (shepherd-service
   (documentation "Run an OpenDHT node.")
   (provision '(opendht dhtnode dhtproxy))
   (requirement '(networking syslogd))
   (start #~(make-forkexec-constructor
             (list #$@(opendht-configuration->command-line-arguments config))
             #:user "opendht"
             #:group "opendht"))
   (stop #~(make-kill-destructor))))

(define opendht-service-type
  (service-type
   (name 'opendht)
   (default-value (opendht-configuration))
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list opendht-shepherd-service))
          (service-extension account-service-type
                             (const %opendht-accounts))))
   (description "Run the OpenDHT @command{dhtnode} command that allows
participating in the distributed hash table based OpenDHT network.  The
service can be configured to act as a proxy to the distributed network, which
can be useful for portable devices where minimizing energy consumption is
paramount.  OpenDHT was originally based on Kademlia and adapted for
applications in communication.  It is used by Jami, for example.")))


;;;
;;; Tor.
;;;

(define-record-type* <tor-configuration>
  tor-configuration make-tor-configuration
  tor-configuration?
  (tor              tor-configuration-tor
                    (default tor))
  (config-file      tor-configuration-config-file
                    (default (plain-file "empty" "")))
  (hidden-services  tor-configuration-hidden-services
                    (default '()))
  (socks-socket-type tor-configuration-socks-socket-type ; 'tcp or 'unix
                     (default 'tcp))
  (control-socket?  tor-configuration-control-socket-path
                    (default #f)))

(define %tor-accounts
  ;; User account and groups for Tor.
  (list (user-group (name "tor") (system? #t))
        (user-account
         (name "tor")
         (group "tor")
         (system? #t)
         (comment "Tor daemon user")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))

(define-configuration/no-serialization tor-onion-service-configuration
  (name
   string
   "Name for this Onion Service.  This creates a
@file{/var/lib/tor/hidden-services/@var{name}} directory, where the
@file{hostname} file contains the @indicateurl{.onion} host name for this
Onion Service.")

  (mapping
   alist
   "Association list of port to address mappings.  The following example:
@lisp
'((22 . \"127.0.0.1:22\")
  (80 . \"127.0.0.1:8080\"))
@end lisp
maps ports 22 and 80 of the Onion Service to the local ports 22 and 8080."))

(define (tor-configuration->torrc config)
  "Return a 'torrc' file for CONFIG."
  (match-record config <tor-configuration>
    (tor config-file hidden-services socks-socket-type control-socket?)
    (computed-file
     "torrc"
     (with-imported-modules '((guix build utils))
       #~(begin
           (use-modules (guix build utils)
                        (ice-9 match))

           (call-with-output-file #$output
             (lambda (port)
               (display "\
### These lines were generated from your system configuration:
DataDirectory /var/lib/tor
Log notice stderr\n" port)
               (when (eq? 'unix '#$socks-socket-type)
                 (display "\
SocksPort unix:/var/run/tor/socks-sock
UnixSocksGroupWritable 1\n" port))
               (when #$control-socket?
                 (display "\
ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck
ControlSocketsGroupWritable 1\n"
                          port))

               (for-each (match-lambda
                           ((service (ports hosts) ...)
                            (format port "\
HiddenServiceDir /var/lib/tor/hidden-services/~a~%"
                                    service)
                            (for-each (lambda (tcp-port host)
                                        (format port "\
HiddenServicePort ~a ~a~%"
                                                tcp-port host))
                                      ports hosts)))
                         '#$(map (match-lambda
                                   (($ <tor-onion-service-configuration> name mapping)
                                    (cons name mapping)))
                                 hidden-services))

               (display "\
### End of automatically generated lines.\n\n" port)

               ;; Append the user's config file.
               (call-with-input-file #$config-file
                 (lambda (input)
                   (dump-port input port)))
               #t)))))))

(define (tor-shepherd-service config)
  "Return a <shepherd-service> running Tor."
  (let* ((torrc (tor-configuration->torrc config))
         (tor   (least-authority-wrapper
                 (file-append (tor-configuration-tor config) "/bin/tor")
                 #:name "tor"
                 #:mappings (list (file-system-mapping
                                   (source "/var/lib/tor")
                                   (target source)
                                   (writable? #t))
                                  (file-system-mapping
                                   (source "/var/run/tor")
                                   (target source)
                                   (writable? #t))
                                  (file-system-mapping
                                   (source torrc)
                                   (target source)))
                 #:namespaces (delq 'net %namespaces))))
    (list (shepherd-service
           (provision '(tor))

           ;; Tor needs at least one network interface to be up, hence the
           ;; dependency on 'loopback'.
           (requirement '(user-processes loopback syslogd))

           ;; XXX: #:pid-file won't work because the wrapped 'tor'
           ;; program would print its PID within the user namespace
           ;; instead of its actual PID outside.  There's no inetd or
           ;; systemd socket activation support either (there's
           ;; 'sd_notify' though), so we're stuck with that.
           (start #~(make-forkexec-constructor
                     (list #$tor "-f" #$torrc)
                     #:user "tor" #:group "tor"))
           (stop #~(make-kill-destructor))
           (actions (list (shepherd-configuration-action torrc)))
           (documentation "Run the Tor anonymous network overlay.")))))

(define (tor-activation config)
  "Set up directories for Tor and its hidden services, if any."
  #~(begin
      (use-modules (guix build utils))

      (define %user
        (getpw "tor"))

      (define (initialize service)
        (let ((directory (string-append "/var/lib/tor/hidden-services/"
                                        service)))
          (mkdir-p directory)
          (chown directory (passwd:uid %user) (passwd:gid %user))

          ;; The daemon bails out if we give wider permissions.
          (chmod directory #o700)))

      ;; Allow Tor to write its PID file.
      (mkdir-p "/var/run/tor")
      (chown "/var/run/tor" (passwd:uid %user) (passwd:gid %user))
      ;; Set the group permissions to rw so that if the system administrator
      ;; has specified UnixSocksGroupWritable=1 in their torrc file, members
      ;; of the "tor" group will be able to use the SOCKS socket.
      (chmod "/var/run/tor" #o750)

      ;; Allow Tor to access the hidden services' directories.
      (mkdir-p "/var/lib/tor")
      (chown "/var/lib/tor" (passwd:uid %user) (passwd:gid %user))
      (chmod "/var/lib/tor" #o700)

      ;; Make sure /var/lib is accessible to the 'tor' user.
      (chmod "/var/lib" #o755)

      (for-each initialize
                '#$(map tor-onion-service-configuration-name
                        (tor-configuration-hidden-services config)))))

(define tor-service-type
  (service-type (name 'tor)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          tor-shepherd-service)
                       (service-extension account-service-type
                                          (const %tor-accounts))
                       (service-extension activation-service-type
                                          tor-activation)))

                ;; This can be extended with Tor Onion Services.
                (compose concatenate)
                (extend (lambda (config services)
                          (tor-configuration
                           (inherit config)
                           (hidden-services
                            (append (tor-configuration-hidden-services config)
                                    services)))))
                (default-value (tor-configuration))
                (description
                 "Run the @uref{https://torproject.org, Tor} anonymous
networking daemon.")))

(define-deprecated (tor-hidden-service name mapping)
  #f
  "Define a new Tor @dfn{hidden service} called @var{name} and implementing
@var{mapping}.  @var{mapping} is a list of port/host tuples, such as:

@example
 '((22 . \"127.0.0.1:22\")
   (80 . \"127.0.0.1:8080\"))
@end example

In this example, port 22 of the hidden service is mapped to local port 22, and
port 80 is mapped to local port 8080.

This creates a @file{/var/lib/tor/hidden-services/@var{name}} directory, where
the @file{hostname} file contains the @code{.onion} host name for the hidden
service.

See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor
project's documentation} for more information."
  (simple-service 'tor-hidden-service
                  tor-service-type
                  (list (tor-onion-service-configuration
                         (name name)
                         (mapping mapping)))))


;;;
;;; ModemManager
;;;

(define-record-type* <modem-manager-configuration>
  modem-manager-configuration make-modem-manager-configuration
  modem-manager-configuration?
  (modem-manager modem-manager-configuration-modem-manager
                   (default modem-manager)))


;;;
;;; NetworkManager
;;;

;; TODO: deprecated field, remove later.
(define-with-syntax-properties (warn-iwd?-field-deprecation
                                (value properties))
  (when value
    (warning (source-properties->location properties)
             (G_ "the 'iwd?' field is deprecated, please use \
'shepherd-requirement' field instead~%")))
  value)

(define-record-type* <network-manager-configuration>
  network-manager-configuration make-network-manager-configuration
  network-manager-configuration?
  (network-manager network-manager-configuration-network-manager
                   (default network-manager))
  (shepherd-requirement network-manager-configuration-shepherd-requirement
                        (default '(wpa-supplicant)))
  (dns network-manager-configuration-dns
       (default "default"))
  (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like
               (default '()))
  (iwd? network-manager-configuration-iwd?  ; TODO: deprecated field, remove.
        (default #f)
        (sanitize warn-iwd?-field-deprecation)))

(define (network-manager-activation config)
  ;; Activation gexp for NetworkManager
  (match-record config <network-manager-configuration>
    (ne