
module Server.Packet
    ( -- * Pipes
      PacketParseException (..)
    , decoder
    , encoder

      -- * Handshake
    , InboundPacketHandshake (..)
    , getInPacketHandshake
    , OutboundPacketHandshake (..)
    , putOutPacketHandshake

      -- * Login
    , InboundPacketLogin (..)
    , getInPacketLogin
    , OutboundPacketLogin (..)
    , putOutPacketLogin

      -- * Session
    , InboundPacketSession (..)
    , getInPacketSession
    , OutboundPacketSession (..)
    , putOutPacketSession
    ) where

import           Control.Applicative
import           Control.Exception
import qualified Control.Monad.State.Strict as S
import           Data.Word
import           Data.Typeable
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS

import           Data.Binary.Put
import           Data.Binary.Get

import           Pipes
import           Pipes.Binary


decoder :: Monad m
    => Get a
    -> Producer ByteString m r
    -> Producer a m r
decoder getter = decoder_
  where
    decoder_ p0 = do
        x <- lift (next p0)
        case x of
            Left r -> return r
            Right (bs, p1) -> do
                (ea, p2) <- lift $ S.runStateT (decodeGet getter) (yield bs >> p1)
                case ea of
                    Left e  -> throw (PacketParseException e)
                    Right a -> yield a >> decoder_ p2

encoder :: Monad m
    => (a -> Put)
    -> Producer a m r
    -> Producer ByteString m r
encoder putter p = for p (encodePut . putter)


getByteStringWithLen :: Get ByteString
getByteStringWithLen = getWord32be >>= getByteString . fromIntegral

putByteStringWithLen :: ByteString -> Put
putByteStringWithLen bs = putWord32be (fromIntegral $ BS.length bs) >> putByteString bs


data PacketParseException = PacketParseException DecodingError
    deriving (Show, Typeable)

instance Exception PacketParseException


data InboundPacketHandshake = InboundPacketHandshake Word32

getInPacketHandshake :: Get InboundPacketHandshake
getInPacketHandshake = InboundPacketHandshake <$> get

data OutboundPacketHandshake = OutboundPacketHandshake Word32

putOutPacketHandshake :: OutboundPacketHandshake -> Put
putOutPacketHandshake (OutboundPacketHandshake magic) = put magic


data InboundPacketLogin = InboundPacketLogin ByteString ByteString

getInPacketLogin :: Get InboundPacketLogin
getInPacketLogin = InboundPacketLogin <$> getByteStringWithLen <*> getByteStringWithLen

data OutboundPacketLogin
    = OutboundLoginSuccess
    | OutboundLoginFailure

putOutPacketLogin :: OutboundPacketLogin -> Put
putOutPacketLogin p = case p of
    OutboundLoginSuccess -> putWord8 0
    OutboundLoginFailure -> putWord8 1


data InboundPacketSession
    = InboundPacketJoin ByteString
    | InboundPacketMessage ByteString ByteString
    | InboundPacketDisconnect ByteString

getInPacketSession :: Get InboundPacketSession
getInPacketSession = do
    op <- getWord8
    case op of
        0 -> InboundPacketJoin <$> getByteStringWithLen
        1 -> InboundPacketMessage <$> getByteStringWithLen <*> getByteStringWithLen

data OutboundPacketSession
    = OutboundPacketSend ByteString
    | OutboundPacketQuit ByteString

putOutPacketSession :: OutboundPacketSession -> Put
putOutPacketSession p = case p of
    (OutboundPacketSend msg) -> putWord8 0 >> putByteStringWithLen msg
    (OutboundPacketQuit msg) -> putWord8 1 >> putByteStringWithLen msg
