Icmp echo serialize

src/Packets/L2.hs

@@ -3,8 +3,15 @@ module Packets.L2
   (
   ) where
 
-import           Packets.Packet (Serializable (..))
+import           Packets.MacAddress (MacAddress (..))
 
+data L2Header =
+  L2Header
+  {
+    sourceMac :: MacAddress
+  , destMac   :: MacAddress
+  , payload   :: L2Payload
+  }
 
-data L2Header
+data L2Payload -- = Dot1Q Tpid Dot1QTag EtherType L2Payload | L2EtherType EtherType L3Payload
 

src/Packets/L3.hs

@@ -0,0 +1,80 @@
+
+module Packets.L3
+  (
+    L3Payload(..)
+  , ipChecksum
+  , IcmpCode(..)
+  , IcmpType(..)
+  , IcmpId(..)
+  , IcmpSqnum(..)
+  , IcmpPacket(..)
+  ) where
+
+import           Data.Binary     (Binary (..), Put (..), putWord8)
+import           Data.Binary.Put (putByteString, putWord16be, runPut)
+import           Data.Bits       (shiftR, (.&.))
+import qualified Data.ByteString as B
+import           Data.Word       (Word16 (..), Word8 (..))
+
+data L3Payload = IcmpPayload IcmpPacket
+  deriving (Show, Eq)
+
+data IcmpType =
+    IcmpTypeEchoRequest
+  | IcmpTypeEchoResponse
+  | IcmpTypeOther Word8
+  deriving (Show, Eq)
+
+newtype IcmpCode = IcmpCode { unIcmpCode :: Int }
+  deriving (Show, Eq)
+
+newtype IcmpId = IcmpId { unIcmpId :: Word16 }
+  deriving (Show, Eq)
+
+newtype IcmpSqnum = IcmpSqnum { unIcmpSqnum :: Word16 }
+  deriving (Show, Eq)
+
+data IcmpPacket =
+    IcmpEchoRequest IcmpId IcmpSqnum B.ByteString
+  | IcmpEchoResponse IcmpId IcmpSqnum B.ByteString
+  | IcmpUnknown IcmpType IcmpCode B.ByteString
+  deriving (Show, Eq)
+
+ipChecksum :: B.ByteString -> Word16
+ipChecksum bs = 0xffff - (fromIntegral . adjustedSum . sum . words) bs
+  where
+    adjustedSum x = if x > 0xffff
+      then adjustedSum $ x .&. 0xffff + x `shiftR` 16
+      else x
+
+    words :: B.ByteString -> [Int]
+    words bs =
+      let (h, t) = B.splitAt 2 bs in
+        case (B.unpack . B.take 2) h of
+          [x1, x2] -> (fromIntegral x1 * 0x100 + fromIntegral x2) : words t
+          [x1]     -> (fromIntegral x1 * 0x100) : words t
+          []       -> []
+
+instance Binary IcmpType where
+  put IcmpTypeEchoRequest  = putWord8 8
+  put IcmpTypeEchoResponse = putWord8 0
+  get = error ""
+
+fillIcmpChecksum :: B.ByteString -> B.ByteString
+fillIcmpChecksum src = B.take 2 src <> rawChecksum <> B.drop 4 src
+  where
+    checksum = ipChecksum src
+    rawChecksum = B.pack (fromIntegral <$> [ checksum `shiftR` 8, checksum .&. 0xff ])
+
+instance Binary IcmpPacket where
+  put (IcmpEchoRequest icmpId icmpSqnum payload) = putByteString $ fillIcmpChecksum . B.toStrict . runPut $ do
+    put IcmpTypeEchoRequest
+    putWord8 0 -- ICMP Code
+    putWord16be 0 -- Fill later
+    putWord16be . unIcmpId $ icmpId
+    putWord16be . unIcmpSqnum $ icmpSqnum
+    putByteString payload
+
+  put _ = undefined
+  get = undefined
+

test/Test.hs

@@ -4,11 +4,14 @@ module Main
   main
   ) where
 
+import qualified Test.Packets.L3
 import qualified Test.Packets.MacAddress
 import           Test.Tasty
 
 main = defaultMain tests
 
 tests :: TestTree
-tests = testGroup "Tests" [ Test.Packets.MacAddress.tests ]
+tests = testGroup "Tests" [
+    Test.Packets.MacAddress.tests
+  , Test.Packets.L3.tests ]
 

test/Test/Packets/L3.hs

@@ -0,0 +1,45 @@
+
+module Test.Packets.L3
+  (
+    tests
+  ) where
+
+import           Data.Binary         (encode)
+import qualified Data.ByteString     as B
+import           Data.Word           (Word8 (..))
+import           Hedgehog            (MonadGen (..), forAll, property, (===))
+import           Hedgehog.Gen
+import qualified Hedgehog.Range      as Range
+import           Packets.L3
+import           Test.Tasty
+import           Test.Tasty.Hedgehog
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "L3" [ unitTests]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit tests" [ testIpChecksum
+                                   , testSerializeEchoRequest ]
+
+testIpChecksum :: TestTree
+testIpChecksum = testCase "ipChecksum case 1" $ do
+  let testIcmp = B.pack [
+        0x08, 0x00, 0x00, 0x00, 0xfc, 0x6b, 0x59, 0xfb,
+        0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68]
+  let checksum = ipChecksum testIcmp
+  checksum @?= 0x1003
+
+testSerializeEchoRequest :: TestTree
+testSerializeEchoRequest = testCase "serialize IcmpEchoRequest" $ do
+  let payload = B.pack [
+        0x1c, 0x25, 0x31, 0x65, 0x00, 0x00, 0x00, 0x00,
+        0x72, 0x51, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
+        0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27,
+        0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37
+        ]
+  let testIcmp = B.pack [ 0x08, 0x00, 0xd8, 0x7c, 0x9d, 0xd2, 0x00, 0x02] <> payload
+  let icmp = IcmpEchoRequest (IcmpId 40402) (IcmpSqnum 2) payload
+  (B.toStrict . encode) icmp @=? testIcmp
+
+

theta.cabal

@@ -16,12 +16,13 @@ extra-source-files:  README.md
 
 library theta-lib
   hs-source-dirs:      src
-  modules:             Packets.Serializable
-                     , Packets.L2
+  exposed-modules:     Packets.L2
+                     , Packets.L3
                      , Packets.MacAddress
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
                      , bytestring
+                     , binary
   ghc-options:         -Wall
                        -Wcompat
                        -Widentities
@@ -37,6 +38,7 @@ Test-Suite test-theta
   hs-source-dirs:      src test
   main-is:             Test.hs
   other-modules:       Test.Packets.MacAddress
+                     , Test.Packets.L3
   build-depends:       base
                      , theta-lib
                      , tasty
@@ -44,3 +46,4 @@ Test-Suite test-theta
                      , tasty-hedgehog
                      , hedgehog
                      , bytestring
+                     , binary