{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Periodic.Server
  ( startServer
  ) where


import           Metro                     (NodeMode (..), SessionMode (..))
import           Metro.Class               (Servable (STP),
                                            Transport (TransportConfig))
import qualified Metro.Class               as S (Servable (ServerConfig))
import           Metro.Conn                (receive, runConnT, send)
import           Metro.Server              (initServerEnv, runServerT,
                                            setDefaultSessionTimeout,
                                            setKeepalive, setNodeMode,
                                            setOnNodeLeave, setServerName,
                                            setSessionMode, stopServerT)
import qualified Metro.Server              as M (ServerEnv, startServer)
import           Periodic.IOList           (newIOList, toList)
import           Periodic.Node             (sessionGen)
import           Periodic.Server.Client    (handleSessionT)
import           Periodic.Server.Persist   (Persist, PersistConfig)
import           Periodic.Server.Scheduler (failJob, initSchedEnv, removeFunc,
                                            runSchedT, shutdown, startSchedT)
import           Periodic.Server.Types     (ClientConfig (..), Command,
                                            ServerCommand (Data))
import           Periodic.Types            (ClientType, Msgid, Nid (..), Packet,
                                            getClientType, regPacketRES)
import           System.Entropy            (getEntropy)
import           UnliftIO                  (MonadUnliftIO)

type ServerEnv serv =
  M.ServerEnv serv ClientConfig Nid Msgid (Packet Command)

startServer
  :: (Servable serv, Transport tp, Persist db, MonadUnliftIO m)
  => PersistConfig db
  -> (TransportConfig (STP serv) -> TransportConfig tp)
  -> S.ServerConfig serv
  -> m ()
startServer :: PersistConfig db
-> (TransportConfig (STP serv) -> TransportConfig tp)
-> ServerConfig serv
-> m ()
startServer dbconfig :: PersistConfig db
dbconfig mk :: TransportConfig (STP serv) -> TransportConfig tp
mk config :: ServerConfig serv
config = do
  ServerEnv serv tp
sEnv <- (ServerEnv serv tp -> ServerEnv serv tp)
-> m (ServerEnv serv tp) -> m (ServerEnv serv tp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ServerEnv serv tp -> ServerEnv serv tp
forall serv tp. ServerEnv serv tp -> ServerEnv serv tp
mapEnv (m (ServerEnv serv tp) -> m (ServerEnv serv tp))
-> ((SID serv -> ConnEnv tp -> IO (Maybe (Nid, ClientConfig)))
    -> m (ServerEnv serv tp))
-> (SID serv -> ConnEnv tp -> IO (Maybe (Nid, ClientConfig)))
-> m (ServerEnv serv tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerConfig serv
-> IO Msgid
-> (TransportConfig (STP serv) -> TransportConfig tp)
-> (SID serv -> ConnEnv tp -> IO (Maybe (Nid, ClientConfig)))
-> m (ServerEnv serv tp)
forall (m :: * -> *) serv k tp nid u rpkt.
(MonadIO m, Servable serv) =>
ServerConfig serv
-> IO k
-> (TransportConfig (STP serv) -> TransportConfig tp)
-> (SID serv -> ConnEnv tp -> IO (Maybe (nid, u)))
-> m (ServerEnv serv u nid k rpkt tp)
initServerEnv ServerConfig serv
config IO Msgid
sessionGen TransportConfig (STP serv) -> TransportConfig tp
mk ((SID serv -> ConnEnv tp -> IO (Maybe (Nid, ClientConfig)))
 -> m (ServerEnv serv tp))
-> (SID serv -> ConnEnv tp -> IO (Maybe (Nid, ClientConfig)))
-> m (ServerEnv serv tp)
forall a b. (a -> b) -> a -> b
$ \_ connEnv :: ConnEnv tp
connEnv -> do
    (ClientType
_ :: ClientType) <- RegPacket ClientType -> ClientType
forall a. RegPacket a -> a
getClientType (RegPacket ClientType -> ClientType)
-> IO (RegPacket ClientType) -> IO ClientType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnEnv tp
-> ConnT tp IO (RegPacket ClientType) -> IO (RegPacket ClientType)
forall tp (m :: * -> *) a. ConnEnv tp -> ConnT tp m a -> m a
runConnT ConnEnv tp
connEnv ConnT tp IO (RegPacket ClientType)
forall (m :: * -> *) tp pkt.
(MonadUnliftIO m, Transport tp, RecvPacket pkt) =>
ConnT tp m pkt
receive
    ByteString
nid <- Int -> IO ByteString
getEntropy 4
    ConnEnv tp -> ConnT tp IO () -> IO ()
forall tp (m :: * -> *) a. ConnEnv tp -> ConnT tp m a -> m a
runConnT ConnEnv tp
connEnv (ConnT tp IO () -> IO ()) -> ConnT tp IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RegPacket ServerCommand -> ConnT tp IO ()
forall (m :: * -> *) tp pkt.
(MonadUnliftIO m, Transport tp, SendPacket pkt) =>
pkt -> ConnT tp m ()
send (ServerCommand -> RegPacket ServerCommand
forall a. a -> RegPacket a
regPacketRES (ServerCommand -> RegPacket ServerCommand)
-> ServerCommand -> RegPacket ServerCommand
forall a b. (a -> b) -> a -> b
$ ByteString -> ServerCommand
Data ByteString
nid)
    IOList FuncName
wFuncList <- IO (IOList FuncName)
forall (m :: * -> *) a. MonadIO m => m (IOList a)
newIOList
    IOList JobHandle
wJobQueue <- IO (IOList JobHandle)
forall (m :: * -> *) a. MonadIO m => m (IOList a)
newIOList
    Maybe (Nid, ClientConfig) -> IO (Maybe (Nid, ClientConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Nid, ClientConfig) -> IO (Maybe (Nid, ClientConfig)))
-> Maybe (Nid, ClientConfig) -> IO (Maybe (Nid, ClientConfig))
forall a b. (a -> b) -> a -> b
$ (Nid, ClientConfig) -> Maybe (Nid, ClientConfig)
forall a. a -> Maybe a
Just (ByteString -> Nid
Nid ByteString
nid, ClientConfig :: IOList FuncName -> IOList JobHandle -> ClientConfig
ClientConfig {..})

  SchedEnv db tp
schedEnv <- PersistConfig db -> m () -> m (SchedEnv db tp)
forall (m :: * -> *) db tp.
(MonadUnliftIO m, Persist db) =>
PersistConfig db -> m () -> m (SchedEnv db tp)
initSchedEnv PersistConfig db
dbconfig (m () -> m (SchedEnv db tp)) -> m () -> m (SchedEnv db tp)
forall a b. (a -> b) -> a -> b
$ ServerEnv serv tp
-> ServerT serv ClientConfig Nid Msgid (Packet Command) tp m ()
-> m ()
forall serv u nid k rpkt tp (m :: * -> *) a.
ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m a -> m a
runServerT ServerEnv serv tp
sEnv ServerT serv ClientConfig Nid Msgid (Packet Command) tp m ()
forall (m :: * -> *) serv u nid k rpkt tp.
(MonadIO m, Servable serv) =>
ServerT serv u nid k rpkt tp m ()
stopServerT

  ServerEnv serv tp -> (Nid -> ClientConfig -> IO ()) -> m ()
forall (m :: * -> *) serv u nid k rpkt tp.
MonadIO m =>
ServerEnv serv u nid k rpkt tp -> (nid -> u -> IO ()) -> m ()
setOnNodeLeave ServerEnv serv tp
sEnv ((Nid -> ClientConfig -> IO ()) -> m ())
-> (Nid -> ClientConfig -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \_ ClientConfig {..} ->
    SchedEnv db tp -> SchedT db tp IO () -> IO ()
forall db tp (m :: * -> *) a.
SchedEnv db tp -> SchedT db tp m a -> m a
runSchedT SchedEnv db tp
schedEnv (SchedT db tp IO () -> IO ()) -> SchedT db tp IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (JobHandle -> SchedT db tp IO ())
-> [JobHandle] -> SchedT db tp IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JobHandle -> SchedT db tp IO ()
forall (m :: * -> *) db tp.
(MonadUnliftIO m, Persist db) =>
JobHandle -> SchedT db tp m ()
failJob ([JobHandle] -> SchedT db tp IO ())
-> SchedT db tp IO [JobHandle] -> SchedT db tp IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOList JobHandle -> SchedT db tp IO [JobHandle]
forall (m :: * -> *) a. MonadIO m => IOList a -> m [a]
toList IOList JobHandle
wJobQueue
      (FuncName -> SchedT db tp IO ())
-> [FuncName] -> SchedT db tp IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FuncName -> SchedT db tp IO ()
forall (m :: * -> *) db tp.
(MonadIO m, Persist db) =>
FuncName -> SchedT db tp m ()
removeFunc ([FuncName] -> SchedT db tp IO ())
-> SchedT db tp IO [FuncName] -> SchedT db tp IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOList FuncName -> SchedT db tp IO [FuncName]
forall (m :: * -> *) a. MonadIO m => IOList a -> m [a]
toList IOList FuncName
wFuncList

  SchedEnv db tp -> SchedT db tp m () -> m ()
forall db tp (m :: * -> *) a.
SchedEnv db tp -> SchedT db tp m a -> m a
runSchedT SchedEnv db tp
schedEnv (SchedT db tp m () -> m ()) -> SchedT db tp m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SchedT db tp m ()
forall (m :: * -> *) db tp.
(MonadUnliftIO m, Persist db, Transport tp) =>
SchedT db tp m ()
startSchedT
    ServerEnv serv tp
-> SessionT
     ClientConfig Nid Msgid (Packet Command) tp (SchedT db tp m) ()
-> SchedT db tp m ()
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
ServerEnv serv u nid k rpkt tp
-> SessionT u nid k rpkt tp m () -> m ()
M.startServer ServerEnv serv tp
sEnv SessionT
  ClientConfig Nid Msgid (Packet Command) tp (SchedT db tp m) ()
forall (m :: * -> *) db tp.
(MonadUnliftIO m, Persist db, Transport tp) =>
SessionT ClientConfig Command tp (SchedT db tp m) ()
handleSessionT
    SchedT db tp m ()
forall (m :: * -> *) db tp. MonadUnliftIO m => SchedT db tp m ()
shutdown
  where mapEnv :: ServerEnv serv tp -> ServerEnv serv tp
        mapEnv :: ServerEnv serv tp -> ServerEnv serv tp
mapEnv =
          NodeMode -> ServerEnv serv tp -> ServerEnv serv tp
forall serv u nid k rpkt tp.
NodeMode
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setNodeMode NodeMode
Multi
          (ServerEnv serv tp -> ServerEnv serv tp)
-> (ServerEnv serv tp -> ServerEnv serv tp)
-> ServerEnv serv tp
-> ServerEnv serv tp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMode -> ServerEnv serv tp -> ServerEnv serv tp
forall serv u nid k rpkt tp.
SessionMode
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setSessionMode SessionMode
SingleAction
          (ServerEnv serv tp -> ServerEnv serv tp)
-> (ServerEnv serv tp -> ServerEnv serv tp)
-> ServerEnv serv tp
-> ServerEnv serv tp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ServerEnv serv tp -> ServerEnv serv tp
forall serv u nid k rpkt tp.
Int64
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setKeepalive 500
          (ServerEnv serv tp -> ServerEnv serv tp)
-> (ServerEnv serv tp -> ServerEnv serv tp)
-> ServerEnv serv tp
-> ServerEnv serv tp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ServerEnv serv tp -> ServerEnv serv tp
forall serv u nid k rpkt tp.
Int64
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setDefaultSessionTimeout 100
          (ServerEnv serv tp -> ServerEnv serv tp)
-> (ServerEnv serv tp -> ServerEnv serv tp)
-> ServerEnv serv tp
-> ServerEnv serv tp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerEnv serv tp -> ServerEnv serv tp
forall serv u nid k rpkt tp.
String
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setServerName "Periodic"