{-# LANGUAGE FlexibleInstances #-}

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.Applicative (Applicative(..), Alternative(..))
import Control.Monad(liftM,MonadPlus(..),ap)
import Net.Packet
import Net.Bits
import Monad.Util

class Parse a where parse :: PacketParser a


newtype PacketParser a = P {forall a. PacketParser a -> In -> Maybe (Out a)
unP::In->Maybe (Out a)}
data In = ByteAligned !InPacket
        | Unaligned !Int !InPacket
emptyIn :: In
emptyIn = InPacket -> In
ByteAligned InPacket
emptyInPack

data Out a = Out !a !In

doParse :: InPacket -> Maybe a
doParse InPacket
p = PacketParser a -> InPacket -> Maybe a
forall {a}. PacketParser a -> InPacket -> Maybe a
parseInPacket PacketParser a
forall a. Parse a => PacketParser a
parse InPacket
p

parseInPacket :: PacketParser a -> InPacket -> Maybe a
parseInPacket (P In -> Maybe (Out a)
parser) InPacket
p =
  case In -> Maybe (Out a)
parser (InPacket -> In
ByteAligned InPacket
p) of
     Just (Out a
result (ByteAligned InPacket
p)) | InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 -> a -> Maybe a
forall a. a -> Maybe a
Just a
result
     Maybe (Out a)
_ -> Maybe a
forall a. Maybe a
Nothing

instance Functor PacketParser where fmap :: forall a b. (a -> b) -> PacketParser a -> PacketParser b
fmap = (a -> b) -> PacketParser a -> PacketParser b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PacketParser where
  pure :: forall a. a -> PacketParser a
pure a
x = (In -> Maybe (Out a)) -> PacketParser a
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out a)) -> PacketParser a)
-> (In -> Maybe (Out a)) -> PacketParser a
forall a b. (a -> b) -> a -> b
$ \ In
p -> Out a -> Maybe (Out a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> In -> Out a
forall a. a -> In -> Out a
Out a
x In
p)
  <*> :: forall a b.
PacketParser (a -> b) -> PacketParser a -> PacketParser b
(<*>) = PacketParser (a -> b) -> PacketParser a -> PacketParser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad PacketParser where
  P In -> Maybe (Out a)
pa >>= :: forall a b.
PacketParser a -> (a -> PacketParser b) -> PacketParser b
>>= a -> PacketParser b
xpb = (In -> Maybe (Out b)) -> PacketParser b
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out b)) -> PacketParser b)
-> (In -> Maybe (Out b)) -> PacketParser b
forall a b. (a -> b) -> a -> b
$ \ In
p0 -> do Out a
x In
p1 <-In -> Maybe (Out a)
pa In
p0
				PacketParser b -> In -> Maybe (Out b)
forall a. PacketParser a -> In -> Maybe (Out a)
unP (a -> PacketParser b
xpb a
x) In
p1

instance MonadFail PacketParser where
  fail :: forall a. String -> PacketParser a
fail String
s = (In -> Maybe (Out a)) -> PacketParser a
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out a)) -> PacketParser a)
-> (In -> Maybe (Out a)) -> PacketParser a
forall a b. (a -> b) -> a -> b
$ \ In
_ -> String -> Maybe (Out a)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s

instance MonadPlus PacketParser where
  mzero :: forall a. PacketParser a
mzero = String -> PacketParser a
forall a. String -> PacketParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no matching alternative"
  P In -> Maybe (Out a)
