implement toEthernetStreamC (#145)

clash-eth.cabal

@@ -104,6 +104,7 @@ library
     Clash.Cores.Ethernet.Examples.EchoStack
     Clash.Cores.Ethernet.Examples.RxStacks
     Clash.Cores.Ethernet.Examples.TxStacks
+    Clash.Cores.Ethernet.IP.EthernetStream
     Clash.Cores.Ethernet.IP.InternetChecksum
     Clash.Cores.Ethernet.IP.IPPacketizers
     Clash.Cores.Ethernet.IP.IPv4Types
@@ -162,6 +163,7 @@ test-suite test-library
   other-modules:
     Test.Cores.Ethernet.Arp.ArpManager
     Test.Cores.Ethernet.Arp.ArpTable
+    Test.Cores.Ethernet.IP.EthernetStream
     Test.Cores.Ethernet.IP.InternetChecksum
     Test.Cores.Ethernet.IP.IPPacketizers
     Test.Cores.Ethernet.Mac.EthernetTypes

src/Clash/Cores/Ethernet/IP/EthernetStream.hs

@@ -0,0 +1,75 @@
+{-# language FlexibleContexts #-}
+{-# language RecordWildCards #-}
+module Clash.Cores.Ethernet.IP.EthernetStream
+  (toEthernetStreamC) where
+
+import Clash.Cores.Ethernet.Arp.ArpTypes
+import Clash.Cores.Ethernet.IP.IPv4Types
+import Clash.Cores.Ethernet.Mac.EthernetTypes
+import Clash.Prelude
+import Data.Bifunctor
+import Data.Maybe ( isJust )
+import Protocols
+import Protocols.Extra.PacketStream
+
+-- | State of Ethernet stream transformer `toEthernetStream`
+data EthernetStreamState
+  = Idle
+  | Drop
+  | Forward {_mac :: MacAddress}
+  deriving (Generic, NFDataX, Show, ShowX)
+
+-- | Takes our IPv4 address (as a signal), a packet stream with IPv4 addresses in the metadata,
+-- performs an ARP lookup from a user-given ARP service, and
+-- outputs the packet with a completed ethernet header containing
+-- the IPv4 ether type, our IPv4 address and the looked up destination MAC.
+-- If the ARP service gave an ArpEntryNotFound, then this circuit drops the
+-- entire packet. It does not time out, instead expects the ARP service to send
+-- an ArpEntryNotFound after an appropriate timeout.
+toEthernetStreamC
+  :: forall (dom :: Domain) (dataWidth :: Nat)
+  .  HiddenClockResetEnable dom
+  => Signal dom MacAddress
+  -- ^ My Mac address
+  -> Circuit
+      (PacketStream dom dataWidth IPv4Address)
+      (PacketStream dom dataWidth EthernetHeader, ArpLookup dom)
+toEthernetStreamC myMac = fromSignals ckt
+  where
+    ckt
+      :: (Signal dom (Maybe (PacketStreamM2S dataWidth IPv4Address))
+         , (Signal dom PacketStreamS2M, Signal dom  (Maybe ArpResponse)))
+      -> (Signal dom PacketStreamS2M
+         , (Signal dom (Maybe (PacketStreamM2S dataWidth EthernetHeader)),Signal dom (Maybe IPv4Address)))
+    ckt (packetInS, (ackInS, arpInS)) = (second unbundle . mealyB go Idle . second bundle) (myMac, packetInS, (ackInS, arpInS))
+      where
+        go
+          :: EthernetStreamState
+          -> (MacAddress, Maybe (PacketStreamM2S dataWidth IPv4Address)
+             , (PacketStreamS2M, Maybe ArpResponse))
+          -> (EthernetStreamState, (PacketStreamS2M
+             , (Maybe (PacketStreamM2S dataWidth EthernetHeader), Maybe IPv4Address)))
+        go Idle (_, pktIn, (_, arpResponse)) = (newSt, (PacketStreamS2M False, (Nothing, fmap _meta pktIn)))
+          where
+            newSt = case arpResponse of
+              Nothing -> Idle
+              Just ArpEntryNotFound -> Drop
+              Just (ArpEntryFound ma) -> Forward{_mac = ma}
+        go Drop (_, pktIn, (_, _))
+          = (nextSt, (PacketStreamS2M True, (Nothing, Nothing)))
+          where
+            pktInX = fromJustX pktIn
+            nextSt =
+              if isJust pktIn && isJust (_last pktInX)
+              then Idle
+              else Drop
+        go st@Forward{..} (mac, pktIn, (PacketStreamS2M ack, _))
+          = (nextSt, (PacketStreamS2M ack, (pktOut, Nothing)))
+          where
+            pktInX = fromJustX pktIn
+            nextSt =
+              if isJust pktIn && isJust (_last pktInX) && ack
+              then Idle
+              else st
+            hdr = EthernetHeader _mac mac 0x0800
+            pktOut = fmap (hdr <$) pktIn

tests/Test/Cores/Ethernet/IP/EthernetStream.hs

@@ -0,0 +1,137 @@
+{-# language FlexibleContexts #-}
+{-# language NumericUnderscores #-}
+{-# language RecordWildCards #-}
+module Test.Cores.Ethernet.IP.EthernetStream where
+
+import Clash.Prelude
+
+-- hedgehog
+import Hedgehog
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+
+-- tasty
+import Test.Tasty
+import Test.Tasty.Hedgehog ( HedgehogTestLimit(HedgehogTestLimit) )
+import Test.Tasty.Hedgehog.Extra ( testProperty )
+import Test.Tasty.TH ( testGroupGenerator )
+
+-- clash-protocols
+import Protocols
+import Protocols.Extra.PacketStream
+import Protocols.Hedgehog
+
+-- IP
+import Clash.Cores.Ethernet.IP.EthernetStream
+import Clash.Cores.Ethernet.IP.IPv4Types
+
+-- MAC
+import Clash.Cores.Ethernet.Mac.EthernetTypes
+
+-- ARP
+import Clash.Cores.Ethernet.Arp.ArpTypes
+import Test.Protocols.Extra.PacketStream
+
+myMac :: MacAddress
+myMac = MacAddress (6 :> 6:> 6:> 6:> 6:> 6:> Nil)
+
+someMac :: MacAddress
+someMac = MacAddress (7 :> 7:> 0:> 7 :> 7:> 6:> Nil)
+
+-- | drive the bwd of the arp lookup constantly with
+-- a given response.
+arpConstC
+  :: forall (dom :: Domain)
+   . HiddenClockResetEnable dom
+  => KnownDomain dom
+  => ArpResponse
+  -> Circuit (ArpLookup dom) ()
+arpConstC response = fromSignals ckt
+  where
+    ckt (_,_) = (pure $ Just response, ())
+
+-- | toEthernetStream, but with the arp lookup given
+-- by arpConstC
+testCircuit
+  :: forall (dom :: Domain) (dataWidth :: Nat)
+   . HiddenClockResetEnable dom
+  => KnownDomain dom
+  => ArpResponse
+  -> Circuit (PacketStream dom dataWidth IPv4Address) (PacketStream dom dataWidth EthernetHeader)
+testCircuit response = circuit $ \packet -> do
+  (packetOut, lookup) <- toEthernetStreamC $ pure myMac -< packet
+  () <- arpConstC response -< lookup
+  idC -< packetOut
+
+-- model of testCircuit: inserts the given macadress when the
+-- arp response is an ArpEntryFound mac,
+-- drops the entire packet if the arp response is ArpEntryNotFound.
+model
+  :: ArpResponse
+  -> [PacketStreamM2S dataWidth IPv4Address]
+  -> [PacketStreamM2S dataWidth EthernetHeader]
+model response = case response of
+  ArpEntryNotFound -> const []
+  ArpEntryFound ma -> fmap (hdr <$)
+    where
+      hdr = EthernetHeader ma myMac 0x0800
+
+ethernetStreamTest
+  :: forall (dataWidth :: Nat)
+    . 1 <= dataWidth
+  => KnownNat dataWidth
+  => 1 <= dataWidth
+  => SNat dataWidth
+  -> ArpResponse
+  -> Property
+ethernetStreamTest SNat arpResponse =
+  propWithModelSingleDomain
+    @System
+    defExpectOptions
+    (fmap (cleanPackets . fullPackets) (Gen.list (Range.linear 0 100) genPackets))
+    (exposeClockResetEnable (model arpResponse))
+    (exposeClockResetEnable @System ckt)
+    (===)
+  where
+    ckt :: forall (dom :: Domain)
+      . HiddenClockResetEnable dom
+      => Circuit (PacketStream dom dataWidth IPv4Address) (PacketStream dom dataWidth EthernetHeader)
+    ckt = testCircuit arpResponse
+
+    -- This generates the packets
+    genPackets =
+      PacketStreamM2S <$>
+      genVec Gen.enumBounded <*>
+      Gen.maybe Gen.enumBounded <*>
+      (IPv4Address <$> genVec Gen.enumBounded) <*>
+      Gen.enumBounded
+
+    genVec :: (KnownNat n, 1 <= n) => Gen a -> Gen (Vec n a)
+    genVec gen = sequence (repeat gen)
+
+
+-- | We test whether the circuit succesfully inserts the given macadress when the
+-- arp lookup service constantly gives an ArpEntryFound mac,
+-- and whether the circuit succesfully drops the entire packet if the arp lookup
+-- service constantly gives an ArpEntryNotFound.
+prop_ethernetstreamer_d1_noresp, prop_ethernetstreamer_d21_noresp, prop_ethernetstreamer_d28_noresp :: Property
+prop_ethernetstreamer_d1_resp, prop_ethernetstreamer_d21_resp, prop_ethernetstreamer_d28_resp :: Property
+
+-- dataWidth ~ 1
+prop_ethernetstreamer_d1_noresp  = ethernetStreamTest d1 ArpEntryNotFound
+prop_ethernetstreamer_d1_resp = ethernetStreamTest d21 (ArpEntryFound someMac)
+
+-- dataWidth large
+prop_ethernetstreamer_d21_resp = ethernetStreamTest d21 (ArpEntryFound someMac)
+prop_ethernetstreamer_d21_noresp  = ethernetStreamTest d21 ArpEntryNotFound
+
+-- dataWidth extra large
+prop_ethernetstreamer_d28_resp = ethernetStreamTest d28 (ArpEntryFound someMac)
+prop_ethernetstreamer_d28_noresp  = ethernetStreamTest d28 ArpEntryNotFound
+
+
+tests :: TestTree
+tests =
+    localOption (mkTimeout 12_000_000 {- 12 seconds -})
+  $ localOption (HedgehogTestLimit (Just 1_000))
+  $(testGroupGenerator)

tests/unittests.hs

@@ -5,6 +5,7 @@ import Test.Tasty
 import Test.Cores.Ethernet.Arp.ArpManager qualified
 import Test.Cores.Ethernet.Arp.ArpTable qualified
 import Test.Cores.Ethernet.Icmp qualified
+import Test.Cores.Ethernet.IP.EthernetStream qualified
 import Test.Cores.Ethernet.IP.InternetChecksum qualified
 import Test.Cores.Ethernet.IP.IPPacketizers qualified
 import Test.Cores.Ethernet.Mac.EthernetTypes qualified
@@ -25,6 +26,7 @@ main :: IO ()
 main = defaultMain $ testGroup "."
   [ Test.Cores.Ethernet.Arp.ArpManager.tests
   , Test.Cores.Ethernet.Arp.ArpTable.tests
+  , Test.Cores.Ethernet.IP.EthernetStream.tests
   , Test.Cores.Ethernet.IP.InternetChecksum.tests
   , Test.Cores.Ethernet.IP.IPPacketizers.tests
   , Test.Cores.Ethernet.Mac.EthernetTypes.tests