{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

module Periodic.Types.Packet
  ( Magic (..)
  , Packet
  , getPacketData
  , getPacketMagic
  , packetREQ
  , packetRES
  , getResult

  , RegPacket
  , regPacketREQ
  , regPacketRES
  , getClientType
  ) where

import           Data.Binary             (Binary (..), decode, decodeOrFail,
                                          encode)
import           Data.Binary.Get         (getByteString, getWord32be)
import           Data.Binary.Put         (putByteString, putWord32be)
import           Data.ByteString         (ByteString)
import qualified Data.ByteString         as B (drop, empty, length)
import           Data.ByteString.Lazy    (fromStrict, toStrict)
import           Metro.Class             (GetPacketId (..), RecvPacket (..),
                                          SendPacket (..), SetPacketId (..))
import           Periodic.CRC32          (CRC32 (..), digest)
import           Periodic.Types.Error    (Error (..))
import           Periodic.Types.Internal (Msgid (..))
import           UnliftIO                (throwIO)

data Magic = REQ
    | RES
    deriving (Int -> Magic -> ShowS
[Magic] -> ShowS
Magic -> String
(Int -> Magic -> ShowS)
-> (Magic -> String) -> ([Magic] -> ShowS) -> Show Magic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Magic] -> ShowS
$cshowList :: [Magic] -> ShowS
show :: Magic -> String
$cshow :: Magic -> String
showsPrec :: Int -> Magic -> ShowS
$cshowsPrec :: Int -> Magic -> ShowS
Show, Magic -> Magic -> Bool
(Magic -> Magic -> Bool) -> (Magic -> Magic -> Bool) -> Eq Magic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Magic -> Magic -> Bool
$c/= :: Magic -> Magic -> Bool
== :: Magic -> Magic -> Bool
$c== :: Magic -> Magic -> Bool
Eq)

instance Binary Magic where
  get :: Get Magic
get = do
    ByteString
bs <- Int -> Get ByteString
getByteString 4
    case ByteString
bs of
      "\x00REQ" -> Magic -> Get Magic
forall (f :: * -> *) a. Applicative f => a -> f a
pure Magic
REQ
      "\x00RES" -> Magic -> Get Magic
forall (f :: * -> *) a. Applicative f => a -> f a
pure Magic
RES
      _         -> String -> Get Magic
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Magic) -> String -> Get Magic
forall a b. (a -> b) -> a -> b
$ "No such magic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs

  put :: Magic -> Put
put REQ = ByteString -> Put
putByteString "\x00REQ"
  put RES = ByteString -> Put
putByteString "\x00RES"

magicLength :: Int
magicLength :: Int
magicLength = 4

discoverMagic :: Monad m => ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
discoverMagic :: ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
discoverMagic "\0REQ" _ = (Magic, ByteString) -> m (Magic, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Magic
REQ, "\0REQ")
discoverMagic "\0RES" _ = (Magic, ByteString) -> m (Magic, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Magic
REQ, "\0RES")
discoverMagic prev :: ByteString
prev recv :: Int -> m ByteString
recv = do
  ByteString
bs <- (ByteString
prev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m ByteString
recv 1
  if ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
magicLength then ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
forall (m :: * -> *).
Monad m =>
ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
discoverMagic (Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
magicLength) ByteString
bs) Int -> m ByteString
recv
                               else ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
forall (m :: * -> *).
Monad m =>
ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
discoverMagic ByteString
bs Int -> m ByteString
recv

newtype PacketLength = PacketLength Int
  deriving (Int -> PacketLength -> ShowS
[PacketLength] -> ShowS
PacketLength -> String
(Int -> PacketLength -> ShowS)
-> (PacketLength -> String)
-> ([PacketLength] -> ShowS)
-> Show PacketLength
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PacketLength] -> ShowS
$cshowList :: [PacketLength] -> ShowS
show :: PacketLength -> String
$cshow :: PacketLength -> String
showsPrec :: Int -> PacketLength -> ShowS
$cshowsPrec :: Int -> PacketLength -> ShowS
Show, PacketLength -> PacketLength -> Bool
(PacketLength -> PacketLength -> Bool)
-> (PacketLength -> PacketLength -> Bool) -> Eq PacketLength
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PacketLength -> PacketLength -> Bool
$c/= :: PacketLength -> PacketLength -> Bool
== :: PacketLength -> PacketLength -> Bool
$c== :: PacketLength -> PacketLength -> Bool
Eq)

