124 lines
4.4 KiB
Racket
124 lines
4.4 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang syndicate
|
|
;; Ethernet driver
|
|
|
|
(provide (struct-out available-ethernet-interface)
|
|
(struct-out ethernet-interface)
|
|
(struct-out ethernet-packet)
|
|
zero-ethernet-address
|
|
broadcast-ethernet-address
|
|
ethernet-packet-pattern)
|
|
|
|
(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")
|
|
(require syndicate/pattern-expander)
|
|
|
|
(assertion-struct available-ethernet-interface (name))
|
|
(assertion-struct ethernet-interface (name hwaddr))
|
|
(message-struct ethernet-packet (interface-name from-wire? source destination ethertype body))
|
|
|
|
(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
|
|
|
|
(for [(n interface-names)]
|
|
(assert (available-ethernet-interface n)))
|
|
|
|
(during/spawn
|
|
(observe (ethernet-packet $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)
|
|
|
|
(assert (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
|
|
|
(define control-ch (make-async-channel))
|
|
(thread (lambda () (interface-packet-read-loop interface-name h control-ch)))
|
|
(signal-background-activity! +1)
|
|
(on-start (async-channel-put control-ch 'unblock))
|
|
(on-stop (async-channel-put control-ch 'quit))
|
|
|
|
;; (on (message ($ 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))))
|
|
|
|
(on (message ($ p (ethernet-packet interface-name #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-name 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-name p))
|
|
(when decoded (ground-send! decoded))
|
|
(unblocked)]))
|
|
(blocked)
|
|
(raw-interface-close h)
|
|
(signal-background-activity! -1))
|
|
|
|
(define (decode-ethernet-packet interface-name p)
|
|
(bit-string-case p
|
|
([ (destination :: binary bytes 6)
|
|
(source :: binary bytes 6)
|
|
(ethertype :: integer bytes 2)
|
|
(body :: binary) ]
|
|
(ethernet-packet interface-name
|
|
#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))))
|
|
|
|
(begin-for-declarations
|
|
(define-pattern-expander ethernet-packet-pattern
|
|
(syntax-rules ()
|
|
[(_ interface-name from-wire? ethertype)
|
|
(ethernet-packet interface-name from-wire? _ _ ethertype _)])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(spawn-ethernet-driver)
|