(Less im)Proper routing.
This commit is contained in:
parent
25c970902d
commit
e76fa1527c
104
arp.rkt
104
arp.rkt
|
@ -4,6 +4,7 @@
|
||||||
|
|
||||||
(provide (struct-out arp-query)
|
(provide (struct-out arp-query)
|
||||||
(struct-out arp-assertion)
|
(struct-out arp-assertion)
|
||||||
|
(struct-out arp-interface)
|
||||||
spawn-arp-driver)
|
spawn-arp-driver)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
@ -14,10 +15,12 @@
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
|
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
|
(require "configuration.rkt")
|
||||||
(require "ethernet.rkt")
|
(require "ethernet.rkt")
|
||||||
|
|
||||||
(struct arp-query (protocol protocol-address hardware-address) #:prefab)
|
(struct arp-query (protocol protocol-address interface link-address) #:prefab)
|
||||||
(struct arp-assertion (protocol protocol-address) #:prefab)
|
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
|
||||||
|
(struct arp-interface (interface-name) #:prefab)
|
||||||
|
|
||||||
(define ARP-ethertype #x0806)
|
(define ARP-ethertype #x0806)
|
||||||
(define cache-entry-lifetime-msec (* 14400 1000))
|
(define cache-entry-lifetime-msec (* 14400 1000))
|
||||||
|
@ -25,12 +28,31 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (spawn-arp-driver)
|
||||||
|
(spawn-demand-matcher (arp-interface (?!))
|
||||||
|
#:supply-level 1
|
||||||
|
spawn-arp-interface))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(struct cache-key (protocol address) #:transparent)
|
(struct cache-key (protocol address) #:transparent)
|
||||||
(struct cache-value (expiry address) #:transparent)
|
(struct cache-value (expiry interface address) #:transparent)
|
||||||
|
|
||||||
(struct state (hwaddr cache queries assertions) #:transparent)
|
(struct state (cache queries assertions) #:transparent)
|
||||||
|
|
||||||
|
(define (spawn-arp-interface interface-name)
|
||||||
|
(log-info "spawn-arp-interface ~v" interface-name)
|
||||||
|
(lookup-ethernet-hwaddr (gestalt-for-supply interface-name)
|
||||||
|
interface-name
|
||||||
|
(lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr))))
|
||||||
|
|
||||||
|
(define (gestalt-for-supply interface-name)
|
||||||
|
(sub (arp-interface interface-name) #:level 1))
|
||||||
|
|
||||||
|
(define (spawn-arp-interface* interface-name hwaddr)
|
||||||
|
(log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr)
|
||||||
|
(define interface (ethernet-interface interface-name hwaddr))
|
||||||
|
|
||||||
(define (spawn-arp-driver interface-name)
|
|
||||||
(define (expire-cache cache)
|
(define (expire-cache cache)
|
||||||
(define now (current-inexact-milliseconds))
|
(define now (current-inexact-milliseconds))
|
||||||
(define (not-expired? v) (< now (cache-value-expiry v)))
|
(define (not-expired? v) (< now (cache-value-expiry v)))
|
||||||
|
@ -47,11 +69,13 @@
|
||||||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype))
|
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype))
|
||||||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype) #:level 1)
|
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype) #:level 1)
|
||||||
(pub (ethernet-packet-pattern interface-name #f ARP-ethertype))
|
(pub (ethernet-packet-pattern interface-name #f ARP-ethertype))
|
||||||
(sub (arp-assertion ? ?) #:level 1)
|
(gestalt-for-supply interface-name)
|
||||||
(pub (arp-query ? ? ?) #:level 2)
|
(sub (arp-assertion ? ? interface-name) #:level 1)
|
||||||
|
(pub (arp-query ? ? interface ?) #:level 2)
|
||||||
(for/fold [(g (gestalt-empty))] [((k v) (in-hash cache))]
|
(for/fold [(g (gestalt-empty))] [((k v) (in-hash cache))]
|
||||||
(gestalt-union g (pub (arp-query (cache-key-protocol k)
|
(gestalt-union g (pub (arp-query (cache-key-protocol k)
|
||||||
(cache-key-address k)
|
(cache-key-address k)
|
||||||
|
(cache-value-interface v)
|
||||||
(cache-value-address v)))))))
|
(cache-value-address v)))))))
|
||||||
|
|
||||||
(define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
(define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
||||||
|
@ -67,9 +91,9 @@
|
||||||
(sender-pa :: binary bytes plen)
|
(sender-pa :: binary bytes plen)
|
||||||
(target-ha :: binary bytes hlen)
|
(target-ha :: binary bytes hlen)
|
||||||
(target-pa :: binary bytes plen))))
|
(target-pa :: binary bytes plen))))
|
||||||
(ethernet-packet (ethernet-interface interface-name (state-hwaddr s))
|
(ethernet-packet interface
|
||||||
#f
|
#f
|
||||||
(state-hwaddr s)
|
hwaddr
|
||||||
dest-mac
|
dest-mac
|
||||||
ARP-ethertype
|
ARP-ethertype
|
||||||
packet))
|
packet))
|
||||||
|
@ -84,15 +108,24 @@
|
||||||
(sender-hardware-address0 :: binary bytes hlen)
|
(sender-hardware-address0 :: binary bytes hlen)
|
||||||
(sender-protocol-address0 :: binary bytes plen)
|
(sender-protocol-address0 :: binary bytes plen)
|
||||||
(target-hardware-address0 :: binary bytes hlen)
|
(target-hardware-address0 :: binary bytes hlen)
|
||||||
(target-protocol-address0 :: binary bytes plen) ]
|
(target-protocol-address0 :: binary bytes plen)
|
||||||
|
(:: binary) ;; TODO: are the extra zeros coming from the
|
||||||
|
;; router real, or an artifact of my
|
||||||
|
;; packet-capture implementation?
|
||||||
|
]
|
||||||
(let ()
|
(let ()
|
||||||
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
|
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
|
||||||
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
|
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
|
||||||
(define target-protocol-address (bit-string->bytes target-protocol-address0))
|
(define target-protocol-address (bit-string->bytes target-protocol-address0))
|
||||||
|
;; (log-info "~a ARP Adding ~a = ~a to cache"
|
||||||
|
;; interface-name
|
||||||
|
;; (pretty-bytes sender-protocol-address)
|
||||||
|
;; (pretty-bytes sender-hardware-address))
|
||||||
(define cache (hash-set (expire-cache (state-cache s))
|
(define cache (hash-set (expire-cache (state-cache s))
|
||||||
(cache-key ptype sender-protocol-address)
|
(cache-key ptype sender-protocol-address)
|
||||||
(cache-value (+ (current-inexact-milliseconds)
|
(cache-value (+ (current-inexact-milliseconds)
|
||||||
cache-entry-lifetime-msec)
|
cache-entry-lifetime-msec)
|
||||||
|
interface
|
||||||
sender-hardware-address)))
|
sender-hardware-address)))
|
||||||
(transition (struct-copy state s
|
(transition (struct-copy state s
|
||||||
[cache cache])
|
[cache cache])
|
||||||
|
@ -105,7 +138,7 @@
|
||||||
sender-hardware-address
|
sender-hardware-address
|
||||||
ptype
|
ptype
|
||||||
2 ;; reply
|
2 ;; reply
|
||||||
(state-hwaddr s)
|
hwaddr
|
||||||
target-protocol-address
|
target-protocol-address
|
||||||
sender-hardware-address
|
sender-hardware-address
|
||||||
sender-protocol-address))
|
sender-protocol-address))
|
||||||
|
@ -115,29 +148,25 @@
|
||||||
(routing-update (compute-gestalt cache))))))
|
(routing-update (compute-gestalt cache))))))
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(define queries-projection (compile-gestalt-projection (arp-query (?!) (?!) ?)))
|
(define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?)))
|
||||||
(define (gestalt->queries g)
|
(define (gestalt->queries g)
|
||||||
(for/set [(e (in-set (matcher-key-set (gestalt-project g 0 1 #f queries-projection))))]
|
(for/set [(e (in-set (gestalt-project/keys g queries-projection)))]
|
||||||
(match-define (list ptype pa) e)
|
(match-define (list ptype pa) e)
|
||||||
(cache-key ptype pa)))
|
(cache-key ptype pa)))
|
||||||
|
|
||||||
(define assertions-projection (compile-gestalt-projection (arp-assertion (?!) (?!))))
|
(define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?)))
|
||||||
(define (gestalt->assertions g)
|
(define (gestalt->assertions g)
|
||||||
(for/set [(e (matcher-key-set (gestalt-project g 0 0 #t assertions-projection)))]
|
(for/set [(e (in-set (gestalt-project/keys g assertions-projection)))]
|
||||||
(match-define (list ptype pa) e)
|
(match-define (list ptype pa) e)
|
||||||
(cache-key ptype pa)))
|
(cache-key ptype pa)))
|
||||||
|
|
||||||
(define (analyze-gestalt g s)
|
(define (analyze-gestalt g s)
|
||||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
|
||||||
(define new-queries (gestalt->queries g))
|
(define new-queries (gestalt->queries g))
|
||||||
(define new-assertions (gestalt->assertions g))
|
(define new-assertions (gestalt->assertions g))
|
||||||
(define added-queries (set-subtract new-queries (state-queries s)))
|
(define added-queries (set-subtract new-queries (state-queries s)))
|
||||||
(define added-assertions (set-subtract new-assertions (state-assertions s)))
|
(define added-assertions (set-subtract new-assertions (state-assertions s)))
|
||||||
(define unanswered-queries (set-subtract added-queries (list->set (hash-keys (state-cache s)))))
|
(define unanswered-queries (set-subtract added-queries (list->set (hash-keys (state-cache s)))))
|
||||||
(define new-s (struct-copy state s
|
(define new-s (struct-copy state s [queries new-queries] [assertions new-assertions]))
|
||||||
[hwaddr hwaddr]
|
|
||||||
[queries new-queries]
|
|
||||||
[assertions (if hwaddr new-assertions (state-assertions s))]))
|
|
||||||
(define (some-asserted-pa ptype)
|
(define (some-asserted-pa ptype)
|
||||||
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
|
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
|
||||||
(set->list new-assertions))
|
(set->list new-assertions))
|
||||||
|
@ -152,9 +181,12 @@
|
||||||
;; (log-info "analyze-gestalt: new-s ~v" new-s)
|
;; (log-info "analyze-gestalt: new-s ~v" new-s)
|
||||||
(transition new-s
|
(transition new-s
|
||||||
(list
|
(list
|
||||||
|
(when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name)))
|
||||||
|
(quit))
|
||||||
(for/list [(q (in-set unanswered-queries))]
|
(for/list [(q (in-set unanswered-queries))]
|
||||||
(define pa (some-asserted-pa (cache-key-protocol q)))
|
(define pa (some-asserted-pa (cache-key-protocol q)))
|
||||||
(log-info "Asking for ~a from ~a"
|
(log-info "~a ARP Asking for ~a from ~a"
|
||||||
|
interface-name
|
||||||
(pretty-bytes (cache-key-address q))
|
(pretty-bytes (cache-key-address q))
|
||||||
(and pa (pretty-bytes pa)))
|
(and pa (pretty-bytes pa)))
|
||||||
(if pa
|
(if pa
|
||||||
|
@ -167,23 +199,23 @@
|
||||||
zero-ethernet-address
|
zero-ethernet-address
|
||||||
(cache-key-address q)))
|
(cache-key-address q)))
|
||||||
'()))
|
'()))
|
||||||
(when hwaddr ;; don't announce until we know our own hwaddr
|
(for/list [(a (in-set added-assertions))]
|
||||||
(for/list [(a (in-set added-assertions))]
|
(log-info "~a ARP Announcing ~a as ~a"
|
||||||
(log-info "Announcing ~a as ~a"
|
interface-name
|
||||||
(pretty-bytes (cache-key-address a))
|
(pretty-bytes (cache-key-address a))
|
||||||
(pretty-bytes hwaddr))
|
(pretty-bytes hwaddr))
|
||||||
(send (build-packet new-s
|
(send (build-packet new-s
|
||||||
broadcast-ethernet-address
|
broadcast-ethernet-address
|
||||||
(cache-key-protocol a)
|
(cache-key-protocol a)
|
||||||
2 ;; reply -- gratuitous announcement
|
2 ;; reply -- gratuitous announcement
|
||||||
hwaddr
|
hwaddr
|
||||||
(cache-key-address a)
|
(cache-key-address a)
|
||||||
hwaddr
|
hwaddr
|
||||||
(cache-key-address a))))))))
|
(cache-key-address a)))))))
|
||||||
|
|
||||||
(list (set-wakeup-alarm)
|
(list (set-wakeup-alarm)
|
||||||
(spawn (lambda (e s)
|
(spawn (lambda (e s)
|
||||||
;; (log-info "ARP: ~v // ~v" e s)
|
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(analyze-gestalt g s)]
|
(analyze-gestalt g s)]
|
||||||
|
@ -196,5 +228,5 @@
|
||||||
(list (set-wakeup-alarm)
|
(list (set-wakeup-alarm)
|
||||||
(routing-update (compute-gestalt (state-cache new-s)))))]
|
(routing-update (compute-gestalt (state-cache new-s)))))]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(state #f (hash) (set) (set))
|
(state (hash) (set) (set))
|
||||||
(compute-gestalt (hash)))))
|
(compute-gestalt (hash)))))
|
||||||
|
|
|
@ -0,0 +1,15 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide (struct-out ethernet-interface)
|
||||||
|
(struct-out host-route)
|
||||||
|
(struct-out net-route))
|
||||||
|
|
||||||
|
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||||
|
|
||||||
|
;; A Route is one of
|
||||||
|
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
|
||||||
|
;; - (net-route NetAddrBytes NetmaskNat IpAddrBytes), a gateway route for a subnet
|
||||||
|
;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
|
||||||
|
;; NetmaskNat in a net-route is a default route.
|
||||||
|
(struct host-route (ip-addr netmask interface-name) #:prefab)
|
||||||
|
(struct net-route (network-addr netmask link) #:prefab)
|
29
ethernet.rkt
29
ethernet.rkt
|
@ -1,14 +1,15 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
;; Ethernet driver
|
;; Ethernet driver
|
||||||
|
|
||||||
(provide (struct-out ethernet-interface)
|
(provide (struct-out ethernet-packet)
|
||||||
(struct-out ethernet-packet)
|
|
||||||
zero-ethernet-address
|
zero-ethernet-address
|
||||||
broadcast-ethernet-address
|
broadcast-ethernet-address
|
||||||
interface-names
|
interface-names
|
||||||
spawn-ethernet-driver
|
spawn-ethernet-driver
|
||||||
|
ethernet-hwaddr-projection
|
||||||
gestalt->hwaddr
|
gestalt->hwaddr
|
||||||
ethernet-packet-pattern)
|
ethernet-packet-pattern
|
||||||
|
lookup-ethernet-hwaddr)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -20,9 +21,9 @@
|
||||||
(require packet-socket)
|
(require packet-socket)
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
|
|
||||||
|
(require "configuration.rkt")
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
|
|
||||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
|
||||||
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
||||||
|
|
||||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||||
|
@ -50,6 +51,7 @@
|
||||||
(spawn (lambda (e h)
|
(spawn (lambda (e h)
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
|
|
||||||
(if (gestalt-empty? g)
|
(if (gestalt-empty? g)
|
||||||
(begin (async-channel-put control-ch 'quit)
|
(begin (async-channel-put control-ch 'quit)
|
||||||
(transition #f (quit)))
|
(transition #f (quit)))
|
||||||
|
@ -118,12 +120,11 @@
|
||||||
(ethertype :: integer bytes 2)
|
(ethertype :: integer bytes 2)
|
||||||
(body :: binary))))
|
(body :: binary))))
|
||||||
|
|
||||||
(define (hwaddr-projection interface-name)
|
(define (ethernet-hwaddr-projection interface-name)
|
||||||
(compile-gestalt-projection (ethernet-packet (ethernet-interface interface-name (?!)) ? ? ? ? ?)))
|
(project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?)))
|
||||||
|
|
||||||
(define (gestalt->hwaddr g interface-name)
|
(define (gestalt->hwaddr g interface-name)
|
||||||
(define hwaddrs
|
(define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name)))
|
||||||
(matcher-key-set/single (gestalt-project g 0 0 #t (hwaddr-projection interface-name))))
|
|
||||||
(case (set-count hwaddrs)
|
(case (set-count hwaddrs)
|
||||||
[(0) #f]
|
[(0) #f]
|
||||||
[(1) (set-first hwaddrs)]
|
[(1) (set-first hwaddrs)]
|
||||||
|
@ -133,3 +134,15 @@
|
||||||
|
|
||||||
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
||||||
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
||||||
|
|
||||||
|
(define (lookup-ethernet-hwaddr base-gestalt interface-name k)
|
||||||
|
(on-gestalt #:timeout-msec 5000
|
||||||
|
#:on-timeout (lambda ()
|
||||||
|
(log-info "Lookup of ethernet interface ~v failed" interface-name)
|
||||||
|
'())
|
||||||
|
(lambda (_g hwaddrss)
|
||||||
|
(and (not (set-empty? hwaddrss))
|
||||||
|
(let ((hwaddr (car (set-first hwaddrss))))
|
||||||
|
(k hwaddr))))
|
||||||
|
base-gestalt
|
||||||
|
(ethernet-hwaddr-projection interface-name)))
|
||||||
|
|
446
ip.rkt
446
ip.rkt
|
@ -1,8 +1,11 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide (struct-out ip-packet)
|
(provide (struct-out ip-packet)
|
||||||
(struct-out ip-interface)
|
|
||||||
ip-address->hostname
|
ip-address->hostname
|
||||||
|
apply-netmask
|
||||||
|
ip-address-in-subnet?
|
||||||
|
gestalt->local-ip-addresses
|
||||||
|
observe-local-ip-addresses-gestalt
|
||||||
broadcast-ip-address
|
broadcast-ip-address
|
||||||
spawn-ip-driver)
|
spawn-ip-driver)
|
||||||
|
|
||||||
|
@ -14,12 +17,208 @@
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
|
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
|
(require "configuration.rkt")
|
||||||
(require "checksum.rkt")
|
(require "checksum.rkt")
|
||||||
(require "ethernet.rkt")
|
(require "ethernet.rkt")
|
||||||
(require "arp.rkt")
|
(require "arp.rkt")
|
||||||
|
|
||||||
(struct ip-packet (source destination protocol options body) #:prefab) ;; TODO: more fields
|
(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
|
||||||
(struct ip-interface (address ethernet) #:prefab)
|
source
|
||||||
|
destination
|
||||||
|
protocol
|
||||||
|
options
|
||||||
|
body)
|
||||||
|
#:prefab) ;; TODO: more fields
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (ip-address->hostname bs)
|
||||||
|
(bit-string-case bs
|
||||||
|
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||||
|
|
||||||
|
(define (apply-netmask addr netmask)
|
||||||
|
(bit-string-case addr
|
||||||
|
([ (n :: integer bytes 4) ]
|
||||||
|
(bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
|
||||||
|
:: integer bytes 4)))))
|
||||||
|
|
||||||
|
(define (ip-address-in-subnet? addr network netmask)
|
||||||
|
(equal? (apply-netmask network netmask)
|
||||||
|
(apply-netmask addr netmask)))
|
||||||
|
|
||||||
|
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||||
|
|
||||||
|
(define local-ip-address-projector (project-pubs (host-route (?!) ? ?)))
|
||||||
|
(define (gestalt->local-ip-addresses g) (gestalt-project/single g local-ip-address-projector))
|
||||||
|
(define observe-local-ip-addresses-gestalt (sub (host-route ? ? ?) #:level 2))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (spawn-ip-driver)
|
||||||
|
(list
|
||||||
|
(spawn-demand-matcher (host-route (?!) (?!) (?!))
|
||||||
|
#:supply-level 1
|
||||||
|
spawn-host-route)
|
||||||
|
(spawn-demand-matcher (net-route (?!) (?!) (?!))
|
||||||
|
#:supply-level 1
|
||||||
|
spawn-net-route)))
|
||||||
|
|
||||||
|
(define (host-route-supply ip-addr netmask interface-name)
|
||||||
|
(sub (host-route ip-addr netmask interface-name) #:level 1))
|
||||||
|
|
||||||
|
(define (net-route-supply network-addr netmask link)
|
||||||
|
(sub (net-route network-addr netmask link) #:level 1))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Local IP route
|
||||||
|
|
||||||
|
(define (spawn-host-route my-address netmask interface-name)
|
||||||
|
(list
|
||||||
|
(let ((network-addr (apply-netmask my-address netmask)))
|
||||||
|
(spawn-normal-ip-route (host-route-supply my-address netmask interface-name)
|
||||||
|
network-addr
|
||||||
|
netmask
|
||||||
|
interface-name))
|
||||||
|
(spawn (lambda (e s)
|
||||||
|
(match e
|
||||||
|
[(routing-update g)
|
||||||
|
(transition s (when (gestalt-empty? g) (quit)))]
|
||||||
|
[(message (ip-packet _ peer-address _ _ _ body) _ _)
|
||||||
|
(bit-string-case body
|
||||||
|
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||||
|
(case type
|
||||||
|
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||||
|
(log-info "Ping of ~a from ~a"
|
||||||
|
(pretty-bytes my-address)
|
||||||
|
(pretty-bytes peer-address))
|
||||||
|
(define reply-data0 (bit-string 0
|
||||||
|
code
|
||||||
|
(0 :: integer bytes 2) ;; TODO
|
||||||
|
(rest :: binary)))
|
||||||
|
(transition s (send (ip-packet #f
|
||||||
|
my-address
|
||||||
|
peer-address
|
||||||
|
PROTOCOL-ICMP
|
||||||
|
#""
|
||||||
|
(ip-checksum 2 reply-data0))))]
|
||||||
|
[else
|
||||||
|
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||||
|
type
|
||||||
|
code
|
||||||
|
checksum
|
||||||
|
(pretty-bytes my-address)
|
||||||
|
(pretty-bytes peer-address)
|
||||||
|
(dump-bytes->string rest))
|
||||||
|
#f]))
|
||||||
|
(else #f))]
|
||||||
|
[_ #f]))
|
||||||
|
(void)
|
||||||
|
(gestalt-union (pub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
|
||||||
|
(sub (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
|
||||||
|
(pub (arp-assertion IPv4-ethertype my-address interface-name))
|
||||||
|
(host-route-supply my-address netmask interface-name)))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Gateway IP 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)]))
|
||||||
|
|
||||||
|
(define (spawn-gateway-ip-route network netmask gateway-addr)
|
||||||
|
(lookup-arp gateway-addr
|
||||||
|
?
|
||||||
|
(net-route-supply network netmask gateway-addr)
|
||||||
|
(lambda (interface gateway-hwaddr)
|
||||||
|
(spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr))))
|
||||||
|
|
||||||
|
(define (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr)
|
||||||
|
(define host-route-projector (project-subs (host-route (?!) ? ?)))
|
||||||
|
(define net-route-projector (project-subs (net-route (?!) (?!) ?)))
|
||||||
|
|
||||||
|
(define (covered-by-some-other-route? addr routes)
|
||||||
|
(for/or ([r (in-set routes)])
|
||||||
|
(match-define (list net msk) r)
|
||||||
|
(and (positive? msk)
|
||||||
|
(ip-address-in-subnet? addr net msk))))
|
||||||
|
|
||||||
|
(spawn (lambda (e routes)
|
||||||
|
(match e
|
||||||
|
[(routing-update g)
|
||||||
|
(define host-ips (gestalt-project/single g host-route-projector))
|
||||||
|
(define net-ips+netmasks (gestalt-project/keys g net-route-projector))
|
||||||
|
(transition (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks)
|
||||||
|
(when (gestalt-empty? (gestalt-filter g (net-route-supply network
|
||||||
|
netmask
|
||||||
|
gateway-addr)))
|
||||||
|
(quit)))]
|
||||||
|
[(message (? ip-packet? p) _ _)
|
||||||
|
(and (not (equal? (ip-packet-source-interface p) (ethernet-interface-name interface)))
|
||||||
|
(not (covered-by-some-other-route? (ip-packet-destination p) routes))
|
||||||
|
(transition routes
|
||||||
|
(send (ethernet-packet interface
|
||||||
|
#f
|
||||||
|
(ethernet-interface-hwaddr interface)
|
||||||
|
gateway-hwaddr
|
||||||
|
IPv4-ethertype
|
||||||
|
(format-ip-packet p)))))]
|
||||||
|
[_ #f]))
|
||||||
|
(set)
|
||||||
|
(gestalt-union (if (zero? netmask)
|
||||||
|
(net-route-supply network netmask gateway-addr)
|
||||||
|
(gestalt-empty))
|
||||||
|
observe-local-ip-addresses-gestalt
|
||||||
|
(sub (ip-packet ? ? ? ? ? ?))
|
||||||
|
(pub (ip-packet ? ? ? ? ? ?)))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Normal IP route
|
||||||
|
|
||||||
|
(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name)
|
||||||
|
(spawn (lambda (e s)
|
||||||
|
(match e
|
||||||
|
[(routing-update g)
|
||||||
|
(log-info "normal-ip route ~v/~v/~v quitting:\n~a"
|
||||||
|
network
|
||||||
|
netmask
|
||||||
|
interface-name
|
||||||
|
(gestalt->pretty-string g))
|
||||||
|
(transition s (when (gestalt-empty? g) (quit)))]
|
||||||
|
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
||||||
|
(define p (parse-ip-packet interface-name body))
|
||||||
|
(and p (transition s (send p)))]
|
||||||
|
[(message (? ip-packet? p) _ _)
|
||||||
|
(define destination (ip-packet-destination p))
|
||||||
|
(and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||||
|
(ip-address-in-subnet? destination network netmask)
|
||||||
|
(transition
|
||||||
|
s
|
||||||
|
(lookup-arp destination
|
||||||
|
(ethernet-interface interface-name ?)
|
||||||
|
(gestalt-empty)
|
||||||
|
(lambda (interface destination-hwaddr)
|
||||||
|
(send (ethernet-packet interface
|
||||||
|
#f
|
||||||
|
(ethernet-interface-hwaddr interface)
|
||||||
|
destination-hwaddr
|
||||||
|
IPv4-ethertype
|
||||||
|
(format-ip-packet p)))))))]
|
||||||
|
[_ #f]))
|
||||||
|
(void)
|
||||||
|
(gestalt-union gestalt-for-supply
|
||||||
|
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||||
|
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
||||||
|
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
||||||
|
(pub (arp-interface interface-name))
|
||||||
|
(sub (ip-packet ? ? ? ? ? ?))
|
||||||
|
(pub (ip-packet ? ? ? ? ? ?)))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define IPv4-ethertype #x0800)
|
(define IPv4-ethertype #x0800)
|
||||||
|
|
||||||
|
@ -32,174 +231,83 @@
|
||||||
|
|
||||||
(define default-ttl 64)
|
(define default-ttl 64)
|
||||||
|
|
||||||
(define (ip-address->hostname bs)
|
(define (parse-ip-packet interface-name body)
|
||||||
(bit-string-case bs
|
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
||||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
(bit-string-case body
|
||||||
|
([ (= IP-VERSION :: bits 4)
|
||||||
|
(header-length :: bits 4)
|
||||||
|
service-type
|
||||||
|
(total-length :: bits 16)
|
||||||
|
(id :: bits 16)
|
||||||
|
(flags :: bits 3)
|
||||||
|
(fragment-offset :: bits 13)
|
||||||
|
ttl
|
||||||
|
protocol
|
||||||
|
(header-checksum :: bits 16) ;; TODO: check checksum
|
||||||
|
(source-ip0 :: binary bits 32)
|
||||||
|
(destination-ip0 :: binary bits 32)
|
||||||
|
(rest :: binary) ]
|
||||||
|
(let ((source-ip (bit-string->bytes source-ip0))
|
||||||
|
(destination-ip (bit-string->bytes destination-ip0))
|
||||||
|
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))))
|
||||||
|
(if (and (>= header-length 5)
|
||||||
|
(>= (bit-string-byte-count body) (* header-length 4)))
|
||||||
|
(bit-string-case rest
|
||||||
|
([ (opts :: binary bytes options-length)
|
||||||
|
(data :: binary) ]
|
||||||
|
(ip-packet interface-name
|
||||||
|
(bit-string->bytes source-ip)
|
||||||
|
(bit-string->bytes destination-ip)
|
||||||
|
protocol
|
||||||
|
(bit-string->bytes opts)
|
||||||
|
(bit-string->bytes data))))
|
||||||
|
#f)))
|
||||||
|
(else #f)))
|
||||||
|
|
||||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
(define (format-ip-packet p)
|
||||||
|
(match-define (ip-packet _ src dst protocol options body) p)
|
||||||
|
|
||||||
(struct state (hwaddr) #:transparent)
|
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||||
|
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
||||||
|
|
||||||
(define (spawn-ip-driver interface-name my-address)
|
(define header0 (bit-string (IP-VERSION :: bits 4)
|
||||||
|
(header-length :: bits 4)
|
||||||
|
0 ;; TODO: service type
|
||||||
|
((+ (* header-length 4) (bit-string-byte-count body))
|
||||||
|
:: bits 16)
|
||||||
|
(0 :: bits 16) ;; TODO: identifier
|
||||||
|
(0 :: bits 3) ;; TODO: flags
|
||||||
|
(0 :: bits 13) ;; TODO: fragments
|
||||||
|
default-ttl
|
||||||
|
protocol
|
||||||
|
(0 :: bits 16)
|
||||||
|
(src :: binary bits 32)
|
||||||
|
(dst :: binary bits 32)
|
||||||
|
(options :: binary)))
|
||||||
|
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
|
||||||
|
|
||||||
(define (analyze-incoming-packet body s)
|
full-packet)
|
||||||
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
|
||||||
(bit-string-case body
|
|
||||||
([ (= IP-VERSION :: bits 4)
|
|
||||||
(header-length :: bits 4)
|
|
||||||
service-type
|
|
||||||
(total-length :: bits 16)
|
|
||||||
(id :: bits 16)
|
|
||||||
(flags :: bits 3)
|
|
||||||
(fragment-offset :: bits 13)
|
|
||||||
ttl
|
|
||||||
protocol
|
|
||||||
(header-checksum :: bits 16) ;; TODO: check checksum
|
|
||||||
(source-ip0 :: binary bits 32)
|
|
||||||
(destination-ip0 :: binary bits 32)
|
|
||||||
(rest :: binary) ]
|
|
||||||
(let ((source-ip (bit-string->bytes source-ip0))
|
|
||||||
(destination-ip (bit-string->bytes destination-ip0))
|
|
||||||
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))))
|
|
||||||
(if (and (not (equal? source-ip my-address))
|
|
||||||
(or (equal? destination-ip my-address)
|
|
||||||
(equal? destination-ip broadcast-ip-address))
|
|
||||||
(>= header-length 5)
|
|
||||||
(>= (bit-string-byte-count body) (* header-length 4)))
|
|
||||||
(bit-string-case rest
|
|
||||||
([ (opts :: binary bytes options-length)
|
|
||||||
(data :: binary) ]
|
|
||||||
(transition s (send (ip-packet (bit-string->bytes source-ip)
|
|
||||||
(bit-string->bytes destination-ip)
|
|
||||||
protocol
|
|
||||||
(bit-string->bytes opts)
|
|
||||||
(bit-string->bytes data))))))
|
|
||||||
#f)))
|
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
(define (analyze-gestalt g s)
|
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
|
||||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
(on-gestalt (lambda (_g arp-results)
|
||||||
(define new-s (struct-copy state s [hwaddr hwaddr]))
|
(if (not arp-results)
|
||||||
(transition new-s (routing-update (compute-gestalt new-s))))
|
(error 'ip "Someone has published a wildcard arp result")
|
||||||
|
(and (not (set-empty? arp-results))
|
||||||
(define (compute-gestalt s)
|
(match (set-first arp-results)
|
||||||
(gestalt-union
|
[(list interface hwaddr)
|
||||||
(pub (arp-assertion IPv4-ethertype my-address))
|
(log-info "ARP lookup yielded ~a on ~a for ~a"
|
||||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
(pretty-bytes hwaddr)
|
||||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
(ethernet-interface-name interface)
|
||||||
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
(ip-address->hostname ipaddr))
|
||||||
(sub (ip-packet my-address ? ? ? ?))
|
(when (> (set-count arp-results) 1)
|
||||||
(pub (ip-packet ? my-address ? ? ?))
|
(log-warning "Ambiguous ARP result for ~a: ~v"
|
||||||
(if (state-hwaddr s)
|
(ip-address->hostname ipaddr)
|
||||||
(pub (ip-interface my-address (ethernet-interface interface-name (state-hwaddr s))))
|
arp-results))
|
||||||
(gestalt-empty))))
|
(k interface hwaddr)]))))
|
||||||
|
base-gestalt
|
||||||
(list
|
(project-pubs (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!)))
|
||||||
(spawn-icmp-driver my-address)
|
#:timeout-msec 5000
|
||||||
(let ((state0 (state #f)))
|
#:on-timeout (lambda ()
|
||||||
(spawn (lambda (e s)
|
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||||
(match e
|
(ip-address->hostname ipaddr))
|
||||||
[(routing-update g)
|
'())))
|
||||||
(analyze-gestalt g s)]
|
|
||||||
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
|
||||||
(analyze-incoming-packet body s)]
|
|
||||||
[(message (ip-packet _ peer-address protocol options body) _ _)
|
|
||||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
|
||||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
|
||||||
(define header0
|
|
||||||
(bit-string (IP-VERSION :: bits 4)
|
|
||||||
(header-length :: bits 4)
|
|
||||||
0 ;; TODO: service type
|
|
||||||
((+ (* header-length 4) (bit-string-byte-count body))
|
|
||||||
:: bits 16)
|
|
||||||
(0 :: bits 16) ;; TODO: identifier
|
|
||||||
(0 :: bits 3) ;; TODO: flags
|
|
||||||
(0 :: bits 13) ;; TODO: fragments
|
|
||||||
default-ttl
|
|
||||||
protocol
|
|
||||||
(0 :: bits 16)
|
|
||||||
(my-address :: binary bits 32)
|
|
||||||
(peer-address :: binary bits 32)
|
|
||||||
(options :: binary)))
|
|
||||||
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary)
|
|
||||||
(body :: binary)))
|
|
||||||
(transition s (spawn-packet-sender interface-name
|
|
||||||
(state-hwaddr s)
|
|
||||||
peer-address
|
|
||||||
full-packet))]
|
|
||||||
[_ #f]))
|
|
||||||
state0
|
|
||||||
(compute-gestalt state0)))))
|
|
||||||
|
|
||||||
(define arp-result-projection (compile-gestalt-projection (arp-query ? ? (?!))))
|
|
||||||
|
|
||||||
(define (spawn-packet-sender interface-name local-hwaddr remote-ip full-packet)
|
|
||||||
(define timer-id (list (gensym 'packet) remote-ip))
|
|
||||||
(list
|
|
||||||
(send (set-timer timer-id 5000 'relative))
|
|
||||||
(spawn (lambda (e s)
|
|
||||||
(match e
|
|
||||||
[(routing-update g)
|
|
||||||
(define all-results
|
|
||||||
(matcher-key-set/single (gestalt-project g 0 0 #t arp-result-projection)))
|
|
||||||
(match all-results
|
|
||||||
[#f (error 'ip "Someone has published a wildcard arp result")]
|
|
||||||
[(? set-empty?) #f] ;; no results yet, keep waiting
|
|
||||||
[_
|
|
||||||
(define remote-hwaddr (set-first all-results))
|
|
||||||
(unless (= 1 (set-count all-results))
|
|
||||||
(log-warning "Ambiguous arp result for ~a: ~v"
|
|
||||||
(ip-address->hostname remote-ip)
|
|
||||||
all-results))
|
|
||||||
(transition s
|
|
||||||
(list
|
|
||||||
(send (ethernet-packet (ethernet-interface interface-name
|
|
||||||
local-hwaddr)
|
|
||||||
#f
|
|
||||||
local-hwaddr
|
|
||||||
remote-hwaddr
|
|
||||||
IPv4-ethertype
|
|
||||||
full-packet))
|
|
||||||
(quit)))])]
|
|
||||||
[(message (timer-expired _ _) _ _)
|
|
||||||
(log-warning "ARP lookup failed, packet dropped")
|
|
||||||
(transition s (quit))]
|
|
||||||
[_ #f]))
|
|
||||||
(void)
|
|
||||||
(gestalt-union (sub (timer-expired timer-id ?))
|
|
||||||
(sub (arp-query IPv4-ethertype remote-ip ?) #:level 1)))))
|
|
||||||
|
|
||||||
(define (spawn-icmp-driver my-address)
|
|
||||||
(spawn (lambda (e s)
|
|
||||||
(match e
|
|
||||||
[(message (ip-packet peer-address _ _ _ body) _ _)
|
|
||||||
(bit-string-case body
|
|
||||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
|
||||||
(case type
|
|
||||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
|
||||||
(log-info "Ping of ~a from ~a"
|
|
||||||
(pretty-bytes my-address)
|
|
||||||
(pretty-bytes peer-address))
|
|
||||||
(define reply-data0 (bit-string 0
|
|
||||||
code
|
|
||||||
(0 :: integer bytes 2) ;; TODO
|
|
||||||
(rest :: binary)))
|
|
||||||
(transition s (send (ip-packet my-address
|
|
||||||
peer-address
|
|
||||||
PROTOCOL-ICMP
|
|
||||||
#""
|
|
||||||
(ip-checksum 2 reply-data0))))]
|
|
||||||
[else
|
|
||||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
|
||||||
type
|
|
||||||
code
|
|
||||||
checksum
|
|
||||||
(pretty-bytes my-address)
|
|
||||||
(pretty-bytes peer-address)
|
|
||||||
(dump-bytes->string rest))
|
|
||||||
#f]))
|
|
||||||
(else #f))]
|
|
||||||
[_ #f]))
|
|
||||||
(void)
|
|
||||||
(gestalt-union (pub (ip-packet my-address ? PROTOCOL-ICMP ? ?))
|
|
||||||
(sub (ip-packet ? my-address PROTOCOL-ICMP ? ?)))))
|
|
||||||
|
|
38
main.rkt
38
main.rkt
|
@ -2,28 +2,35 @@
|
||||||
|
|
||||||
(require minimart/demand-matcher)
|
(require minimart/demand-matcher)
|
||||||
(require minimart/drivers/timer)
|
(require minimart/drivers/timer)
|
||||||
|
(require "configuration.rkt")
|
||||||
(require "ethernet.rkt")
|
(require "ethernet.rkt")
|
||||||
(require "arp.rkt")
|
(require "arp.rkt")
|
||||||
(require "ip.rkt")
|
(require "ip.rkt")
|
||||||
(require "tcp.rkt")
|
(require "tcp.rkt")
|
||||||
|
|
||||||
(define interface "vboxnet0")
|
|
||||||
|
|
||||||
;;(log-events-and-actions? #t)
|
;;(log-events-and-actions? #t)
|
||||||
|
|
||||||
(spawn-timer-driver)
|
(spawn-timer-driver)
|
||||||
(spawn-ethernet-driver)
|
(spawn-ethernet-driver)
|
||||||
(spawn-arp-driver interface)
|
(spawn-arp-driver)
|
||||||
(spawn-ip-driver interface (bytes 192 168 56 222))
|
(spawn-ip-driver)
|
||||||
(spawn-tcp-driver)
|
(spawn-tcp-driver)
|
||||||
|
|
||||||
|
(spawn (lambda (e s) #f)
|
||||||
|
(void)
|
||||||
|
(gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||||
|
(pub (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
|
||||||
|
(pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1)))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(local-require racket/set racket/string)
|
(local-require racket/set racket/string)
|
||||||
|
|
||||||
(define (spawn-session them us)
|
(define (spawn-session them us)
|
||||||
(define user (gensym 'user))
|
(define user (gensym 'user))
|
||||||
(define remote-detector (compile-gestalt-projection (?!)))
|
(define remote-detector (project-pubs #:meta-level 1 (?!)))
|
||||||
(define peer-detector (compile-gestalt-projection `(,(?!) says ,?)))
|
(define peer-detector (project-pubs `(,(?!) says ,?)))
|
||||||
(define (send-to-remote fmt . vs)
|
(define (send-to-remote fmt . vs)
|
||||||
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
|
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
|
||||||
(define (say who fmt . vs)
|
(define (say who fmt . vs)
|
||||||
|
@ -38,12 +45,10 @@
|
||||||
[(message `(,who says ,what) 0 #f)
|
[(message `(,who says ,what) 0 #f)
|
||||||
(transition old-peers (say who "says: ~a" what))]
|
(transition old-peers (say who "says: ~a" what))]
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(define new-peers
|
(define new-peers (gestalt-project/single g peer-detector))
|
||||||
(matcher-key-set/single (gestalt-project g 0 0 #t peer-detector)))
|
|
||||||
(transition
|
(transition
|
||||||
new-peers
|
new-peers
|
||||||
(list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector))
|
(list (when (matcher-empty? (gestalt-project g remote-detector)) (quit))
|
||||||
(quit))
|
|
||||||
(for/list [(who (set-subtract new-peers old-peers))]
|
(for/list [(who (set-subtract new-peers old-peers))]
|
||||||
(say who "arrived."))
|
(say who "arrived."))
|
||||||
(for/list [(who (set-subtract old-peers new-peers))]
|
(for/list [(who (set-subtract old-peers new-peers))]
|
||||||
|
@ -68,15 +73,18 @@
|
||||||
(local-require racket/pretty)
|
(local-require racket/pretty)
|
||||||
(match e
|
(match e
|
||||||
[(message m _ _)
|
[(message m _ _)
|
||||||
(pretty-write `(MAIN ,m))]
|
;; (pretty-write `(MAIN ,m))
|
||||||
|
(void)]
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(printf "MAIN gestalt:\n")
|
;; (printf "MAIN gestalt:\n")
|
||||||
(pretty-print-gestalt g)]
|
;; (pretty-print-gestalt g)
|
||||||
|
(void)]
|
||||||
[_ (void)])
|
[_ (void)])
|
||||||
(flush-output)
|
(flush-output)
|
||||||
#f)
|
#f)
|
||||||
(void)
|
(void)
|
||||||
(gestalt-union
|
(gestalt-union
|
||||||
;;(sub ? #:level 5)
|
(sub ? #:level 5)
|
||||||
(sub (tcp-channel ? ? ?) #:level 5)
|
(pub ? #:level 5)
|
||||||
|
;;(sub (tcp-channel ? ? ?) #:level 5)
|
||||||
))
|
))
|
||||||
|
|
70
tcp.rkt
70
tcp.rkt
|
@ -70,10 +70,8 @@
|
||||||
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
||||||
|
|
||||||
(define (spawn-port-allocator)
|
(define (spawn-port-allocator)
|
||||||
(define port-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))
|
(define port-projection
|
||||||
(define port-compproj (compile-gestalt-projection port-projection))
|
(project-subs (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?)))
|
||||||
(define ip-projection (ip-interface (?!) ?))
|
|
||||||
(define ip-compproj (compile-gestalt-projection ip-projection))
|
|
||||||
|
|
||||||
;; TODO: Choose a sensible IP address for the outbound connection.
|
;; TODO: Choose a sensible IP address for the outbound connection.
|
||||||
;; We don't have enough information to do this well at the moment,
|
;; We don't have enough information to do this well at the moment,
|
||||||
|
@ -90,18 +88,17 @@
|
||||||
(spawn (lambda (e s)
|
(spawn (lambda (e s)
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-compproj)))
|
(define local-ips (gestalt->local-ip-addresses g))
|
||||||
(define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-compproj)))
|
(define extracted-ports (gestalt-project/keys g port-projection))
|
||||||
(if (or (not extracted-ports) (not extracted-ips))
|
(if (or (not extracted-ports) (not local-ips))
|
||||||
(error 'tcp "Someone has published a wildcard TCP address or IP interface")
|
(error 'tcp "Someone has published a wildcard TCP address or IP interface")
|
||||||
(transition (let ((local-ips (for/set [(e (in-set extracted-ips))] (car e))))
|
(transition (port-allocator-state
|
||||||
(port-allocator-state
|
(for/fold [(s (set))] [(e (in-set extracted-ports))]
|
||||||
(for/fold [(s (set))] [(e (in-set extracted-ports))]
|
(match-define (list si sp di dp) e)
|
||||||
(match-define (list si sp di dp) e)
|
(let* ((s (if (set-member? local-ips si) (set-add s sp) s))
|
||||||
(let* ((s (if (set-member? local-ips si) (set-add s sp) s))
|
(s (if (set-member? local-ips di) (set-add s dp) s)))
|
||||||
(s (if (set-member? local-ips di) (set-add s dp) s)))
|
s))
|
||||||
s))
|
local-ips)
|
||||||
local-ips))
|
|
||||||
'()))]
|
'()))]
|
||||||
[(message (tcp-port-allocation-request local-addr remote-addr) _ _)
|
[(message (tcp-port-allocation-request local-addr remote-addr) _ _)
|
||||||
(define currently-used-ports (port-allocator-state-used-ports s))
|
(define currently-used-ports (port-allocator-state-used-ports s))
|
||||||
|
@ -117,8 +114,8 @@
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(port-allocator-state (set) (set))
|
(port-allocator-state (set) (set))
|
||||||
(gestalt-union (sub (tcp-port-allocation-request ? ?))
|
(gestalt-union (sub (tcp-port-allocation-request ? ?))
|
||||||
(sub (projection->pattern ip-projection) #:level 1)
|
observe-local-ip-addresses-gestalt
|
||||||
(pub (projection->pattern port-projection) #:level 1))))
|
(pub (tcp-channel (tcp-address ? ?) (tcp-address ? ?) ?) #:level 1))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Relay between kernel-level and user-level
|
;; Relay between kernel-level and user-level
|
||||||
|
@ -159,17 +156,12 @@
|
||||||
|
|
||||||
(define PROTOCOL-TCP 6)
|
(define PROTOCOL-TCP 6)
|
||||||
|
|
||||||
(struct codec-state (active-state-vectors) #:transparent)
|
(struct codec-state (local-ips active-state-vectors) #:transparent)
|
||||||
|
|
||||||
(define (spawn-kernel-tcp-driver)
|
(define (spawn-kernel-tcp-driver)
|
||||||
|
|
||||||
(define (flip-statevec statevec)
|
|
||||||
(match-define (list si sp di dp) statevec)
|
|
||||||
(list di dp si sp))
|
|
||||||
|
|
||||||
(define (state-vector-active? statevec s)
|
(define (state-vector-active? statevec s)
|
||||||
(or (set-member? (codec-state-active-state-vectors s) statevec)
|
(set-member? (codec-state-active-state-vectors s) statevec))
|
||||||
(set-member? (codec-state-active-state-vectors s) (flip-statevec statevec))))
|
|
||||||
|
|
||||||
(define (analyze-incoming-packet src-ip dst-ip body s)
|
(define (analyze-incoming-packet src-ip dst-ip body s)
|
||||||
(bit-string-case body
|
(bit-string-case body
|
||||||
|
@ -237,14 +229,15 @@
|
||||||
(else #f))))
|
(else #f))))
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(define statevec-projection
|
(define statevec-projection (project-subs (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
|
||||||
(compile-gestalt-projection
|
|
||||||
(tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
|
|
||||||
|
|
||||||
(define (analyze-gestalt g s)
|
(define (analyze-gestalt g s)
|
||||||
(define statevecs (matcher-key-set (gestalt-project g 0 0 #f statevec-projection)))
|
(define local-ips (gestalt->local-ip-addresses g))
|
||||||
(log-info "gestalt yielded statevecs ~v" statevecs)
|
(define statevecs (gestalt-project/keys g statevec-projection))
|
||||||
(transition (struct-copy codec-state s [active-state-vectors statevecs]) '()))
|
(log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips)
|
||||||
|
(transition (struct-copy codec-state s
|
||||||
|
[local-ips local-ips]
|
||||||
|
[active-state-vectors statevecs]) '()))
|
||||||
|
|
||||||
(define (deliver-outbound-packet p s)
|
(define (deliver-outbound-packet p s)
|
||||||
(match-define (tcp-packet #f
|
(match-define (tcp-packet #f
|
||||||
|
@ -294,26 +287,29 @@
|
||||||
0
|
0
|
||||||
PROTOCOL-TCP
|
PROTOCOL-TCP
|
||||||
((bit-string-byte-count payload) :: integer bytes 2)))
|
((bit-string-byte-count payload) :: integer bytes 2)))
|
||||||
(transition s (send (ip-packet src-ip dst-ip PROTOCOL-TCP #""
|
(transition s (send (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||||
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
||||||
|
|
||||||
(spawn (lambda (e s)
|
(spawn (lambda (e s)
|
||||||
|
(log-info "xxxxx TCP ~v" e)
|
||||||
(match e
|
(match e
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(analyze-gestalt g s)]
|
(analyze-gestalt g s)]
|
||||||
[(message (ip-packet src dst _ _ body) _ _)
|
[(message (ip-packet source-if src dst _ _ body) _ _)
|
||||||
|
#:when (and source-if ;; source-if == #f iff packet originates locally
|
||||||
|
(set-member? (codec-state-local-ips s) dst))
|
||||||
(analyze-incoming-packet src dst body s)]
|
(analyze-incoming-packet src dst body s)]
|
||||||
[(message (? tcp-packet? p) _ _)
|
[(message (? tcp-packet? p) _ _)
|
||||||
#:when (not (tcp-packet-from-wire? p))
|
#:when (not (tcp-packet-from-wire? p))
|
||||||
(deliver-outbound-packet p s)]
|
(deliver-outbound-packet p s)]
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
(codec-state (set))
|
(codec-state (set) (set))
|
||||||
(gestalt-union (pub (ip-packet ? ? PROTOCOL-TCP ? ?))
|
(gestalt-union (pub (ip-packet #f ? ? PROTOCOL-TCP ? ?))
|
||||||
(sub (ip-packet ? ? PROTOCOL-TCP ? ?))
|
(sub (ip-packet ? ? ? PROTOCOL-TCP ? ?))
|
||||||
(sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?))
|
(sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?))
|
||||||
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?))
|
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?))
|
||||||
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)
|
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1)
|
||||||
#:level 1))))
|
observe-local-ip-addresses-gestalt)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Per-connection state vector process
|
;; Per-connection state vector process
|
||||||
|
|
Loading…
Reference in New Issue