2014-06-16 01:16:14 +00:00
|
|
|
#lang racket/base
|
|
|
|
;; Ethernet driver
|
|
|
|
|
2014-06-19 01:24:47 +00:00
|
|
|
(provide (struct-out ethernet-packet)
|
2014-06-16 01:16:14 +00:00
|
|
|
zero-ethernet-address
|
|
|
|
broadcast-ethernet-address
|
|
|
|
interface-names
|
|
|
|
spawn-ethernet-driver
|
2014-06-19 01:24:47 +00:00
|
|
|
ethernet-packet-pattern
|
|
|
|
lookup-ethernet-hwaddr)
|
2014-06-16 01:16:14 +00:00
|
|
|
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/async-channel)
|
|
|
|
|
2016-01-24 01:11:59 +00:00
|
|
|
(require prospect-monolithic)
|
|
|
|
(require prospect-monolithic/demand-matcher)
|
2014-06-16 01:16:14 +00:00
|
|
|
|
|
|
|
(require packet-socket)
|
|
|
|
(require bitsyntax)
|
|
|
|
|
2014-06-19 01:24:47 +00:00
|
|
|
(require "configuration.rkt")
|
2014-06-16 01:16:14 +00:00
|
|
|
(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)
|
2016-01-24 01:11:59 +00:00
|
|
|
(spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?))
|
|
|
|
(ethernet-interface (?!) ?)
|
2014-06-16 01:16:14 +00:00
|
|
|
spawn-interface-tap))
|
|
|
|
|
|
|
|
(define (spawn-interface-tap interface-name)
|
|
|
|
(define h (raw-interface-open interface-name))
|
|
|
|
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
|
|
|
(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)
|
|
|
|
(define control-ch (make-async-channel))
|
|
|
|
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
|
|
|
(spawn (lambda (e h)
|
|
|
|
(match e
|
2016-01-24 01:11:59 +00:00
|
|
|
[(scn g)
|
|
|
|
(if (trie-empty? g)
|
2014-06-16 01:16:14 +00:00
|
|
|
(begin (async-channel-put control-ch 'quit)
|
2016-01-24 01:11:59 +00:00
|
|
|
(quit))
|
2014-06-16 01:16:14 +00:00
|
|
|
(begin (async-channel-put control-ch 'unblock)
|
|
|
|
#f))]
|
2016-01-24 01:11:59 +00:00
|
|
|
[(message (at-meta (? ethernet-packet? p)))
|
2014-06-17 16:06:43 +00:00
|
|
|
;; (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)))
|
2016-01-24 01:11:59 +00:00
|
|
|
(transition h (message p))]
|
|
|
|
[(message (? ethernet-packet? p))
|
2014-06-17 16:06:43 +00:00
|
|
|
;; (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)))
|
2014-06-16 01:16:14 +00:00
|
|
|
(raw-interface-write h (encode-ethernet-packet p))
|
|
|
|
#f]
|
|
|
|
[_ #f]))
|
|
|
|
h
|
2016-01-24 01:11:59 +00:00
|
|
|
(scn/union (assertion interface)
|
|
|
|
(subscription (ethernet-packet interface #f ? ? ? ?))
|
|
|
|
(subscription (observe (ethernet-packet interface #t ? ? ? ?)))
|
|
|
|
(subscription (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))]))
|
2014-06-16 01:16:14 +00:00
|
|
|
|
|
|
|
(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 ?))
|
2014-06-19 01:24:47 +00:00
|
|
|
|
2016-01-24 01:11:59 +00:00
|
|
|
(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 (?!))))
|