{-# LANGUAGE OverloadedStrings #-} module Periodic.Trans.Client ( ClientT , ClientEnv , open , close , runClientT , ping , submitJob_ , submitJob , runJob_ , runJob , removeJob , dropFunc , status , configGet , configSet , load , dump , shutdown ) where import Control.Monad (forever, void) import Data.Binary (decode) import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) import Metro.Class (Transport, TransportConfig) import Metro.Conn (initConnEnv, runConnT) import qualified Metro.Conn as Conn import Metro.Node (NodeMode (..), SessionMode (..), initEnv1, request, setDefaultSessionTimeout, setNodeMode, setSessionMode, startNodeT, withSessionT) import Metro.Session (send) import Periodic.Node import Periodic.Trans.BaseClient import Periodic.Types (ClientType (TypeClient), getClientType, getResult, packetREQ, regPacketREQ) import Periodic.Types.ClientCommand import Periodic.Types.Internal (ConfigKey (..)) import Periodic.Types.Job import Periodic.Types.ServerCommand import UnliftIO import UnliftIO.Concurrent (threadDelay) type ClientEnv = BaseClientEnv () type ClientT = BaseClientT () runClientT :: Monad m => ClientEnv tp -> ClientT tp m a -> m a runClientT :: ClientEnv tp -> ClientT tp m a -> m a runClientT = ClientEnv tp -> ClientT tp m a -> m a forall (m :: * -> *) u rpkt tp a. Monad m => NodeEnv u rpkt tp -> NodeT u rpkt tp m a -> m a runNodeT open :: (MonadUnliftIO m, Transport tp) => TransportConfig tp -> m (ClientEnv tp) open :: TransportConfig tp -> m (ClientEnv tp) open config :: TransportConfig tp config = do ConnEnv tp connEnv <- TransportConfig tp -> m (ConnEnv tp) forall (m :: * -> *) tp. (MonadIO m, Transport tp) => TransportConfig tp -> m (ConnEnv tp) initConnEnv TransportConfig tp config RegPacket ServerCommand r <- ConnEnv tp -> ConnT tp m (RegPacket ServerCommand) -> m (RegPacket ServerCommand) forall tp (m :: * -> *) a. ConnEnv tp -> ConnT tp m a -> m a runConnT ConnEnv tp connEnv (ConnT tp m (RegPacket ServerCommand) -> m (RegPacket ServerCommand)) -> ConnT tp m (RegPacket ServerCommand) -> m (RegPacket ServerCommand) forall a b. (a -> b) -> a -> b $ do RegPacket ClientType -> ConnT tp m () forall (m :: * -> *) tp pkt. (MonadUnliftIO m, Transport tp, SendPacket pkt) => pkt -> ConnT tp m () Conn.send (RegPacket ClientType -> ConnT tp m ()) -> RegPacket ClientType -> ConnT tp m () forall a b. (a -> b) -> a -> b $ ClientType -> RegPacket ClientType forall a. a -> RegPacket a regPacketREQ ClientType TypeClient ConnT tp m (RegPacket ServerCommand) forall (m :: * -> *) tp pkt. (MonadUnliftIO m, Transport tp, RecvPacket pkt) => ConnT tp m pkt Conn.receive let nid :: ByteString nid = case RegPacket ServerCommand -> ServerCommand forall a. RegPacket a -> a getClientType RegPacket ServerCommand r of Data v :: ByteString v -> ByteString v _ -> "" ClientEnv tp clientEnv <- (NodeEnv () Nid Msgid (Packet ServerCommand) -> NodeEnv () Nid Msgid (Packet ServerCommand)) -> ConnEnv tp -> () -> Nid -> IO Msgid -> m (ClientEnv tp) forall (m :: * -> *) u nid k rpkt tp. MonadIO m => (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt) -> ConnEnv tp -> u -> nid -> IO k -> m (NodeEnv1 u nid k rpkt tp) initEnv1 NodeEnv () Nid Msgid (Packet ServerCommand) -> NodeEnv () Nid Msgid (Packet ServerCommand) forall u nid k rpkt. NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt mapEnv ConnEnv tp connEnv () (ByteString -> Nid Nid ByteString nid) IO Msgid sessionGen ClientEnv tp -> ClientT tp m () -> m () forall (m :: * -> *) tp a. Monad m => ClientEnv tp -> ClientT tp m a -> m a runClientT ClientEnv tp clientEnv (ClientT tp m () -> m ()) -> ClientT tp m () -> m () forall a b. (a -> b) -> a -> b $ do NodeT () Nid Msgid (Packet ServerCommand) tp m (Async Any) -> ClientT tp m () forall (f :: * -> *) a. Functor f => f a -> f () void (NodeT () Nid Msgid (Packet ServerCommand) tp m (Async Any) -> ClientT tp m ()) -> (NodeT () Nid Msgid (Packet ServerCommand) tp m Any -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async Any)) -> NodeT () Nid Msgid (Packet ServerCommand) tp m Any -> ClientT tp m () forall b c a. (b -> c) -> (a -> b) -> a -> c . NodeT () Nid Msgid (Packet ServerCommand) tp m Any -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async Any) forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a) async (NodeT () Nid Msgid (Packet ServerCommand) tp m Any -> ClientT tp m ()) -> NodeT () Nid Msgid (Packet ServerCommand) tp m Any -> ClientT tp m () forall a b. (a -> b) -> a -> b $ ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m Any forall (f :: * -> *) a b. Applicative f => f a -> f b forever (ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m Any) -> ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m Any forall a b. (a -> b) -> a -> b $ do Int -> ClientT tp m () forall (m :: * -> *). MonadIO m => Int -> m () threadDelay (Int -> ClientT tp m ()) -> Int -> ClientT tp m () forall a b. (a -> b) -> a -> b $ 100 Int -> Int -> Int forall a. Num a => a -> a -> a * 1000 Int -> Int -> Int forall a. Num a => a -> a -> a * 1000 ClientT tp m () forall (m :: * -> *) tp u. (MonadUnliftIO m, Transport tp) => BaseClientT u tp m () checkHealth NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ()) -> ClientT tp m () forall (f :: * -> *) a. Functor f => f a -> f () void (NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ()) -> ClientT tp m ()) -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ()) -> ClientT tp m () forall a b. (a -> b) -> a -> b $ ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ()) forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a) async (ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ())) -> ClientT tp m () -> NodeT () Nid Msgid (Packet ServerCommand) tp m (Async ()) forall a b. (a -> b) -> a -> b $ SessionT () Nid Msgid (Packet ServerCommand) tp m () -> ClientT tp m () forall (m :: * -> *) tp rpkt k u nid. (MonadUnliftIO m, Transport tp, RecvPacket rpkt, GetPacketId k rpkt, Eq k, Hashable k) => SessionT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m () startNodeT SessionT () Nid Msgid (Packet ServerCommand) tp m () forall (m :: * -> *) u rpkt tp. MonadIO m => SessionT u rpkt tp m () defaultSessionHandler ClientEnv tp -> m (ClientEnv tp) forall (m :: * -> *) a. Monad m => a -> m a return ClientEnv tp clientEnv where mapEnv :: NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt mapEnv = NodeMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt forall u nid k rpkt. NodeMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt setNodeMode NodeMode Multi (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt) -> (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt) -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt forall b c a. (b -> c) -> (a -> b) -> a -> c . SessionMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt forall u nid k rpkt. SessionMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt setSessionMode SessionMode SingleAction (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt) -> (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt) -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt forall b c a. (b -> c) -> (a -> b) -> a -> c . Int64 -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt forall u nid k rpkt. Int64 -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt setDefaultSessionTimeout 100 dropFunc :: (MonadUnliftIO m, Transport tp) => FuncName -> BaseClientT u tp m Bool dropFunc :: FuncName -> BaseClientT u tp m Bool dropFunc func :: FuncName func = Bool -> (ServerCommand -> Bool) -> Maybe (Packet ServerCommand) -> Bool forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult Bool False ServerCommand -> Bool isSuccess (Maybe (Packet ServerCommand) -> Bool) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ (FuncName -> ClientCommand DropFunc FuncName func)) removeJob :: (MonadUnliftIO m, Transport tp) => FuncName -> JobName -> BaseClientT u tp m Bool removeJob :: FuncName -> JobName -> BaseClientT u tp m Bool removeJob f :: FuncName f n :: JobName n = Bool -> (ServerCommand -> Bool) -> Maybe (Packet ServerCommand) -> Bool forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult Bool False ServerCommand -> Bool isSuccess (Maybe (Packet ServerCommand) -> Bool) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ (FuncName -> JobName -> ClientCommand RemoveJob FuncName f JobName n)) status :: (MonadUnliftIO m, Transport tp) => BaseClientT u tp m ByteString status :: BaseClientT u tp m ByteString status = ByteString -> (ServerCommand -> ByteString) -> Maybe (Packet ServerCommand) -> ByteString forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult "" ServerCommand -> ByteString getRaw (Maybe (Packet ServerCommand) -> ByteString) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m ByteString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ ClientCommand Status) where getRaw :: ServerCommand -> ByteString getRaw :: ServerCommand -> ByteString getRaw (Data bs :: ByteString bs) = ByteString bs getRaw _ = "" configGet :: (MonadUnliftIO m, Transport tp) => String -> BaseClientT u tp m Int configGet :: String -> BaseClientT u tp m Int configGet k :: String k = Int -> (ServerCommand -> Int) -> Maybe (Packet ServerCommand) -> Int forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult 0 ServerCommand -> Int getV (Maybe (Packet ServerCommand) -> Int) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ (ConfigKey -> ClientCommand ConfigGet (String -> ConfigKey ConfigKey String k))) where getV :: ServerCommand -> Int getV :: ServerCommand -> Int getV (Config v :: Int v) = Int v getV _ = 0 configSet :: (MonadUnliftIO m, Transport tp) => String -> Int -> BaseClientT u tp m Bool configSet :: String -> Int -> BaseClientT u tp m Bool configSet k :: String k v :: Int v = Bool -> (ServerCommand -> Bool) -> Maybe (Packet ServerCommand) -> Bool forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult Bool False ServerCommand -> Bool isSuccess (Maybe (Packet ServerCommand) -> Bool) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ (ConfigKey -> Int -> ClientCommand ConfigSet (String -> ConfigKey ConfigKey String k) Int v)) load :: (MonadUnliftIO m, Transport tp) => [Job] -> BaseClientT u tp m Bool load :: [Job] -> BaseClientT u tp m Bool load jobs :: [Job] jobs = Bool -> (ServerCommand -> Bool) -> Maybe (Packet ServerCommand) -> Bool forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult Bool False ServerCommand -> Bool isSuccess (Maybe (Packet ServerCommand) -> Bool) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ ([Job] -> ClientCommand Load [Job] jobs)) dump :: (MonadUnliftIO m, Transport tp) => BaseClientT u tp m [Job] dump :: BaseClientT u tp m [Job] dump = [Job] -> (ServerCommand -> [Job]) -> Maybe (Packet ServerCommand) -> [Job] forall a b. a -> (b -> a) -> Maybe (Packet b) -> a getResult [] ServerCommand -> [Job] getV (Maybe (Packet ServerCommand) -> [Job]) -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) -> BaseClientT u tp m [Job] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Int64 -> Packet ClientCommand -> NodeT u Nid Msgid (Packet ServerCommand) tp m (Maybe (Packet ServerCommand)) forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt, Eq k, Hashable k) => Maybe Int64 -> spkt -> NodeT u nid k rpkt tp m (Maybe rpkt) request Maybe Int64 forall a. Maybe a Nothing (ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ ClientCommand Dump) where getV :: ServerCommand -> [Job] getV :: ServerCommand -> [Job] getV (Data bs :: ByteString bs) = ByteString -> [Job] forall a. Binary a => ByteString -> a decode (ByteString -> [Job]) -> ByteString -> [Job] forall a b. (a -> b) -> a -> b $ ByteString -> ByteString fromStrict ByteString bs getV _ = [] shutdown :: (MonadUnliftIO m, Transport tp) => BaseClientT u tp m () shutdown :: BaseClientT u tp m () shutdown = Maybe Int64 -> SessionT u Nid Msgid (Packet ServerCommand) tp m () -> BaseClientT u tp m () forall (m :: * -> *) k u nid rpkt tp a. (MonadUnliftIO m, Eq k, Hashable k) => Maybe Int64 -> SessionT u nid k rpkt tp m a -> NodeT u nid k rpkt tp m a withSessionT Maybe Int64 forall a. Maybe a Nothing (SessionT u Nid Msgid (Packet ServerCommand) tp m () -> BaseClientT u tp m ()) -> SessionT u Nid Msgid (Packet ServerCommand) tp m () -> BaseClientT u tp m () forall a b. (a -> b) -> a -> b $ Packet ClientCommand -> SessionT u Nid Msgid (Packet ServerCommand) tp m () forall (m :: * -> *) tp spkt k u nid rpkt. (MonadUnliftIO m, Transport tp, SendPacket spkt, SetPacketId k spkt) => spkt -> SessionT u nid k rpkt tp m () send (Packet ClientCommand -> SessionT u Nid Msgid (Packet ServerCommand) tp m ()) -> Packet ClientCommand -> SessionT u Nid Msgid (Packet ServerCommand) tp m () forall a b. (a -> b) -> a -> b $ ClientCommand -> Packet ClientCommand forall a. a -> Packet a packetREQ ClientCommand Shutdown