p1 mplus :: forall a. PacketParser a -> PacketParser a -> PacketParser a
`mplus` P In -> Maybe (Out a)
p2 = (In -> Maybe (Out a)) -> PacketParser a
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out a)) -> PacketParser a)
-> (In -> Maybe (Out a)) -> PacketParser a
forall a b. (a -> b) -> a -> b
$ \ In
p -> In -> Maybe (Out a)
p1 In
p Maybe (Out a) -> Maybe (Out a) -> Maybe (Out a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` In -> Maybe (Out a)
p2 In
p

instance Alternative PacketParser where
  empty :: forall a. PacketParser a
empty = PacketParser a
forall a. PacketParser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall a. PacketParser a -> PacketParser a -> PacketParser a
(<|>) = PacketParser a -> PacketParser a -> PacketParser a
forall a. PacketParser a -> PacketParser a -> PacketParser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Parse InPacket where parse :: PacketParser InPacket
parse = PacketParser InPacket
therest
instance Parse (UArray Int Word8) where parse :: PacketParser (UArray Int Word8)
parse = InPacket -> UArray Int Word8
toChunk (InPacket -> UArray Int Word8)
-> PacketParser InPacket -> PacketParser (UArray Int Word8)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser InPacket
therest

therest :: PacketParser InPacket
therest =
  (In -> Maybe (Out InPacket)) -> PacketParser InPacket
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out InPacket)) -> PacketParser InPacket)
-> (In -> Maybe (Out InPacket)) -> PacketParser InPacket
forall a b. (a -> b) -> a -> b
$ \ In
p ->
  case In
p of
    ByteAligned InPacket
p -> Out InPacket -> Maybe (Out InPacket)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (InPacket -> In -> Out InPacket
forall a. a -> In -> Out a
Out InPacket
p In
emptyIn)
    In
_ -> String -> Maybe (Out InPacket)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The rest is not byte aligned"

trunc :: Int -> PacketParser ()
trunc Int
len' =
  (In -> Maybe (Out ())) -> PacketParser ()
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out ())) -> PacketParser ())
-> (In -> Maybe (Out ())) -> PacketParser ()
forall a b. (a -> b) -> a -> b
$ \ In
p ->
  case In
p of
    ByteAligned InPacket
p ->
      Out () -> Maybe (Out ())
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Out () -> Maybe (Out ())) -> Out () -> Maybe (Out ())
forall a b. (a -> b) -> a -> b
$ () -> In -> Out ()
forall a. a -> In -> Out a
Out () (InPacket -> In
ByteAligned (Int -> InPacket -> InPacket
takeInPack Int
len' InPacket
p))
    In
_ -> String -> Maybe (Out ())
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PacketParsing.trunc: the rest is not byte aligned"

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

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

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

instance Parse a => Parse [a] where
  parse :: PacketParser [a]
parse = ((:) (a -> [a] -> [a]) -> PacketParser a -> PacketParser ([a] -> [a])
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser a
forall a. Parse a => PacketParser a
parse PacketParser ([a] -> [a]) -> PacketParser [a] -> PacketParser [a]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<# PacketParser [a]
forall a. Parse a => PacketParser a
parse) PacketParser [a] -> PacketParser [a] -> PacketParser [a]
forall a. PacketParser a -> PacketParser a -> PacketParser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [a] -> PacketParser [a]
forall a. a -> PacketParser a
forall (m :: * -> *) a. Monad m => a -> m a
return []

instance Parse Bool   where parse :: PacketParser Bool
parse = PacketParser Bool
onebit
instance Parse Word8  where parse :: PacketParser Word8
parse = PacketParser Word8
word8
instance Parse Word16 where parse :: PacketParser Word16
parse = PacketParser Word16
word16
instance Parse Word32 where parse :: PacketParser Word32
parse = PacketParser Word32
word32
instance Parse Char   where parse :: PacketParser Char
parse = Int -> Char
forall a. Enum a => Int -> a
toEnum(Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Char) -> PacketParser Word8 -> PacketParser Char
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
word8 -- No Unicode!!

-- Bit numbering within bytes is big endian: 0=highest bit, 7=lowest bit
onebit :: PacketParser Bool
onebit =
  (In -> Maybe (Out Bool)) -> PacketParser Bool
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out Bool)) -> PacketParser Bool)
-> (In -> Maybe (Out Bool)) -> PacketParser Bool
forall a b. (a -> b) -> a -> b
$ \ In
p ->
  case In
p of
    Unaligned Int
7 InPacket
p ->
	if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
	then String -> Maybe (Out Bool)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
        else Out Bool -> Maybe (Out Bool)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> In -> Out Bool
forall a. a -> In -> Out a
Out (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (InPacket -> Int -> Word8
byteAt InPacket
p Int
0) Int
0) (InPacket -> In
ByteAligned (Int -> InPacket -> InPacket
dropInPack Int
1 InPacket
p)))
    Unaligned Int
o InPacket
p -> Int -> InPacket -> Maybe (Out Bool)
forall {m :: * -> *}.
MonadFail m =>
Int -> InPacket -> m (Out Bool)
unaligned Int
o InPacket
p
    ByteAligned InPacket
p -> Int -> InPacket -> Maybe (Out Bool)
forall {m :: * -> *}.
MonadFail m =>
Int -> InPacket -> m (Out Bool)
unaligned Int
0 InPacket
p
  where
    unaligned :: Int -> InPacket -> m (Out Bool)
unaligned Int
o InPacket
p =
	if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
	then String -> m (Out Bool)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
        else Out Bool -> m (Out Bool)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> In -> Out Bool
forall a. a -> In -> Out a
Out (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (InPacket -> Int -> Word8
byteAt InPacket
p Int
0) (Int
7Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
o)) (Int -> InPacket -> In
Unaligned (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) InPacket
p))


-- Could be more efficient for aligned bytes...
bytes :: t -> PacketParser [Word8]
bytes t
0 = [Word8] -> PacketParser [Word8]
forall a. a -> PacketParser a
forall (m :: * -> *) a. Monad m => a -> m a
return []
bytes t
n = (:) (Word8 -> [Word8] -> [Word8])
-> PacketParser Word8 -> PacketParser ([Word8] -> [Word8])
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
word8 PacketParser ([Word8] -> [Word8])
-> PacketParser [Word8] -> PacketParser [Word8]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<# t -> PacketParser [Word8]
bytes (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)


bits :: Int -> PacketParser a
bits Int
0 = a -> PacketParser a
forall a. a -> PacketParser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
0
bits Int
n =
    if Int
bitcntInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
    then Word8 -> [Word8] -> a
forall {a1} {t} {a}.
(FiniteBits a1, Integral t, Integral a1, Integral a, Bits t) =>
a -> [a1] -> t
join (Word8 -> [Word8] -> a)
-> PacketParser Word8 -> PacketParser ([Word8] -> a)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
word8 PacketParser ([Word8] -> a)
-> PacketParser [Word8] -> PacketParser a
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
bytecntInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    else Word8 -> [Word8] -> a
forall {a1} {t} {a}.
(FiniteBits a1, Integral t, Integral a1, Integral a, Bits t) =>
a -> [a1] -> t
join (Word8 -> [Word8] -> a)
-> PacketParser Word8 -> PacketParser ([Word8] -> a)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# Int -> PacketParser Word8
bits' Int
bitcnt PacketParser ([Word8] -> a)
-> PacketParser [Word8] -> PacketParser a
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
bytecnt
  where
    (Int
bytecnt,Int
bitcnt) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod`  Int
8
    bits' :: Int -> PacketParser Word8
bits' Int
n = -- pre: 1<=n && n<=7
      (In -> Maybe (Out Word8)) -> PacketParser Word8
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out Word8)) -> PacketParser Word8)
-> (In -> Maybe (Out Word8)) -> PacketParser Word8
forall a b. (a -> b) -> a -> b
$ \ In
p ->
      case In
