syndicate-2017/examples/netstack/incremental-highlevel/ethernet.rkt

126 lines
4.6 KiB
Racket

#lang syndicate
;; Ethernet driver
(provide (struct-out ethernet-packet)
zero-ethernet-address
broadcast-ethernet-address
interface-names
spawn-ethernet-driver
ethernet-packet-pattern
lookup-ethernet-hwaddr)
(require/activate syndicate/drivers/timer)
(require racket/set)
(require racket/match)
(require racket/async-channel)
(require packet-socket)
(require bitsyntax)
(require "configuration.rkt")
(require "dump-bytes.rkt")
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
(define interface-names (raw-interface-names))
(log-info "Device names: ~a" interface-names)
(define (spawn-ethernet-driver)
(spawn #:name 'ethernet-driver
(during/spawn
(observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
#:name (list 'ethernet-interface interface-name)
(define h (raw-interface-open interface-name))
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
(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))
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
(on-start (flush!) ;; ensure all subscriptions are in place
(async-channel-put control-ch 'unblock)
(spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
(on (retracted interface)
(async-channel-put control-ch 'quit))))
(on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _))))
;; (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)))
(send! p))
(on (message ($ p (ethernet-packet interface #f _ _ _ _)))
;; (log-info "Interface ~a OUTBOUND 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)))
(raw-interface-write h (encode-ethernet-packet p))))))
(define (interface-packet-read-loop interface h control-ch)
(define (blocked)
(match (async-channel-get control-ch)
['unblock (unblocked)]
['quit (void)]))
(define (unblocked)
(match (async-channel-try-get control-ch)
['unblock (unblocked)]
['quit (void)]
[#f
(define p (raw-interface-read h))
(define decoded (decode-ethernet-packet interface p))
(when decoded (send-ground-message decoded))
(unblocked)]))
(blocked)
(raw-interface-close h))
(define (decode-ethernet-packet interface p)
(bit-string-case p
([ (destination :: binary bytes 6)
(source :: binary bytes 6)
(ethertype :: integer bytes 2)
(body :: binary) ]
(ethernet-packet interface
#t
(bit-string->bytes source)
(bit-string->bytes destination)
ethertype
(bit-string->bytes body)))
(else #f)))
(define (encode-ethernet-packet p)
(match-define (ethernet-packet _ _ source destination ethertype body) p)
(bit-string->bytes
(bit-string (destination :: binary bytes 6)
(source :: binary bytes 6)
(ethertype :: integer bytes 2)
(body :: binary))))
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
(define (lookup-ethernet-hwaddr interface-name)
(define timer-id (gensym 'lookup-ethernet-hwaddr))
(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)
(k #f))
(stop-when (asserted (ethernet-interface interface-name $hwaddr))
(k hwaddr))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-ethernet-driver)