;;; 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)