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

309
examples/netstack/arp.rkt
View File

@ -1,22 +1,20 @@
#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.
(provide (struct-out arp-query) (provide (struct-out arp-query)
(struct-out arp-assertion) (struct-out arp-assertion)
(struct-out arp-interface) (struct-out arp-interface)
spawn-arp-driver) spawn-arp-driver)
(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,51 +29,31 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 now (current-inexact-milliseconds))
(define (not-expired? v) (< now (cache-value-expiry v)))
(for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
(values k v)))
(define (spawn-arp-interface interface-name) (define (run-arp-interface interface-name hwaddr)
(log-info "spawn-arp-interface ~v" interface-name) (log-info "ARP interface ~v ~v" interface-name hwaddr)
(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 interface (ethernet-interface interface-name hwaddr))
(define (expire-cache cache)
(define now (current-inexact-milliseconds))
(define (not-expired? v) (< now (cache-value-expiry v)))
(for/hash [((k v) (in-hash cache)) #:when (not-expired? v)]
(values k v)))
(define timer-key (list 'arp interface-name))
(define (set-wakeup-alarm)
(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))
(define plen (bytes-length target-pa)) (define plen (bytes-length target-pa))
@ -96,140 +74,123 @@
ARP-ethertype ARP-ethertype
packet)) packet))
(define (analyze-incoming-packet source destination body s) (define (some-asserted-pa ptype)
(bit-string-case body (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
([ (= 1 :: integer bytes 2) ['() #f]
(ptype :: integer bytes 2) [(list* k _) (cache-key-address k)]))
hlen
plen
(oper :: integer bytes 2)
(sender-hardware-address0 :: binary bytes hlen)
(sender-protocol-address0 :: binary bytes plen)
(target-hardware-address0 :: binary bytes hlen)
(target-protocol-address0 :: binary bytes plen)
(:: binary) ;; The extra zeros exist because ethernet packets
;; have a minimum size. This is, in part, why
;; IPv4 headers have a total-length field, so
;; that the zero padding can be removed.
]
(let ()
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
(define target-protocol-address (bit-string->bytes target-protocol-address0))
(define learned-key (cache-key ptype sender-protocol-address))
(when (and (set-member? (state-queries s) learned-key) ;; it is relevant to our interests
(not (equal? sender-hardware-address
(cache-value-address (hash-ref (state-cache s)
learned-key
(lambda ()
(cache-value #f #f #f)))))))
(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))
learned-key
(cache-value (+ (current-inexact-milliseconds)
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))
(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 (observe (arp-query (?!) (?!) ? ?))) (define (send-questions!)
(define (gestalt->queries g) (for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
(for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))] (define pa (some-asserted-pa (cache-key-protocol q)))
(match-define (list ptype pa) e) (log-info "~a ARP Asking for ~a from ~a"
(cache-key ptype pa))) 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))))))
(define assertions-projection (arp-assertion (?!) (?!) ?)) (field [cache (hash)]
(define (gestalt->assertions g) [queries (set)]
(for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))] [assertions (set)])
(match-define (list ptype pa) e)
(cache-key ptype pa)))
(define (analyze-gestalt g s) (on-start (define timer-key (list 'arp interface-name))
(define new-assertions (gestalt->assertions g)) (define (arm-timer!) (send! (set-timer timer-key wakeup-interval 'relative)))
(define added-assertions (set-subtract new-assertions (state-assertions s))) (arm-timer!)
(define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions])) (react (on (message (timer-expired timer-key _))
(if (trie-empty? (project-assertions g (arp-interface interface-name))) (cache (expire-cache (cache)))
(quit) (send-questions!)
(transition new-s (arm-timer!))))
(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) (on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
(define unanswered-queries (match-define (ethernet-packet _ _ source destination _ body) p)
(set-subtract (state-queries s) (list->set (hash-keys (state-cache s))))) (bit-string-case body
(define (some-asserted-pa ptype) ([ (= 1 :: integer bytes 2)
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (ptype :: integer bytes 2)
(set->list (state-assertions s))) hlen
['() #f] plen
[(list* k _) (cache-key-address k)])) (oper :: integer bytes 2)
(transition s (sender-hardware-address0 :: binary bytes hlen)
(for/list [(q (in-set unanswered-queries))] (sender-protocol-address0 :: binary bytes plen)
(define pa (some-asserted-pa (cache-key-protocol q))) (target-hardware-address0 :: binary bytes hlen)
(log-info "~a ARP Asking for ~a from ~a" (target-protocol-address0 :: binary bytes plen)
interface-name (:: binary) ;; The extra zeros exist because ethernet packets
(pretty-bytes (cache-key-address q)) ;; have a minimum size. This is, in part, why IPv4
(and pa (pretty-bytes pa))) ;; headers have a total-length field, so that the
(when pa ;; zero padding can be removed.
(message (build-packet broadcast-ethernet-address ]
(cache-key-protocol q) (let ()
1 ;; request (define sender-protocol-address (bit-string->bytes sender-protocol-address0))
hwaddr (define sender-hardware-address (bit-string->bytes sender-hardware-address0))
pa (define target-protocol-address (bit-string->bytes target-protocol-address0))
zero-ethernet-address (define learned-key (cache-key ptype sender-protocol-address))
(cache-key-address q)))))))
(list (set-wakeup-alarm) (when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
(spawn (lambda (e s) (not (equal? sender-hardware-address
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) (cache-value-address (hash-ref (cache)
(match e learned-key
[(scn g) (lambda ()
(sequence-transitions (analyze-gestalt g s) (cache-value #f #f #f)))))))
send-questions)] (log-info "~a ARP Adding ~a = ~a to cache"
[(message (ethernet-packet _ _ source destination _ body)) interface-name
(analyze-incoming-packet source destination body s)] (pretty-bytes sender-protocol-address)
[(message (timer-expired _ _)) (pretty-bytes sender-hardware-address)))
(define new-s (struct-copy state s
[cache (expire-cache (state-cache s))])) (cache (hash-set (expire-cache (cache))
(sequence-transitions (transition new-s learned-key
(list (set-wakeup-alarm) (cache-value (+ (current-inexact-milliseconds)
(compute-gestalt (state-cache new-s)))) cache-entry-lifetime-msec)
send-questions)] interface
[_ #f])) sender-hardware-address)))
(state (hash) (set) (set)) (case oper
(compute-gestalt (hash))))) [(1) ;; request
(when (set-member? (assertions) (cache-key ptype target-protocol-address))
(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) (void)] ;; reply
[else (void)])))
(else #f)))
(during (arp-assertion $protocol $protocol-address interface-name)
(define a (cache-key protocol protocol-address))
(on-start (assertions (set-add (assertions) a))
(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))))
(on-stop (assertions (set-remove (assertions) a))))
(during (observe (arp-query $protocol $protocol-address interface _))
(define key (cache-key protocol protocol-address))
(on-start (queries (set-add (queries) key))
(send-questions!))
(on-stop (queries (set-remove (queries) key)))
(assert #:when (hash-has-key? (cache) key)
(match (hash-ref (cache) key)
[(cache-value _ ifname addr)
(arp-query protocol protocol-address ifname addr)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-arp-driver)

113
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)) (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h))) (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(cond
[(not h) (define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
(log-error "ethernet: Couldn't open interface ~v" interface-name) (assert interface)
'()]
[else (define control-ch (make-async-channel))
(log-info "Opened interface ~a, yielding handle ~v" interface-name h) (thread (lambda () (interface-packet-read-loop interface h control-ch)))
(define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface h control-ch))) (on-start (flush!) ;; ensure all subscriptions are in place
(spawn (lambda (e h) (async-channel-put control-ch 'unblock)
(match e (actor #:name (list 'ethernet-interface-quit-monitor interface-name)
[(scn g) (react (on (retracted interface)
(if (trie-empty? g) (async-channel-put control-ch 'quit)))))
(begin (async-channel-put control-ch 'quit)
(quit)) (on (message ($ p (ethernet-packet interface #t _ _ _ _)) #:meta-level 1)
(begin (async-channel-put control-ch 'unblock) ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
#f))] ;; (ethernet-interface-name (ethernet-packet-interface p))
[(message (at-meta (? ethernet-packet? p))) ;; (pretty-bytes (ethernet-packet-source p))
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)" ;; (pretty-bytes (ethernet-packet-destination p))
;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (number->string (ethernet-packet-ethertype p) 16))
;; (pretty-bytes (ethernet-packet-source p)) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
;; (pretty-bytes (ethernet-packet-destination p)) (send! p))
;; (number->string (ethernet-packet-ethertype p) 16))
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) (on (message ($ p (ethernet-packet interface #f _ _ _ _)))
(transition h (message p))] ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
[(message (? ethernet-packet? p)) ;; (ethernet-interface-name (ethernet-packet-interface p))
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)" ;; (pretty-bytes (ethernet-packet-source p))
;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (pretty-bytes (ethernet-packet-destination p))
;; (pretty-bytes (ethernet-packet-source p)) ;; (number->string (ethernet-packet-ethertype p) 16))
;; (pretty-bytes (ethernet-packet-destination p)) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
;; (number->string (ethernet-packet-ethertype p) 16)) (raw-interface-write h (encode-ethernet-packet p)))))))
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body 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)
(log-info "Lookup of ethernet interface ~v failed" interface-name) (on-start (send! (set-timer timer-id 5000 'relative)))
'()) (stop-when (message (timer-expired timer-id _))
(lambda (_g hwaddrss) (log-info "Lookup of ethernet interface ~v failed" interface-name)
(and (not (set-empty? hwaddrss)) (k #f))
(let ((hwaddr (car (set-first hwaddrss)))) (stop-when (asserted (ethernet-interface interface-name $hwaddr))
(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)