Be more explicit about gateway routes having specific interfaces, to avoid ARP reqs on the wrong interface.
This commit is contained in:
parent
93b1b0fcf3
commit
ea9660d83d
|
@ -2,14 +2,16 @@
|
||||||
|
|
||||||
(provide (struct-out ethernet-interface)
|
(provide (struct-out ethernet-interface)
|
||||||
(struct-out host-route)
|
(struct-out host-route)
|
||||||
|
(struct-out gateway-route)
|
||||||
(struct-out net-route))
|
(struct-out net-route))
|
||||||
|
|
||||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||||
|
|
||||||
;; A Route is one of
|
;; A Route is one of
|
||||||
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
|
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
|
||||||
;; - (net-route NetAddrBytes NetmaskNat IpAddrBytes), a gateway route for a subnet
|
;; - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet
|
||||||
;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
|
;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
|
||||||
;; NetmaskNat in a net-route is a default route.
|
;; NetmaskNat in a net-route is a default route.
|
||||||
(struct host-route (ip-addr netmask interface-name) #:prefab)
|
(struct host-route (ip-addr netmask interface-name) #:prefab)
|
||||||
|
(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab)
|
||||||
(struct net-route (network-addr netmask link) #:prefab)
|
(struct net-route (network-addr netmask link) #:prefab)
|
||||||
|
|
61
ip.rkt
61
ip.rkt
|
@ -64,6 +64,9 @@
|
||||||
(spawn-demand-matcher (host-route (?!) (?!) (?!))
|
(spawn-demand-matcher (host-route (?!) (?!) (?!))
|
||||||
#:supply-level 1
|
#:supply-level 1
|
||||||
spawn-host-route)
|
spawn-host-route)
|
||||||
|
(spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!))
|
||||||
|
#:supply-level 1
|
||||||
|
spawn-gateway-route)
|
||||||
(spawn-demand-matcher (net-route (?!) (?!) (?!))
|
(spawn-demand-matcher (net-route (?!) (?!) (?!))
|
||||||
#:supply-level 1
|
#:supply-level 1
|
||||||
spawn-net-route)))
|
spawn-net-route)))
|
||||||
|
@ -71,6 +74,9 @@
|
||||||
(define (host-route-supply ip-addr netmask interface-name)
|
(define (host-route-supply ip-addr netmask interface-name)
|
||||||
(sub (host-route ip-addr netmask interface-name) #:level 1))
|
(sub (host-route ip-addr netmask interface-name) #:level 1))
|
||||||
|
|
||||||
|
(define (gateway-route-supply network-addr netmask gateway-addr interface-name)
|
||||||
|
(sub (gateway-route network-addr netmask gateway-addr interface-name) #:level 1))
|
||||||
|
|
||||||
(define (net-route-supply network-addr netmask link)
|
(define (net-route-supply network-addr netmask link)
|
||||||
(sub (net-route network-addr netmask link) #:level 1))
|
(sub (net-route network-addr netmask link) #:level 1))
|
||||||
|
|
||||||
|
@ -123,27 +129,21 @@
|
||||||
(pub (arp-assertion IPv4-ethertype my-address interface-name))
|
(pub (arp-assertion IPv4-ethertype my-address interface-name))
|
||||||
(host-route-supply my-address netmask interface-name)))))
|
(host-route-supply my-address netmask interface-name)))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; General net route
|
|
||||||
|
|
||||||
(define (spawn-net-route network-addr netmask link)
|
|
||||||
(cond
|
|
||||||
[(bytes? link) (spawn-gateway-ip-route network-addr netmask link)]
|
|
||||||
[(string? link) (spawn-normal-ip-route (net-route-supply network-addr netmask link)
|
|
||||||
network-addr
|
|
||||||
netmask
|
|
||||||
link)]
|
|
||||||
[else (error 'ip "Invalid net-route: ~v ~v ~v" network-addr netmask link)]))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Gateway IP route
|
;; Gateway IP route
|
||||||
|
|
||||||
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
|
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
|
||||||
|
|
||||||
(define (spawn-gateway-ip-route network netmask gateway-addr)
|
(define (spawn-gateway-route network netmask gateway-addr interface-name)
|
||||||
|
(define gestalt-for-supply (gateway-route-supply network netmask gateway-addr interface-name))
|
||||||
|
|
||||||
(define host-route-projector (project-subs (host-route (?!) ? ?)))
|
(define host-route-projector (project-subs (host-route (?!) ? ?)))
|
||||||
|
(define gateway-route-projector (project-subs (gateway-route (?!) (?!) ? ?)))
|
||||||
(define net-route-projector (project-subs (net-route (?!) (?!) ?)))
|
(define net-route-projector (project-subs (net-route (?!) (?!) ?)))
|
||||||
(define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype gateway-addr (?!) (?!))))
|
(define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype
|
||||||
|
gateway-addr
|
||||||
|
(?! (ethernet-interface interface-name ?))
|
||||||
|
(?!))))
|
||||||
|
|
||||||
(define (covered-by-some-other-route? addr routes)
|
(define (covered-by-some-other-route? addr routes)
|
||||||
(for/or ([r (in-set routes)])
|
(for/or ([r (in-set routes)])
|
||||||
|
@ -155,22 +155,28 @@
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(define host-ips (gestalt-project/single g host-route-projector))
|
(define host-ips (gestalt-project/single g host-route-projector))
|
||||||
(define net-ips+netmasks (gestalt-project/keys g net-route-projector))
|
(define gw-nets+netmasks (gestalt-project/keys g gateway-route-projector))
|
||||||
|
(define net-nets+netmasks (gestalt-project/keys g net-route-projector))
|
||||||
(define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector)))
|
(define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector)))
|
||||||
(and vs (not (set-empty? vs)) (set-first vs))))
|
(and vs (not (set-empty? vs)) (set-first vs))))
|
||||||
|
(when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s)))
|
||||||
|
(log-info "Discovered gateway ~a at ~a on interface ~a."
|
||||||
|
(ip-address->hostname gateway-addr)
|
||||||
|
(ethernet-interface-name (car gw-ip+hwaddr))
|
||||||
|
(pretty-bytes (cadr gw-ip+hwaddr))))
|
||||||
(transition (gateway-route-state
|
(transition (gateway-route-state
|
||||||
(set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks)
|
(set-union (for/set ([ip host-ips]) (list ip 32))
|
||||||
|
gw-nets+netmasks
|
||||||
|
net-nets+netmasks)
|
||||||
(and gw-ip+hwaddr (car gw-ip+hwaddr))
|
(and gw-ip+hwaddr (car gw-ip+hwaddr))
|
||||||
(and gw-ip+hwaddr (cadr gw-ip+hwaddr)))
|
(and gw-ip+hwaddr (cadr gw-ip+hwaddr)))
|
||||||
(when (gestalt-empty? (gestalt-filter g (net-route-supply network
|
(when (gestalt-empty? (gestalt-filter g gestalt-for-supply)) (quit)))]
|
||||||
netmask
|
|
||||||
gateway-addr)))
|
|
||||||
(quit)))]
|
|
||||||
[(message (? ip-packet? p) _ _)
|
[(message (? ip-packet? p) _ _)
|
||||||
(define gw-if (gateway-route-state-gateway-interface s))
|
(define gw-if (gateway-route-state-gateway-interface s))
|
||||||
(when (not gw-if)
|
(when (not gw-if)
|
||||||
(log-warning "Gateway hwaddr for ~a not known, packet dropped"
|
(log-warning "Gateway hwaddr for ~a not known, packet dropped: ~v"
|
||||||
(ip-address->hostname gateway-addr)))
|
(ip-address->hostname gateway-addr)
|
||||||
|
p))
|
||||||
(and gw-if
|
(and gw-if
|
||||||
(not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if)))
|
(not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if)))
|
||||||
(not (covered-by-some-other-route? (ip-packet-destination p)
|
(not (covered-by-some-other-route? (ip-packet-destination p)
|
||||||
|
@ -184,17 +190,22 @@
|
||||||
(format-ip-packet p)))))]
|
(format-ip-packet p)))))]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(gateway-route-state (set) #f #f)
|
(gateway-route-state (set) #f #f)
|
||||||
(gestalt-union (if (zero? netmask)
|
(gestalt-union gestalt-for-supply
|
||||||
(net-route-supply network netmask gateway-addr)
|
|
||||||
(gestalt-empty))
|
|
||||||
|
|
||||||
(sub (ip-packet ? ? ? ? ? ?))
|
(sub (ip-packet ? ? ? ? ? ?))
|
||||||
(pub (ip-packet ? ? ? ? ? ?))
|
(pub (ip-packet ? ? ? ? ? ?))
|
||||||
|
|
||||||
observe-local-ip-addresses-gestalt
|
observe-local-ip-addresses-gestalt
|
||||||
(sub (net-route ? ? ?) #:level 2)
|
(sub (net-route ? ? ?) #:level 2)
|
||||||
|
(sub (gateway-route ? ? ? ?) #:level 2)
|
||||||
(projection->gestalt gateway-arp-projector))))
|
(projection->gestalt gateway-arp-projector))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; General net route
|
||||||
|
|
||||||
|
(define (spawn-net-route network-addr netmask link)
|
||||||
|
(spawn-normal-ip-route (net-route-supply network-addr netmask link) network-addr netmask link))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Normal IP route
|
;; Normal IP route
|
||||||
|
|
||||||
|
|
4
main.rkt
4
main.rkt
|
@ -23,12 +23,12 @@
|
||||||
(void)
|
(void)
|
||||||
(match (gethostname)
|
(match (gethostname)
|
||||||
["hop"
|
["hop"
|
||||||
(gestalt-union (pub (net-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1)))
|
(gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
|
||||||
(pub (host-route (bytes 192 168 1 222) 24 "wlan0")))]
|
(pub (host-route (bytes 192 168 1 222) 24 "wlan0")))]
|
||||||
["stockholm.ccs.neu.edu"
|
["stockholm.ccs.neu.edu"
|
||||||
(gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0"))
|
(gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||||
(pub (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
|
(pub (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
|
||||||
(pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1))))]
|
(pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
|
||||||
[else
|
[else
|
||||||
(error 'stack-configuration "No setup for hostname ~a" (gethostname))]))
|
(error 'stack-configuration "No setup for hostname ~a" (gethostname))]))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue