{-# LANGUAGE RecordWildCards #-} module Hans.IP4.Icmp4 where import Hans.Checksum (computeChecksum) import Hans.Device.Types (ChecksumOffload(..)) import Hans.IP4.Packet (IP4,getIP4,putIP4) import Hans.Serialize (runPutPacket) import Control.Monad (unless,when,replicateM,liftM2) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Int (Int32) import Data.Serialize (Serialize(..)) import Data.Serialize.Get (Get,getWord8,getWord16be,getWord32be,getInt32be,label ,getByteString,skip,remaining,isEmpty) import Data.Serialize.Put (Put,Putter,putWord8,putWord16be,putWord32be,putByteString) import Data.Word (Word8,Word16,Word32) -- General ICMP Packets -------------------------------------------------------- type Lifetime = Word16 getLifetime :: Get Lifetime getLifetime = getWord16be putLifetime :: Putter Lifetime putLifetime = putWord16be data Icmp4Packet -- RFC 792 - Internet Control Message Protocol = 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 -- rfc 1393 - Traceroute Using an IP Option | TraceRoute !TraceRouteCode !Identifier !Word16 !Word16 !Word32 !Word32 -- rfc 950 - Internet Standard Subnetting Procedure | 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")) getIcmp4Packet :: Get Icmp4Packet getIcmp4Packet = label "ICMP" $ do ty <- getWord8 let firstGet :: Serialize a => String -> (a -> Get b) -> Get b firstGet labelString f = label labelString $ do code <- get skip 2 -- checksum f code case ty of 0 -> firstGet "Echo Reply" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber dat <- getByteString =<< remaining return $! EchoReply ident seqNum dat 3 -> firstGet "DestinationUnreachable" $ \ code -> do skip 4 -- unused dat <- getByteString =<< remaining return $! DestinationUnreachable code dat 4 -> firstGet "Source Quence" $ \ NoCode -> do skip 4 -- unused dat <- getByteString =<< remaining return $! SourceQuench dat 5 -> firstGet "Redirect" $ \ code -> do gateway <- getIP4 dat <- getByteString =<< remaining return $! Redirect code gateway dat 8 -> firstGet "Echo" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber 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 <- getLifetime addrs <- replicateM (fromIntegral n) get return $! RouterAdvertisement lifetime addrs 10 -> firstGet "Router Solicitation" $ \ NoCode -> do skip 4 -- reserved return RouterSolicitation 11 -> firstGet "Time Exceeded" $ \ code -> do skip 4 -- unused dat <- getByteString =<< remaining return $! TimeExceeded code dat 12 -> firstGet "Parameter Problem" $ \ NoCode -> do ptr <- getWord8 skip 3 -- unused dat <- getByteString =<< remaining return $! ParameterProblem ptr dat 13 -> firstGet "Timestamp" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber origTime <- getWord32be recvTime <- getWord32be tranTime <- getWord32be return $! Timestamp ident seqNum origTime recvTime tranTime 14 -> firstGet "Timestamp Reply" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber origTime <- getWord32be recvTime <- getWord32be tranTime <- getWord32be return $! TimestampReply ident seqNum origTime recvTime tranTime 15 -> firstGet "Information" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber return $! Information ident seqNum 16 -> firstGet "Information Reply" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber return $! InformationReply ident seqNum 17 -> firstGet "Address Mask" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber skip 4 -- address mask return $! AddressMask ident seqNum 18 -> firstGet "Address Mask Reply" $ \ NoCode -> do ident <- getIdentifier seqNum <- getSequenceNumber mask <- getWord32be return $! AddressMaskReply ident seqNum mask 30 -> firstGet "Trace Route" $ \ code -> do ident <- getIdentifier skip 2 -- unused outHop <- getWord16be retHop <- getWord16be speed <- getWord32be mtu <- getWord32be return $! TraceRoute code ident outHop retHop speed mtu _ -> fail ("Unknown type: " ++ show ty) -- NOTE: we may want to parameterize this on the MTU of the device that will -- send the message, as it could fragment. renderIcmp4Packet :: ChecksumOffload -> Icmp4Packet -> L.ByteString renderIcmp4Packet ChecksumOffload { .. } pkt | coIcmp4 = bytes | otherwise = L.take 2 bytes `L.append` runPutPacket 2 100 (L.drop 4 bytes) (putWord16be cs) where -- best guess mtu mtu = 1500 - 20 bytes = runPutPacket mtu mtu L.empty (putIcmp4Packet pkt) cs = computeChecksum bytes putIcmp4Packet :: Putter Icmp4Packet putIcmp4Packet = put' where firstPut :: Serialize a => Word8 -> a -> Put firstPut ty code = do putWord8 ty put code putWord16be 0 put' (EchoReply ident seqNum dat) = do firstPut 0 NoCode putIdentifier ident putSequenceNumber seqNum putByteString dat put' (DestinationUnreachable code dat) = do firstPut 3 code putWord32be 0 -- unused putByteString dat put' (SourceQuench dat) = do firstPut 4 NoCode putWord32be 0 -- unused putByteString dat put' (Redirect code gateway dat) = do firstPut 5 code putIP4 gateway putByteString dat put' (Echo ident seqNum dat) = do firstPut 8 NoCode putIdentifier ident putSequenceNumber seqNum putByteString dat put' (RouterAdvertisement lifetime addrs) = do let len = length addrs addrSize = 2 when (len > 255) (fail "Too many routers in Router Advertisement") firstPut 9 NoCode putWord8 (fromIntegral len) putWord8 addrSize putLifetime lifetime mapM_ put addrs put' RouterSolicitation = do firstPut 10 NoCode putWord32be 0 -- RESERVED put' (TimeExceeded code dat) = do firstPut 11 code putWord32be 0 -- unused putByteString dat put' (ParameterProblem ptr dat) = do firstPut 12 NoCode put ptr putWord8 0 -- unused putWord16be 0 -- unused putByteString dat put' (Timestamp ident seqNum origTime recvTime tranTime) = do firstPut 13 NoCode putIdentifier ident putSequenceNumber seqNum putWord32be origTime putWord32be recvTime putWord32be tranTime put' (TimestampReply ident seqNum origTime recvTime tranTime) = do firstPut 14 NoCode putIdentifier ident putSequenceNumber seqNum putWord32be origTime putWord32be recvTime putWord32be tranTime put' (Information ident seqNum) = do firstPut 15 NoCode putIdentifier ident putSequenceNumber seqNum put' (InformationReply ident seqNum) = do firstPut 16 NoCode putIdentifier ident putSequenceNumber seqNum put' (AddressMask ident seqNum) = do firstPut 17 NoCode putIdentifier ident putSequenceNumber seqNum putWord32be 0 -- address mask put' (AddressMaskReply ident seqNum mask) = do firstPut 18 NoCode putIdentifier ident putSequenceNumber seqNum putWord32be mask put' (TraceRoute code ident outHop retHop speed mtu) = do firstPut 30 code putIdentifier ident putWord16be 0 -- unused putWord16be outHop putWord16be retHop putWord32be speed putWord32be 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 NetUnreachable = putWord8 0 put HostUnreachable = putWord8 1 put ProtocolUnreachable = putWord8 2 put PortUnreachable = putWord8 3 put FragmentationUnreachable = putWord8 4 put SourceRouteFailed = putWord8 5 put DestinationNetworkUnknown = putWord8 6 put DestinationHostUnknown = putWord8 7 put SourceHostIsolatedError = putWord8 8 put AdministrativelyProhibited = putWord8 9 put HostAdministrativelyProhibited = putWord8 10 put NetworkUnreachableForTOS = putWord8 11 put HostUnreachableForTOS = putWord8 12 put CommunicationAdministrativelyProhibited = putWord8 13 put HostPrecedenceViolation = putWord8 14 put 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 -- Router Discovery Data ------------------------------------------------------- type PreferenceLevel = Int32 data RouterAddress = RouterAddress { raAddr :: IP4 , raPreferenceLevel :: PreferenceLevel } deriving (Eq,Show) instance Serialize RouterAddress where get = do raAddr <- getIP4 raPreferenceLevel <- getInt32be return RouterAddress { .. } put RouterAddress { .. } = do putIP4 raAddr putWord32be (fromIntegral raPreferenceLevel) type Identifier = Word16 getIdentifier :: Get Identifier getIdentifier = getWord16be {-# INLINE getIdentifier #-} putIdentifier :: Putter Identifier putIdentifier = putWord16be {-# INLINE putIdentifier #-} type SequenceNumber = Word16 getSequenceNumber :: Get SequenceNumber getSequenceNumber = getWord16be {-# INLINE getSequenceNumber #-} putSequenceNumber :: Putter SequenceNumber putSequenceNumber = putWord16be {-# INLINE putSequenceNumber #-} getUntilDone :: Serialize a => Get [a] getUntilDone = do empty <- isEmpty if empty then return [] else liftM2 (:) get getUntilDone