diff --git a/clash-eth.cabal b/clash-eth.cabal index 3e078998..4ae08f90 100644 --- a/clash-eth.cabal +++ b/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 diff --git a/src/Clash/Cores/Ethernet/IP/EthernetStream.hs b/src/Clash/Cores/Ethernet/IP/EthernetStream.hs new file mode 100644 index 00000000..0828dd23 --- /dev/null +++ b/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 diff --git a/tests/Test/Cores/Ethernet/IP/EthernetStream.hs b/tests/Test/Cores/Ethernet/IP/EthernetStream.hs new file mode 100644 index 00000000..250f1413 --- /dev/null +++ b/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) diff --git a/tests/unittests.hs b/tests/unittests.hs index a94d7172..bce2e59e 100644 --- a/tests/unittests.hs +++ b/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