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

Translate Ethernet and ARP to incremental/actor style

This commit is contained in:
Tony Garnock-Jones 2016-07-12 16:46:21 -04:00
parent 4357424e78
commit fb5b6e80b8
3 changed files with 191 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
examples/netstack/arp.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang syndicate/actor
;; ARP protocol, http://tools.ietf.org/html/rfc826 ;; ARP protocol, http://tools.ietf.org/html/rfc826
;; Only does ARP-over-ethernet. ;; Only does ARP-over-ethernet.
@ -9,14 +9,12 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require syndicate/monolithic) (require/activate syndicate/drivers/timer)
(require syndicate/drivers/timer)
(require syndicate/demand-matcher)
(require bitsyntax) (require bitsyntax)
(require "dump-bytes.rkt") (require "dump-bytes.rkt")
(require "configuration.rkt") (require "configuration.rkt")
(require "ethernet.rkt") (require/activate "ethernet.rkt")
(struct arp-query (protocol protocol-address interface link-address) #:prefab) (struct arp-query (protocol protocol-address interface link-address) #:prefab)
(struct arp-assertion (protocol protocol-address interface-name) #:prefab) (struct arp-assertion (protocol protocol-address interface-name) #:prefab)
@ -31,50 +29,30 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-arp-driver) (define (spawn-arp-driver)
(spawn-demand-matcher (arp-interface (?!)) (actor #:name 'arp-driver
(arp-interface-up (?!)) (react (during/actor (arp-interface $interface-name)
spawn-arp-interface)) #:name (list 'arp-interface interface-name)
(assert (arp-interface-up interface-name))
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
(when (not hwaddr)
(error 'arp "Failed to look up ARP interface ~v"
interface-name))
(react (run-arp-interface interface-name hwaddr)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct cache-key (protocol address) #:transparent) (struct cache-key (protocol address) #:transparent)
(struct cache-value (expiry interface address) #:transparent) (struct cache-value (expiry interface address) #:transparent)
(struct state (cache queries assertions) #:transparent) (define (expire-cache c)
(define (spawn-arp-interface interface-name)
(log-info "spawn-arp-interface ~v" interface-name)
(lookup-ethernet-hwaddr (assertion (arp-interface-up interface-name))
interface-name
(lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr))))
(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 (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)))
(for/hash [((k v) (in-hash cache)) #:when (not-expired? v)] (for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
(values k v))) (values k v)))
(define timer-key (list 'arp interface-name)) (define (run-arp-interface interface-name hwaddr)
(log-info "ARP interface ~v ~v" interface-name hwaddr)
(define (set-wakeup-alarm) (define interface (ethernet-interface interface-name hwaddr))
(message (set-timer timer-key wakeup-interval 'relative)))
(define (compute-gestalt cache)
(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 (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))
@ -96,7 +74,41 @@
ARP-ethertype ARP-ethertype
packet)) packet))
(define (analyze-incoming-packet source destination body s) (define (some-asserted-pa ptype)
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
['() #f]
[(list* k _) (cache-key-address k)]))
(define (send-questions!)
(for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
(define pa (some-asserted-pa (cache-key-protocol q)))
(log-info "~a ARP Asking for ~a from ~a"
interface-name
(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))))))
(field [cache (hash)]
[queries (set)]
[assertions (set)])
(on-start (define timer-key (list 'arp interface-name))
(define (arm-timer!) (send! (set-timer timer-key wakeup-interval 'relative)))
(arm-timer!)
(react (on (message (timer-expired timer-key _))
(cache (expire-cache (cache)))
(send-questions!)
(arm-timer!))))
(on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
(match-define (ethernet-packet _ _ source destination _ body) p)
(bit-string-case body (bit-string-case body
([ (= 1 :: integer bytes 2) ([ (= 1 :: integer bytes 2)
(ptype :: integer bytes 2) (ptype :: integer bytes 2)
@ -108,18 +120,19 @@
(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) ;; The extra zeros exist because ethernet packets (:: binary) ;; The extra zeros exist because ethernet packets
;; have a minimum size. This is, in part, why ;; have a minimum size. This is, in part, why IPv4
;; IPv4 headers have a total-length field, so ;; headers have a total-length field, so that the
;; that the zero padding can be removed. ;; zero padding can be removed.
] ]
(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))
(define learned-key (cache-key ptype sender-protocol-address)) (define learned-key (cache-key ptype sender-protocol-address))
(when (and (set-member? (state-queries s) learned-key) ;; it is relevant to our interests
(when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
(not (equal? sender-hardware-address (not (equal? sender-hardware-address
(cache-value-address (hash-ref (state-cache s) (cache-value-address (hash-ref (cache)
learned-key learned-key
(lambda () (lambda ()
(cache-value #f #f #f))))))) (cache-value #f #f #f)))))))
@ -127,109 +140,57 @@
interface-name interface-name
(pretty-bytes sender-protocol-address) (pretty-bytes sender-protocol-address)
(pretty-bytes sender-hardware-address))) (pretty-bytes sender-hardware-address)))
(define cache (hash-set (expire-cache (state-cache s))
(cache (hash-set (expire-cache (cache))
learned-key learned-key
(cache-value (+ (current-inexact-milliseconds) (cache-value (+ (current-inexact-milliseconds)
cache-entry-lifetime-msec) cache-entry-lifetime-msec)
interface interface
sender-hardware-address))) sender-hardware-address)))
(transition (struct-copy state s [cache cache])
(list
(case oper (case oper
[(1) ;; request [(1) ;; request
(if (set-member? (state-assertions s) (when (set-member? (assertions) (cache-key ptype target-protocol-address))
(cache-key ptype target-protocol-address))
(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) (void)] ;; reply
[(2) '()] ;; reply [else (void)])))
[else '()])
(compute-gestalt cache)))))
(else #f))) (else #f)))
(define queries-projection (observe (arp-query (?!) (?!) ? ?))) (during (arp-assertion $protocol $protocol-address interface-name)
(define (gestalt->queries g) (define a (cache-key protocol protocol-address))
(for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))] (on-start (assertions (set-add (assertions) a))
(match-define (list ptype pa) e)
(cache-key ptype pa)))
(define assertions-projection (arp-assertion (?!) (?!) ?))
(define (gestalt->assertions g)
(for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))]
(match-define (list ptype pa) e)
(cache-key ptype pa)))
(define (analyze-gestalt g s)
(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]))
(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" (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))
(message (build-packet broadcast-ethernet-address (send! (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))))
(on-stop (assertions (set-remove (assertions) a))))
(define (send-questions s) (during (observe (arp-query $protocol $protocol-address interface _))
(define unanswered-queries (define key (cache-key protocol protocol-address))
(set-subtract (state-queries s) (list->set (hash-keys (state-cache s))))) (on-start (queries (set-add (queries) key))
(define (some-asserted-pa ptype) (send-questions!))
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (on-stop (queries (set-remove (queries) key)))
(set->list (state-assertions s))) (assert #:when (hash-has-key? (cache) key)
['() #f] (match (hash-ref (cache) key)
[(list* k _) (cache-key-address k)])) [(cache-value _ ifname addr)
(transition s (arp-query protocol protocol-address ifname addr)]))))
(for/list [(q (in-set unanswered-queries))]
(define pa (some-asserted-pa (cache-key-protocol q)))
(log-info "~a ARP Asking for ~a from ~a"
interface-name
(pretty-bytes (cache-key-address q))
(and pa (pretty-bytes pa)))
(when pa
(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) (spawn-arp-driver)
(match e
[(scn g)
(sequence-transitions (analyze-gestalt g s)
send-questions)]
[(message (ethernet-packet _ _ source destination _ body))
(analyze-incoming-packet source destination body s)]
[(message (timer-expired _ _))
(define new-s (struct-copy state s
[cache (expire-cache (state-cache s))]))
(sequence-transitions (transition new-s
(list (set-wakeup-alarm)
(compute-gestalt (state-cache new-s))))
send-questions)]
[_ #f]))
(state (hash) (set) (set))
(compute-gestalt (hash)))))

77
examples/netstack/ethernet.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang syndicate/actor
;; Ethernet driver ;; Ethernet driver
(provide (struct-out ethernet-packet) (provide (struct-out ethernet-packet)
@ -9,14 +9,11 @@
ethernet-packet-pattern ethernet-packet-pattern
lookup-ethernet-hwaddr) lookup-ethernet-hwaddr)
(require/activate syndicate/drivers/timer)
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require racket/async-channel) (require racket/async-channel)
(require syndicate/monolithic)
(require syndicate/demand-matcher)
(require "on-claim.rkt")
(require packet-socket) (require packet-socket)
(require bitsyntax) (require bitsyntax)
@ -32,52 +29,44 @@
(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 (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)) (actor #:name 'ethernet-driver
(ethernet-interface (?!) ?) (react (during/actor
spawn-interface-tap)) (observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
#:name (list 'ethernet-interface interface-name)
(define (spawn-interface-tap interface-name)
(define h (raw-interface-open interface-name)) (define h (raw-interface-open interface-name))
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h))) (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
(cond
[(not h)
(log-error "ethernet: Couldn't open interface ~v" interface-name)
'()]
[else
(log-info "Opened interface ~a, yielding handle ~v" interface-name h) (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
(assert interface)
(define control-ch (make-async-channel)) (define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface h control-ch))) (thread (lambda () (interface-packet-read-loop interface h control-ch)))
(spawn (lambda (e h)
(match e (on-start (flush!) ;; ensure all subscriptions are in place
[(scn g) (async-channel-put control-ch 'unblock)
(if (trie-empty? g) (actor #:name (list 'ethernet-interface-quit-monitor interface-name)
(begin (async-channel-put control-ch 'quit) (react (on (retracted interface)
(quit)) (async-channel-put control-ch 'quit)))))
(begin (async-channel-put control-ch 'unblock)
#f))] (on (message ($ p (ethernet-packet interface #t _ _ _ _)) #:meta-level 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 (message p))] (send! p))
[(message (? ethernet-packet? p))
(on (message ($ p (ethernet-packet interface #f _ _ _ _)))
;; (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))
;; (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)))
(raw-interface-write h (encode-ethernet-packet p)) (raw-interface-write h (encode-ethernet-packet p)))))))
#f]
[_ #f]))
h
(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 (interface-packet-read-loop interface h control-ch)
(define (blocked) (define (blocked)
@ -121,14 +110,16 @@
(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-interests interface-name k) (define (lookup-ethernet-hwaddr interface-name)
(on-claim #:timeout-msec 5000 (define timer-id (gensym 'lookup-ethernet-hwaddr))
#:on-timeout (lambda () (react/suspend (k)
(on-start (send! (set-timer timer-id 5000 'relative)))
(stop-when (message (timer-expired timer-id _))
(log-info "Lookup of ethernet interface ~v failed" interface-name) (log-info "Lookup of ethernet interface ~v failed" interface-name)
'()) (k #f))
(lambda (_g hwaddrss) (stop-when (asserted (ethernet-interface interface-name $hwaddr))
(and (not (set-empty? hwaddrss))
(let ((hwaddr (car (set-first hwaddrss))))
(k hwaddr)))) (k hwaddr))))
base-interests
(ethernet-interface interface-name (?!)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-ethernet-driver)

10
examples/netstack/main.rkt
View File

@ -1,19 +1,17 @@
#lang syndicate/monolithic #lang syndicate/monolithic
(require/activate syndicate/drivers/timer)
(require/activate "ethernet.rkt")
(require/activate "arp.rkt")
(require syndicate/demand-matcher) (require syndicate/demand-matcher)
(require syndicate/drivers/timer)
(require "demo-config.rkt") (require "demo-config.rkt")
(require "ethernet.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)
(spawn-timer-driver)
(spawn-ethernet-driver)
(spawn-arp-driver)
(spawn-ip-driver) (spawn-ip-driver)
(spawn-tcp-driver) (spawn-tcp-driver)
(spawn-udp-driver) (spawn-udp-driver)