Initial work towards migration from minimart to prospect-monolithic

This commit is contained in:
Tony Garnock-Jones 2016-01-23 20:11:59 -05:00
parent 543073fd2e
commit ca5bf47adf
10 changed files with 279 additions and 325 deletions

148
arp.rkt
View File

@ -9,9 +9,9 @@
(require racket/set)
(require racket/match)
(require minimart)
(require minimart/drivers/timer)
(require minimart/demand-matcher)
(require prospect-monolithic)
(require prospect-monolithic/drivers/timer)
(require prospect-monolithic/demand-matcher)
(require bitsyntax)
(require "dump-bytes.rkt")
@ -22,6 +22,8 @@
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
(struct arp-interface (interface-name) #:prefab)
(struct arp-interface-up (interface-name) #:prefab)
(define ARP-ethertype #x0806)
(define cache-entry-lifetime-msec (* 14400 1000))
(define wakeup-interval 5000)
@ -30,7 +32,7 @@
(define (spawn-arp-driver)
(spawn-demand-matcher (arp-interface (?!))
#:supply-level 1
(arp-interface-up (?!))
spawn-arp-interface))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -42,13 +44,10 @@
(define (spawn-arp-interface interface-name)
(log-info "spawn-arp-interface ~v" interface-name)
(lookup-ethernet-hwaddr (gestalt-for-supply interface-name)
(lookup-ethernet-hwaddr (assertion (arp-interface-up 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))
@ -62,21 +61,20 @@
(define timer-key (list 'arp interface-name))
(define (set-wakeup-alarm)
(send (set-timer timer-key wakeup-interval 'relative)))
(message (set-timer timer-key wakeup-interval 'relative)))
(define (compute-gestalt cache)
(gestalt-union (sub (timer-expired timer-key ?))
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype))
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype) #:level 1)
(pub (ethernet-packet-pattern interface-name #f ARP-ethertype))
(gestalt-for-supply interface-name)
(sub (arp-assertion ? ? interface-name) #:level 1)
(pub (arp-query ? ? interface ?) #:level 2)
(for/fold [(g (gestalt-empty))] [((k v) (in-hash cache))]
(gestalt-union g (pub (arp-query (cache-key-protocol k)
(cache-key-address k)
(cache-value-interface v)
(cache-value-address v)))))))
(scn/union (subscription (timer-expired timer-key ?))
(subscription interface)
(subscription (ethernet-packet-pattern interface-name #t ARP-ethertype))
(assertion (arp-interface-up interface-name))
(subscription (arp-assertion ? ? interface-name))
(subscription (observe (arp-query ? ? interface ?)))
(for/fold [(g (trie-empty))] [((k v) (in-hash cache))]
(assertion-set-union g (assertion (arp-query (cache-key-protocol k)
(cache-key-address k)
(cache-value-interface v)
(cache-value-address v)))))))
(define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
(define hlen (bytes-length target-ha))
@ -135,40 +133,39 @@
cache-entry-lifetime-msec)
interface
sender-hardware-address)))
(transition (struct-copy state s
[cache cache])
(list
(case oper
[(1) ;; request
(if (set-member? (state-assertions s)
(cache-key ptype target-protocol-address))
(begin
(log-info "~a ARP answering request for ~a/~a"
interface-name
ptype
(pretty-bytes target-protocol-address))
(send (build-packet sender-hardware-address
ptype
2 ;; reply
hwaddr
target-protocol-address
sender-hardware-address
sender-protocol-address)))
'())]
[(2) '()] ;; reply
[else '()])
(routing-update (compute-gestalt cache))))))
(transition (struct-copy state s [cache cache])
(list
(case oper
[(1) ;; request
(if (set-member? (state-assertions s)
(cache-key ptype target-protocol-address))
(begin
(log-info "~a ARP answering request for ~a/~a"
interface-name
ptype
(pretty-bytes target-protocol-address))
(message (build-packet sender-hardware-address
ptype
2 ;; reply
hwaddr
target-protocol-address
sender-hardware-address
sender-protocol-address)))
'())]
[(2) '()] ;; reply
[else '()])
(compute-gestalt cache)))))
(else #f)))
(define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?)))
(define queries-projection (compile-projection (observe (arp-query (?!) (?!) ? ?))))
(define (gestalt->queries g)
(for/set [(e (in-set (gestalt-project/keys g queries-projection)))]
(for/set [(e (in-set (trie-project/set g queries-projection)))]
(match-define (list ptype pa) e)
(cache-key ptype pa)))
(define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?)))
(define assertions-projection (compile-projection (arp-assertion (?!) (?!) ?)))
(define (gestalt->assertions g)
(for/set [(e (in-set (gestalt-project/keys g assertions-projection)))]
(for/set [(e (in-set (trie-project/set g assertions-projection)))]
(match-define (list ptype pa) e)
(cache-key ptype pa)))
@ -176,22 +173,22 @@
(define new-assertions (gestalt->assertions g))
(define added-assertions (set-subtract new-assertions (state-assertions s)))
(define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions]))
(transition new-s
(list
(when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name)))
(quit))
(for/list [(a (in-set added-assertions))]
(log-info "~a ARP Announcing ~a as ~a"
interface-name
(pretty-bytes (cache-key-address a))
(pretty-bytes hwaddr))
(send (build-packet broadcast-ethernet-address
(cache-key-protocol a)
2 ;; reply -- gratuitous announcement
hwaddr
(cache-key-address a)
hwaddr
(cache-key-address a)))))))
(if (trie-empty? (project-assertions g (arp-interface interface-name)))
(quit)
(transition new-s
(list
(for/list [(a (in-set added-assertions))]
(log-info "~a ARP Announcing ~a as ~a"
interface-name
(pretty-bytes (cache-key-address a))
(pretty-bytes hwaddr))
(message (build-packet broadcast-ethernet-address
(cache-key-protocol a)
2 ;; reply -- gratuitous announcement
hwaddr
(cache-key-address a)
hwaddr
(cache-key-address a))))))))
(define (send-questions s)
(define unanswered-queries
@ -209,30 +206,29 @@
(pretty-bytes (cache-key-address q))
(and pa (pretty-bytes pa)))
(when pa
(send (build-packet broadcast-ethernet-address
(cache-key-protocol q)
1 ;; request
hwaddr
pa
zero-ethernet-address
(cache-key-address q)))))))
(message (build-packet broadcast-ethernet-address
(cache-key-protocol q)
1 ;; request
hwaddr
pa
zero-ethernet-address
(cache-key-address q)))))))
(list (set-wakeup-alarm)
(spawn (lambda (e s)
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
(match e
[(routing-update g)
[(scn g)
(sequence-transitions (analyze-gestalt g s)
send-questions)]
[(message (ethernet-packet _ _ source destination _ body) _ _)
[(message (ethernet-packet _ _ source destination _ body))
(analyze-incoming-packet source destination body s)]
[(message (timer-expired _ _) _ _)
[(message (timer-expired _ _))
(define new-s (struct-copy state s
[cache (expire-cache (state-cache s))]))
(define new-g (compute-gestalt (state-cache new-s)))
(sequence-transitions (transition new-s
(list (set-wakeup-alarm)
(routing-update new-g)))
(compute-gestalt (state-cache new-s))))
send-questions)]
[_ #f]))
(state (hash) (set) (set))

View File

@ -3,7 +3,9 @@
(provide (struct-out ethernet-interface)
(struct-out host-route)
(struct-out gateway-route)
(struct-out net-route))
(struct-out net-route)
(struct-out route-up))
(struct ethernet-interface (name hwaddr) #:prefab)
@ -15,3 +17,5 @@
(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 route-up (route) #:prefab) ;; assertion: the given Route is running

View File

@ -2,7 +2,7 @@
;; Demonstration stack configuration for various hosts.
(require racket/match)
(require minimart)
(require prospect-monolithic)
(require (only-in mzlib/os gethostname))
(require "configuration.rkt")
@ -13,14 +13,14 @@
(void)
(match (gethostname)
["skip"
(gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
(pub (host-route (bytes 192 168 1 222) 24 "en0")))]
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
(assertion (host-route (bytes 192 168 1 222) 24 "en0")))]
[(or "hop" "walk")
(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")))]
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
(assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))]
["stockholm.ccs.neu.edu"
(gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0"))
(pub (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
(pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
(scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0"))
(assertion (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
(assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
[else
(error 'spawn-demo-config "No setup for hostname ~a" (gethostname))])))

View File

@ -6,8 +6,6 @@
broadcast-ethernet-address
interface-names
spawn-ethernet-driver
ethernet-hwaddr-projection
gestalt->hwaddr
ethernet-packet-pattern
lookup-ethernet-hwaddr)
@ -15,8 +13,8 @@
(require racket/match)
(require racket/async-channel)
(require minimart)
(require minimart/demand-matcher)
(require prospect-monolithic)
(require prospect-monolithic/demand-matcher)
(require packet-socket)
(require bitsyntax)
@ -33,8 +31,8 @@
(log-info "Device names: ~a" interface-names)
(define (spawn-ethernet-driver)
(spawn-demand-matcher (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)
#:demand-is-subscription? #t
(spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?))
(ethernet-interface (?!) ?)
spawn-interface-tap))
(define (spawn-interface-tap interface-name)
@ -50,22 +48,21 @@
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
(spawn (lambda (e h)
(match e
[(routing-update g)
(if (gestalt-empty? g)
[(scn g)
(if (trie-empty? g)
(begin (async-channel-put control-ch 'quit)
(transition #f (quit)))
(quit))
(begin (async-channel-put control-ch 'unblock)
#f))]
[(message (? ethernet-packet? p) 1 #f) ;; from metalevel 1
[(message (at-meta (? ethernet-packet? p)))
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
;; (ethernet-interface-name (ethernet-packet-interface p))
;; (pretty-bytes (ethernet-packet-source p))
;; (pretty-bytes (ethernet-packet-destination p))
;; (number->string (ethernet-packet-ethertype p) 16))
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
(transition h (send p))]
[(message (? ethernet-packet? p) 0 #f) ;; from metalevel 0
(transition h (message p))]
[(message (? ethernet-packet? p))
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
;; (ethernet-interface-name (ethernet-packet-interface p))
;; (pretty-bytes (ethernet-packet-source p))
@ -76,10 +73,10 @@
#f]
[_ #f]))
h
(gestalt-union (pub (ethernet-packet interface #t ? ? ? ?))
(pub (ethernet-packet interface #t ? ? ? ?) #:level 1)
(sub (ethernet-packet interface #f ? ? ? ?))
(sub (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))]))
(scn/union (assertion interface)
(subscription (ethernet-packet interface #f ? ? ? ?))
(subscription (observe (ethernet-packet interface #t ? ? ? ?)))
(subscription (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))]))
(define (interface-packet-read-loop interface h control-ch)
(define (blocked)
@ -120,29 +117,17 @@
(ethertype :: integer bytes 2)
(body :: binary))))
(define (ethernet-hwaddr-projection interface-name)
(project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?)))
(define (gestalt->hwaddr g interface-name)
(define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name)))
(case (set-count hwaddrs)
[(0) #f]
[(1) (set-first hwaddrs)]
[else
(log-warning "gestalt->hwaddr: multiple addresses for interface ~a: ~v" interface-name hwaddrs)
(set-first hwaddrs)]))
(define (ethernet-packet-pattern 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)))
(define (lookup-ethernet-hwaddr base-interests interface-name k)
(on-claim #: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-interests
(ethernet-interface interface-name (?!))))

View File

@ -1,7 +1,7 @@
#lang minimart
#lang prospect-monolithic
(require minimart/demand-matcher)
(require minimart/drivers/timer)
(require prospect-monolithic/demand-matcher)
(require prospect-monolithic/drivers/timer)
(require "demo-config.rkt")
(require "ethernet.rkt")
(require "arp.rkt")

210
ip.rkt
View File

@ -13,9 +13,9 @@
(require racket/set)
(require racket/match)
(require (only-in racket/string string-split))
(require minimart)
(require minimart/drivers/timer)
(require minimart/demand-matcher)
(require prospect-monolithic)
(require prospect-monolithic/drivers/timer)
(require prospect-monolithic/demand-matcher)
(require bitsyntax)
(require "dump-bytes.rkt")
@ -53,48 +53,38 @@
(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 local-ip-address-projector (compile-projection (host-route (?!) ? ?)))
(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector))
(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-ip-driver)
(list
(spawn-demand-matcher (host-route (?!) (?!) (?!))
#:supply-level 1
(route-up (host-route (?!) (?!) (?!)))
spawn-host-route)
(spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!))
#:supply-level 1
(route-up (gateway-route (?!) (?!) (?!) (?!)))
spawn-gateway-route)
(spawn-demand-matcher (net-route (?!) (?!) (?!))
#:supply-level 1
(route-up (net-route (?!) (?!) (?!)))
spawn-net-route)))
(define (host-route-supply ip-addr netmask interface-name)
(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)
(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)
(spawn-normal-ip-route (host-route 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) _ _)
[(scn (? trie-empty?)) (quit)]
[(message (ip-packet _ peer-address _ _ _ body))
(bit-string-case body
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
(case type
@ -106,12 +96,12 @@
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))))]
(transition s (message (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
@ -124,10 +114,10 @@
(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)))))
(scn/union (advertisement (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
(subscription (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
(assertion (arp-assertion IPv4-ethertype my-address interface-name))
(subscription (host-route my-address netmask interface-name))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gateway IP route
@ -135,15 +125,16 @@
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
(define (spawn-gateway-route network netmask gateway-addr interface-name)
(define gestalt-for-supply (gateway-route-supply network netmask gateway-addr interface-name))
(define the-route (gateway-route network netmask gateway-addr interface-name))
(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 gateway-arp-projector (project-pubs (arp-query IPv4-ethertype
gateway-addr
(?! (ethernet-interface interface-name ?))
(?!))))
(define host-route-projector (compile-projection (host-route (?!) ? ?)))
(define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?)))
(define net-route-projector (compile-projection (net-route (?!) (?!) ?)))
(define gateway-arp-projector (compile-projection
(arp-query IPv4-ethertype
gateway-addr
(?! (ethernet-interface interface-name ?))
(?!))))
(define (covered-by-some-other-route? addr routes)
(for/or ([r (in-set routes)])
@ -153,25 +144,27 @@
(spawn (lambda (e s)
(match e
[(routing-update g)
(define host-ips (gestalt-project/single g host-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)))
[(scn g)
(define host-ips (trie-project/set/single g host-route-projector))
(define gw-nets+netmasks (trie-project/set g gateway-route-projector))
(define net-nets+netmasks (trie-project/set g net-route-projector))
(define gw-ip+hwaddr (let ((vs (trie-project/set g gateway-arp-projector)))
(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
(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 (cadr gw-ip+hwaddr)))
(when (gestalt-empty? (gestalt-filter g gestalt-for-supply)) (quit)))]
[(message (? ip-packet? p) _ _)
(if (trie-empty? (project-assertions g (?! the-route)))
(quit)
(transition (gateway-route-state
(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 (cadr gw-ip+hwaddr)))
'()))]
[(message (? ip-packet? p))
(define gw-if (gateway-route-state-gateway-interface s))
(when (not gw-if)
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
@ -181,42 +174,39 @@
(not (covered-by-some-other-route? (ip-packet-destination p)
(gateway-route-state-routes s)))
(transition s
(send (ethernet-packet gw-if
#f
(ethernet-interface-hwaddr gw-if)
(gateway-route-state-gateway-hwaddr s)
IPv4-ethertype
(format-ip-packet p)))))]
(message (ethernet-packet gw-if
#f
(ethernet-interface-hwaddr gw-if)
(gateway-route-state-gateway-hwaddr s)
IPv4-ethertype
(format-ip-packet p)))))]
[_ #f]))
(gateway-route-state (set) #f #f)
(gestalt-union gestalt-for-supply
(sub (ip-packet ? ? ? ? ? ?))
(pub (ip-packet ? ? ? ? ? ?))
observe-local-ip-addresses-gestalt
(sub (net-route ? ? ?) #:level 2)
(sub (gateway-route ? ? ? ?) #:level 2)
(projection->gestalt gateway-arp-projector))))
(scn/union (subscription the-route)
(assertion (route-up the-route))
(subscription (ip-packet ? ? ? ? ? ?))
observe-local-ip-addresses-gestalt
(subscription (net-route ? ? ?))
(subscription (gateway-route ? ? ? ?))
(subscription (projection->pattern 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))
(spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normal IP route
(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name)
(define (spawn-normal-ip-route the-route network netmask interface-name)
(spawn (lambda (e s)
(match e
[(routing-update g)
(transition s (when (gestalt-empty? g) (quit)))]
[(message (ethernet-packet _ _ _ _ _ body) _ _)
[(scn (? trie-empty?)) (quit)]
[(message (ethernet-packet _ _ _ _ _ body))
(define p (parse-ip-packet interface-name body))
(and p (transition s (send p)))]
[(message (? ip-packet? p) _ _)
(and p (transition s (message 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)
@ -224,23 +214,21 @@
s
(lookup-arp destination
(ethernet-interface interface-name ?)
(gestalt-empty)
(trie-empty)
(lambda (interface destination-hwaddr)
(send (ethernet-packet interface
#f
(ethernet-interface-hwaddr interface)
destination-hwaddr
IPv4-ethertype
(format-ip-packet p)))))))]
(message (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 ? ? ? ? ? ?)))))
(scn/union (subscription the-route)
(assertion (route-up the-route))
(subscription (ethernet-packet-pattern interface-name #t IPv4-ethertype))
(assertion (arp-interface interface-name))
(subscription (ip-packet ? ? ? ? ? ?)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -313,25 +301,25 @@
full-packet)
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
(on-gestalt (lambda (_g arp-results)
(if (not arp-results)
(error 'ip "Someone has published a wildcard arp result")
(and (not (set-empty? arp-results))
(match (set-first arp-results)
[(list interface hwaddr)
(log-info "ARP lookup yielded ~a on ~a for ~a"
(pretty-bytes hwaddr)
(ethernet-interface-name interface)
(ip-address->hostname ipaddr))
(when (> (set-count arp-results) 1)
(log-warning "Ambiguous ARP result for ~a: ~v"
(ip-address->hostname ipaddr)
arp-results))
(k interface hwaddr)]))))
base-gestalt
(project-pubs (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!)))
#:timeout-msec 5000
#:on-timeout (lambda ()
(log-warning "ARP lookup of ~a failed, packet dropped"
(ip-address->hostname ipaddr))
'())))
(on-claim (lambda (_g arp-results)
(if (not arp-results)
(error 'ip "Someone has published a wildcard arp result")
(and (not (set-empty? arp-results))
(match (set-first arp-results)
[(list interface hwaddr)
(log-info "ARP lookup yielded ~a on ~a for ~a"
(pretty-bytes hwaddr)
(ethernet-interface-name interface)
(ip-address->hostname ipaddr))
(when (> (set-count arp-results) 1)
(log-warning "Ambiguous ARP result for ~a: ~v"
(ip-address->hostname ipaddr)
arp-results))
(k interface hwaddr)]))))
base-gestalt
(arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))
#:timeout-msec 5000
#:on-timeout (lambda ()
(log-warning "ARP lookup of ~a failed, packet dropped"
(ip-address->hostname ipaddr))
'())))

141
main.rkt
View File

@ -1,13 +1,13 @@
#lang minimart
#lang prospect-monolithic
(require minimart/demand-matcher)
(require minimart/drivers/timer)
(require prospect-monolithic/demand-matcher)
(require prospect-monolithic/drivers/timer)
(require "demo-config.rkt")
(require "ethernet.rkt")
(require "arp.rkt")
(require "ip.rkt")
(require "tcp.rkt")
(require "udp.rkt")
;; (require "tcp.rkt")
;; (require "udp.rkt")
;;(log-events-and-actions? #t)
@ -15,94 +15,95 @@
(spawn-ethernet-driver)
(spawn-arp-driver)
(spawn-ip-driver)
(spawn-tcp-driver)
(spawn-udp-driver)
;; (spawn-tcp-driver)
;; (spawn-udp-driver)
(spawn-demo-config)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
#;(let ()
(local-require racket/set racket/string)
(define (spawn-session them us)
(define user (gensym 'user))
(define remote-detector (project-pubs #:meta-level 1 (?!)))
(define peer-detector (project-pubs `(,(?!) says ,?)))
(define remote-detector (compile-projection (at-meta (?!))))
(define peer-detector (compile-projection (advertise `(,(?!) says ,?))))
(define (send-to-remote fmt . vs)
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
(message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define (say who fmt . vs)
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(list (send-to-remote "Welcome, ~a.\n" user)
(spawn (lambda (e old-peers)
(log-info "~a: ~v --> ~v" user e old-peers)
(match e
[(message (tcp-channel _ _ bs) 1 #f)
(transition old-peers
(send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))]
[(message `(,who says ,what) 0 #f)
(transition old-peers (say who "says: ~a" what))]
[(routing-update g)
(define new-peers (gestalt-project/single g peer-detector))
(transition
new-peers
(list (when (matcher-empty? (gestalt-project g remote-detector)) (quit))
(for/list [(who (set-subtract new-peers old-peers))]
(say who "arrived."))
(for/list [(who (set-subtract old-peers new-peers))]
(say who "departed."))))]
[#f #f]))
(set)
(gestalt-union (sub `(,? says ,?))
(sub `(,? says ,?) #:level 1)
(pub `(,user says ,?))
(sub (tcp-channel them us ?) #:meta-level 1)
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
(pub (tcp-channel us them ?) #:meta-level 1)))))
(spawn-world
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 6667)) ?)
#:meta-level 1
spawn-session))
(spawn
(lambda (e peers)
(match e
[(message (at-meta (tcp-channel _ _ bs)))
(transition peers (message `(,user says ,(string-trim (bytes->string/utf-8 bs)))))]
[(message `(,who says ,what))
(transition peers (say who "says: ~a" what))]
[(scn assertions)
(if (trie-empty? (trie-project assertions remote-detector))
(quit (send-to-remote "Goodbye!\n"))
(let ((new-peers (trie-project/set/single assertions peer-detector)))
(define arrived (set-subtract new-peers peers))
(define departed (set-subtract peers new-peers))
(transition new-peers
(list (for/list [(who arrived)] (say who "arrived."))
(for/list [(who departed)] (say who "departed."))))))]
[#f #f]))
(set)
(scn/union
(subscription `(,? says ,?)) ;; read actual chat messages
(subscription (advertise `(,? says ,?))) ;; observe peer presence
(advertisement `(,user says ,?)) ;; advertise our presence
(subscription (tcp-channel them us ?) #:meta-level 1) ;; read from remote client
(subscription (advertise (tcp-channel them us ?)) #:meta-level 1) ;; monitor remote client
(advertisement (tcp-channel us them ?) #:meta-level 1) ;; we will write to remote client
))))
(spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
(observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
#:meta-level 1
spawn-session)
)
(let ()
#;(let ()
(spawn (lambda (e s)
(match e
[(message (udp-packet src dst body) _ _)
[(message (udp-packet src dst body))
(log-info "Got packet from ~v: ~v" src body)
(transition s (send (udp-packet dst
src
(string->bytes/utf-8 (format "You said: ~a" body)))))]
(transition s (message
(udp-packet dst
src
(string->bytes/utf-8 (format "You said: ~a" body)))))]
[_ #f]))
(void)
(gestalt-union (sub (udp-packet ? (udp-listener 6667) ?)))))
(scn (subscription (udp-packet ? (udp-listener 6667) ?)))))
(let ()
#;(let ()
(define (spawn-session them us)
(list
(send 'bump)
(spawn (lambda (e s)
(match e
[(message `(counter ,counter) _ _)
[(message `(counter ,counter))
(define response
(string->bytes/utf-8
(format (string-append
"HTTP/1.0 200 OK\r\n\r\n"
"<h1>Hello world from minimart-netstack!</h1>\n"
"<p>This is running on minimart's own\n"
"<a href='https://github.com/tonyg/minimart-netstack/'>\n"
"<h1>Hello world from prospect-monolithic-netstack!</h1>\n"
"<p>This is running on prospect-monolithic's own\n"
"<a href='https://github.com/tonyg/prospect-netstack/'>\n"
"TCP/IP stack</a>.</p>\n"
"<p>There have been ~a requests prior to this one.</p>")
counter)))
(transition s (list (send #:meta-level 1 (tcp-channel us them response))
(transition s (list (message #:meta-level 1 (tcp-channel us them response))
(quit)))]
[_ #f]))
(void)
(gestalt-union (sub `(counter ,?))
(sub (tcp-channel them us ?) #:meta-level 1)
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
(pub (tcp-channel us them ?) #:meta-level 1)))))
(scn/union (subscription `(counter ,?))
(subscription (tcp-channel them us ?) #:meta-level 1)
(subscription (advertise (tcp-channel them us ?)) #:meta-level 1)
(advertisement (tcp-channel us them ?) #:meta-level 1)))))
(spawn-world
(spawn (lambda (e counter)
@ -111,30 +112,10 @@
(transition (+ counter 1) (send `(counter ,counter)))]
[_ #f]))
0
(gestalt-union (sub 'bump)
(pub `(counter ,?))))
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)
(scn (subscription 'bump)))
(spawn-demand-matcher (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?))
(observe (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?))
#:meta-level 1
spawn-session))
)
(spawn (lambda (e s)
(local-require racket/pretty)
(match e
[(message m _ _)
;; (pretty-write `(MAIN ,m))
(void)]
[(routing-update g)
;; (printf "MAIN gestalt:\n")
;; (pretty-print-gestalt g)
(void)]
[_ (void)])
(flush-output)
#f)
(void)
(gestalt-union
(sub ? #:level 5)
(pub ? #:level 5)
;;(sub (tcp-channel ? ? ?) #:level 5)
))

View File

@ -6,7 +6,7 @@
(require racket/set)
(require racket/match)
(require minimart)
(require prospect-monolithic)
(require "ip.rkt")
(struct port-allocation-request (type k) #:prefab)

View File

@ -8,9 +8,9 @@
(require racket/set)
(require racket/match)
(require minimart)
(require minimart/drivers/timer)
(require minimart/demand-matcher)
(require prospect-monolithic)
(require prospect-monolithic/drivers/timer)
(require prospect-monolithic/demand-matcher)
(require bitsyntax)
(require "dump-bytes.rkt")

View File

@ -10,8 +10,8 @@
(require racket/set)
(require racket/match)
(require minimart)
(require minimart/demand-matcher)
(require prospect-monolithic)
(require prospect-monolithic/demand-matcher)
(require bitsyntax)
(require "dump-bytes.rkt")