7 changed files with 181 additions and 217 deletions
@ -0,0 +1,106 @@
@@ -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' |
||||
@ -1,67 +0,0 @@
@@ -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 |
||||
@ -1,13 +0,0 @@
@@ -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 |
||||
@ -0,0 +1,73 @@
@@ -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 |
||||
Loading…
Reference in new issue