module Data.Pack.Packet where
import Control.Applicative
import Control.Monad.IO.Class
import Data.ByteString
import Data.ByteString.Internal (ByteString(..))
import Data.Vector.Storable.Internal (getPtr)
import Foreign
type Packer a = a -> Packet String a
newtype Packet e a = Packet
{ unPacket ::
( ByteString -> Ptr () -> Ptr () -> IO (Ptr (), Either e a)
, Int -> Int
, ByteString -> Ptr () -> Ptr () -> IO (Ptr ()) )
}
instance Functor (Packet e) where
fmap f m =
let (get, size, put) = unPacket m
fmapget (p, e) = return (p, fmap f e)
in Packet (\t b p -> get t b p >>= fmapget, size, put)
instance Applicative (Packet e) where
pure a = Packet
( \_ _ p -> return (p, Right a)
, id
, \_ _ p -> return p)
Packet (fg, fs, fp) <*> Packet (get, size, put) = Packet
( \t b p ->
fg t b p >>= \(p', ef) ->
either (\l -> return (p', Left l)) (\f ->
get t b p' >>= \(p'', ev) ->
either (\l -> return (p'', Left l)) (\v ->
return (p'', Right $ f v)
) ev
) ef
, size . fs
, \t b p -> fp t b p >>= put t b
)
instance Monad (Packet e) where
return = pure
Packet (mg, ms, mp) >>= f =
let Packet (_, size, set) = f (error "packer cannot touch do-bindings")
in Packet
( \t b p ->
mg t b p >>= \(p', eg) ->
either (\r -> return (p', Left r)) (\v ->
let Packet (get, _, _) = f v
in get t b p'
) eg
, size . ms
, \t b p -> mp t b p >>= set t b
)
dimapP :: (b -> a) -> (a -> b) -> (a -> Packet e a) -> b -> Packet e b
dimapP ba ab f b = ab <$> f (ba b)
simple :: Storable a => Int -> (a -> b) -> (b -> a) -> Packer b
simple = fixedPacket (const peek) poke
fixedPacket :: (ByteString -> Ptr a -> IO a) -> (Ptr a -> a -> IO ()) -> Int -> (a -> b) -> (b -> a) -> Packer b
fixedPacket get put n toHost fromHost =
dimapP fromHost toHost $ \a -> Packet
( \bs b p -> (plusPtr p n,) <$> checkBdr n b p (get bs (castPtr p))
, (+n)
, \_ _ p -> put (castPtr p) a >> return (plusPtr p n))
asymmPacket :: (ByteString -> IO (Int, Either String a)) -> (Ptr a -> IO ()) -> Int -> Packet String a
asymmPacket get put putsize = Packet
( \(PS fp _ _) bottom cur -> do
let offset = cur `minusPtr` getPtr fp
let bs = PS fp offset (bottom `minusPtr` cur)
(getsize, value) <- get bs
return (plusPtr cur getsize, value)
, (+ putsize)
, \_ _ p -> put (castPtr p) >> return (plusPtr p putsize))
checkBdr :: Int -> Ptr () -> Ptr () -> IO a -> IO (Either String a)
checkBdr n bottom ptr f | plusPtr ptr n <= bottom = Right <$> f
checkBdr _ _ _ _ = return (Left "not enough bytes.")
getTop :: ByteString -> IO (Ptr a)
getTop (PS fp off _) =
return $ castPtr $ getPtr fp `plusPtr` off