syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
arp.rkt
View File

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

6
configuration.rkt
View File

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

16
demo-config.rkt
View File

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

65
ethernet.rkt
View File

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

6
fetchurl.rkt
View File

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

210
ip.rkt
View File

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

141
main.rkt
View File

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

2
port-allocator.rkt
View File

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

6
tcp.rkt
View File

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

4
udp.rkt
View File

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