module Net.IPv4 where

-- Internet Protocol
-- reference: http://rfc.net/std0005.html

import Data.Char
import Net.Bits
import Net.Utils
import Net.Packet
import Net.PacketParsing

data Addr           = Addr !Word8 !Word8 !Word8 !Word8
                      deriving (Addr -> Addr -> Bool
(Addr -> Addr -> Bool) -> (Addr -> Addr -> Bool) -> Eq Addr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Addr -> Addr -> Bool
== :: Addr -> Addr -> Bool
$c/= :: Addr -> Addr -> Bool
/= :: Addr -> Addr -> Bool
Eq,Eq Addr
Eq Addr =>
(Addr -> Addr -> Ordering)
-> (Addr -> Addr -> Bool)
-> (Addr -> Addr -> Bool)
-> (Addr -> Addr -> Bool)
-> (Addr -> Addr -> Bool)
-> (Addr -> Addr -> Addr)
-> (Addr -> Addr -> Addr)
-> Ord Addr
Addr -> Addr -> Bool
Addr -> Addr -> Ordering
Addr -> Addr -> Addr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Addr -> Addr -> Ordering
compare :: Addr -> Addr -> Ordering
$c< :: Addr -> Addr -> Bool
< :: Addr -> Addr -> Bool
$c<= :: Addr -> Addr -> Bool
<= :: Addr -> Addr -> Bool
$c> :: Addr -> Addr -> Bool
> :: Addr -> Addr -> Bool
$c>= :: Addr -> Addr -> Bool
>= :: Addr -> Addr -> Bool
$cmax :: Addr -> Addr -> Addr
max :: Addr -> Addr -> Addr
$cmin :: Addr -> Addr -> Addr
min :: Addr -> Addr -> Addr
Ord)

loopbackAddr :: Addr
loopbackAddr = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr Word8
127 Word8
0 Word8
0 Word8
1
broadcastAddr :: Addr -> Addr
broadcastAddr Addr
a = Addr
a Addr -> Addr -> Addr
`orAddr` Addr -> Addr
complAddr (Addr -> Addr
defaultNetmask Addr
a)

type Netmask = Addr
netmaskA :: Addr
netmaskA = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr Word8
255 Word8
0 Word8
0 Word8
0
netmaskB :: Addr
netmaskB = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr Word8
255 Word8
255 Word8
0 Word8
0
netmaskC :: Addr
netmaskC = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr Word8
255 Word8
255 Word8
255 Word8
0

defaultNetmask :: Addr -> Addr
defaultNetmask (Addr Word8
b Word8
_ Word8
_ Word8
_)
  | Word8
bWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<Word8
128 = Addr
netmaskA
  | Word8
bWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<Word8
192 = Addr
netmaskB
  | Word8
bWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<Word8
224 = Addr
netmaskC

sameNet :: (Addr, Addr) -> Addr -> Bool
sameNet (Addr
netIP,Addr
netmask) Addr
ip = Addr
ip Addr -> Addr -> Addr
`andAddr` Addr
netmask Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
netIP Addr -> Addr -> Addr
`andAddr` Addr
netmask

liftA1 :: (Word8 -> Word8) -> Addr -> Addr
liftA1 Word8 -> Word8
f (Addr Word8
b1 Word8
b2 Word8
b3 Word8
b4) = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr (Word8 -> Word8
f Word8
b1) (Word8 -> Word8
f Word8
b2) (Word8 -> Word8
f Word8
b3) (Word8 -> Word8
f Word8
b4)
liftA2 :: (Word8 -> Word8 -> Word8) -> Addr -> Addr -> Addr
liftA2 Word8 -> Word8 -> Word8
f (Addr Word8
a1 Word8
a2 Word8
a3 Word8
a4) (Addr Word8
b1 Word8
b2 Word8
b3 Word8
b4) =
  Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr (Word8 -> Word8 -> Word8
f Word8
a1 Word8
b1) (Word8 -> Word8 -> Word8
f Word8
a2 Word8
b2) (Word8 -> Word8 -> Word8
f Word8
a3 Word8
b3) (Word8 -> Word8 -> Word8
f Word8
a4 Word8
b4)

