mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-01-30 22:36:50 +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 @@ (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-syntax-rule (false-if-netlink-error exp)
|
|||
#: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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue