mirror of
https://https.git.savannah.gnu.org/git/guix.git/
synced 2025-07-10 16:50:43 +02:00
cfa2de2a77
* doc/guix.texi (Networking Services) <nftables>: Update doc. * gnu/services/networking.scm (list-of-debug-levels?): (debug-level?, maybe-list-of-debug-levels?): (nftables-configuration): Rewrite using `define-configuration'. [debug-levels]: New field. (nftables-shepherd-service): Honor it. * gnu/tests/networking.scm (%inetd-echo-port): Extract to top level. (run-iptables-test): Adjust accordingly. (make-nftables-os): New procedure. (%default-nftables-ruleset-for-tests): New variable. (%nftables-os): Likewise. (%test-nftables): New test. Change-Id: I2889603342ff6d2be6261c3de6e4fddd9a9bbe2d
1278 lines
43 KiB
Scheme
1278 lines
43 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
|
||
;;; Copyright © 2017, 2020 Marius Bakke <marius@gnu.org>
|
||
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
|
||
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
|
||
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
|
||
;;; Copyright © 2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2025 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||
;;;
|
||
;;; 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 tests networking)
|
||
#:use-module (gnu tests)
|
||
#:use-module (gnu system)
|
||
#:use-module (gnu system vm)
|
||
#:use-module (gnu services)
|
||
#:use-module (gnu services base)
|
||
#:use-module (gnu services dns)
|
||
#:use-module (gnu services networking)
|
||
#:use-module (gnu services ssh)
|
||
#:use-module (guix gexp)
|
||
#:use-module (guix store)
|
||
#:use-module (guix monads)
|
||
#:use-module (guix modules)
|
||
#:use-module (gnu packages admin)
|
||
#:use-module (gnu packages bash)
|
||
#:use-module (gnu packages linux)
|
||
#:use-module (gnu packages networking)
|
||
#:use-module (gnu packages guile)
|
||
#:use-module (gnu services shepherd)
|
||
#:use-module (ice-9 match)
|
||
#:export (%test-static-networking
|
||
%test-static-networking-failure
|
||
%test-static-networking-advanced
|
||
%test-inetd
|
||
%test-openvswitch
|
||
%test-dhcpd
|
||
%test-dhcpcd
|
||
%test-dnsmasq
|
||
%test-tor
|
||
%test-iptables
|
||
%test-nftables
|
||
%test-ipfs))
|
||
|
||
|
||
;;;
|
||
;;; Static networking.
|
||
;;;
|
||
|
||
(define (run-static-networking-test vm)
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette)
|
||
(guix build syscalls))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(guix build syscalls)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette
|
||
'(#$vm "-nic" "user,model=virtio-net-pci")))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "static-networking")
|
||
|
||
(test-assert "service is up"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(start-service 'networking))
|
||
marionette))
|
||
|
||
(test-assert "network interfaces"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (guix build syscalls))
|
||
(network-interface-names))
|
||
marionette))
|
||
|
||
(test-equal "address of eth0"
|
||
"10.0.2.15"
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(addr (network-interface-address sock "eth0")))
|
||
(close-port sock)
|
||
(inet-ntop (sockaddr:fam addr) (sockaddr:addr addr)))
|
||
marionette))
|
||
|
||
(test-equal "netmask of eth0"
|
||
"255.255.255.0"
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(mask (network-interface-netmask sock "eth0")))
|
||
(close-port sock)
|
||
(inet-ntop (sockaddr:fam mask) (sockaddr:addr mask)))
|
||
marionette))
|
||
|
||
(test-equal "eth0 is up"
|
||
IFF_UP
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(flags (network-interface-flags sock "eth0")))
|
||
(logand flags IFF_UP))
|
||
marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "static-networking" test))
|
||
|
||
(define %test-static-networking
|
||
(system-test
|
||
(name "static-networking")
|
||
(description "Test the 'static-networking' service.")
|
||
(value
|
||
(let ((os (marionette-operating-system
|
||
(simple-operating-system
|
||
(service static-networking-service-type
|
||
(list %qemu-static-networking)))
|
||
#:imported-modules '((gnu services herd)
|
||
(guix combinators)))))
|
||
(run-static-networking-test (virtual-machine os))))))
|
||
|
||
|
||
(define %static-networking-with-nonexistent-device
|
||
;; Similar to %QEMU-STATIC-NETWORKING except that the device does not exist.
|
||
(static-networking
|
||
(addresses (list (network-address
|
||
(device "does-not-exist") ;<- really
|
||
(value "10.0.2.15/24"))))
|
||
(routes (list (network-route
|
||
(destination "default")
|
||
(gateway "10.0.2.2"))))
|
||
(requirement '())
|
||
(provision '(networking))
|
||
(name-servers '("10.0.2.3"))))
|
||
|
||
(define (run-static-networking-failure-test vm)
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette)
|
||
(guix build syscalls))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(guix build syscalls)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette '(#$vm)))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "static-networking")
|
||
|
||
(test-equal "service fails to start"
|
||
#f
|
||
;; The 'start' method of the 'networking' service should fail
|
||
;; within a minute or so. Previously it would never complete:
|
||
;; <https://issues.guix.gnu.org/71173>.
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(alarm 180) ;must complete in a timely fashion
|
||
(start-service 'networking))
|
||
marionette))
|
||
|
||
(test-equal "network interfaces"
|
||
'("lo")
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (guix build syscalls))
|
||
(network-interface-names))
|
||
marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "static-networking-failure" test))
|
||
|
||
(define %test-static-networking-failure
|
||
(system-test
|
||
(name "static-networking-failure")
|
||
(description "Test the behavior of the 'static-networking' service when
|
||
passed an invalid device.")
|
||
(value
|
||
(let ((os (marionette-operating-system
|
||
(simple-operating-system
|
||
(service static-networking-service-type
|
||
(list %static-networking-with-nonexistent-device)))
|
||
#:imported-modules '((gnu services herd)
|
||
(guix combinators)))))
|
||
(run-static-networking-failure-test (virtual-machine os))))))
|
||
|
||
|
||
(define (run-static-networking-advanced-test vm)
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette)
|
||
(guix build syscalls))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(guix build syscalls)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette
|
||
'(#$vm "-net" "nic,model=e1000,macaddr=98:11:22:33:44:55"
|
||
"-net" "nic,model=e1000,macaddr=98:11:22:33:44:56")))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "static-networking-advanced")
|
||
|
||
(test-assert "service is up"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(start-service 'networking))
|
||
marionette))
|
||
|
||
(test-assert "network interfaces"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (guix build syscalls))
|
||
(network-interface-names))
|
||
marionette))
|
||
|
||
(test-equal "bond0 bonding mode"
|
||
"802.3ad 4"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(call-with-input-file "/sys/class/net/bond0/bonding/mode" read-line))
|
||
marionette))
|
||
|
||
(test-equal "bond0 bonding lacp_rate"
|
||
"fast 1"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(call-with-input-file "/sys/class/net/bond0/bonding/lacp_rate" read-line))
|
||
marionette))
|
||
|
||
(test-equal "bond0 bonding miimon"
|
||
"100"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(call-with-input-file "/sys/class/net/bond0/bonding/miimon" read-line))
|
||
marionette))
|
||
|
||
(test-equal "bond0 bonding slaves"
|
||
"a b"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(call-with-input-file "/sys/class/net/bond0/bonding/slaves" read-line))
|
||
marionette))
|
||
|
||
;; The hw mac address will come from the first slave bonded to the
|
||
;; channel.
|
||
(test-equal "bond0 mac address"
|
||
"98:11:22:33:44:55"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(call-with-input-file "/sys/class/net/bond0/address" read-line))
|
||
marionette))
|
||
|
||
(test-equal "bond0.1055 is up"
|
||
IFF_UP
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(flags (network-interface-flags sock "bond0.1055")))
|
||
(logand flags IFF_UP))
|
||
marionette))
|
||
|
||
(test-equal "bond0.1055 address is correct"
|
||
"192.168.1.4"
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(addr (network-interface-address sock "bond0.1055")))
|
||
(close-port sock)
|
||
(inet-ntop (sockaddr:fam addr) (sockaddr:addr addr)))
|
||
marionette))
|
||
|
||
(test-equal "bond0.1055 netmask is correct"
|
||
"255.255.255.0"
|
||
(marionette-eval
|
||
'(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(mask (network-interface-netmask sock "bond0.1055")))
|
||
(close-port sock)
|
||
(inet-ntop (sockaddr:fam mask) (sockaddr:addr mask)))
|
||
marionette))
|
||
(test-end))))
|
||
|
||
(gexp->derivation "static-networking-advanced" test))
|
||
|
||
(define %test-static-networking-advanced
|
||
(system-test
|
||
(name "static-networking-advanced")
|
||
(description "Test the 'static-networking' service with advanced features like bonds, vlans etc...")
|
||
(value
|
||
(let ((os (marionette-operating-system
|
||
(simple-operating-system
|
||
(service static-networking-service-type
|
||
(list (static-networking
|
||
(links (list
|
||
|
||
(network-link
|
||
(mac-address "98:11:22:33:44:55")
|
||
(arguments '((name . "a"))))
|
||
|
||
(network-link
|
||
(mac-address "98:11:22:33:44:56")
|
||
(arguments '((name . "b"))))
|
||
|
||
(network-link
|
||
(name "bond0")
|
||
(type 'bond)
|
||
(arguments '((mode . "802.3ad")
|
||
(miimon . 100)
|
||
(lacp-active . "on")
|
||
(lacp-rate . "fast"))))
|
||
|
||
(network-link
|
||
(name "a")
|
||
(arguments '((master . "bond0"))))
|
||
|
||
(network-link
|
||
(name "b")
|
||
(arguments '((master . "bond0"))))
|
||
|
||
(network-link
|
||
(name "bond0.1055")
|
||
(type 'vlan)
|
||
(arguments '((id . 1055)
|
||
(link . "bond0"))))))
|
||
|
||
(addresses (list (network-address
|
||
(value "192.168.1.4/24")
|
||
(device "bond0.1055"))))))))
|
||
#:imported-modules '((gnu services herd)
|
||
(guix combinators)))))
|
||
(run-static-networking-advanced-test (virtual-machine os))))))
|
||
|
||
|
||
;;;
|
||
;;; Inetd.
|
||
;;;
|
||
|
||
(define %inetd-os
|
||
;; Operating system with 2 inetd services.
|
||
(simple-operating-system
|
||
(service dhcp-client-service-type)
|
||
(service inetd-service-type
|
||
(inetd-configuration
|
||
(entries (list
|
||
(inetd-entry
|
||
(name "echo")
|
||
(socket-type 'stream)
|
||
(protocol "tcp")
|
||
(wait? #f)
|
||
(user "root"))
|
||
(inetd-entry
|
||
(name "dict")
|
||
(socket-type 'stream)
|
||
(protocol "tcp")
|
||
(wait? #f)
|
||
(user "root")
|
||
(program (file-append bash
|
||
"/bin/bash"))
|
||
(arguments
|
||
(list "bash" (plain-file "my-dict.sh" "\
|
||
while read line
|
||
do
|
||
if [[ $line =~ ^DEFINE\\ (.*)$ ]]
|
||
then
|
||
case ${BASH_REMATCH[1]} in
|
||
Guix)
|
||
echo GNU Guix is a package management tool for the GNU system.
|
||
;;
|
||
G-expression)
|
||
echo Like an S-expression but with a G.
|
||
;;
|
||
*)
|
||
echo NO DEFINITION FOUND
|
||
;;
|
||
esac
|
||
else
|
||
echo ERROR
|
||
fi
|
||
done" ))))))))))
|
||
|
||
(define* (run-inetd-test)
|
||
"Run tests in %INETD-OS, where the inetd service provides an echo service on
|
||
port 7, and a dict service on port 2628."
|
||
(define os
|
||
(marionette-operating-system %inetd-os))
|
||
|
||
(define vm
|
||
(virtual-machine
|
||
(operating-system os)
|
||
(port-forwardings `((8007 . 7)
|
||
(8628 . 2628)))))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (ice-9 rdelim)
|
||
(srfi srfi-64)
|
||
(gnu build marionette))
|
||
(define marionette
|
||
(make-marionette (list #$vm)))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "inetd")
|
||
|
||
;; Make sure the PID file is created.
|
||
(test-assert "PID file"
|
||
(wait-for-file "/var/run/inetd.pid" marionette
|
||
#:timeout 30))
|
||
|
||
;; Test the echo service.
|
||
(test-equal "echo response"
|
||
"Hello, Guix!"
|
||
(let ((echo (socket PF_INET SOCK_STREAM 0))
|
||
(addr (make-socket-address AF_INET INADDR_LOOPBACK 8007)))
|
||
(connect echo addr)
|
||
(display "Hello, Guix!\n" echo)
|
||
(let ((response (read-line echo)))
|
||
(close echo)
|
||
response)))
|
||
|
||
;; Test the dict service
|
||
(test-equal "dict response"
|
||
"GNU Guix is a package management tool for the GNU system."
|
||
(let ((dict (socket PF_INET SOCK_STREAM 0))
|
||
(addr (make-socket-address AF_INET INADDR_LOOPBACK 8628)))
|
||
(connect dict addr)
|
||
(display "DEFINE Guix\n" dict)
|
||
(let ((response (read-line dict)))
|
||
(close dict)
|
||
response)))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "inetd-test" test))
|
||
|
||
(define %test-inetd
|
||
(system-test
|
||
(name "inetd")
|
||
(description "Connect to a host with an INETD server.")
|
||
(value (run-inetd-test))))
|
||
|
||
|
||
;;;
|
||
;;; Open vSwitch
|
||
;;;
|
||
|
||
(define setup-openvswitch
|
||
#~(let ((ovs-vsctl (lambda (str)
|
||
(zero? (apply system*
|
||
#$(file-append openvswitch "/bin/ovs-vsctl")
|
||
(string-tokenize str)))))
|
||
(add-native-port (lambda (if)
|
||
(string-append "--may-exist add-port br0 " if
|
||
" vlan_mode=native-untagged"
|
||
" -- set Interface " if
|
||
" type=internal"))))
|
||
(and (ovs-vsctl "--may-exist add-br br0")
|
||
;; Connect eth0 as an "untagged" port (no VLANs).
|
||
(ovs-vsctl "--may-exist add-port br0 eth0 vlan_mode=native-untagged")
|
||
(ovs-vsctl (add-native-port "ovs0")))))
|
||
|
||
(define openvswitch-configuration-service
|
||
(simple-service 'openvswitch-configuration shepherd-root-service-type
|
||
(list (shepherd-service
|
||
(provision '(openvswitch-configuration))
|
||
(requirement '(vswitchd))
|
||
(start #~(lambda ()
|
||
#$setup-openvswitch))
|
||
(respawn? #f)))))
|
||
|
||
(define %openvswitch-os
|
||
(operating-system
|
||
(inherit (simple-operating-system
|
||
(simple-service 'openswitch-networking
|
||
static-networking-service-type
|
||
(list (static-networking
|
||
(addresses (list (network-address
|
||
(value "10.1.1.1/24")
|
||
(device "ovs0"))))
|
||
(requirement '(openvswitch-configuration)))))
|
||
(service openvswitch-service-type)
|
||
openvswitch-configuration-service))
|
||
;; Ensure the interface name does not change depending on the driver.
|
||
(kernel-arguments (cons "net.ifnames=0" %default-kernel-arguments))))
|
||
|
||
(define (run-openvswitch-test)
|
||
(define os
|
||
(marionette-operating-system %openvswitch-os
|
||
#:imported-modules '((gnu services herd)
|
||
(guix build syscalls))))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette)
|
||
(guix build syscalls))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(guix build syscalls)
|
||
(ice-9 popen)
|
||
(ice-9 rdelim)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "openvswitch")
|
||
|
||
;; Wait for our configuration to be active (it sets up br0).
|
||
(test-assert "openvswitch-configuration is running"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(wait-for-service 'openvswitch-configuration))
|
||
marionette))
|
||
|
||
;; Make sure the bridge is created.
|
||
(test-assert "br0 exists"
|
||
(marionette-eval
|
||
'(zero? (system* #$(file-append openvswitch "/bin/ovs-vsctl")
|
||
"br-exists" "br0"))
|
||
marionette))
|
||
|
||
;; Make sure eth0 is connected to the bridge.
|
||
(test-equal "eth0 is connected to br0"
|
||
"br0"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 popen) (ice-9 rdelim))
|
||
(let* ((port (open-pipe*
|
||
OPEN_READ
|
||
(string-append #$openvswitch "/bin/ovs-vsctl")
|
||
"port-to-br" "eth0"))
|
||
(output (read-line port)))
|
||
(close-pipe port)
|
||
output))
|
||
marionette))
|
||
|
||
;; Make sure the virtual interface got a static IP.
|
||
(test-assert "networking has started on ovs0"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd)
|
||
(srfi srfi-1))
|
||
(live-service-running
|
||
(find (lambda (live)
|
||
(memq 'networking
|
||
(live-service-provision live)))
|
||
(current-services))))
|
||
marionette))
|
||
|
||
(test-equal "ovs0 is up"
|
||
IFF_UP
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (guix build syscalls))
|
||
|
||
(let* ((sock (socket AF_INET SOCK_STREAM 0))
|
||
(flags (network-interface-flags sock "ovs0")))
|
||
(close-port sock)
|
||
(logand flags IFF_UP)))
|
||
marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "openvswitch-test" test))
|
||
|
||
(define %test-openvswitch
|
||
(system-test
|
||
(name "openvswitch")
|
||
(description "Test a running OpenvSwitch configuration.")
|
||
(value (run-openvswitch-test))))
|
||
|
||
|
||
;;;
|
||
;;; DHCP Daemon
|
||
;;;
|
||
|
||
(define minimal-dhcpd-v4-config-file
|
||
(plain-file "dhcpd.conf"
|
||
"\
|
||
default-lease-time 600;
|
||
max-lease-time 7200;
|
||
|
||
subnet 192.168.1.0 netmask 255.255.255.0 {
|
||
range 192.168.1.100 192.168.1.200;
|
||
option routers 192.168.1.1;
|
||
option domain-name-servers 192.168.1.2, 192.168.1.3;
|
||
option domain-name \"dummy.domain.name.abc123xyz\";
|
||
}
|
||
"))
|
||
|
||
(define dhcpd-v4-configuration
|
||
(dhcpd-configuration
|
||
(config-file minimal-dhcpd-v4-config-file)
|
||
(version "4")
|
||
(interfaces '("ens3"))))
|
||
|
||
(define %dhcpd-os
|
||
(simple-operating-system
|
||
(service static-networking-service-type
|
||
(list (static-networking
|
||
(addresses (list (network-address
|
||
(value "192.168.1.4/24")
|
||
(device "ens3"))))
|
||
(routes (list (network-route
|
||
(destination "default")
|
||
(gateway "192.168.1.1"))))
|
||
(name-servers '("192.168.1.2" "192.168.1.3")))))
|
||
(service dhcpd-service-type dhcpd-v4-configuration)))
|
||
|
||
(define (run-dhcpd-test)
|
||
(define os
|
||
(marionette-operating-system %dhcpd-os
|
||
#:imported-modules '((gnu services herd))))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "dhcpd")
|
||
|
||
(test-assert "pid file exists"
|
||
(wait-for-file
|
||
'#$(dhcpd-configuration-pid-file dhcpd-v4-configuration)
|
||
marionette))
|
||
|
||
(test-assert "lease file exists"
|
||
(wait-for-file
|
||
'#$(dhcpd-configuration-lease-file dhcpd-v4-configuration)
|
||
marionette
|
||
#:read '(@ (ice-9 textual-ports) get-string-all)))
|
||
|
||
(test-assert "run directory exists"
|
||
(marionette-eval
|
||
'(file-exists?
|
||
#$(dhcpd-configuration-run-directory dhcpd-v4-configuration))
|
||
marionette))
|
||
|
||
(test-assert "dhcpd is alive"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(wait-for-service 'dhcpv4-daemon))
|
||
marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "dhcpd-test" test))
|
||
|
||
(define %test-dhcpd
|
||
(system-test
|
||
(name "dhcpd")
|
||
(description "Test a running DHCP daemon configuration.")
|
||
(value (run-dhcpd-test))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; dnsmasq tests.
|
||
;;;
|
||
|
||
|
||
(define dnsmasq-os-configuration
|
||
(dnsmasq-configuration))
|
||
|
||
(define %dnsmasq-os
|
||
(simple-operating-system
|
||
(service dhcp-client-service-type)
|
||
(service dnsmasq-service-type
|
||
(dnsmasq-configuration
|
||
(extra-options
|
||
(list "--log-facility=/tmp/dnsmasq.log"))))))
|
||
|
||
|
||
(define (run-dnsmasq-test)
|
||
(define os
|
||
(marionette-operating-system %dnsmasq-os
|
||
#:imported-modules '((gnu services herd))))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "dnsmasq")
|
||
|
||
(test-assert "dnsmasq is alive"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(wait-for-service 'dnsmasq))
|
||
marionette))
|
||
|
||
(test-assert "pid file exists"
|
||
(wait-for-file
|
||
'#$(dnsmasq-configuration-pid-file dnsmasq-os-configuration)
|
||
marionette))
|
||
|
||
(test-assert "send SIGHUP"
|
||
(positive?
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(system* "sync")
|
||
(let* ((port (open-input-file "/tmp/dnsmasq.log")))
|
||
(seek port 0 SEEK_END)
|
||
(system* "herd" "reload" "dnsmasq")
|
||
(system* "sync")
|
||
(let ((line (read-line port)))
|
||
(close-port port)
|
||
(string-contains line "read /etc/hosts"))))
|
||
marionette)))
|
||
|
||
(test-assert "send SIGUSR1"
|
||
(positive?
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 rdelim))
|
||
(system* "sync")
|
||
(let* ((port (open-input-file "/tmp/dnsmasq.log")))
|
||
(seek port 0 SEEK_END)
|
||
(system* "herd" "stats" "dnsmasq")
|
||
(system* "sync")
|
||
(let ((line (read-line port)))
|
||
(close-port port)
|
||
(string-contains-ci line "time"))))
|
||
marionette)))
|
||
|
||
(test-assert "dnsmasq is alive"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
(wait-for-service 'dnsmasq))
|
||
marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "dnsmasq-test" test))
|
||
|
||
(define %test-dnsmasq
|
||
(system-test
|
||
(name "dnsmasq")
|
||
(description "Test a running dnsmasq daemon configuration.")
|
||
(value (run-dnsmasq-test))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; DHCPCD Daemon
|
||
;;;
|
||
|
||
(define %dhcpcd-os
|
||
(let ((base-os
|
||
(simple-operating-system
|
||
(service dhcpcd-service-type
|
||
(dhcpcd-configuration
|
||
(command-arguments '("--debug" "--logfile" "/dev/console"))
|
||
(interfaces '("ens3")))))))
|
||
(operating-system
|
||
(inherit base-os)
|
||
(packages
|
||
(append (list dhcpcd iproute)
|
||
(operating-system-packages base-os))))))
|
||
|
||
(define (run-dhcpcd-test)
|
||
"Run tests in %dhcpcd-os with a running dhcpcd daemon on localhost."
|
||
(define os
|
||
(marionette-operating-system
|
||
%dhcpcd-os
|
||
#:imported-modules '((gnu services herd))))
|
||
|
||
(define vm
|
||
(virtual-machine os))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (srfi srfi-64)
|
||
(gnu build marionette))
|
||
(define marionette
|
||
(make-marionette (list #$vm)))
|
||
|
||
(define (wait-for-lease)
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 popen) (ice-9 rdelim))
|
||
|
||
(let loop ((i 15))
|
||
(if (> i 0)
|
||
(let* ((port (open-input-pipe "dhcpcd --dumplease ens3"))
|
||
(output (read-string port)))
|
||
(close-port port)
|
||
(unless (string-contains output "reason=BOUND")
|
||
(sleep 1)
|
||
(loop (- i 1))))
|
||
(error "failed to obtain a DHCP lease"))))
|
||
marionette))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "dhcpcd")
|
||
|
||
(test-assert "service is running"
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd))
|
||
|
||
;; Make sure the 'dhcpcd' command is found.
|
||
(setenv "PATH" "/run/current-system/profile/sbin")
|
||
|
||
(wait-for-service 'networking))
|
||
marionette))
|
||
|
||
(test-assert "IPC socket exists"
|
||
(marionette-eval
|
||
'(file-exists? "/var/run/dhcpcd/ens3.sock")
|
||
marionette))
|
||
|
||
(test-equal "IPC is functional"
|
||
0
|
||
(marionette-eval
|
||
'(status:exit-val
|
||
(system* "dhcpcd" "--dumplease" "ens3"))
|
||
marionette))
|
||
|
||
(test-equal "aquires IPv4 address via DHCP"
|
||
1
|
||
(and
|
||
(wait-for-lease)
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (ice-9 popen) (ice-9 rdelim))
|
||
|
||
(let* ((port (open-input-pipe "ip -4 address show dev ens3"))
|
||
(lines (string-split (read-string port) #\newline)))
|
||
(close-port port)
|
||
(length
|
||
(filter (lambda (line)
|
||
(string-contains line "scope global dynamic"))
|
||
lines))))
|
||
marionette)))
|
||
|
||
(test-end))))
|
||
(gexp->derivation "dhcpcd-test" test))
|
||
|
||
(define %test-dhcpcd
|
||
(system-test
|
||
(name "dhcpcd")
|
||
(description "Test that the dhcpcd obtains IP DHCP leases.")
|
||
(value (run-dhcpcd-test))))
|
||
|
||
|
||
;;;
|
||
;;; Services related to Tor
|
||
;;;
|
||
|
||
(define %tor-os
|
||
(simple-operating-system
|
||
(service tor-service-type)))
|
||
|
||
(define %tor-os/unix-socks-socket
|
||
(simple-operating-system
|
||
(service tor-service-type
|
||
(tor-configuration
|
||
(socks-socket-type 'unix)))))
|
||
|
||
(define (run-tor-test)
|
||
(define os
|
||
(marionette-operating-system %tor-os
|
||
#:imported-modules '((gnu services herd))
|
||
#:requirements '(tor)))
|
||
|
||
(define os/unix-socks-socket
|
||
(marionette-operating-system %tor-os/unix-socks-socket
|
||
#:imported-modules '((gnu services herd))
|
||
#:requirements '(tor)))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(ice-9 popen)
|
||
(ice-9 rdelim)
|
||
(srfi srfi-64))
|
||
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(define (tor-is-alive? marionette)
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd)
|
||
(srfi srfi-1))
|
||
(live-service-running
|
||
(find (lambda (live)
|
||
(memq 'tor
|
||
(live-service-provision live)))
|
||
(current-services))))
|
||
marionette))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "tor")
|
||
|
||
;; Test the usual Tor service.
|
||
|
||
(test-assert "tor is alive"
|
||
(tor-is-alive? marionette))
|
||
|
||
(test-assert "tor is listening"
|
||
(let ((default-port 9050))
|
||
(wait-for-tcp-port default-port marionette)))
|
||
|
||
;; Don't run two VMs at once.
|
||
(marionette-control "quit" marionette)
|
||
|
||
;; Test the Tor service using a SOCKS socket.
|
||
|
||
(let* ((socket-directory "/tmp/more-sockets")
|
||
(_ (mkdir socket-directory))
|
||
(marionette/unix-socks-socket
|
||
(make-marionette
|
||
(list #$(virtual-machine os/unix-socks-socket))
|
||
;; We can't use the same socket directory as the first
|
||
;; marionette.
|
||
#:socket-directory socket-directory)))
|
||
(test-assert "tor is alive, even when using a SOCKS socket"
|
||
(tor-is-alive? marionette/unix-socks-socket))
|
||
|
||
(test-assert "tor is listening, even when using a SOCKS socket"
|
||
(wait-for-unix-socket "/var/run/tor/socks-sock"
|
||
marionette/unix-socks-socket)))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "tor-test" test))
|
||
|
||
(define %test-tor
|
||
(system-test
|
||
(name "tor")
|
||
(description "Test a running Tor daemon configuration.")
|
||
(value (run-tor-test))))
|
||
|
||
(define %inetd-echo-port 7)
|
||
|
||
(define* (run-iptables-test)
|
||
"Run tests of 'iptables-service-type'."
|
||
(define iptables-rules
|
||
"*filter
|
||
:INPUT ACCEPT
|
||
:FORWARD ACCEPT
|
||
:OUTPUT ACCEPT
|
||
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp-port-unreachable
|
||
COMMIT
|
||
")
|
||
|
||
(define ip6tables-rules
|
||
"*filter
|
||
:INPUT ACCEPT
|
||
:FORWARD ACCEPT
|
||
:OUTPUT ACCEPT
|
||
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp6-port-unreachable
|
||
COMMIT
|
||
")
|
||
|
||
(define os
|
||
(marionette-operating-system
|
||
(simple-operating-system
|
||
(service dhcp-client-service-type)
|
||
(service inetd-service-type
|
||
(inetd-configuration
|
||
(entries (list
|
||
(inetd-entry
|
||
(name "echo")
|
||
(socket-type 'stream)
|
||
(protocol "tcp")
|
||
(wait? #f)
|
||
(user "root"))))))
|
||
(service iptables-service-type
|
||
(iptables-configuration
|
||
(ipv4-rules (plain-file "iptables.rules" iptables-rules))
|
||
(ipv6-rules (plain-file "ip6tables.rules" ip6tables-rules)))))
|
||
#:imported-modules '((gnu services herd))
|
||
#:requirements '(inetd iptables)))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (srfi srfi-64)
|
||
(gnu build marionette))
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(define (dump-iptables iptables-save marionette)
|
||
(marionette-eval
|
||
`(begin
|
||
(use-modules (ice-9 popen)
|
||
(ice-9 rdelim)
|
||
(ice-9 regex))
|
||
(call-with-output-string
|
||
(lambda (out)
|
||
(call-with-port
|
||
(open-pipe* OPEN_READ ,iptables-save)
|
||
(lambda (in)
|
||
(let loop ((line (read-line in)))
|
||
;; iptables-save does not output rules in the exact
|
||
;; same format we loaded using iptables-restore. It
|
||
;; adds comments, packet counters, etc. We remove
|
||
;; these additions.
|
||
(unless (eof-object? line)
|
||
(cond
|
||
;; Remove comments
|
||
((string-match "^#" line) #t)
|
||
;; Remove packet counters
|
||
((string-match "^:([A-Z]*) ([A-Z]*) .*" line)
|
||
=> (lambda (match-record)
|
||
(format out ":~a ~a~%"
|
||
(match:substring match-record 1)
|
||
(match:substring match-record 2))))
|
||
;; Pass other lines without modification
|
||
(else (display line out)
|
||
(newline out)))
|
||
(loop (read-line in)))))))))
|
||
marionette))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "iptables")
|
||
|
||
(test-equal "iptables-save dumps the same rules that were loaded"
|
||
(dump-iptables #$(file-append iptables "/sbin/iptables-save")
|
||
marionette)
|
||
#$iptables-rules)
|
||
|
||
(test-equal "ip6tables-save dumps the same rules that were loaded"
|
||
(dump-iptables #$(file-append iptables "/sbin/ip6tables-save")
|
||
marionette)
|
||
#$ip6tables-rules)
|
||
|
||
(test-error "iptables firewall blocks access to inetd echo service"
|
||
'misc-error
|
||
(wait-for-tcp-port #$%inetd-echo-port marionette
|
||
#:timeout 5))
|
||
|
||
;; TODO: This test freezes up at the login prompt without any
|
||
;; relevant messages on the console. Perhaps it is waiting for some
|
||
;; timeout. Find and fix this issue.
|
||
;; (test-assert "inetd echo service is accessible after iptables firewall is stopped"
|
||
;; (begin
|
||
;; (marionette-eval
|
||
;; '(begin
|
||
;; (use-modules (gnu services herd))
|
||
;; (stop-service 'iptables))
|
||
;; marionette)
|
||
;; (wait-for-tcp-port #$%inetd-echo-port marionette #:timeout 5)))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "iptables" test))
|
||
|
||
(define %test-iptables
|
||
(system-test
|
||
(name "iptables")
|
||
(description "Test a running iptables daemon.")
|
||
(value (run-iptables-test))))
|
||
|
||
|
||
;;;
|
||
;;; nftables.
|
||
;;;
|
||
|
||
(define (make-nftables-os ruleset)
|
||
(simple-operating-system
|
||
(service dhcp-client-service-type)
|
||
(service inetd-service-type
|
||
(inetd-configuration
|
||
(entries (list
|
||
(inetd-entry
|
||
(name "echo")
|
||
(socket-type 'stream)
|
||
(protocol "tcp")
|
||
(wait? #f)
|
||
(user "root"))))))
|
||
(service openssh-service-type)
|
||
(service nftables-service-type
|
||
(nftables-configuration
|
||
(debug-levels '(all))
|
||
(ruleset ruleset)))))
|
||
|
||
(define %default-nftables-ruleset-for-tests
|
||
;; This is like the %default-nftables-ruleset, but without allowing any
|
||
;; connections from the loopback interface.
|
||
(plain-file "nftables.conf" "\
|
||
table inet filter {
|
||
chain input {
|
||
type filter hook input priority 0; policy drop;
|
||
|
||
# early drop of invalid connections
|
||
ct state invalid drop
|
||
|
||
# allow established/related connections
|
||
ct state { established, related } accept
|
||
|
||
# allow from loopback
|
||
# iif lo accept # COMMENTED OUT FOR TESTS
|
||
# drop connections to lo not coming from lo
|
||
iif != lo ip daddr 127.0.0.1/8 drop
|
||
iif != lo ip6 daddr ::1/128 drop
|
||
|
||
# allow icmp
|
||
ip protocol icmp accept
|
||
ip6 nexthdr icmpv6 accept
|
||
|
||
# allow ssh
|
||
tcp dport ssh accept
|
||
|
||
# reject everything else
|
||
reject with icmpx type port-unreachable
|
||
}
|
||
chain forward {
|
||
type filter hook forward priority 0; policy drop;
|
||
}
|
||
chain output {
|
||
type filter hook output priority 0; policy accept;
|
||
}
|
||
}"))
|
||
|
||
(define %nftables-os
|
||
(make-nftables-os %default-nftables-ruleset-for-tests))
|
||
|
||
(define (run-nftables-test)
|
||
(define os
|
||
(marionette-operating-system
|
||
%nftables-os
|
||
#:imported-modules '((gnu services herd))
|
||
#:requirements '(inetd nftables ssh)))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(srfi srfi-64))
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "nftables")
|
||
|
||
(test-error "nftables blocks access to inetd echo service"
|
||
'misc-error
|
||
(wait-for-tcp-port #$%inetd-echo-port marionette
|
||
#:timeout 5))
|
||
|
||
(test-assert "nftables allows access to SSH TCP port 22"
|
||
(wait-for-tcp-port 22 marionette))
|
||
|
||
(test-end))))
|
||
|
||
(gexp->derivation "nftables-test" test))
|
||
|
||
(define %test-nftables
|
||
(system-test
|
||
(name "nftables")
|
||
(description "Test the nftables service properly allow or block
|
||
connection to ports.")
|
||
(value (run-nftables-test))))
|
||
|
||
|
||
;;;
|
||
;;; IPFS service
|
||
;;;
|
||
|
||
(define %ipfs-os
|
||
(simple-operating-system
|
||
(service ipfs-service-type)))
|
||
|
||
(define (run-ipfs-test)
|
||
(define os
|
||
(marionette-operating-system %ipfs-os
|
||
#:imported-modules (source-module-closure
|
||
'((gnu services herd)
|
||
(guix ipfs)))
|
||
#:extensions (list guile-json-4)
|
||
#:requirements '(ipfs)))
|
||
|
||
(define test
|
||
(with-imported-modules '((gnu build marionette))
|
||
#~(begin
|
||
(use-modules (gnu build marionette)
|
||
(rnrs bytevectors)
|
||
(srfi srfi-64)
|
||
(ice-9 binary-ports))
|
||
|
||
(define marionette
|
||
(make-marionette (list #$(virtual-machine os))))
|
||
|
||
(define (ipfs-is-alive?)
|
||
(marionette-eval
|
||
'(begin
|
||
(use-modules (gnu services herd)
|
||
(srfi srfi-1))
|
||
(live-service-running
|
||
(find (lambda (live)
|
||
(memq 'ipfs
|
||
(live-service-provision live)))
|
||
(current-services))))
|
||
marionette))
|
||
|
||
;; The default API endpoint port 5001 is used,
|
||
;; so there is no need to parameterize %ipfs-base-url.
|
||
(define (add-data data)
|
||
(marionette-eval `(content-name (add-data ,data)) marionette))
|
||
(define (read-contents object)
|
||
(marionette-eval
|
||
`(let* ((input (read-contents ,object))
|
||
(all-input (get-bytevector-all input)))
|
||
(close-port input)
|
||
all-input)
|
||
marionette))
|
||
|
||
(marionette-eval '(use-modules (guix ipfs)) marionette)
|
||
(test-runner-current (system-test-runner #$output))
|
||
(test-begin "ipfs")
|
||
|
||
;; Test the IPFS service.
|
||
|
||
(test-assert "ipfs is alive" (ipfs-is-alive?))
|
||
|
||
(test-assert "ipfs is listening on the gateway"
|
||
(let ((default-port 8082))
|
||
(wait-for-tcp-port default-port marionette)))
|
||
|
||
(test-assert "ipfs is listening on the API endpoint"
|
||
(let ((default-port 5001))
|
||
(wait-for-tcp-port default-port marionette)))
|
||
|
||
(define test-bv (string->utf8 "hello ipfs!"))
|
||
(test-equal "can upload and download a file to/from ipfs"
|
||
test-bv
|
||
(read-contents (add-data test-bv)))
|
||
|
||
(test-end))))
|
||
(gexp->derivation "ipfs-test" test))
|
||
|
||
(define %test-ipfs
|
||
(system-test
|
||
(name "ipfs")
|
||
(description "Test a running IPFS daemon configuration.")
|
||
(value (run-ipfs-test))))
|