From ae5efe195427ea45014aedbee97accb51e296295 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 22 Oct 2023 19:07:50 +0700 Subject: [PATCH] Move Icmp to corresponding module --- src/Packets/Icmp.hs | 106 ++++++++++++++++++++++++++++++++++++++ src/Packets/L3.hs | 82 ----------------------------- stack.yaml | 67 ------------------------ stack.yaml.lock | 13 ----- test/Test.hs | 4 +- test/Test/Packets/Icmp.hs | 73 ++++++++++++++++++++++++++ test/Test/Packets/L3.hs | 53 ------------------- 7 files changed, 181 insertions(+), 217 deletions(-) create mode 100644 src/Packets/Icmp.hs delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock create mode 100644 test/Test/Packets/Icmp.hs diff --git a/src/Packets/Icmp.hs b/src/Packets/Icmp.hs new file mode 100644 index 0000000..dfd602b --- /dev/null +++ b/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' diff --git a/src/Packets/L3.hs b/src/Packets/L3.hs index df459ec..2f911ca 100644 --- a/src/Packets/L3.hs +++ b/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 - diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index ed28a44..0000000 --- a/stack.yaml +++ /dev/null @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 10c6345..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs index 8293396..94d4b4e 100644 --- a/test/Test.hs +++ b/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 ] diff --git a/test/Test/Packets/Icmp.hs b/test/Test/Packets/Icmp.hs new file mode 100644 index 0000000..0fa5372 --- /dev/null +++ b/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 diff --git a/test/Test/Packets/L3.hs b/test/Test/Packets/L3.hs index 29bc748..627d8a8 100644 --- a/test/Test/Packets/L3.hs +++ b/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 -