module Net.IPv4 where
import Data.Char
import Net.Bits
import Net.Utils
import Net.Packet
import Net.PacketParsing
data Addr = Addr !Word8 !Word8 !Word8 !Word8
deriving (Eq,Ord)
loopbackAddr = Addr 127 0 0 1
broadcastAddr a = a `orAddr` complAddr (defaultNetmask a)
type Netmask = Addr
netmaskA = Addr 255 0 0 0
netmaskB = Addr 255 255 0 0
netmaskC = Addr 255 255 255 0
defaultNetmask (Addr b _ _ _)
| b<128 = netmaskA
| b<192 = netmaskB
| b<224 = netmaskC
sameNet (netIP,netmask) ip = ip `andAddr` netmask == netIP `andAddr` netmask
liftA1 f (Addr b1 b2 b3 b4) = Addr (f b1) (f b2) (f b3) (f b4)
liftA2 f (Addr a1 a2 a3 a4) (Addr b1 b2 b3 b4) =
Addr (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4)
andAddr = liftA2 (.&.)
orAddr = liftA2 (.|.)
complAddr = liftA1 complement
instance Parse Addr where
parse = Addr # parse <# parse <# parse <# parse
instance Unparse Addr where
unparse (Addr b1 b2 b3 b4) = unparse (b1,b2,b3,b4)
instance Show Addr where
show (Addr a b c d)
= show a ++ "."
++ show b ++ "."
++ show c ++ "."
++ show d
instance Read Addr where
readsPrec _ s = [(Addr a b c d,r)|(a,r1)<-num s, (_,r2)<-dot r1,
(b,r3)<-num r2, (_,r4)<-dot r3,
(c,r5)<-num r4, (_,r6)<-dot r5,
(d,r )<-num r6]
where dot s = [((),r)|'.':r<-[s]]
num s = [(read n,r)|(n@(_:_),r)<-[span isDigit s]]
data Precedence = Routine
| Priority
| Immediate
| Flash
| Flash_Override
| CRITIC_ECP
| Internetwork_Control
| Network_Control
deriving (Show,Enum)
instance Parse Precedence where
parse = toEnum # bits 3
data Packet content = Packet
{ version :: !Word8
, headerLen :: !Int
, tos :: !TypeOfService
, totalLen :: !Word16
, identifier :: !Word16
, flags :: !Flags
, fragOff :: !Word16
, timeToLive :: !Word8
, protocol :: !Protocol
, headerCheck :: !Word16
, source, dest :: !Addr
, options :: ![Word8]
, content :: !content
} deriving Show
data TypeOfService = TOS
{ precedence :: !Precedence
, lowDelay :: !Bool
, highThrough :: !Bool
, highReal :: !Bool
}
deriving Show
instance Parse TypeOfService where
parse = TOS # parse <# parse <# parse <# parse #! skip 2
data Flags = Flags
{
don'tFrag :: !Bool
, moreFrags :: !Bool
}
deriving Show
instance Parse Flags where
parse = return Flags #! skip 1 <# parse <# parse
skip :: Int -> PacketParser Word32
skip = bits
template proto src dst body =
Packet { version = 4
, headerLen = 5
, tos = TOS Routine False False False
, totalLen = 0
, identifier = 0
, flags = Flags False False
, fragOff = 0
, timeToLive = 64
, protocol = proto
, headerCheck = 0
, source = src
, dest = dst
, options = []
, content = body
}
instance Functor Packet where fmap f p = p { content = f (content p) }
instance Container Packet where contents = content
data Protocol = ICMP
| TCP
| UDP
| Unknown !Word8
deriving (Show,Eq)
num_prot :: [(Int,Protocol)]
num_prot = [ (1,ICMP)
, (6,TCP)
, (17,UDP)
]
prot_num :: [(Protocol,Int)]
prot_num = map swap num_prot
where swap (x,y) = (y,x)
instance Enum Protocol where
fromEnum (Unknown x) = fromIntegral x
fromEnum x = case lookup x prot_num of
Just n -> n
_ -> error ("bug: Protcol number for " ++ show x ++ " is missing.")
toEnum x = case lookup x num_prot of
Nothing -> Unknown (fromIntegral x)
Just x -> x
instance Parse Protocol where
parse = toEnum . fromIntegral # word8
instance Unparse Protocol where
unparse p = unparse (b::Word8)
where b = fromIntegral (fromEnum p)
data Option = Short Word8
| Long
{ optType :: OptType
, optLen :: Word8
, optData :: [Word8] }
data OptType = OptType
{ optCopied :: Bool
, optClass :: OptClass
, optNumber :: Word8
}
data OptClass = Control | Reserved1 | DebugMeasure | Reserved4
deriving Enum
instance Parse contents => Parse (Packet contents) where
parse =
do v <- bits 4
hl <- bits 4
let olen = (hl5)*4
tos <- parse
totlen <- parse
let datalen = fromIntegral totlen 4*hl
Packet v hl tos totlen
# parse
<# parse
<# bits 13
<# parse
<# parse
<# parse
<# parse
<# parse
<# bytes olen
#! trunc datalen
<# parse
instance Unparse a => Unparse (Packet a) where
unparse p = unparse (ipv4unparse (fmap doUnparse p))
ipv4unparse :: Packet OutPacket -> OutPacket
ipv4unparse p = addChunk realHeader (content p)
where
hL = 5 + optWords
optLen = length (options p)
optWords = (optLen+3) `div` 4
padLen = 4 * optWords optLen
tL = hL * 4 + outLen (content p)
realHeader = listArray (0,hL * 4 1) (header c3 c4)
header c3 c4 =
[ a1 , a2 , a3 , a4
, b1 , b2 , b3 , b4
, c1 , c2 , c3 , c4
, d1 , d2 , d3 , d4
, e1 , e2 , e3 , e4 ]
++ options p ++ replicate padLen 0
check = checksum (bytes_to_words_big (header 0 0))
t = tos p
a1 = (4 `shiftL` 4) .|. (fromIntegral hL .&. 0x0F)
a2 = bit 4 (lowDelay t)
$ bit 3 (highThrough t)
$ bit 2 (highReal t)
$ (fromIntegral (fromEnum (precedence t)) `shiftL` 5)
a3 = tL .!. 1
a4 = tL .!. 0
f = flags p
b1 = identifier p .!. 1
b2 = identifier p .!. 0
b3 = bit 6 (don'tFrag f)
$ bit 5 (moreFrags f)
$ (fragOff p .!. 1)
b4 = fragOff p .!. 0
c1 = fromIntegral (timeToLive p)
c2 = fromIntegral $ fromEnum $ protocol p
c3 = check .!. 1
c4 = check .!. 0
Addr d1 d2 d3 d4 = source p
Addr e1 e2 e3 e4 = dest p
bit n b a = if b then a `setBit` n else a