From: "Ludovic Courtès" <ludo@gnu.org>
To: 75100@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#75100] [PATCH 1/3] services: static-networking: Run set-up/tear-down as a separate process.
Date: Wed, 25 Dec 2024 22:15:31 +0100 [thread overview]
Message-ID: <42215a4536fa59b6d30e5346289043f8ab17b239.1735160803.git.ludo@gnu.org> (raw)
In-Reply-To: <cover.1735160803.git.ludo@gnu.org>
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
next prev parent reply other threads:[~2024-12-25 21:16 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
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 [this message]
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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=42215a4536fa59b6d30e5346289043f8ab17b239.1735160803.git.ludo@gnu.org \
--to=ludo@gnu.org \
--cc=75100@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).