Module.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module      : Game.GoreAndAsh.Sync.Module
Description : Monad transformer and game module instance
Copyright   : (c) Anton Gushcha, 2015-2016
License     : BSD3
Maintainer  : ncrashed@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Game.GoreAndAsh.Sync.Module(
    SyncT(..)
  , registerSyncIdInternal
  , addSyncTypeRepInternal
  , syncRequestIdInternal
  , getServiceChannel
  , syncLog
  ) where

import Control.Monad.Base 
import Control.Monad.Catch
import Control.Monad.Error.Class 
import Control.Monad.Fix 
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource 
import Data.Maybe
import Data.Monoid 
import Data.Proxy 
import Data.Serialize
import Data.Text (Text, pack)
import Data.Word
import qualified Data.ByteString as BS 
import qualified Data.HashMap.Strict as H 
import qualified Data.Sequence as S 

import Game.GoreAndAsh
import Game.GoreAndAsh.Actor 
import Game.GoreAndAsh.Actor.TypeRep
import Game.GoreAndAsh.Logging
import Game.GoreAndAsh.Network
import Game.GoreAndAsh.Sync.State

-- | Monad transformer of sync core module.
--
-- [@s@] - State of next core module in modules chain;
--
-- [@m@] - Next monad in modules monad stack;
--
-- [@a@] - Type of result value;
--
-- How to embed module:
-- 
-- @
-- type AppStack = ModuleStack [LoggingT, NetworkT, ActorT, SyncT, ... other modules ... ] IO
--
-- -- | Current GHC (7.10.3) isn't able to derive this
-- instance SyncMonad AppMonad where 
--   getSyncIdM = AppMonad . getSyncIdM
--   getSyncTypeRepM = AppMonad . getSyncTypeRepM
--   registerSyncIdM = AppMonad . registerSyncIdM
--   addSyncTypeRepM a b = AppMonad $ addSyncTypeRepM a b
--   syncScheduleMessageM peer ch i mt msg  = AppMonad $ syncScheduleMessageM peer ch i mt msg
--   syncSetLoggingM = AppMonad . syncSetLoggingM
--   syncSetRoleM = AppMonad . syncSetRoleM
--   syncGetRoleM = AppMonad syncGetRoleM
--   syncRequestIdM a b = AppMonad $ syncRequestIdM a b 
--
-- newtype AppMonad a = AppMonad (AppStack a)
--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, MonadThrow, MonadCatch, NetworkMonad, ActorMonad)
-- @
--
-- The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.
newtype SyncT s m a = SyncT { runSyncT :: StateT (SyncState s) m a }
  deriving (Functor, Applicative, Monad, MonadState (SyncState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadError e)

instance MonadBase IO m => MonadBase IO (SyncT s m) where 
  liftBase = SyncT . liftBase 

instance MonadResource m => MonadResource (SyncT s m) where 
  liftResourceT = SyncT . liftResourceT
  
instance (NetworkMonad m, LoggingMonad m, ActorMonad m, GameModule m s) => GameModule (SyncT s m) (SyncState s) where 
  type ModuleState (SyncT s m) = SyncState s
  runModule (SyncT m) s = do
    ((a, s'), nextState) <- runModule runCurrentModule (syncNextState s)
    return (a, s' {
        syncNextState = nextState 
      })  
    where
    runCurrentModule = do 
      (a, s') <- runStateT m s
      s'' <- processServiceMessages s'
      return (a, s'')

  newModuleState = emptySyncState <$> newModuleState
  withModule _ = withModule (Proxy :: Proxy m)
  cleanupModule _ = return ()

-- | Detect service messages arrived to the machine and process them
--
-- Note: service channel had id 1 by default, but if there is no such
-- channel, it fallbacks to 0. Make shure that client and server has corresponding
-- count of channels.
processServiceMessages :: (ActorMonad m, NetworkMonad m, LoggingMonad m) => SyncState s -> m (SyncState s)
processServiceMessages sstate = do 
  serviceChan <- getServiceChannel
  peers <- networkPeersM
  foldM (process serviceChan) sstate peers
  where
  -- | Process one peer
  process serviceChan s peer = do 
    bss <- peerMessagesM peer serviceChan
    let serviceMsgs = catMaybesSeq . fmap decodeService $ bss
    foldM (processService serviceChan peer) s serviceMsgs

  -- | Decode service message
  decodeService bs = case decode bs of 
    Left _ -> Nothing 
    Right (w64 :: Word64, mbs :: BS.ByteString) -> if w64 == 0 
      then case decode mbs of 
        Left _ -> Nothing 
        Right !msg -> Just msg 
      else Nothing 

  -- | Service one service message for given peer
  processService serviceChan peer s serviceMsg = case serviceMsg of
    SyncServiceRequestId aname -> do 
      syncLog s $ "Received request for network id for actor " <> pack aname
      marep <- findActorTypeRepM aname
      case marep of 
        Nothing -> do
          syncLog s "Such actor isn't known"
          sendService peer serviceChan $ SyncServiceResponseNotRegistered aname
          return s
        Just arep -> case H.lookup arep . syncIdMap $ s of 
          Nothing -> do
            syncLog s "Registering actor network id, sending"
            let (w64, s') = registerSyncIdInternal arep s 
            sendService peer serviceChan $ SyncServiceResponseId aname w64
            return s'
          Just w64 -> do 
            syncLog s "Known actor id, sending"
            sendService peer serviceChan $ SyncServiceResponseId aname w64
            return s 
    SyncServiceResponseId aname w64 -> do 
      syncLog s $ "Received response for network id for actor " <> pack aname <> " and id " <> pack (show w64)
      marep <- findActorTypeRepM aname 
      case marep of 
        Nothing -> do
          syncLog s "Not known actor, ignoring"
          return s 
        Just arep -> do 
          syncLog s "Sending all scheduled messages"
          let s' = addSyncTypeRepInternal arep w64 s 
              msgs = fromMaybe S.empty . H.lookup peer . syncScheduledMessages $! s'
          sheduled <- fmap catMaybesSeq . forM msgs $ \(aname', chan, msg) -> if aname == aname'
            then do 
              peerSendM peer chan . msg $! w64 
              return Nothing
            else return $! Just (aname', chan, msg)
          
          let sended = S.length msgs - S.length sheduled
          syncLog s $ "Sended: " <> pack (show sended)
          
          return $! s' {
              syncScheduledMessages = H.insert peer sheduled . syncScheduledMessages $! s'
            }
    SyncServiceResponseNotRegistered aname -> do 
      putMsgLnM $ "Sync module: Failed to resolve actor id with name " <> (pack aname) 
      return s 

-- | Helper for sending service messages
sendService :: (NetworkMonad m, LoggingMonad m) => Peer -> ChannelID -> SyncServiceMsg -> m ()
sendService peer chanid msg = do 
  let msg' = encode (0 :: Word64, encode msg)
  peerSendM peer chanid . Message ReliableMessage $ msg'

-- | catMaybes for sequences
catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a 
catMaybesSeq = fmap fromJust . S.filter isJust

-- | Internal implementation of actor registrarion when monadic context isn't in scope
registerSyncIdInternal :: HashableTypeRep -> SyncState s -> (Word64, SyncState s)
registerSyncIdInternal tr sstate = case H.lookup tr . syncIdMap $! sstate of 
  Just !i -> (i, sstate)
  Nothing -> (i, sstate { 
        syncIdMap = H.insert tr i . syncIdMap $! sstate
      , syncIdMapRev = H.insert i tr . syncIdMapRev $! sstate
      , syncNextId = i+1          
      })
    where
      !i = findNextEmptyId sstate $ syncNextId sstate
  where
    findNextEmptyId ss i = case H.lookup i .syncIdMapRev $! ss of 
      Nothing -> i 
      Just _ -> findNextEmptyId ss (i+1)

-- | Internal implementation of actor registrarion when monadic context isn't in scope
addSyncTypeRepInternal :: HashableTypeRep -> Word64 -> SyncState s -> SyncState s
addSyncTypeRepInternal !tr !i sstate = case H.lookup i . syncIdMapRev $! sstate of 
  Just _ -> sstate
  Nothing -> sstate { 
      syncIdMap = H.insert tr i . syncIdMap $! sstate
    , syncIdMapRev = H.insert i tr . syncIdMapRev $! sstate
    }

-- | Internal implementation of sending service request for actor net id
syncRequestIdInternal :: forall proxy i m s . (ActorMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i) 
    => Peer -> proxy i -> SyncState s -> m (SyncState s)
syncRequestIdInternal peer p s = do
  chan <- getServiceChannel
  registerActorTypeRepM p
  sendService peer chan $ SyncServiceRequestId $ show $ actorFingerprint p
  return s

-- | Return channel id 1 if network module has more than 1 channel, either fallback to 0
--
-- Note: If you open more than one channel,
-- the module would use chanel id 1 as service channel, therefore count of channels
-- on client and server should match (server won't response on channel 1 if it doesn't
-- have it).
getServiceChannel :: NetworkMonad m => m ChannelID 
getServiceChannel = do 
  maxi <- networkChannels
  return . ChannelID $! if maxi > 1 then 1 else 0

-- | Log only when flag is turned on
syncLog :: LoggingMonad m => SyncState s -> Text -> m ()
syncLog SyncState{..} = when syncLogging . putMsgLnM . ("Sync module: " <>)