module Nettle.IPv4.IPPacket (
IPPacket(..)
, IPHeader(..)
, DifferentiatedServicesCodePoint
, FragOffset
, IPProtocol
, IPTypeOfService
, TransportPort
, ipTypeTcp
, ipTypeUdp
, ipTypeIcmp
, IPBody(..)
, fromTCPPacket
, fromUDPPacket
, withIPPacket
, foldIPPacket
, foldIPBody
, getIPPacket
, getIPPacket2
, getIPHeader
, ICMPHeader
, ICMPType
, ICMPCode
, getICMPHeader
, TCPHeader
, TCPPortNumber
, getTCPHeader
, UDPHeader
, UDPPortNumber
, getUDPHeader
) where
import Nettle.IPv4.IPAddress
import Data.Bits
import Data.Word
import qualified Data.ByteString.Lazy as B
import Data.HList
import Data.Binary.Strict.Get
import Data.ByteString as S
import qualified Data.Binary.Get as Binary
type IPPacket = IPHeader :*: IPBody :*: HNil
data IPHeader = IPHeader { ipSrcAddress :: !IPAddress
, ipDstAddress :: !IPAddress
, ipProtocol :: !IPProtocol
, headerLength :: !Int
, totalLength :: !Int
, dscp :: !DifferentiatedServicesCodePoint
}
deriving (Read,Show,Eq)
type DifferentiatedServicesCodePoint = Word8
type FragOffset = Word16
type IPProtocol = Word8
type IPTypeOfService = Word8
type TransportPort = Word16
ipTypeTcp, ipTypeUdp, ipTypeIcmp :: IPProtocol
ipTypeTcp = 6
ipTypeUdp = 17
ipTypeIcmp = 1
data IPBody = TCPInIP TCPHeader
| UDPInIP UDPHeader S.ByteString
| ICMPInIP ICMPHeader
| UninterpretedIPBody B.ByteString
deriving (Show,Eq)
foldIPPacket :: (IPHeader -> IPBody -> a) -> IPPacket -> a
foldIPPacket f (HCons h (HCons b HNil)) = f h b
foldIPBody :: (TCPHeader -> a) -> (UDPHeader -> a) -> (ICMPHeader -> a) -> (B.ByteString -> a) -> IPBody -> a
foldIPBody f g h k (TCPInIP x) = f x
foldIPBody f g h k (UDPInIP x body) = g x
foldIPBody f g h k (ICMPInIP x) = h x
foldIPBody f g h k (UninterpretedIPBody x) = k x
fromTCPPacket :: IPBody -> Maybe (TCPHeader :*: HNil)
fromTCPPacket (TCPInIP body) = Just (hCons body hNil)
fromTCPPacket _ = Nothing
fromUDPPacket :: IPBody -> Maybe (UDPHeader :*: S.ByteString :*: HNil)
fromUDPPacket (UDPInIP hdr body) = Just (hCons hdr (hCons body hNil))
fromUDPPacket _ = Nothing
withIPPacket :: HList l => (IPBody -> Maybe l) -> IPPacket -> Maybe (IPHeader :*: l)
withIPPacket f pkt = fmap (hCons (hOccurs pkt)) (f (hOccurs pkt))
getIPHeader :: Get IPHeader
getIPHeader = do
b1 <- getWord8
diffServ <- getWord8
totalLen <- getWord16be
ident <- getWord16be
flagsAndFragOffset <- getWord16be
ttl <- getWord8
nwproto <- getIPProtocol
hdrChecksum <- getWord16be
nwsrc <- getIPAddress
nwdst <- getIPAddress
return (IPHeader { ipSrcAddress = nwsrc
, ipDstAddress = nwdst
, ipProtocol = nwproto
, headerLength = fromIntegral (b1 .&. 0x0f)
, totalLength = fromIntegral totalLen
, dscp = shiftR diffServ 2
} )
getIPHeader2 :: Binary.Get IPHeader
getIPHeader2 = do
b1 <- Binary.getWord8
diffServ <- Binary.getWord8
totalLen <- Binary.getWord16be
ident <- Binary.getWord16be
flagsAndFragOffset <- Binary.getWord16be
ttl <- Binary.getWord8
nwproto <- getIPProtocol2
hdrChecksum <- Binary.getWord16be
nwsrc <- getIPAddress2
nwdst <- getIPAddress2
return (IPHeader { ipSrcAddress = nwsrc
, ipDstAddress = nwdst
, ipProtocol = nwproto
, headerLength = fromIntegral (b1 .&. 0x0f)
, totalLength = fromIntegral totalLen
, dscp = shiftR diffServ 2
} )
getIPProtocol :: Get IPProtocol
getIPProtocol = getWord8
getIPProtocol2 :: Binary.Get IPProtocol
getIPProtocol2 = Binary.getWord8
getIPPacket :: Get IPPacket
getIPPacket = do
hdr <- getIPHeader
body <- getIPBody hdr
return body
where getIPBody hdr@(IPHeader {..})
| ipProtocol == ipTypeTcp = getTCPHeader >>= return . (\tcpHdr -> hCons hdr (hCons (TCPInIP tcpHdr) hNil))
| ipProtocol == ipTypeUdp =
do udpHdr <- getUDPHeader
body <- getByteString (fromIntegral (totalLength (4 * headerLength)) 4)
return (hCons hdr (hCons (UDPInIP udpHdr body) hNil))
| ipProtocol == ipTypeIcmp = getICMPHeader >>= return . (\icmpHdr -> hCons hdr (hCons (ICMPInIP icmpHdr) hNil))
| otherwise =
getByteString (fromIntegral (totalLength (4 * headerLength))) >>=
return . (\bs -> hCons hdr (hCons (UninterpretedIPBody (B.fromChunks [bs])) hNil))
getIPPacket2 :: Binary.Get IPPacket
getIPPacket2 = do
hdr <- getIPHeader2
body <- getIPBody hdr
return body
where getIPBody hdr@(IPHeader {..})
| ipProtocol == ipTypeTcp = getTCPHeader2 >>= return . (\tcpHdr -> hCons hdr (hCons (TCPInIP tcpHdr) hNil))
| ipProtocol == ipTypeUdp = do udpHdr <- getUDPHeader2
body <- Binary.getByteString (fromIntegral (totalLength (4 * headerLength)))
return (hCons hdr (hCons (UDPInIP udpHdr body) hNil))
| ipProtocol == ipTypeIcmp = getICMPHeader2 >>= return . (\icmpHdr -> hCons hdr (hCons (ICMPInIP icmpHdr) hNil))
| otherwise = Binary.getByteString (fromIntegral (totalLength (4 * headerLength))) >>=
return . (\bs -> hCons hdr (hCons (UninterpretedIPBody (B.fromChunks [bs])) hNil))
type ICMPHeader = (ICMPType, ICMPCode)
type ICMPType = Word8
type ICMPCode = Word8
getICMPHeader :: Get ICMPHeader
getICMPHeader = do
icmp_type <- getWord8
icmp_code <- getWord8
skip 6
return (icmp_type, icmp_code)
getICMPHeader2 :: Binary.Get ICMPHeader
getICMPHeader2 = do
icmp_type <- Binary.getWord8
icmp_code <- Binary.getWord8
Binary.skip 6
return (icmp_type, icmp_code)
type TCPHeader = (TCPPortNumber, TCPPortNumber)
type TCPPortNumber = Word16
getTCPHeader :: Get TCPHeader
getTCPHeader = do
srcp <- getWord16be
dstp <- getWord16be
return (srcp,dstp)
getTCPHeader2 :: Binary.Get TCPHeader
getTCPHeader2 = do
srcp <- Binary.getWord16be
dstp <- Binary.getWord16be
return (srcp,dstp)
type UDPHeader = (UDPPortNumber, UDPPortNumber)
type UDPPortNumber = Word16
getUDPHeader :: Get UDPHeader
getUDPHeader = do
srcp <- getWord16be
dstp <- getWord16be
return (srcp,dstp)
getUDPHeader2 :: Binary.Get UDPHeader
getUDPHeader2 = do
srcp <- Binary.getWord16be
dstp <- Binary.getWord16be
return (srcp,dstp)