instance Binary PacketLength where
  get :: Get PacketLength
get = Int -> PacketLength
PacketLength (Int -> PacketLength) -> (Word32 -> Int) -> Word32 -> PacketLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> PacketLength) -> Get Word32 -> Get PacketLength
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
  put :: PacketLength -> Put
put (PacketLength l :: Int
l) = Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l

instance Binary CRC32 where
  get :: Get CRC32
get = Word32 -> CRC32
CRC32 (Word32 -> CRC32) -> Get Word32 -> Get CRC32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
  put :: CRC32 -> Put
put (CRC32 l :: Word32
l) = Word32 -> Put
putWord32be Word32
l

putBS :: ByteString -> Put
putBS bs :: ByteString
bs = do
  PacketLength -> Put
forall t. Binary t => t -> Put
put (PacketLength -> Put) -> PacketLength -> Put
forall a b. (a -> b) -> a -> b
$ Int -> PacketLength
PacketLength (Int -> PacketLength) -> Int -> PacketLength
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bs
  CRC32 -> Put
forall t. Binary t => t -> Put
put (CRC32 -> Put) -> CRC32 -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> CRC32
digest ByteString
bs
  ByteString -> Put
putByteString ByteString
bs

getHead :: Get (Magic, CRC32)
getHead = do
  Magic
magic <- Get Magic
forall t. Binary t => Get t
get
  PacketLength _ <- Get PacketLength
forall t. Binary t => Get t
get
  CRC32
crc <- Get CRC32
forall t. Binary t => Get t
get
  (Magic, CRC32) -> Get (Magic, CRC32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Magic
magic, CRC32
crc)

data Packet a = Packet
    { Packet a -> Magic
packetMagic :: Magic
    , Packet a -> CRC32
packetCRC   :: CRC32
    , Packet a -> Msgid
packetId    :: Msgid
    , Packet a -> a
packetData  :: a
    }
    deriving (Int -> Packet a -> ShowS
[Packet a] -> ShowS
Packet a -> String
(Int -> Packet a -> ShowS)
-> (Packet a -> String) -> ([Packet a] -> ShowS) -> Show (Packet a)
forall a. Show a => Int -> Packet a -> ShowS
forall a. Show a => [Packet a] -> ShowS
forall a. Show a => Packet a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Packet a] -> ShowS
$cshowList :: forall a. Show a => [Packet a] -> ShowS
show :: Packet a -> String
$cshow :: forall a. Show a => Packet a -> String
showsPrec :: Int -> Packet a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Packet a -> ShowS
Show, Packet a -> Packet a -> Bool
(Packet a -> Packet a -> Bool)
-> (Packet a -> Packet a -> Bool) -> Eq (Packet a)
forall a. Eq a => Packet a -> Packet a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Packet a -> Packet a -> Bool
$c/= :: forall a. Eq a => Packet a -> Packet a -> Bool
== :: Packet a -> Packet a -> Bool
$c== :: forall a. Eq a => Packet a -> Packet a -> Bool
Eq)

instance Binary a => Binary (Packet a) where
  get :: Get (Packet a)
get = do
    (magic :: Magic
magic, crc :: CRC32
crc) <- Get (Magic, CRC32)
getHead
    ByteString
pid <- Int -> Get ByteString
getByteString 4
    Magic -> CRC32 -> Msgid -> a -> Packet a