p of
	ByteAligned InPacket
p ->
	    if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
	    then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
	    else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out (InPacket -> Int -> Word8
byteAt InPacket
p Int
0 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n)) (Int -> InPacket -> In
Unaligned Int
n InPacket
p))
	Unaligned Int
offset InPacket
p ->
	  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
offset' Int
8 of
	    Ordering
LT -> if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
		  then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
		  else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out (InPacket -> Int -> Word8
byteAt InPacket
p Int
0 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
offset') Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Int -> Word8
forall {a}. (Num a, Bits a) => Int -> a
mask Int
n)
				   (Int -> InPacket -> In
Unaligned Int
offset' InPacket
p))
	    Ordering
EQ -> if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
		  then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
		  else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out (InPacket -> Int -> Word8
byteAt InPacket
p Int
0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Int -> Word8
forall {a}. (Num a, Bits a) => Int -> a
mask Int
n)
				   (InPacket -> In
ByteAligned (Int -> InPacket -> InPacket
dropInPack Int
1 InPacket
p)))
	    Ordering
GT -> if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
2
		  then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
		  else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out ((InPacket -> Int -> Word8
byteAt InPacket
p Int
0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Int -> Word8
forall {a}. (Num a, Bits a) => Int -> a
mask (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
offset)) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
o
				    Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. InPacket -> Int -> Word8
byteAt InPacket
p Int
1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
o))
				   (Int -> InPacket -> In
Unaligned Int
o (Int -> InPacket -> InPacket
dropInPack Int
1 InPacket
p)))
	     where o :: Int
o = Int
offset'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
8
	  where offset' :: Int
offset' = Int
offsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n

    mask :: Int -> a
mask Int
n = Int -> a
forall a. Bits a => Int -> a
bit Int
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1

    join :: a -> [a1] -> t
join a
b1 [a1]
bs = t -> [a1] -> t
forall {a1} {t}.
(FiniteBits a1, Integral t, Integral a1, Bits t) =>
t -> [a1] -> t
join' (a -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b1) [a1]
bs
    join' :: t -> [a1] -> t