andAddr :: Addr -> Addr -> Addr
andAddr   = (Word8 -> Word8 -> Word8) -> Addr -> Addr -> Addr
Net.IPv4.liftA2 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
(.&.)
orAddr :: Addr -> Addr -> Addr
orAddr    = (Word8 -> Word8 -> Word8) -> Addr -> Addr -> Addr
Net.IPv4.liftA2 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
(.|.)
complAddr :: Addr -> Addr
complAddr = (Word8 -> Word8) -> Addr -> Addr
liftA1 Word8 -> Word8
forall a. Bits a => a -> a
complement

--instance Bits Addr where
-- We don't need numeric operations or shifting...
-- It's a pity that the is only one big monolithic Bits class...

instance Parse Addr where
  parse :: PacketParser Addr
parse = Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr (Word8 -> Word8 -> Word8 -> Word8 -> Addr)
-> PacketParser Word8
-> PacketParser (Word8 -> Word8 -> Word8 -> Addr)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
forall a. Parse a => PacketParser a
parse PacketParser (Word8 -> Word8 -> Word8 -> Addr)
-> PacketParser Word8 -> PacketParser (Word8 -> Word8 -> Addr)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word8
forall a. Parse a => PacketParser a
parse PacketParser (Word8 -> Word8 -> Addr)
-> PacketParser Word8 -> PacketParser (Word8 -> Addr)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word8
forall a. Parse a => PacketParser a
parse PacketParser (Word8 -> Addr)
-> PacketParser Word8 -> PacketParser Addr
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word8
forall a. Parse a => PacketParser a
parse

instance Unparse Addr where
  unparse :: Addr -> UnparseS
unparse (Addr Word8
b1 Word8
b2 Word8
b3 Word8
b4) = (Word8, Word8, Word8, Word8) -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse (Word8
b1,Word8
b2,Word8
b3,Word8
b4)

instance Show Addr where
  show :: Addr -> String
show (Addr Word8
a Word8
b Word8
c Word8
d)
                    = Word8 -> String
forall a. Show a => a -> String
show Word8
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
d

instance Read Addr where
  readsPrec :: Int -> ReadS Addr
readsPrec Int
_ String
s = [(Word8 -> Word8 -> Word8 -> Word8 -> Addr
Addr Word8
a Word8
b Word8
c Word8
d,String
r)|(Word8
a,String
r1)<-String -> [(Word8, String)]
forall {a}. Read a => String -> [(a, String)]
num String
s,  (()
_,String
r2)<-String -> [((), String)]
dot String
r1,
		                    (Word8
b,String
r3)<-String -> [(Word8, String)]
forall {a}. Read a => String -> [(a, String)]
num String
r2, (()
_,String
r4)<-String -> [((), String)]
dot String
r3,
		                    (Word8
c,String
r5)<-String -> [(Word8, String)]
forall {a}. Read a => String -> [(a, String)]
num String
r4, (()
_,String
r6)<-String -> [((), String)]
dot String
r5,
		                    (Word8
d,String
r )<-String -> [(Word8, String)]
forall {a}. Read a => String -> [(a, String)]
num String
r6]
    where dot :: String -> [((), String)]
dot String
s = [((),String
r)|Char
'.':String
r<-[String
s]]
	  num :: String -> [(a, String)]