forall a. Magic -> CRC32 -> Msgid -> a -> Packet a
Packet Magic
magic CRC32
crc (ByteString -> Msgid
Msgid ByteString
pid) (a -> Packet a) -> Get a -> Get (Packet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Binary t => Get t
get
  put :: Packet a -> Put
put (Packet magic :: Magic
magic _ (Msgid pid :: ByteString
pid) body :: a
body) = do
    Magic -> Put
forall t. Binary t => t -> Put
put Magic
magic
    ByteString -> Put
putBS (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
pid ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
toStrict (a -> ByteString
forall a. Binary a => a -> ByteString
encode a
body)

commonRecvPacket :: (b -> CRC32) -> (Int -> m ByteString) -> m b
commonRecvPacket f :: b -> CRC32
f recv :: Int -> m ByteString
recv = do
    (_, magicbs :: ByteString
magicbs) <- ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
forall (m :: * -> *).
Monad m =>
ByteString -> (Int -> m ByteString) -> m (Magic, ByteString)
discoverMagic ByteString
B.empty Int -> m ByteString
recv
    ByteString
hbs <- Int -> m ByteString
recv 4
    ByteString
crcbs <- Int -> m ByteString
recv 4
    case ByteString -> PacketLength
forall a. Binary a => ByteString -> a
decode (ByteString -> ByteString
fromStrict ByteString
hbs) of
      PacketLength len :: Int
len -> do
        ByteString
bs <- Int -> m ByteString
recv Int
len
        case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, b)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail (ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
magicbs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
hbs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
crcbs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs) of
          Left (_, _, e1 :: String
e1)   -> Error -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Error -> m b) -> Error -> m b
forall a b. (a -> b) -> a -> b
$ String -> Error
PacketDecodeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ "Packet: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e1
          Right (_, _, pkt :: b
pkt) ->
            if ByteString -> CRC32
digest ByteString
bs CRC32 -> CRC32 -> Bool
forall a. Eq a => a -> a -> Bool
== b -> CRC32
f b
pkt then b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
pkt
                                  else Error -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Error
CRCNotMatch

instance Binary a => RecvPacket (Packet a) where
  recvPacket :: (Int -> m ByteString) -> m (Packet a)
recvPacket = (Packet a -> CRC32) -> (Int -> m ByteString) -> m (Packet a)
forall (m :: * -> *) b.
(Binary b, MonadIO m) =>
(b -> CRC32) -> (Int -> m ByteString) -> m b
commonRecvPacket Packet a -> CRC32
forall a. Packet a -> CRC32
packetCRC

instance Binary a => SendPacket (Packet a) where


instance GetPacketId Msgid (Packet a) where
  getPacketId :: Packet a -> Msgid
getPacketId = Packet a -> Msgid
forall a. Packet a -> Msgid
packetId

instance SetPacketId Msgid (Packet a) where
  setPacketId :: Msgid -> Packet a -> Packet a
setPacketId k :: Msgid
k pkt :: Packet a
pkt = Packet a
pkt { packetId :: Msgid
packetId = Msgid
k }


getPacketData :: Packet a -> a
getPacketData :: Packet a -> a
getPacketData = Packet a -> a
forall a. Packet a -> a
packetData

getPacketMagic :: Packet a -> Magic
getPacketMagic :: Packet a -> Magic
getPacketMagic = Packet a -> Magic
forall a. Packet a -> Magic
packetMagic

packetREQ :: a -> Packet a
packetREQ :: a -> Packet a
packetREQ = Magic -> CRC32 -> Msgid -> a -> Packet a
forall a. Magic -> CRC32 -> Msgid -> a -> Packet a
Packet Magic
REQ (Word32 -> CRC32
CRC32 0) (ByteString -> Msgid
Msgid "0000")

packetRES :: a -> Packet a
packetRES :: a -> Packet a
packetRES = Magic -> CRC32 -> Msgid -> a -> Packet a
forall a. Magic -> CRC32 -> Msgid -> a -> Packet a
Packet Magic
RES (Word32 -> CRC32
CRC32 0) (ByteString -> Msgid
Msgid "0000")

