syndicate-2017/examples/netstack/ethernet.rkt

134 lines
4.7 KiB
Racket

#lang racket/base
;; 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 racket/set)
(require racket/match)
(require racket/async-channel)
(require syndicate-monolithic)
(require syndicate-monolithic/demand-matcher)
(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-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?))
(ethernet-interface (?!) ?)
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
[(scn g)
(if (trie-empty? g)
(begin (async-channel-put control-ch 'quit)
(quit))
(begin (async-channel-put control-ch 'unblock)
#f))]
[(message (at-meta (? ethernet-packet? p)))
;; (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)))
(transition h (message p))]
[(message (? ethernet-packet? p))
;; (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))
#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 (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 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 (?!))))