* [bug#75100] [PATCH 1/3] services: static-networking: Run set-up/tear-down as a separate process.
2024-12-25 21:08 [bug#75100] [PATCH 0/3] Shepherd service of 'static-networking' completes in timely fashion Ludovic Courtès
@ 2024-12-25 21:15 ` Ludovic Courtès
2024-12-25 21:15 ` [bug#75100] [PATCH 2/3] services: static-networking: Fail when devices don’t show up Ludovic Courtès
2024-12-25 21:15 ` [bug#75100] [PATCH 3/3] tests: Run without the Linux kernel “quiet” argument Ludovic Courtès
2 siblings, 0 replies; 4+ messages in thread
From: Ludovic Courtès @ 2024-12-25 21:15 UTC (permalink / raw)
To: 75100; +Cc: Ludovic Courtès
Running that code in PID 1 was fun but it’s not really beneficial and
somewhat risky: risk of blocking, file descriptor leak, inability to
reload Guile-Netlink in shepherd when it’s upgraded, and so on.
This change runs set-up and tear-down as separate processes, which, for
the price of one fork(1), buys us peace of mind.
* gnu/services/base.scm (network-set-up/hurd, network-tear-down/hurd)
(network-tear-down/linux): Use ‘program-file’ instead of ‘scheme-file’.
(network-set-up/linux): Likewise, and remove #:blocking? argument to
‘wait-for-link’.
Change-Id: Ia41479b50eab31ea40c67243fcb1cffe29ac874a
---
gnu/services/base.scm | 361 +++++++++++++++++++++---------------------
1 file changed, 181 insertions(+), 180 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index fc604f029a..f6d1da61cd 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -3055,172 +3055,139 @@ (define (network-set-up/hurd config)
;; The Hurd implements SIOCGIFADDR and other old-style ioctls, but the only
;; way to set up IPv6 is by starting pfinet with the right options.
(if (equal? (static-networking-provision config) '(loopback))
- (scheme-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
- (scheme-file "set-up-pfinet"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 format))
+ (program-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
+ (program-file "set-up-pfinet"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 format))
- ;; TODO: Do that without forking.
- (let ((options '#$(static-networking->hurd-pfinet-options
- config)))
- (format #t "starting '~a~{ ~s~}'~%"
+ ;; TODO: Do that without forking.
+ (let ((options '#$(static-networking->hurd-pfinet-options
+ config)))
+ (format #t "starting '~a~{ ~s~}'~%"
+ #$(file-append hurd "/hurd/pfinet")
+ options)
+ (apply invoke #$(file-append hurd "/bin/settrans")
+ "--active"
+ "--create"
+ "--keep-active"
+ "/servers/socket/2"
#$(file-append hurd "/hurd/pfinet")
- options)
- (apply invoke #$(file-append hurd "/bin/settrans")
- "--active"
- "--create"
- "--keep-active"
- "/servers/socket/2"
- #$(file-append hurd "/hurd/pfinet")
- options)))))))
+ options)))))))
(define (network-tear-down/hurd config)
- (scheme-file "tear-down-pfinet"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ (program-file "tear-down-pfinet"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- ;; Forcefully terminate pfinet. XXX: In theory this
- ;; should just undo the addresses and routes of CONFIG;
- ;; this could be done using ioctls like SIOCDELRT, but
- ;; these are IPv4-only; another option would be to use
- ;; fsysopts but that seems to crash pfinet.
- (invoke #$(file-append hurd "/bin/settrans") "-fg"
- "/servers/socket/2")
- #f))))
+ ;; Forcefully terminate pfinet. XXX: In theory this
+ ;; should just undo the addresses and routes of CONFIG;
+ ;; this could be done using ioctls like SIOCDELRT, but
+ ;; these are IPv4-only; another option would be to use
+ ;; fsysopts but that seems to crash pfinet.
+ (invoke #$(file-append hurd "/bin/settrans") "-fg"
+ "/servers/socket/2")
+ #f))))
(define (network-set-up/linux config)
(match-record config <static-networking>
(addresses links routes)
- (scheme-file "set-up-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route)
- (srfi srfi-1)
- (ice-9 format)
- (ice-9 match))
+ (program-file "set-up-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route)
+ (srfi srfi-1)
+ (ice-9 format)
+ (ice-9 match))
- (define (match-link-by field-accessor value)
- (fold (lambda (link result)
- (if (equal? (field-accessor link) value)
- link
- result))
- #f
- (get-links)))
+ (define (match-link-by field-accessor value)
+ (fold (lambda (link result)
+ (if (equal? (field-accessor link) value)
+ link
+ result))
+ #f
+ (get-links)))
- (define (alist->keyword+value alist)
- (fold (match-lambda*
- (((k . v) r)
- (cons* (symbol->keyword k) v r))) '() alist))
+ (define (alist->keyword+value alist)
+ (fold (match-lambda*
+ (((k . v) r)
+ (cons* (symbol->keyword k) v r))) '() alist))
- ;; FIXME: It is interesting that "modprobe bonding" creates an
- ;; interface bond0 straigt away. If we won't have bonding
- ;; module, and execute `ip link add name bond0 type bond' we
- ;; will get
- ;;
- ;; RTNETLINK answers: File exists
- ;;
- ;; This breaks our configuration if we want to
- ;; use `bond0' name. Create (force modprobe
- ;; bonding) and delete the interface to free up
- ;; bond0 name.
- #$(let lp ((links links))
- (cond
- ((null? links) #f)
- ((and (network-link? (car links))
- ;; Type is not mandatory
- (false-if-exception
- (eq? (network-link-type (car links)) 'bond)))
- #~(begin
- (false-if-exception (link-add "bond0" "bond"))
- (link-del "bond0")))
- (else (lp (cdr links)))))
+ ;; FIXME: It is interesting that "modprobe bonding" creates an
+ ;; interface bond0 straigt away. If we won't have bonding
+ ;; module, and execute `ip link add name bond0 type bond' we
+ ;; will get
+ ;;
+ ;; RTNETLINK answers: File exists
+ ;;
+ ;; This breaks our configuration if we want to
+ ;; use `bond0' name. Create (force modprobe
+ ;; bonding) and delete the interface to free up
+ ;; bond0 name.
+ #$(let lp ((links links))
+ (cond
+ ((null? links) #f)
+ ((and (network-link? (car links))
+ ;; Type is not mandatory
+ (false-if-exception
+ (eq? (network-link-type (car links)) 'bond)))
+ #~(begin
+ (false-if-exception (link-add "bond0" "bond"))
+ (link-del "bond0")))
+ (else (lp (cdr links)))))
- #$@(map (match-lambda
- (($ <network-link> name type mac-address arguments)
- (cond
- ;; Create a new interface
- ((and (string? name) (symbol? type))
- #~(begin
- (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
- ;; XXX: If we add routes, addresses must be
- ;; already assigned, and interfaces must be
- ;; up. It doesn't matter if they won't have
- ;; carrier or anything.
- (link-set #$name #:up #t)))
+ #$@(map (match-lambda
+ (($ <network-link> name type mac-address arguments)
+ (cond
+ ;; Create a new interface
+ ((and (string? name) (symbol? type))
+ #~(begin
+ (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
+ ;; XXX: If we add routes, addresses must be
+ ;; already assigned, and interfaces must be
+ ;; up. It doesn't matter if they won't have
+ ;; carrier or anything.
+ (link-set #$name #:up #t)))
- ;; Amend an existing interface
- ((and (string? name)
- (eq? type #f))
- #~(let ((link (match-link-by link-name #$name)))
- (if link
- (apply link-set
- (link-id link)
- (alist->keyword+value '#$arguments))
- (format #t (G_ "Interface with name '~a' not found~%") #$name))))
- ((string? mac-address)
- #~(let ((link (match-link-by link-addr #$mac-address)))
- (if link
- (apply link-set
- (link-id link)
- (alist->keyword+value '#$arguments))
- (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
- links)
+ ;; Amend an existing interface
+ ((and (string? name)
+ (eq? type #f))
+ #~(let ((link (match-link-by link-name #$name)))
+ (if link
+ (apply link-set
+ (link-id link)
+ (alist->keyword+value '#$arguments))
+ (format #t (G_ "Interface with name '~a' not found~%") #$name))))
+ ((string? mac-address)
+ #~(let ((link (match-link-by link-addr #$mac-address)))
+ (if link
+ (apply link-set
+ (link-id link)
+ (alist->keyword+value '#$arguments))
+ (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
+ links)
- #$@(map (lambda (address)
- #~(begin
- ;; Before going any further, wait for the
- ;; device to show up.
- (wait-for-link
- #$(network-address-device address)
- #:blocking? #f)
+ #$@(map (lambda (address)
+ #~(begin
+ ;; Before going any further, wait for the
+ ;; device to show up.
+ (wait-for-link
+ #$(network-address-device address))
- (addr-add #$(network-address-device address)
- #$(network-address-value address)
- #:ipv6?
- #$(network-address-ipv6? address))
- ;; FIXME: loopback?
- (link-set #$(network-address-device address)
- #:multicast-on #t
- #:up #t)))
- addresses)
+ (addr-add #$(network-address-device address)
+ #$(network-address-value address)
+ #:ipv6?
+ #$(network-address-ipv6? address))
+ ;; FIXME: loopback?
+ (link-set #$(network-address-device address)
+ #:multicast-on #t
+ #:up #t)))
+ addresses)
- #$@(map (lambda (route)
- #~(route-add #$(network-route-destination route)
- #:device
- #$(network-route-device route)
- #:ipv6?
- #$(network-route-ipv6? route)
- #:via
- #$(network-route-gateway route)
- #:src
- #$(network-route-source route)))
- routes)
- #t)))))
-
-(define (network-tear-down/linux config)
- (match-record config <static-networking>
- (addresses links routes)
- (scheme-file "tear-down-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route)
- (netlink error)
- (srfi srfi-34))
-
- (define-syntax-rule (false-if-netlink-error exp)
- (guard (c ((netlink-error? c) #f))
- exp))
-
- ;; Wrap calls in 'false-if-netlink-error' so this
- ;; script goes as far as possible undoing the effects
- ;; of "set-up-network".
-
- #$@(map (lambda (route)
- #~(false-if-netlink-error
- (route-del #$(network-route-destination route)
+ #$@(map (lambda (route)
+ #~(route-add #$(network-route-destination route)
#:device
#$(network-route-device route)
#:ipv6?
@@ -3228,31 +3195,63 @@ (define (network-tear-down/linux config)
#:via
#$(network-route-gateway route)
#:src
- #$(network-route-source route))))
- routes)
+ #$(network-route-source route)))
+ routes)
+ #t)))))
- ;; Cleanup addresses first, they might be assigned to
- ;; created bonds, vlans or bridges.
- #$@(map (lambda (address)
- #~(false-if-netlink-error
- (addr-del #$(network-address-device
- address)
- #$(network-address-value address)
- #:ipv6?
- #$(network-address-ipv6? address))))
- addresses)
+(define (network-tear-down/linux config)
+ (match-record config <static-networking>
+ (addresses links routes)
+ (program-file "tear-down-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route)
+ (netlink error)
+ (srfi srfi-34))
- ;; It is now safe to delete some links
- #$@(map (match-lambda
- (($ <network-link> name type mac-address arguments)
- (cond
- ;; We delete interfaces that were created
- ((and (string? name) (symbol? type))
- #~(false-if-netlink-error
- (link-del #$name)))
- (else #t))))
- links)
- #f)))))
+ (define-syntax-rule (false-if-netlink-error exp)
+ (guard (c ((netlink-error? c) #f))
+ exp))
+
+ ;; Wrap calls in 'false-if-netlink-error' so this
+ ;; script goes as far as possible undoing the effects
+ ;; of "set-up-network".
+
+ #$@(map (lambda (route)
+ #~(false-if-netlink-error
+ (route-del #$(network-route-destination route)
+ #:device
+ #$(network-route-device route)
+ #:ipv6?
+ #$(network-route-ipv6? route)
+ #:via
+ #$(network-route-gateway route)
+ #:src
+ #$(network-route-source route))))
+ routes)
+
+ ;; Cleanup addresses first, they might be assigned to
+ ;; created bonds, vlans or bridges.
+ #$@(map (lambda (address)
+ #~(false-if-netlink-error
+ (addr-del #$(network-address-device
+ address)
+ #$(network-address-value address)
+ #:ipv6?
+ #$(network-address-ipv6? address))))
+ addresses)
+
+ ;; It is now safe to delete some links
+ #$@(map (match-lambda
+ (($ <network-link> name type mac-address arguments)
+ (cond
+ ;; We delete interfaces that were created
+ ((and (string? name) (symbol? type))
+ #~(false-if-netlink-error
+ (link-del #$name)))
+ (else #t))))
+ links)
+ #f)))))
(define (static-networking-shepherd-service config)
(match-record config <static-networking>
@@ -3267,16 +3266,18 @@ (define (static-networking-shepherd-service config)
(start #~(lambda _
;; Return #t if successfully started.
- (load #$(let-system (system target)
- (if (string-contains (or target system) "-linux")
- (network-set-up/linux config)
- (network-set-up/hurd config))))))
+ (zero? (system*
+ #$(let-system (system target)
+ (if (string-contains (or target system) "-linux")
+ (network-set-up/linux config)
+ (network-set-up/hurd config)))))))
(stop #~(lambda _
;; Return #f is successfully stopped.
- (load #$(let-system (system target)
- (if (string-contains (or target system) "-linux")
- (network-tear-down/linux config)
- (network-tear-down/hurd config))))))
+ (zero? (system*
+ #$(let-system (system target)
+ (if (string-contains (or target system) "-linux")
+ (network-tear-down/linux config)
+ (network-tear-down/hurd config)))))))
(respawn? #f)))))
(define (static-networking-shepherd-services networks)
--
2.46.0
^ permalink raw reply related [flat|nested] 4+ messages in thread* [bug#75100] [PATCH 2/3] services: static-networking: Fail when devices don’t show up.
2024-12-25 21:08 [bug#75100] [PATCH 0/3] Shepherd service of 'static-networking' completes in timely fashion Ludovic Courtès
2024-12-25 21:15 ` [bug#75100] [PATCH 1/3] services: static-networking: Run set-up/tear-down as a separate process Ludovic Courtès
@ 2024-12-25 21:15 ` Ludovic Courtès
2024-12-25 21:15 ` [bug#75100] [PATCH 3/3] tests: Run without the Linux kernel “quiet” argument Ludovic Courtès
2 siblings, 0 replies; 4+ messages in thread
From: Ludovic Courtès @ 2024-12-25 21:15 UTC (permalink / raw)
To: 75100; +Cc: Ludovic Courtès
Fixes <https://issues.guix.gnu.org/71173>.
* gnu/services/base.scm (network-set-up/linux): Define
‘max-set-up-duration’ and use it.
* gnu/tests/networking.scm (%static-networking-with-nonexistent-device):
New variable.
(run-static-networking-failure-test): New procedure.
(%test-static-networking-failure): New variable.
Change-Id: Idba9b36750aa8c6368c8f6d1bc1358066f7432e4
---
gnu/services/base.scm | 17 ++++++++--
gnu/tests/networking.scm | 71 +++++++++++++++++++++++++++++++++++++++-
2 files changed, 84 insertions(+), 4 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index f6d1da61cd..15497b23f7 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -3092,6 +3092,10 @@ (define (network-tear-down/hurd config)
#f))))
(define (network-set-up/linux config)
+ (define max-set-up-duration
+ ;; Maximum waiting time in seconds for devices to be up.
+ 60)
+
(match-record config <static-networking>
(addresses links routes)
(program-file "set-up-network"
@@ -3169,12 +3173,19 @@ (define (network-set-up/linux config)
(format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
links)
+ ;; 'wait-for-link' below could wait forever when
+ ;; passed a non-existent device. To ensure timely
+ ;; completion, install an alarm.
+ (alarm #$max-set-up-duration)
+
#$@(map (lambda (address)
- #~(begin
+ #~(let ((device
+ #$(network-address-device address)))
;; Before going any further, wait for the
;; device to show up.
- (wait-for-link
- #$(network-address-device address))
+ (format #t "Waiting for network device '~a'...~%"
+ device)
+ (wait-for-link device)
(addr-add #$(network-address-device address)
#$(network-address-value address)
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index b1ab43efb6..e7c02b9e00 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -4,7 +4,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
-;;; Copyright © 2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,6 +39,7 @@ (define-module (gnu tests networking)
#: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
@@ -124,7 +125,75 @@ (define %test-static-networking
#:imported-modules '((gnu services herd)
(guix combinators)))))
(run-static-networking-test (virtual-machine os))))))
+\f
+(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))))))
+
+\f
(define (run-static-networking-advanced-test vm)
(define test
(with-imported-modules '((gnu build marionette)
--
2.46.0
^ permalink raw reply related [flat|nested] 4+ messages in thread