getResult :: a -> (b -> a) -> Maybe (Packet b) -> a
getResult :: a -> (b -> a) -> Maybe (Packet b) -> a
getResult defv :: a
defv _ Nothing  = a
defv
getResult _ f :: b -> a
f (Just rpkt :: Packet b
rpkt) = b -> a
f (Packet b -> b
forall a. Packet a -> a
getPacketData Packet b
rpkt)

data RegPacket a = RegPacket
    { RegPacket a -> Magic
regMagic :: Magic
    , RegPacket a -> CRC32
regCRC   :: CRC32
    , RegPacket a -> a
regType  :: a
    }
    deriving (Int -> RegPacket a -> ShowS
[RegPacket a] -> ShowS
RegPacket a -> String
(Int -> RegPacket a -> ShowS)
-> (RegPacket a -> String)
-> ([RegPacket a] -> ShowS)
-> Show (RegPacket a)
forall a. Show a => Int -> RegPacket a -> ShowS
forall a. Show a => [RegPacket a] -> ShowS
forall a. Show a => RegPacket a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegPacket a] -> ShowS
$cshowList :: forall a. Show a => [RegPacket a] -> ShowS
show :: RegPacket a -> String
$cshow :: forall a. Show a => RegPacket a -> String
showsPrec :: Int -> RegPacket a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RegPacket a -> ShowS
Show, RegPacket a -> RegPacket a -> Bool
(RegPacket a -> RegPacket a -> Bool)
-> (RegPacket a -> RegPacket a -> Bool) -> Eq (RegPacket a)
forall a. Eq a => RegPacket a -> RegPacket a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegPacket a -> RegPacket a -> Bool
$c/= :: forall a. Eq a => RegPacket a -> RegPacket a -> Bool
== :: RegPacket a -> RegPacket a -> Bool
$c== :: forall a. Eq a => RegPacket a -> RegPacket a -> Bool
Eq)

instance Binary a => Binary (RegPacket a) where
  get :: Get (RegPacket a)
get = do
    (magic :: Magic
magic, crc :: CRC32
crc) <- Get (Magic, CRC32)
getHead
    Magic -> CRC32 -> a -> RegPacket a
forall a. Magic -> CRC32 -> a -> RegPacket a
RegPacket Magic
magic CRC32
crc (a -> RegPacket a) -> Get a -> Get (RegPacket a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Binary t => Get t
get
  put :: RegPacket a -> Put
put (RegPacket magic :: Magic
magic _ body :: a
body) = do
    Magic -> Put
forall t. Binary t => t -> Put
put Magic
magic
    ByteString -> Put
putBS (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (a -> ByteString
forall a. Binary a => a -> ByteString
encode a
body)

instance Binary a => RecvPacket (RegPacket a) where
  recvPacket :: (Int -> m ByteString) -> m (RegPacket a)
recvPacket = (RegPacket a -> CRC32) -> (Int -> m ByteString) -> m (RegPacket a)
forall (m :: * -> *) b.
(Binary b, MonadIO m) =>
(b -> CRC32) -> (Int -> m ByteString) -> m b
commonRecvPacket RegPacket a -> CRC32
forall a. RegPacket a -> CRC32
regCRC

instance Binary a => SendPacket (RegPacket a) where

regPacketREQ :: a -> RegPacket a
regPacketREQ :: a -> RegPacket a
regPacketREQ = Magic -> CRC32 -> a -> RegPacket a
forall a. Magic -> CRC32 -> a -> RegPacket a
RegPacket Magic
REQ (Word32 -> CRC32
CRC32 0)

regPacketRES :: a -> RegPacket a
regPacketRES :: a -> RegPacket a
regPacketRES = Magic -> CRC32 -> a -> RegPacket a
forall a. Magic -> CRC32 -> a -> RegPacket a
RegPacket Magic
RES (Word32 -> CRC32
CRC32 0)

getClientType :: RegPacket a -> a
getClientType :: RegPacket a -> a
getClientType = RegPacket a -> a
forall a. RegPacket a -> a
regType