num String
s = [(String -> a
forall a. Read a => String -> a
read String
n,String
r)|(n :: String
n@(Char
_:String
_),String
r)<-[(Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s]]

-- 3 bits
data Precedence     = Routine
                    | Priority
                    | Immediate
                    | Flash
                    | Flash_Override
                    | CRITIC_ECP
                    | Internetwork_Control
                    | Network_Control
                      deriving (Int -> Precedence -> ShowS
[Precedence] -> ShowS
Precedence -> String
(Int -> Precedence -> ShowS)
-> (Precedence -> String)
-> ([Precedence] -> ShowS)
-> Show Precedence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Precedence -> ShowS
showsPrec :: Int -> Precedence -> ShowS
$cshow :: Precedence -> String
show :: Precedence -> String
$cshowList :: [Precedence] -> ShowS
showList :: [Precedence] -> ShowS
Show,Int -> Precedence
Precedence -> Int
Precedence -> [Precedence]
Precedence -> Precedence
Precedence -> Precedence -> [Precedence]
Precedence -> Precedence -> Precedence -> [Precedence]
(Precedence -> Precedence)
-> (Precedence -> Precedence)
-> (Int -> Precedence)
-> (Precedence -> Int)
-> (Precedence -> [Precedence])
-> (Precedence -> Precedence -> [Precedence])
-> (Precedence -> Precedence -> [Precedence])
-> (Precedence -> Precedence -> Precedence -> [Precedence])
-> Enum Precedence
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Precedence -> Precedence
succ :: Precedence -> Precedence
$cpred :: Precedence -> Precedence
pred :: Precedence -> Precedence
$ctoEnum :: Int -> Precedence
toEnum :: Int -> Precedence
$cfromEnum :: Precedence -> Int
fromEnum :: Precedence -> Int
$cenumFrom :: Precedence -> [Precedence]
enumFrom :: Precedence -> [Precedence]
$cenumFromThen :: Precedence -> Precedence -> [Precedence]
enumFromThen :: Precedence -> Precedence -> [Precedence]
$cenumFromTo :: Precedence -> Precedence -> [Precedence]
enumFromTo :: Precedence -> Precedence -> [Precedence]
$cenumFromThenTo :: Precedence -> Precedence -> Precedence -> [Precedence]
enumFromThenTo :: Precedence -> Precedence -> Precedence -> [Precedence]
Enum)

instance Parse Precedence where
  parse :: PacketParser Precedence
parse = Int -> Precedence
forall a. Enum a => Int -> a
toEnum (Int -> Precedence) -> PacketParser Int -> PacketParser Precedence
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# Int -> PacketParser Int
forall {a}. (Integral a, Bits a) => Int -> PacketParser a
bits Int
3

-- an IP version 4 packet
data Packet content = Packet
                    { forall content. Packet content -> Word8
version       :: !Word8{-4-}
                    , forall content. Packet content -> Int
headerLen     :: !Int{-4-} -- in units of 4 bytes
		    , forall content. Packet content -> TypeOfService
tos           :: !TypeOfService{-8-}
                    , forall content. Packet content -> Word16
totalLen      :: !Word16 -- in bytes
                    , forall content. Packet content -> Word16
identifier    :: !Word16
                    , forall content. Packet content -> Flags
flags         :: !Flags{-3-}
                    , forall content. Packet content -> Word16
fragOff       :: !Word16{-13-}  -- in units of 8 bytes
                    , forall content. Packet content -> Word8
timeToLive    :: !Word8{-8-}
                    , forall content. Packet content -> Protocol
protocol      :: !Protocol{-8-}
                    , forall content. Packet content -> Word16
headerCheck   :: !Word16
                    , forall content. Packet content -> Addr
source, forall content. Packet content -> Addr
dest  :: !Addr
                    , forall content. Packet content -> [Word8]
options       :: ![Word8]
                    , forall content. Packet content -> content
content       :: !content
                    } deriving Int -> Packet content -> ShowS
[Packet content] -> ShowS
Packet content -> String
(Int -> Packet content -> ShowS)
-> (Packet content -> String)
-> ([Packet content] -> ShowS)
-> Show (Packet content)
forall content. Show content => Int -> Packet content -> ShowS
forall content. Show content => [Packet content] -> ShowS
forall content. Show content => Packet content -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall content. Show content => Int -> Packet content -> ShowS
showsPrec :: Int -> Packet content -> ShowS
$cshow :: forall content. Show content => Packet content -> String
show :: Packet content -> String
$cshowList :: forall content. Show content => [Packet content] -> ShowS
showList :: [Packet content] -> ShowS
Show

data TypeOfService  = TOS
                    { TypeOfService -> Precedence
precedence    :: !Precedence{-3-}
                    , TypeOfService -> Bool
lowDelay      :: !Bool{-1-}
                    , TypeOfService -> Bool
highThrough   :: !Bool{-1-}
                    , TypeOfService -> Bool
highReal      :: !Bool{-1-}
                   -- reserved     :: Bits 2 -- should be zero
                    }
                   deriving Int -> TypeOfService -> ShowS
[TypeOfService] -> ShowS
TypeOfService -> String
(Int -> TypeOfService -> ShowS)
-> (TypeOfService -> String)
-> ([TypeOfService] -> ShowS)
-> Show TypeOfService
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeOfService -> ShowS
showsPrec :: Int -> TypeOfService -> ShowS
$cshow :: TypeOfService -> String
show :: TypeOfService -> String
$cshowList :: [TypeOfService] -> ShowS
showList :: [TypeOfService] -> ShowS
Show

instance Parse TypeOfService where
  parse :: PacketParser TypeOfService
parse = Precedence -> Bool -> Bool -> Bool -> TypeOfService
TOS (Precedence -> Bool -> Bool -> Bool -> TypeOfService)
-> PacketParser Precedence
-> PacketParser (Bool -> Bool -> Bool -> TypeOfService)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Precedence
forall a. Parse a => PacketParser a
parse PacketParser (Bool -> Bool -> Bool -> TypeOfService)
-> PacketParser Bool
-> PacketParser (Bool -> Bool -> TypeOfService)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Bool
forall a. Parse a => PacketParser a
parse PacketParser (Bool -> Bool -> TypeOfService)
-> PacketParser Bool -> PacketParser (Bool -> TypeOfService)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Bool
forall a. Parse a => PacketParser a
parse PacketParser (Bool -> TypeOfService)
-> PacketParser Bool -> PacketParser TypeOfService
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Bool
forall a. Parse a => PacketParser a
parse PacketParser TypeOfService
-> PacketParser Word32 -> PacketParser TypeOfService
forall {m :: * -> *} {b} {a}. Monad m => m b -> m a -> m b
#! Int -> PacketParser Word32
skip Int
2

data Flags          = Flags
                    { -- reserved   :: Bits 1 -- should be zero
                      Flags -> Bool
don'tFrag     :: !Bool{-1-}
                    , Flags -> Bool
moreFrags     :: !Bool{-1-}
                    }
                   deriving Int -> Flags -> ShowS
[Flags] -> ShowS
Flags -> String
(Int -> Flags -> ShowS)
-> (Flags -> String) -> ([Flags] -> ShowS) -> Show Flags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Flags -> ShowS
showsPrec :: Int -> Flags -> ShowS
$cshow :: Flags -> String
show :: Flags -> String
$cshowList :: [Flags] -> ShowS
showList :: [Flags] -> ShowS
Show

instance Parse Flags where
  parse :: PacketParser Flags
parse = (Bool -> Bool -> Flags) -> PacketParser (Bool -> Bool -> Flags)
forall a. a -> PacketParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool -> Bool -> Flags
Flags PacketParser (Bool -> Bool -> Flags)
-> PacketParser Word32 -> PacketParser (Bool -> Bool -> Flags)
forall {m :: * -> *} {b} {a}. Monad m => m b -> m a -> m b
#! Int -> PacketParser Word32
skip Int
1 PacketParser (Bool -> Bool -> Flags)
-> PacketParser Bool -> PacketParser (Bool -> Flags)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Bool
forall a. Parse a => PacketParser a
parse PacketParser (Bool -> Flags)
-> PacketParser Bool -> PacketParser Flags
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Bool
forall a. Parse a => PacketParser a
parse

-- For skipping upto 32 bits:
skip :: Int -> PacketParser Word32
skip :: Int -> PacketParser Word32
skip = Int -> PacketParser Word32
forall {a}. (Integral a, Bits a) => Int -> PacketParser a
bits

template :: Protocol -> Addr -> Addr -> content -> Packet content
template Protocol
proto Addr
src Addr
dst content
body =
           -- A quick hack, I haven't read the RFC... /TH
           Packet   { version :: Word8
version       = Word8
4
                    , headerLen :: Int
headerLen     = Int
5 -- minimum header length
                    , tos :: TypeOfService
tos           = Precedence -> Bool -> Bool -> Bool -> TypeOfService
TOS Precedence
Routine Bool
False Bool
False Bool
False
                    , totalLen :: Word16
totalLen      = Word16
0
                    , identifier :: Word16
identifier    = Word16
0
                    , flags :: Flags
flags         = Bool -> Bool -> Flags
Flags Bool
False Bool
False
                    , fragOff :: Word16
fragOff       = Word16
0
                    , timeToLive :: Word8
timeToLive    = Word8
64
                    , protocol :: Protocol
protocol      = Protocol
proto
                    , headerCheck :: Word16
headerCheck   = Word16
0
                    , source :: Addr
source        = Addr
src
                    , dest :: Addr
dest          = Addr
dst
                    , options :: [Word8]
options       = []
                    , content :: content
content       = content
body
                    }

instance Functor   Packet where fmap :: forall a b. (a -> b) -> Packet a -> Packet b
fmap a -> b
f Packet a
p = Packet a
p { content = f (content p) }
instance Container Packet where contents :: forall content. Packet content -> content
contents = Packet a -> a
forall content. Packet content -> content
content

data Protocol       = ICMP
                    | TCP
                    | UDP
                    | Unknown !Word8
                    deriving (Int -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
(Int -> Protocol -> ShowS)
-> (Protocol -> String) -> ([Protocol] -> ShowS) -> Show Protocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Protocol -> ShowS
showsPrec :: Int -> Protocol -> ShowS
$cshow :: Protocol -> String
show :: Protocol -> String
$cshowList :: [Protocol] -> ShowS
showList :: [Protocol] -> ShowS
Show,Protocol -> Protocol -> Bool
(Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool) -> Eq Protocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
/= :: Protocol -> Protocol -> Bool
Eq)

num_prot           :: [(Int,Protocol)]
num_prot :: [(Int, Protocol)]
num_prot            = [ (Int
1,Protocol
ICMP)
		      , (Int
6,Protocol
TCP)
                      , (Int
17,Protocol
UDP)
                      ]

prot_num           :: [(Protocol,Int)]
prot_num :: [(Protocol, Int)]
prot_num            = ((Int, Protocol) -> (Protocol, Int))
-> [(Int, Protocol)] -> [(Protocol, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Protocol) -> (Protocol, Int)
forall {b} {a}. (b, a) -> (a, b)
swap [(Int, Protocol)]
num_prot
  where swap :: (b, a) -> (a, b)
swap (b
x,a
y)  = (a
y,b
x)

instance Enum Protocol where
  fromEnum :: Protocol -> Int
fromEnum (Unknown Word8
x)  = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x
  fromEnum Protocol
x            = case Protocol -> [(Protocol, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Protocol
x [(Protocol, Int)]
prot_num of
                            Just Int
n -> Int
n
                            Maybe Int
_      -> String -> Int
forall a. HasCallStack => String -> a
error (String
"bug: Protcol number for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Protocol -> String
forall a. Show a => a -> String
show Protocol
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is missing.")

  toEnum :: Int -> Protocol
toEnum Int
x              = case Int -> [(Int, Protocol)] -> Maybe Protocol
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
x [(Int, Protocol)]
num_prot of
                            Maybe Protocol
Nothing -> Word8 -> Protocol
Unknown (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
                            Just Protocol
x  -> Protocol
x

instance Parse Protocol where
  parse :: PacketParser Protocol
parse = Int -> Protocol
forall a. Enum a => Int -> a
toEnum (Int -> Protocol) -> (Word8 -> Int) -> Word8 -> Protocol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Protocol) -> PacketParser Word8 -> PacketParser Protocol
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
word8

instance Unparse Protocol where
  unparse :: Protocol -> UnparseS
unparse Protocol
p = Word8 -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse (Word8
b::Word8)
     where b :: Word8
b = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Protocol -> Int
forall a. Enum a => a -> Int
fromEnum Protocol
p)

-- TODO:
data Option         = Short Word8
                    | Long
                        { Option -> OptType
optType :: OptType
                        , Option -> Word8
optLen  :: Word8    -- includes type & self
                        , Option -> [Word8]
optData :: [Word8] }

data OptType        = OptType
                        { OptType -> Bool
optCopied :: Bool     {-1-}
                        , OptType -> OptClass
optClass  :: OptClass {-2-}
                        , OptType -> Word8
optNumber :: Word8    {-5-}
                        }

data OptClass       = Control | Reserved1 | DebugMeasure | Reserved4
                      deriving Int -> OptClass
OptClass -> Int
OptClass -> [OptClass]
OptClass -> OptClass
OptClass -> OptClass -> [OptClass]
OptClass -> OptClass -> OptClass -> [OptClass]
(OptClass -> OptClass)
-> (OptClass -> OptClass)
-> (Int -> OptClass)
-> (OptClass -> Int)
-> (OptClass -> [OptClass])
-> (OptClass -> OptClass -> [OptClass])
-> (OptClass -> OptClass -> [OptClass])
-> (OptClass -> OptClass -> OptClass -> [OptClass])
-> Enum OptClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: OptClass -> OptClass
succ :: OptClass -> OptClass
$cpred :: OptClass -> OptClass
pred :: OptClass -> OptClass
$ctoEnum :: Int -> OptClass
toEnum :: Int -> OptClass
$cfromEnum :: OptClass -> Int
fromEnum :: OptClass -> Int
$cenumFrom :: OptClass -> [OptClass]
enumFrom :: OptClass -> [OptClass]
$cenumFromThen :: OptClass -> OptClass -> [OptClass]
enumFromThen :: OptClass -> OptClass -> [OptClass]
$cenumFromTo :: OptClass -> OptClass -> [OptClass]
enumFromTo :: OptClass -> OptClass -> [OptClass]
$cenumFromThenTo :: OptClass -> OptClass -> OptClass -> [OptClass]
enumFromThenTo :: OptClass -> OptClass -> OptClass -> [OptClass]
Enum


--instance Parse (Packet InPacket) where parse = ipv4parse # therest

instance Parse contents => Parse (Packet contents) where
  parse :: PacketParser (Packet contents)
parse =
    do Word8
v    <- Int -> PacketParser Word8
forall {a}. (Integral a, Bits a) => Int -> PacketParser a
bits Int
4     -- version       :: !Word8{-4-}
       Int
hl   <- Int -> PacketParser Int
forall {a}. (Integral a, Bits a) => Int -> PacketParser a
bits Int
4     -- headerLen     :: !Int{-4-} -- in units of 4 bytes
       let olen :: Int
olen = (Int
hlInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
5)Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
4  -- length of options and padding
       TypeOfService
tos <- PacketParser TypeOfService
forall a. Parse a => PacketParser a
parse       -- tos           :: !TypeOfService
       Word16
totlen <- PacketParser Word16
forall a. Parse a => PacketParser a
parse    -- totalLen      :: !Int{-16-} -- in bytes
       let datalen :: Int
datalen = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
totlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
hl
       Word8
-> Int
-> TypeOfService
-> Word16
-> Word16
-> Flags
-> Word16
-> Word8
-> Protocol
-> Word16
-> Addr
-> Addr
-> [Word8]
-> contents
-> Packet contents
forall content.
Word8
-> Int
-> TypeOfService
-> Word16
-> Word16
-> Flags
-> Word16
-> Word8
-> Protocol
-> Word16
-> Addr
-> Addr
-> [Word8]
-> content
-> Packet content
Packet Word8
v Int
hl TypeOfService
tos Word16
totlen
	     # parse      -- identifier    :: !Word16
	    PacketParser
  (Flags
   -> Word16
   -> Word8
   -> Protocol
   -> Word16
   -> Addr
   -> Addr
   -> [Word8]
   -> contents
   -> Packet contents)
-> PacketParser Flags
-> PacketParser
     (Word16
      -> Word8
      -> Protocol
      -> Word16
      -> Addr
      -> Addr
      -> [Word8]
      -> contents
      -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Flags
forall a. Parse a => PacketParser a
parse      -- flags         :: !Flags{-3-}
	    PacketParser
  (Word16
   -> Word8
   -> Protocol
   -> Word16
   -> Addr
   -> Addr
   -> [Word8]
   -> contents
   -> Packet contents)
-> PacketParser Word16
-> PacketParser
     (Word8
      -> Protocol
      -> Word16
      -> Addr
      -> Addr
      -> [Word8]
      -> contents
      -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# Int -> PacketParser Word16
forall {a}. (Integral a, Bits a) => Int -> PacketParser a
bits Int
13    -- fragOff       :: !Int{-13-}  -- in units of 8 bytes
	    PacketParser
  (Word8
   -> Protocol
   -> Word16
   -> Addr
   -> Addr
   -> [Word8]
   -> contents
   -> Packet contents)
-> PacketParser Word8
-> PacketParser
     (Protocol
      -> Word16
      -> Addr
      -> Addr
      -> [Word8]
      -> contents
      -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word8
forall a. Parse a => PacketParser a
parse      -- timeToLive    :: !Word8{-8-}
	    PacketParser
  (Protocol
   -> Word16
   -> Addr
   -> Addr
   -> [Word8]
   -> contents
   -> Packet contents)
-> PacketParser Protocol
-> PacketParser
     (Word16 -> Addr -> Addr -> [Word8] -> contents -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Protocol
forall a. Parse a => PacketParser a
parse      -- protocol      :: !Protocol
	    PacketParser
  (Word16 -> Addr -> Addr -> [Word8] -> contents -> Packet contents)
-> PacketParser Word16
-> PacketParser
     (Addr -> Addr -> [Word8] -> contents -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word16
forall a. Parse a => PacketParser a
parse      -- headerCheck   :: !Word16
	    PacketParser
  (Addr -> Addr -> [Word8] -> contents -> Packet contents)
-> PacketParser Addr
-> PacketParser (Addr -> [Word8] -> contents -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Addr
forall a. Parse a => PacketParser a
parse      -- source        :: !Addr
	    PacketParser (Addr -> [Word8] -> contents -> Packet contents)
-> PacketParser Addr
-> PacketParser ([Word8] -> contents -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Addr
forall a. Parse a => PacketParser a
parse      -- dest          :: !Addr
	    PacketParser ([Word8] -> contents -> Packet contents)
-> PacketParser [Word8]
-> PacketParser (contents -> Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# Int -> PacketParser [Word8]
forall {t}. (Eq t, Num t) => t -> PacketParser [Word8]
bytes Int
olen -- options       :: ![Word8]
            #! trunc datalen -- discard padding
	    PacketParser (contents -> Packet contents)
-> PacketParser contents -> PacketParser (Packet contents)
forall {m :: * -> *} {a} {b}. Monad m => m (a -> b) -> m a -> m b
<# PacketParser contents
forall a. Parse a => PacketParser a
parse      -- content       :: !content

{-
ipv4parse          :: InPacket -> Packet InPacket
ipv4parse p         = let headerLen   = fromIntegral (a1 .&. 0x0F)
                          hdrByteLen  = headerLen * 4
                          optBytes    = 4 * headerLen - 20
                          totLen      = fromIntegral (p `wordAt` 2)
                          a1          = p `byteAt` 0
                          a2          = p `byteAt` 1
                          b34         = p `wordAt` 6
                      in Packet
                           { version       = a1 `shiftR` 4
                           , headerLen     = headerLen
                           , precedence    = toEnum (fromIntegral ((a2 .&. 0xE0) `shiftR` 5))
                           , lowDelay      = a2 `testBit` 4
                           , highThrough   = a2 `testBit` 3
                           , highReal      = a2 `testBit` 2
                           , totalLen      = totLen
                           , identifier    = p `wordAt` 4
                           , don'tFrag     = b34 `testBit` 14
                           , moreFrags     = b34 `testBit` 13
                           , fragOff       = fromIntegral (0x1FFF .&. b34)
                           , timeToLive    = fromIntegral (p `byteAt` 8)
                           , protocol      = toEnum (fromIntegral (p `byteAt` 9))
                           , headerCheck   = p `wordAt` 10
                           , source        = Addr (p `byteAt` 12)(p `byteAt` 13)(p `byteAt` 14)(p `byteAt` 15)
                           , dest          = Addr (p `byteAt` 16)(p `byteAt` 17)(p `byteAt` 18)(p `byteAt` 19)
                           , options       = [] -- XXX: take optBytes rest
                           , content       = p { from = from p + hdrByteLen, len = totLen - hdrByteLen }
                           }
-}

instance Unparse a => Unparse (Packet a) where
  unparse :: Packet a -> UnparseS
unparse Packet a
p = OutPacket -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse (Packet OutPacket -> OutPacket
ipv4unparse ((a -> OutPacket) -> Packet a -> Packet OutPacket
forall a b. (a -> b) -> Packet a -> Packet b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> OutPacket
forall {a}. Unparse a => a -> OutPacket
doUnparse Packet a
p))

ipv4unparse        :: Packet OutPacket -> OutPacket
ipv4unparse :: Packet OutPacket -> OutPacket
ipv4unparse Packet OutPacket
p       = Chunk -> OutPacketS
addChunk Chunk
realHeader (Packet OutPacket -> OutPacket
forall content. Packet content -> content
content Packet OutPacket
p)
  where -- computed fields
        hL :: Int
hL          = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
optWords
        optLen :: Int
optLen      = [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Packet OutPacket -> [Word8]
forall content. Packet content -> [Word8]
options Packet OutPacket
p)    --- XXX
        optWords :: Int
optWords    = (Int
optLenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4
        padLen :: Int
padLen      = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
optWords Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
optLen
        tL :: Int
tL          = Int
hL Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ OutPacket -> Int
outLen (Packet OutPacket -> OutPacket
forall content. Packet content -> content
content Packet OutPacket
p)

        realHeader :: Chunk
realHeader  = (Int, Int) -> [Word8] -> Chunk
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,Int
hL Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Word8 -> Word8 -> [Word8]
header Word8
c3 Word8
c4)
        header :: Word8 -> Word8 -> [Word8]
header Word8
c3 Word8
c4 =
                     [ Word8
a1 , Word8
a2 , Word8
a3 , Word8
a4
                     , Word8
b1 , Word8
b2 , Word8
b3 , Word8
b4
                     , Word8
c1 , Word8
c2 , Word8
c3 , Word8
c4
                     , Word8
d1 , Word8
d2 , Word8
d3 , Word8
d4
                     , Word8
e1 , Word8
e2 , Word8
e3 , Word8
e4 ]
                     [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Packet OutPacket -> [Word8]
forall content. Packet content -> [Word8]
options Packet OutPacket
p [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
padLen Word8
0

        -- yuk
        -- perhaps use a diff array here
        -- then the list in OutPacket may be made out of different arrays
        check :: Word16
check       = [Word16] -> Word16
checksum ([Word8] -> [Word16]
bytes_to_words_big (Word8 -> Word8 -> [Word8]
header Word8
0 Word8
0))


        -- 1
        t :: TypeOfService
t           = Packet OutPacket -> TypeOfService
forall content. Packet content -> TypeOfService
tos Packet OutPacket
p
        a1 :: Word8
a1          = (Word8
4 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hL Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0F)
        a2 :: Word8
a2          = Int -> Bool -> Word8 -> Word8
forall {a}. Bits a => Int -> Bool -> a -> a
bit Int
4 (TypeOfService -> Bool
lowDelay TypeOfService
t)
                    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Word8 -> Word8
forall {a}. Bits a => Int -> Bool -> a -> a
bit Int
3 (TypeOfService -> Bool
highThrough TypeOfService
t)
                    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Word8 -> Word8
forall {a}. Bits a => Int -> Bool -> a -> a
bit Int
2 (TypeOfService -> Bool
highReal TypeOfService
t)
                    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Precedence -> Int
forall a. Enum a => a -> Int
fromEnum (TypeOfService -> Precedence
precedence TypeOfService
t)) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
5)
        a3 :: Word8
a3          = Int
tL Int -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1
        a4 :: Word8
a4          = Int
tL Int -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0

        -- 2
        f :: Flags
f           = Packet OutPacket -> Flags
forall content. Packet content -> Flags
flags Packet OutPacket
p
        b1 :: Word8
b1          = Packet OutPacket -> Word16
forall content. Packet content -> Word16
identifier Packet OutPacket
p Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1
        b2 :: Word8
b2          = Packet OutPacket -> Word16
forall content. Packet content -> Word16
identifier Packet OutPacket
p Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0
        b3 :: Word8
b3          = Int -> Bool -> Word8 -> Word8
forall {a}. Bits a => Int -> Bool -> a -> a
bit Int
6 (Flags -> Bool
don'tFrag Flags
f)
                    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Word8 -> Word8
forall {a}. Bits a => Int -> Bool -> a -> a
bit Int
5 (Flags -> Bool
moreFrags Flags
f)
                    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ (Packet OutPacket -> Word16
forall content. Packet content -> Word16
fragOff Packet OutPacket
p Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1)
        b4 :: Word8
b4          = Packet OutPacket -> Word16
forall content. Packet content -> Word16
fragOff Packet OutPacket
p Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0

        -- 3
        c1 :: Word8
c1          = Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Packet OutPacket -> Word8
forall content. Packet content -> Word8
timeToLive Packet OutPacket
p)
        c2 :: Word8
c2          = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Protocol -> Int
forall a. Enum a => a -> Int
fromEnum (Protocol -> Int) -> Protocol -> Int
forall a b. (a -> b) -> a -> b
$ Packet OutPacket -> Protocol
forall content. Packet content -> Protocol
protocol Packet OutPacket
p
        c3 :: Word8
c3          = Word16
check Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1
        c4 :: Word8
c4          = Word16
check Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0

        -- 4
        Addr Word8
d1 Word8
d2 Word8
d3 Word8
d4  = Packet OutPacket -> Addr
forall content. Packet content -> Addr
source Packet OutPacket
p

        -- 5
        Addr Word8
e1 Word8
e2 Word8
e3 Word8
e4  = Packet OutPacket -> Addr
forall content. Packet content -> Addr
dest Packet OutPacket
p

        bit :: Int -> Bool -> a -> a
bit Int
n Bool
b a
a   = if Bool
b then a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`setBit` Int
n else a
a