join' t
b1 [] = t
b1
    join' t
b1 (a1
b2:[a1]
bs) = t -> [a1] -> t
join' (t
b1 t -> a1 -> t
forall {a1} {a2} {a3}.
(FiniteBits a1, Integral a2, Integral a1, Num a3, Bits a3) =>
a2 -> a1 -> a3
`nextTo` a1
b2) [a1]
bs

word8 :: PacketParser Word8
word8 =
  (In -> Maybe (Out Word8)) -> PacketParser Word8
forall a. (In -> Maybe (Out a)) -> PacketParser a
P ((In -> Maybe (Out Word8)) -> PacketParser Word8)
-> (In -> Maybe (Out Word8)) -> PacketParser Word8
forall a b. (a -> b) -> a -> b
$ \ In
p ->
  case In
p of
    ByteAligned InPacket
p ->
        if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
	then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
	else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out (InPacket -> Int -> Word8
byteAt InPacket
p Int
0) (InPacket -> In
ByteAligned (Int -> InPacket -> InPacket
dropInPack Int
1 InPacket
p)))
    Unaligned Int
offset InPacket
p ->
        if InPacket -> Int
len InPacket
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
2
	then String -> Maybe (Out Word8)
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End of input"
	else Out Word8 -> Maybe (Out Word8)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> In -> Out Word8
forall a. a -> In -> Out a
Out Word8
out (Int -> InPacket -> In
Unaligned Int
offset (Int -> InPacket -> InPacket
dropInPack Int
1 InPacket
p)))
      where out :: Word8
out = InPacket -> Int -> Word8
byteAt InPacket
p Int
0 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
offset Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. InPacket -> Int -> Word8
byteAt InPacket
p Int
1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
offset)

word16 :: PacketParser Word16
word16 :: PacketParser Word16
word16 = Word8 -> Word8 -> Word16
forall {a1} {a2} {a3}.
(FiniteBits a1, Integral a2, Integral a1, Num a3, Bits a3) =>
a2 -> a1 -> a3
nextTo (Word8 -> Word8 -> Word16)
-> PacketParser Word8 -> PacketParser (Word8 -> Word16)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word8
word8 PacketParser (Word8 -> Word16)
-> PacketParser Word8 -> PacketParser Word16
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word8
word8 -- network byte order = big endian

word32 :: PacketParser Word32
word32 :: PacketParser Word32
word32 = Word16 -> Word16 -> Word32
forall {a1} {a2} {a3}.
(FiniteBits a1, Integral a2, Integral a1, Num a3, Bits a3) =>
a2 -> a1 -> a3
nextTo (Word16 -> Word16 -> Word32)
-> PacketParser Word16 -> PacketParser (Word16 -> Word32)
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# PacketParser Word16
word16 PacketParser (Word16 -> Word32)
-> PacketParser Word16 -> PacketParser Word32
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<# PacketParser Word16
word16 -- network byte order = big endian


check8 :: Word8 -> PacketParser ()
check8 Word8
b = Bool -> PacketParser ()
forall {m :: * -> *}. MonadFail m => Bool -> m ()
check (Bool -> PacketParser ())
-> (Word8 -> Bool) -> Word8 -> PacketParser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
b) (Word8 -> PacketParser ()) -> PacketParser Word8 -> PacketParser ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PacketParser Word8
word8
check16 :: Word16 -> PacketParser ()
check16 Word16
w = Bool -> PacketParser ()
forall {m :: * -> *}. MonadFail m => Bool -> m ()
check (Bool -> PacketParser ())
-> (Word16 -> Bool) -> Word16 -> PacketParser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
==Word16
w) (Word16 -> PacketParser ())
-> PacketParser Word16 -> PacketParser ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PacketParser Word16
word16

check :: Bool -> m ()
check Bool
b = if Bool
b then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () else String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"

