module Net.PacketParsing(
PacketParser,InPacket,doParse,parseInPacket,( #!),( # ),(<# ),
Parse(..),
bytes,bits,word8,word16,word32,check8,check16,check,lift,therest,trunc,
Unparse(..),OutPacket,doUnparse
) where
import Control.Monad(liftM,MonadPlus(..))
import Net.Packet
import Net.Bits
import Monad.Util
class Parse a where parse :: PacketParser a
newtype PacketParser a = P {unP::In->Maybe (Out a)}
data In = ByteAligned !InPacket
| Unaligned !Int !InPacket
emptyIn = ByteAligned emptyInPack
data Out a = Out !a !In
doParse p = parseInPacket parse p
parseInPacket (P parser) p =
case parser (ByteAligned p) of
Just (Out result (ByteAligned p)) | len p==0 -> Just result
_ -> Nothing
instance Functor PacketParser where fmap = liftM
instance Monad PacketParser where
return x = P $ \ p -> return (Out x p)
P pa >>= xpb = P $ \ p0 -> do Out x p1 <-pa p0
unP (xpb x) p1
fail s = P $ \ _ -> fail s
instance MonadPlus PacketParser where
mzero = fail "no matching alternative"
P p1 `mplus` P p2 = P $ \ p -> p1 p `mplus` p2 p
instance Parse InPacket where parse = therest
instance Parse (UArray Int Word8) where parse = toChunk # therest
therest =
P $ \ p ->
case p of
ByteAligned p -> return (Out p emptyIn)
_ -> fail "The rest is not byte aligned"
trunc len' =
P $ \ p ->
case p of
ByteAligned p ->
return $ Out () (ByteAligned (takeInPack len' p))
_ -> fail "PacketParsing.trunc: the rest is not byte aligned"
instance (Parse a,Parse b) => Parse (a,b) where
parse = (,) # parse <# parse
instance (Parse a,Parse b,Parse c) => Parse (a,b,c) where
parse = (,,) # parse <# parse <# parse
instance (Parse a,Parse b,Parse c,Parse d) => Parse (a,b,c,d) where
parse = (,,,) # parse <# parse <# parse <# parse
instance Parse a => Parse [a] where
parse = ((:) # parse <# parse) `mplus` return []
instance Parse Bool where parse = onebit
instance Parse Word8 where parse = word8
instance Parse Word16 where parse = word16
instance Parse Word32 where parse = word32
instance Parse Char where parse = toEnum.fromIntegral # word8
onebit =
P $ \ p ->
case p of
Unaligned 7 p ->
if len p==0
then fail "End of input"
else return (Out (testBit (byteAt p 0) 0) (ByteAligned (dropInPack 1 p)))
Unaligned o p -> unaligned o p
ByteAligned p -> unaligned 0 p
where
unaligned o p =
if len p==0
then fail "End of input"
else return (Out (testBit (byteAt p 0) (7o)) (Unaligned (o+1) p))
bytes 0 = return []
bytes n = (:) # word8 <# bytes (n1)
bits 0 = return 0
bits n =
if bitcnt==0
then join # word8 <# bytes (bytecnt1)
else join # bits' bitcnt <# bytes bytecnt
where
(bytecnt,bitcnt) = n `divMod` 8
bits' n =
P $ \ p ->
case p of
ByteAligned p ->
if len p==0
then fail "End of input"
else return (Out (byteAt p 0 `shiftR` (8n)) (Unaligned n p))
Unaligned offset p ->
case compare offset' 8 of
LT -> if len p==0
then fail "End of input"
else return (Out (byteAt p 0 `shiftR` (8offset') .&. mask n)
(Unaligned offset' p))
EQ -> if len p==0
then fail "End of input"
else return (Out (byteAt p 0 .&. mask n)
(ByteAligned (dropInPack 1 p)))
GT -> if len p<2
then fail "End of input"
else return (Out ((byteAt p 0 .&. mask (8offset)) `shiftL` o
.|. byteAt p 1 `shiftR` (8o))
(Unaligned o (dropInPack 1 p)))
where o = offset'8
where offset' = offset+n
mask n = bit n 1
join b1 bs = join' (fromIntegral b1) bs
join' b1 [] = b1
join' b1 (b2:bs) = join' (b1 `nextTo` b2) bs
word8 =
P $ \ p ->
case p of
ByteAligned p ->
if len p==0
then fail "End of input"
else return (Out (byteAt p 0) (ByteAligned (dropInPack 1 p)))
Unaligned offset p ->
if len p<2
then fail "End of input"
else return (Out out (Unaligned offset (dropInPack 1 p)))
where out = byteAt p 0 `shiftL` offset .|. byteAt p 1 `shiftR` (8offset)
word16 :: PacketParser Word16
word16 = nextTo # word8 <# word8
word32 :: PacketParser Word32
word32 = nextTo # word16 <# word16
check8 b = check . (==b) =<< word8
check16 w = check . (==w) =<< word16
check b = if b then return () else fail "no parse"
lift Nothing = fail "no parse"
lift (Just x) = return x
class Unparse a where unparse :: a -> UnparseS
type UnparseS = Unp -> Unp
data Unp = Unp { cnt:: !Int, obytes:: ![Word8], outpacket:: !OutPacket }
doUnparse x = flush (unparse x empty)
where empty = Unp 0 [] emptyOutPack
instance Unparse Word8 where
unparse b (Unp cnt bs ps) = Unp (cnt+1) (b:bs) ps
instance Unparse Word16 where
unparse w (Unp cnt bs ps) = Unp (cnt+2) (b1:b2:bs) ps
where b1 = w .!. 1
b2 = w .!. 0
instance Unparse Word32 where
unparse w (Unp cnt bs ps) = Unp (cnt+4) (b1:b2:b3:b4:bs) ps
where b1 = w .!. 3
b2 = w .!. 2
b3 = w .!. 1
b4 = w .!. 0
instance Unparse OutPacket where
unparse p unp = Unp 0 [] (appendOutPack (flush unp) p)
flush (Unp cnt bs ps) = addChunk (listArray (0,cnt1) bs) ps
chunk = Unp 0 [] . flush
instance Unparse Chunk where
unparse chunk unp = Unp 0 [] (addChunk chunk (flush unp))
instance Unparse InPacket where
unparse = unparse . toChunk
instance Unparse () where
unparse _ = id
instance (Unparse a,Unparse b) => Unparse (a,b) where
unparse (a,b) = unparse a . unparse b
instance (Unparse a,Unparse b,Unparse c) => Unparse (a,b,c) where
unparse (a,b,c) = unparse a . unparse b . unparse c
instance (Unparse a,Unparse b,Unparse c,Unparse d) => Unparse (a,b,c,d) where
unparse (a,b,c,d) = unparse a . unparse b . unparse c . unparse d
instance (Unparse a,Unparse b,Unparse c,Unparse d,Unparse e)
=> Unparse (a,b,c,d,e) where
unparse (a,b,c,d,e) =
unparse a . unparse b . unparse c . unparse d . unparse e
instance Unparse a => Unparse [a] where
unparse [] = id
unparse (x:xs) = unparse x . unparse xs
instance Unparse Char where
unparse c = unparse (fromIntegral (fromEnum c)::Word8)