mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-02-07 11:29:59 +01:00
services: static-networking: Run set-up/tear-down as a separate process.
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
This commit is contained in:
Ludovic Courtès
parent
911f205dda
commit
8d649a8d17
1 changed files with 181 additions and 180 deletions
|
|
@ -3055,172 +3055,139 @@ to CONFIG."
|
||||||
;; The Hurd implements SIOCGIFADDR and other old-style ioctls, but the only
|
;; 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.
|
;; way to set up IPv6 is by starting pfinet with the right options.
|
||||||
(if (equal? (static-networking-provision config) '(loopback))
|
(if (equal? (static-networking-provision config) '(loopback))
|
||||||
(scheme-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
|
(program-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
|
||||||
(scheme-file "set-up-pfinet"
|
(program-file "set-up-pfinet"
|
||||||
(with-imported-modules '((guix build utils))
|
(with-imported-modules '((guix build utils))
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (guix build utils)
|
(use-modules (guix build utils)
|
||||||
(ice-9 format))
|
(ice-9 format))
|
||||||
|
|
||||||
;; TODO: Do that without forking.
|
;; TODO: Do that without forking.
|
||||||
(let ((options '#$(static-networking->hurd-pfinet-options
|
(let ((options '#$(static-networking->hurd-pfinet-options
|
||||||
config)))
|
config)))
|
||||||
(format #t "starting '~a~{ ~s~}'~%"
|
(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")
|
#$(file-append hurd "/hurd/pfinet")
|
||||||
options)
|
options)))))))
|
||||||
(apply invoke #$(file-append hurd "/bin/settrans")
|
|
||||||
"--active"
|
|
||||||
"--create"
|
|
||||||
"--keep-active"
|
|
||||||
"/servers/socket/2"
|
|
||||||
#$(file-append hurd "/hurd/pfinet")
|
|
||||||
options)))))))
|
|
||||||
|
|
||||||
(define (network-tear-down/hurd config)
|
(define (network-tear-down/hurd config)
|
||||||
(scheme-file "tear-down-pfinet"
|
(program-file "tear-down-pfinet"
|
||||||
(with-imported-modules '((guix build utils))
|
(with-imported-modules '((guix build utils))
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (guix build utils))
|
(use-modules (guix build utils))
|
||||||
|
|
||||||
;; Forcefully terminate pfinet. XXX: In theory this
|
;; Forcefully terminate pfinet. XXX: In theory this
|
||||||
;; should just undo the addresses and routes of CONFIG;
|
;; should just undo the addresses and routes of CONFIG;
|
||||||
;; this could be done using ioctls like SIOCDELRT, but
|
;; this could be done using ioctls like SIOCDELRT, but
|
||||||
;; these are IPv4-only; another option would be to use
|
;; these are IPv4-only; another option would be to use
|
||||||
;; fsysopts but that seems to crash pfinet.
|
;; fsysopts but that seems to crash pfinet.
|
||||||
(invoke #$(file-append hurd "/bin/settrans") "-fg"
|
(invoke #$(file-append hurd "/bin/settrans") "-fg"
|
||||||
"/servers/socket/2")
|
"/servers/socket/2")
|
||||||
#f))))
|
#f))))
|
||||||
|
|
||||||
(define (network-set-up/linux config)
|
(define (network-set-up/linux config)
|
||||||
(match-record config <static-networking>
|
(match-record config <static-networking>
|
||||||
(addresses links routes)
|
(addresses links routes)
|
||||||
(scheme-file "set-up-network"
|
(program-file "set-up-network"
|
||||||
(with-extensions (list guile-netlink)
|
(with-extensions (list guile-netlink)
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (ip addr) (ip link) (ip route)
|
(use-modules (ip addr) (ip link) (ip route)
|
||||||
(srfi srfi-1)
|
(srfi srfi-1)
|
||||||
(ice-9 format)
|
(ice-9 format)
|
||||||
(ice-9 match))
|
(ice-9 match))
|
||||||
|
|
||||||
(define (match-link-by field-accessor value)
|
(define (match-link-by field-accessor value)
|
||||||
(fold (lambda (link result)
|
(fold (lambda (link result)
|
||||||
(if (equal? (field-accessor link) value)
|
(if (equal? (field-accessor link) value)
|
||||||
link
|
link
|
||||||
result))
|
result))
|
||||||
#f
|
#f
|
||||||
(get-links)))
|
(get-links)))
|
||||||
|
|
||||||
(define (alist->keyword+value alist)
|
(define (alist->keyword+value alist)
|
||||||
(fold (match-lambda*
|
(fold (match-lambda*
|
||||||
(((k . v) r)
|
(((k . v) r)
|
||||||
(cons* (symbol->keyword k) v r))) '() alist))
|
(cons* (symbol->keyword k) v r))) '() alist))
|
||||||
|
|
||||||
;; FIXME: It is interesting that "modprobe bonding" creates an
|
;; FIXME: It is interesting that "modprobe bonding" creates an
|
||||||
;; interface bond0 straigt away. If we won't have bonding
|
;; interface bond0 straigt away. If we won't have bonding
|
||||||
;; module, and execute `ip link add name bond0 type bond' we
|
;; module, and execute `ip link add name bond0 type bond' we
|
||||||
;; will get
|
;; will get
|
||||||
;;
|
;;
|
||||||
;; RTNETLINK answers: File exists
|
;; RTNETLINK answers: File exists
|
||||||
;;
|
;;
|
||||||
;; This breaks our configuration if we want to
|
;; This breaks our configuration if we want to
|
||||||
;; use `bond0' name. Create (force modprobe
|
;; use `bond0' name. Create (force modprobe
|
||||||
;; bonding) and delete the interface to free up
|
;; bonding) and delete the interface to free up
|
||||||
;; bond0 name.
|
;; bond0 name.
|
||||||
#$(let lp ((links links))
|
#$(let lp ((links links))
|
||||||
(cond
|
(cond
|
||||||
((null? links) #f)
|
((null? links) #f)
|
||||||
((and (network-link? (car links))
|
((and (network-link? (car links))
|
||||||
;; Type is not mandatory
|
;; Type is not mandatory
|
||||||
(false-if-exception
|
(false-if-exception
|
||||||
(eq? (network-link-type (car links)) 'bond)))
|
(eq? (network-link-type (car links)) 'bond)))
|
||||||
#~(begin
|
#~(begin
|
||||||
(false-if-exception (link-add "bond0" "bond"))
|
(false-if-exception (link-add "bond0" "bond"))
|
||||||
(link-del "bond0")))
|
(link-del "bond0")))
|
||||||
(else (lp (cdr links)))))
|
(else (lp (cdr links)))))
|
||||||
|
|
||||||
#$@(map (match-lambda
|
#$@(map (match-lambda
|
||||||
(($ <network-link> name type mac-address arguments)
|
(($ <network-link> name type mac-address arguments)
|
||||||
(cond
|
(cond
|
||||||
;; Create a new interface
|
;; Create a new interface
|
||||||
((and (string? name) (symbol? type))
|
((and (string? name) (symbol? type))
|
||||||
#~(begin
|
#~(begin
|
||||||
(link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
|
(link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
|
||||||
;; XXX: If we add routes, addresses must be
|
;; XXX: If we add routes, addresses must be
|
||||||
;; already assigned, and interfaces must be
|
;; already assigned, and interfaces must be
|
||||||
;; up. It doesn't matter if they won't have
|
;; up. It doesn't matter if they won't have
|
||||||
;; carrier or anything.
|
;; carrier or anything.
|
||||||
(link-set #$name #:up #t)))
|
(link-set #$name #:up #t)))
|
||||||
|
|
||||||
;; Amend an existing interface
|
;; Amend an existing interface
|
||||||
((and (string? name)
|
((and (string? name)
|
||||||
(eq? type #f))
|
(eq? type #f))
|
||||||
#~(let ((link (match-link-by link-name #$name)))
|
#~(let ((link (match-link-by link-name #$name)))
|
||||||
(if link
|
(if link
|
||||||
(apply link-set
|
(apply link-set
|
||||||
(link-id link)
|
(link-id link)
|
||||||
(alist->keyword+value '#$arguments))
|
(alist->keyword+value '#$arguments))
|
||||||
(format #t (G_ "Interface with name '~a' not found~%") #$name))))
|
(format #t (G_ "Interface with name '~a' not found~%") #$name))))
|
||||||
((string? mac-address)
|
((string? mac-address)
|
||||||
#~(let ((link (match-link-by link-addr #$mac-address)))
|
#~(let ((link (match-link-by link-addr #$mac-address)))
|
||||||
(if link
|
(if link
|
||||||
(apply link-set
|
(apply link-set
|
||||||
(link-id link)
|
(link-id link)
|
||||||
(alist->keyword+value '#$arguments))
|
(alist->keyword+value '#$arguments))
|
||||||
(format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
|
(format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
|
||||||
links)
|
links)
|
||||||
|
|
||||||
#$@(map (lambda (address)
|
#$@(map (lambda (address)
|
||||||
#~(begin
|
#~(begin
|
||||||
;; Before going any further, wait for the
|
;; Before going any further, wait for the
|
||||||
;; device to show up.
|
;; device to show up.
|
||||||
(wait-for-link
|
(wait-for-link
|
||||||
#$(network-address-device address)
|
#$(network-address-device address))
|
||||||
#:blocking? #f)
|
|
||||||
|
|
||||||
(addr-add #$(network-address-device address)
|
(addr-add #$(network-address-device address)
|
||||||
#$(network-address-value address)
|
#$(network-address-value address)
|
||||||
#:ipv6?
|
#:ipv6?
|
||||||
#$(network-address-ipv6? address))
|
#$(network-address-ipv6? address))
|
||||||
;; FIXME: loopback?
|
;; FIXME: loopback?
|
||||||
(link-set #$(network-address-device address)
|
(link-set #$(network-address-device address)
|
||||||
#:multicast-on #t
|
#:multicast-on #t
|
||||||
#:up #t)))
|
#:up #t)))
|
||||||
addresses)
|
addresses)
|
||||||
|
|
||||||
#$@(map (lambda (route)
|
#$@(map (lambda (route)
|
||||||
#~(route-add #$(network-route-destination 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)
|
|
||||||
#:device
|
#:device
|
||||||
#$(network-route-device route)
|
#$(network-route-device route)
|
||||||
#:ipv6?
|
#:ipv6?
|
||||||
|
|
@ -3228,31 +3195,63 @@ to CONFIG."
|
||||||
#:via
|
#:via
|
||||||
#$(network-route-gateway route)
|
#$(network-route-gateway route)
|
||||||
#:src
|
#:src
|
||||||
#$(network-route-source route))))
|
#$(network-route-source route)))
|
||||||
routes)
|
routes)
|
||||||
|
#t)))))
|
||||||
|
|
||||||
;; Cleanup addresses first, they might be assigned to
|
(define (network-tear-down/linux config)
|
||||||
;; created bonds, vlans or bridges.
|
(match-record config <static-networking>
|
||||||
#$@(map (lambda (address)
|
(addresses links routes)
|
||||||
#~(false-if-netlink-error
|
(program-file "tear-down-network"
|
||||||
(addr-del #$(network-address-device
|
(with-extensions (list guile-netlink)
|
||||||
address)
|
#~(begin
|
||||||
#$(network-address-value address)
|
(use-modules (ip addr) (ip link) (ip route)
|
||||||
#:ipv6?
|
(netlink error)
|
||||||
#$(network-address-ipv6? address))))
|
(srfi srfi-34))
|
||||||
addresses)
|
|
||||||
|
|
||||||
;; It is now safe to delete some links
|
(define-syntax-rule (false-if-netlink-error exp)
|
||||||
#$@(map (match-lambda
|
(guard (c ((netlink-error? c) #f))
|
||||||
(($ <network-link> name type mac-address arguments)
|
exp))
|
||||||
(cond
|
|
||||||
;; We delete interfaces that were created
|
;; Wrap calls in 'false-if-netlink-error' so this
|
||||||
((and (string? name) (symbol? type))
|
;; script goes as far as possible undoing the effects
|
||||||
#~(false-if-netlink-error
|
;; of "set-up-network".
|
||||||
(link-del #$name)))
|
|
||||||
(else #t))))
|
#$@(map (lambda (route)
|
||||||
links)
|
#~(false-if-netlink-error
|
||||||
#f)))))
|
(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)
|
(define (static-networking-shepherd-service config)
|
||||||
(match-record config <static-networking>
|
(match-record config <static-networking>
|
||||||
|
|
@ -3267,16 +3266,18 @@ to CONFIG."
|
||||||
|
|
||||||
(start #~(lambda _
|
(start #~(lambda _
|
||||||
;; Return #t if successfully started.
|
;; Return #t if successfully started.
|
||||||
(load #$(let-system (system target)
|
(zero? (system*
|
||||||
(if (string-contains (or target system) "-linux")
|
#$(let-system (system target)
|
||||||
(network-set-up/linux config)
|
(if (string-contains (or target system) "-linux")
|
||||||
(network-set-up/hurd config))))))
|
(network-set-up/linux config)
|
||||||
|
(network-set-up/hurd config)))))))
|
||||||
(stop #~(lambda _
|
(stop #~(lambda _
|
||||||
;; Return #f is successfully stopped.
|
;; Return #f is successfully stopped.
|
||||||
(load #$(let-system (system target)
|
(zero? (system*
|
||||||
(if (string-contains (or target system) "-linux")
|
#$(let-system (system target)
|
||||||
(network-tear-down/linux config)
|
(if (string-contains (or target system) "-linux")
|
||||||
(network-tear-down/hurd config))))))
|
(network-tear-down/linux config)
|
||||||
|
(network-tear-down/hurd config)))))))
|
||||||
(respawn? #f)))))
|
(respawn? #f)))))
|
||||||
|
|
||||||
(define (static-networking-shepherd-services networks)
|
(define (static-networking-shepherd-services networks)
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue