Move Icmp to corresponding module

src/Packets/Icmp.hs

@@ -0,0 +1,106 @@
+
+module Packets.Icmp
+  (
+    IcmpType(..)
+  , IcmpCode(..)
+  , IcmpId(..)
+  , IcmpSqnum(..)
+  , IcmpPacket(..)
+  , ipChecksum
+  ) where
+
+import           Data.Binary     (Binary (..), putWord8)
+import           Data.Binary.Get (getRemainingLazyByteString, getWord16be,
+                                  getWord8)
+import           Data.Binary.Put (putByteString, putWord16be, runPut)
+import           Data.Bits       (shiftR, (.&.))
+import qualified Data.ByteString as B
+import           Data.Word       (Word16, Word8)
+import           Prelude         hiding (words)
+
+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
+  put _                    = putWord8 0
+  get = do
+    w <- getWord8
+    case w of
+      8 -> pure IcmpTypeEchoRequest
+      0 -> pure IcmpTypeEchoResponse
+      _ -> fail $ "Unknown icmp type: " <> show w
+
+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 (IcmpEchoResponse icmpId icmpSqnum payload) = putByteString $ fillIcmpChecksum . B.toStrict . runPut $ do
+    put IcmpTypeEchoResponse
+    putWord8 0 -- ICMP Code
+    putWord16be 0 -- Fill later
+    putWord16be . unIcmpId $ icmpId
+    putWord16be . unIcmpSqnum $ icmpSqnum
+    putByteString payload
+
+  put x = error $ "Unable to serialize: " <> show x
+
+  get = do
+    type' <- get
+    if type' == IcmpTypeEchoRequest || type' == IcmpTypeEchoResponse
+      then do
+        _ <- getWord8
+        checksum <- getWord16be -- TODO check
+        icmpId <- getWord16be
+        icmpSqnum <- getWord16be
+        payload <- B.toStrict <$> getRemainingLazyByteString
+        if type' == IcmpTypeEchoRequest
+          then pure $ IcmpEchoRequest (IcmpId icmpId) (IcmpSqnum icmpSqnum) payload
+          else pure $ IcmpEchoResponse (IcmpId icmpId) (IcmpSqnum icmpSqnum) payload
+      else
+        fail $ "Unknown icmp type: " <> show type'

src/Packets/L3.hs

@@ -1,87 +1,5 @@
 
 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 (IcmpEchoResponse icmpId icmpSqnum payload) = putByteString $ fillIcmpChecksum . B.toStrict . runPut $ do
-    put IcmpTypeEchoResponse
-    putWord8 0 -- ICMP Code
-    putWord16be 0 -- Fill later
-    putWord16be . unIcmpId $ icmpId
-    putWord16be . unIcmpSqnum $ icmpSqnum
-    putByteString payload
-
-  get = undefined
-

stack.yaml

@@ -1,67 +0,0 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/12.yaml
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-#   subdirs:
-#   - auto-update
-#   - wai
-packages:
-- .
-# Dependency packages to be pulled from upstream that are not in the resolver.
-# These entries can reference officially published versions as well as
-# forks / in-progress versions pinned to a git hash. For example:
-#
-# extra-deps:
-# - acme-missiles-0.3
-# - git: https://github.com/commercialhaskell/stack.git
-#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#
-# extra-deps: []
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=2.7"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor

stack.yaml.lock

@@ -1,13 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages: []
-snapshots:
-- completed:
-    size: 640036
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/12.yaml
-    sha256: 9313df78f49519315342f4c51ffc5da12659d3735f8ac3c54a1fb98ff874474e
-  original:
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/12.yaml

test/Test.hs

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

test/Test/Packets/Icmp.hs

@@ -0,0 +1,73 @@
+
+module Test.Packets.Icmp
+  (
+    tests
+  ) where
+
+import           Data.Binary         (decode, 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.Icmp
+import           Test.Tasty
+import           Test.Tasty.Hedgehog
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "Icmp" [ unitTests, properties ]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit tests" [ testIpChecksum
+                                   , testSerializeEchoRequest
+                                   , testSerializeEchoResponse ]
+properties :: TestTree
+properties = testGroup "Properties" [ icmpGetPut ]
+
+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
+
+testSerializeEchoResponse :: TestTree
+testSerializeEchoResponse = testCase "serialize IcmpEchoResponse" $ 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 [ 0x00, 0x00, 0xe0, 0x7c, 0x9d, 0xd2, 0x00, 0x02] <> payload
+  let icmp = IcmpEchoResponse (IcmpId 40402) (IcmpSqnum 2) payload
+  (B.toStrict . encode) icmp @=? testIcmp
+
+
+genIcmp :: (MonadGen m) => m IcmpPacket
+genIcmp = do
+  sqnum <- word16 (Range.linearBounded)
+  id' <- word16 (Range.linearBounded)
+  payload <- bytes (Range.linear 10 500)
+  constructor <- element [IcmpEchoRequest, IcmpEchoResponse]
+  pure $ constructor (IcmpId id') (IcmpSqnum sqnum) payload
+
+icmpGetPut :: TestTree
+icmpGetPut = testProperty "get . put = id" $
+  property $ do
+    icmp <- forAll $ genIcmp
+    (decode . encode) icmp === icmp

test/Test/Packets/L3.hs

@@ -1,57 +1,4 @@
 
 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
-                                   , testSerializeEchoResponse ]
-
-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
-
-testSerializeEchoResponse :: TestTree
-testSerializeEchoResponse = testCase "serialize IcmpEchoResponse" $ 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 [ 0x00, 0x00, 0xe0, 0x7c, 0x9d, 0xd2, 0x00, 0x02] <> payload
-  let icmp = IcmpEchoResponse (IcmpId 40402) (IcmpSqnum 2) payload
-  (B.toStrict . encode) icmp @=? testIcmp
-