lift :: Maybe a -> m a
lift Maybe a
Nothing = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"
lift (Just a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

--------------------------------------------------------------------------------

class Unparse a where unparse :: a -> UnparseS

type UnparseS = Unp -> Unp
data Unp = Unp { Unp -> Int
cnt:: !Int, Unp -> [Word8]
obytes:: ![Word8], Unp -> OutPacket
outpacket:: !OutPacket }

doUnparse :: a -> OutPacket
doUnparse a
x = Unp -> OutPacket
flush (a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
x Unp
empty)
  where empty :: Unp
empty = Int -> [Word8] -> OutPacket -> Unp
Unp Int
0 [] OutPacket
emptyOutPack

instance Unparse Word8 where
  unparse :: Word8 -> UnparseS
unparse Word8
b (Unp Int
cnt [Word8]
bs OutPacket
ps) = Int -> [Word8] -> OutPacket -> Unp
Unp (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Word8
bWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
bs) OutPacket
ps

instance Unparse Word16 where
  unparse :: Word16 -> UnparseS
unparse Word16
w (Unp Int
cnt [Word8]
bs OutPacket
ps) = Int -> [Word8] -> OutPacket -> Unp
Unp (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) (Word8
b1Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:Word8
b2Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
bs) OutPacket
ps
    where b1 :: Word8
b1 = Word16
w Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1
          b2 :: Word8
b2 = Word16
w Word16 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0

instance Unparse Word32 where
  unparse :: Word32 -> UnparseS
unparse Word32
w (Unp Int
cnt [Word8]
bs OutPacket
ps) = Int -> [Word8] -> OutPacket -> Unp
Unp (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4) (Word8
b1Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:Word8
b2Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:Word8
b3Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:Word8
b4Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
bs) OutPacket
ps
    where b1 :: Word8
b1 = Word32
w Word32 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
3
          b2 :: Word8
b2 = Word32
w Word32 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
2
          b3 :: Word8
b3 = Word32
w Word32 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
1
          b4 :: Word8
b4 = Word32
w Word32 -> Int -> Word8
forall {p} {b}.
(Integral p, FiniteBits b, Bits p, Num b) =>
p -> Int -> b
.!. Int
0

instance Unparse OutPacket where
  unparse :: OutPacket -> UnparseS
unparse OutPacket
p Unp
unp = Int -> [Word8] -> OutPacket -> Unp
Unp Int
0 [] (OutPacket -> OutPacket -> OutPacket
appendOutPack (Unp -> OutPacket
flush Unp
unp) OutPacket
p) -- !!

flush :: Unp -> OutPacket
flush (Unp Int
cnt [Word8]
bs OutPacket
ps) = UArray Int Word8 -> OutPacket -> OutPacket
addChunk ((Int, Int) -> [Word8] -> UArray Int Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Word8]
bs) OutPacket
ps
chunk :: UnparseS
chunk = Int -> [Word8] -> OutPacket -> Unp
Unp Int
0 [] (OutPacket -> Unp) -> (Unp -> OutPacket) -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unp -> OutPacket
flush

instance Unparse Chunk where
  unparse :: UArray Int Word8 -> UnparseS
unparse UArray Int Word8
chunk Unp
unp = Int -> [Word8] -> OutPacket -> Unp
Unp Int
0 [] (UArray Int Word8 -> OutPacket -> OutPacket
addChunk UArray Int Word8
chunk (Unp -> OutPacket
flush Unp
unp))

instance Unparse InPacket where
  unparse :: InPacket -> UnparseS
unparse = UArray Int Word8 -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse (UArray Int Word8 -> UnparseS)
-> (InPacket -> UArray Int Word8) -> InPacket -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InPacket -> UArray Int Word8
toChunk

instance Unparse () where
  unparse :: () -> UnparseS
unparse ()
_ = UnparseS
forall a. a -> a
id

instance (Unparse a,Unparse b) => Unparse (a,b) where
  unparse :: (a, b) -> UnparseS
unparse (a
a,b
b) = a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
a UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse b
b

instance (Unparse a,Unparse b,Unparse c) => Unparse (a,b,c) where
  unparse :: (a, b, c) -> UnparseS
unparse (a
a,b
b,c
c) = a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
a UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse b
b UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse c
c

instance (Unparse a,Unparse b,Unparse c,Unparse d) => Unparse (a,b,c,d) where
  unparse :: (a, b, c, d) -> UnparseS
unparse (a
a,b
b,c
c,d
d) = a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
a UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse b
b UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse c
c UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse d
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) -> UnparseS
unparse (a
a,b
b,c
c,d
d,e
e) =
    a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
a UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse b
b UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse c
c UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse d
d UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse e
e

instance Unparse a => Unparse [a] where
  unparse :: [a] -> UnparseS
unparse [] = UnparseS
forall a. a -> a
id
  unparse (a
x:[a]
xs) = a -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse a
x UnparseS -> UnparseS -> UnparseS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse [a]
xs

instance Unparse Char where
  unparse :: Char -> UnparseS
unparse Char
c = Word8 -> UnparseS
forall a. Unparse a => a -> UnparseS
unparse (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)::Word8) -- no Unicode :-(