module Hans.Message.Icmp4 where
import Hans.Address.IP4 (IP4)
import Hans.Message.Types (Lifetime,parseLifetime,renderLifetime)
import Hans.Utils (chunk)
import Hans.Utils.Checksum (pokeChecksum, computeChecksum)
import Control.Monad (liftM2, unless, when, replicateM)
import Data.Serialize (Serialize(..))
import Data.Serialize.Get (getWord8, getByteString, remaining, skip, Get, label,
lookAhead, getBytes, isEmpty, runGet)
import Data.Serialize.Put (Putter, putWord8,putByteString, Put, runPut)
import Data.Int (Int32)
import Data.Word (Word8,Word16,Word32)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
data Icmp4Packet
= EchoReply Identifier SequenceNumber S.ByteString
| DestinationUnreachable DestinationUnreachableCode S.ByteString
| SourceQuench S.ByteString
| Redirect RedirectCode IP4 S.ByteString
| Echo Identifier SequenceNumber S.ByteString
| RouterAdvertisement Lifetime [RouterAddress]
| RouterSolicitation
| TimeExceeded TimeExceededCode S.ByteString
| ParameterProblem Word8 S.ByteString
| Timestamp Identifier SequenceNumber Word32 Word32 Word32
| TimestampReply Identifier SequenceNumber Word32 Word32 Word32
| Information Identifier SequenceNumber
| InformationReply Identifier SequenceNumber
| TraceRoute TraceRouteCode Identifier Word16 Word16 Word32 Word32
| AddressMask Identifier SequenceNumber
| AddressMaskReply Identifier SequenceNumber Word32
deriving (Eq,Show)
noCode :: String -> Get ()
noCode str = do
code <- getWord8
unless (code == 0)
(fail (str ++ " expects code 0"))
parseIcmp4Packet :: S.ByteString -> Either String Icmp4Packet
parseIcmp4Packet = runGet $ do
rest <- lookAhead (getBytes =<< remaining)
unless (computeChecksum 0 rest == 0)
(fail "Bad checksum")
getIcmp4Packet
getIcmp4Packet :: Get Icmp4Packet
getIcmp4Packet = label "ICMP" $ do
ty <- get
let firstGet :: Serialize a => String -> (a -> Get b) -> Get b
firstGet labelString f = label labelString $ do
code <- get
skip 2
f code
case (ty :: Word8) of
0 -> firstGet "Echo Reply" $ \ NoCode -> do
ident <- get
seqNum <- get
dat <- getByteString =<< remaining
return $! EchoReply ident seqNum dat
3 -> firstGet "DestinationUnreachable" $ \ code -> do
skip 4
dat <- getByteString =<< remaining
return $! DestinationUnreachable code dat
4 -> firstGet "Source Quence" $ \ NoCode -> do
skip 4
dat <- getByteString =<< remaining
return $! SourceQuench dat
5 -> firstGet "Redirect" $ \ code -> do
gateway <- get
dat <- getByteString =<< remaining
return $! Redirect code gateway dat
8 -> firstGet "Echo" $ \ NoCode -> do
ident <- get
seqNum <- get
dat <- getByteString =<< remaining
return $! Echo ident seqNum dat
9 -> firstGet "Router Advertisement" $ \ NoCode -> do
n <- getWord8
sz <- getWord8
unless (sz == 2)
(fail ("Expected size 2, got: " ++ show sz))
lifetime <- parseLifetime
addrs <- replicateM (fromIntegral n) get
return $! RouterAdvertisement lifetime addrs
10 -> firstGet "Router Solicitation" $ \ NoCode -> do
skip 4
return RouterSolicitation
11 -> firstGet "Time Exceeded" $ \ code -> do
skip 4
dat <- getByteString =<< remaining
return $! TimeExceeded code dat
12 -> firstGet "Parameter Problem" $ \ NoCode -> do
ptr <- getWord8
skip 3
dat <- getByteString =<< remaining
return $! ParameterProblem ptr dat
13 -> firstGet "Timestamp" $ \ NoCode -> do
ident <- get
seqNum <- get
origTime <- get
recvTime <- get
tranTime <- get
return $! Timestamp ident seqNum origTime recvTime tranTime
14 -> firstGet "Timestamp Reply" $ \ NoCode -> do
ident <- get
seqNum <- get
origTime <- get
recvTime <- get
tranTime <- get
return $! TimestampReply ident seqNum origTime recvTime tranTime
15 -> firstGet "Information" $ \ NoCode -> do
ident <- get
seqNum <- get
return $! Information ident seqNum
16 -> firstGet "Information Reply" $ \ NoCode -> do
ident <- get
seqNum <- get
return $! InformationReply ident seqNum
17 -> firstGet "Address Mask" $ \ NoCode -> do
ident <- get
seqNum <- get
skip 4
return $! AddressMask ident seqNum
18 -> firstGet "Address Mask Reply" $ \ NoCode -> do
ident <- get
seqNum <- get
mask <- get
return $! AddressMaskReply ident seqNum mask
30 -> firstGet "Trace Route" $ \ code -> do
ident <- get
skip 2
outHop <- get
retHop <- get
speed <- get
mtu <- get
return $! TraceRoute code ident outHop retHop speed mtu
_ -> fail ("Unknown type: " ++ show ty)
renderIcmp4Packet :: Icmp4Packet -> L.ByteString
renderIcmp4Packet icmp =
chunk (unsafePerformIO (setChecksum (runPut (putIcmp4Packet icmp))))
where
setChecksum pkt = pokeChecksum (computeChecksum 0 pkt) pkt 2
putIcmp4Packet :: Putter Icmp4Packet
putIcmp4Packet = put'
where
firstPut :: Serialize a => Word8 -> a -> Put
firstPut ty code
= do put ty
put code
put (0 :: Word16)
put' (EchoReply ident seqNum dat)
= do firstPut 0 NoCode
put ident
put seqNum
putByteString dat
put' (DestinationUnreachable code dat)
= do firstPut 3 code
put (0 :: Word32)
putByteString dat
put' (SourceQuench dat)
= do firstPut 4 NoCode
put (0 :: Word32)
putByteString dat
put' (Redirect code gateway dat)
= do firstPut 5 code
put gateway
putByteString dat
put' (Echo ident seqNum dat)
= do firstPut 8 NoCode
put ident
put seqNum
putByteString dat
put' (RouterAdvertisement lifetime addrs)
= do let len = length addrs
addrSize :: Word8
addrSize = 2
when (len > 255)
(fail "Too many routers in Router Advertisement")
firstPut 9 NoCode
put (fromIntegral len :: Word8)
put addrSize
renderLifetime lifetime
mapM_ put addrs
put' RouterSolicitation
= do firstPut 10 NoCode
put (0 :: Word32)
put' (TimeExceeded code dat)
= do firstPut 11 code
put (0 :: Word32)
putByteString dat
put' (ParameterProblem ptr dat)
= do firstPut 12 NoCode
put ptr
put (0 :: Word8)
put (0 :: Word16)
putByteString dat
put' (Timestamp ident seqNum origTime recvTime tranTime)
= do firstPut 13 NoCode
put ident
put seqNum
put origTime
put recvTime
put tranTime
put' (TimestampReply ident seqNum origTime recvTime tranTime)
= do firstPut 14 NoCode
put ident
put seqNum
put origTime
put recvTime
put tranTime
put' (Information ident seqNum)
= do firstPut 15 NoCode
put ident
put seqNum
put' (InformationReply ident seqNum)
= do firstPut 16 NoCode
put ident
put seqNum
put' (AddressMask ident seqNum)
= do firstPut 17 NoCode
put ident
put seqNum
put (0 :: Word32)
put' (AddressMaskReply ident seqNum mask)
= do firstPut 18 NoCode
put ident
put seqNum
put mask
put' (TraceRoute code ident outHop retHop speed mtu)
= do firstPut 30 code
put ident
put (0 :: Word16)
put outHop
put retHop
put speed
put mtu
data NoCode = NoCode
instance Serialize NoCode where
get = do b <- getWord8
unless (b == 0)
(fail ("Expected code 0, got code: " ++ show b))
return NoCode
put NoCode = putWord8 0
data DestinationUnreachableCode
= NetUnreachable
| HostUnreachable
| ProtocolUnreachable
| PortUnreachable
| FragmentationUnreachable
| SourceRouteFailed
| DestinationNetworkUnknown
| DestinationHostUnknown
| SourceHostIsolatedError
| AdministrativelyProhibited
| HostAdministrativelyProhibited
| NetworkUnreachableForTOS
| HostUnreachableForTOS
| CommunicationAdministrativelyProhibited
| HostPrecedenceViolation
| PrecedenceCutoffInEffect
deriving (Eq,Show)
instance Serialize DestinationUnreachableCode where
get = do b <- getWord8
case b of
0 -> return NetUnreachable
1 -> return HostUnreachable
2 -> return ProtocolUnreachable
3 -> return PortUnreachable
4 -> return FragmentationUnreachable
5 -> return SourceRouteFailed
6 -> return DestinationNetworkUnknown
7 -> return DestinationHostUnknown
8 -> return SourceHostIsolatedError
9 -> return AdministrativelyProhibited
10 -> return HostAdministrativelyProhibited
11 -> return NetworkUnreachableForTOS
12 -> return HostUnreachableForTOS
13 -> return CommunicationAdministrativelyProhibited
14 -> return HostPrecedenceViolation
15 -> return PrecedenceCutoffInEffect
_ -> fail "Invalid code for Destination Unreachable"
put code = case code of
NetUnreachable -> putWord8 0
HostUnreachable -> putWord8 1
ProtocolUnreachable -> putWord8 2
PortUnreachable -> putWord8 3
FragmentationUnreachable -> putWord8 4
SourceRouteFailed -> putWord8 5
DestinationNetworkUnknown -> putWord8 6
DestinationHostUnknown -> putWord8 7
SourceHostIsolatedError -> putWord8 8
AdministrativelyProhibited -> putWord8 9
HostAdministrativelyProhibited -> putWord8 10
NetworkUnreachableForTOS -> putWord8 11
HostUnreachableForTOS -> putWord8 12
CommunicationAdministrativelyProhibited -> putWord8 13
HostPrecedenceViolation -> putWord8 14
PrecedenceCutoffInEffect -> putWord8 15
data TimeExceededCode
= TimeToLiveExceededInTransit
| FragmentReassemblyTimeExceeded
deriving (Eq,Show)
instance Serialize TimeExceededCode where
get = do b <- getWord8
case b of
0 -> return TimeToLiveExceededInTransit
1 -> return FragmentReassemblyTimeExceeded
_ -> fail "Invalid code for Time Exceeded"
put TimeToLiveExceededInTransit = putWord8 0
put FragmentReassemblyTimeExceeded = putWord8 1
data RedirectCode
= RedirectForNetwork
| RedirectForHost
| RedirectForTypeOfServiceAndNetwork
| RedirectForTypeOfServiceAndHost
deriving (Eq,Show)
instance Serialize RedirectCode where
get = do b <- getWord8
case b of
0 -> return RedirectForNetwork
1 -> return RedirectForHost
2 -> return RedirectForTypeOfServiceAndNetwork
3 -> return RedirectForTypeOfServiceAndHost
_ -> fail "Invalid code for Time Exceeded"
put RedirectForNetwork = putWord8 0
put RedirectForHost = putWord8 1
put RedirectForTypeOfServiceAndNetwork = putWord8 2
put RedirectForTypeOfServiceAndHost = putWord8 3
data TraceRouteCode
= TraceRouteForwarded
| TraceRouteDiscarded
deriving (Eq,Show)
instance Serialize TraceRouteCode where
get = do b <- getWord8
case b of
0 -> return TraceRouteForwarded
1 -> return TraceRouteDiscarded
_ -> fail "Invalid code for Trace Route"
put TraceRouteForwarded = putWord8 0
put TraceRouteDiscarded = putWord8 1
newtype PreferenceLevel = PreferenceLevel Int32
deriving (Show,Eq,Ord,Num,Serialize)
data RouterAddress = RouterAddress
{ raAddr :: IP4
, raPreferenceLevel :: PreferenceLevel
} deriving (Eq,Show)
instance Serialize RouterAddress where
get = liftM2 RouterAddress get get
put ra = do
put (raAddr ra)
put (raPreferenceLevel ra)
newtype Identifier = Identifier Word16
deriving (Show, Eq, Ord, Num, Serialize)
newtype SequenceNumber = SequenceNumber Word16
deriving (Show, Eq, Ord, Num, Serialize)
getUntilDone :: Serialize a => Get [a]
getUntilDone = do
empty <- isEmpty
if empty then return []
else liftM2 (:) get getUntilDone