module Control.Eff.Concurrent.Protocol.EffectfulServer
( Server(..)
, Event(..)
, start
, startLink
, protocolServerLoop
, TangibleGenServer
, GenServer
, GenServerId(..)
, genServer
)
where
import Control.Applicative
import Control.DeepSeq
import Control.Eff
import Control.Eff.Extend ()
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Process.Timer
import Control.Eff.Concurrent.Protocol
import Control.Eff.Concurrent.Protocol.Request
import Control.Eff.Log
import Control.Lens
import Data.Kind
import Data.String
import Data.Typeable
import Data.Type.Pretty
import qualified Data.Text as T
import GHC.Stack (HasCallStack)
class Server (a :: Type) (e :: [Type -> Type])
where
data Init a e
type ServerPdu a :: Type
type ServerPdu a = a
type ServerEffects a e :: [Type -> Type]
type ServerEffects a e = e
serverTitle :: Init a e -> ProcessTitle
default serverTitle :: Typeable (ServerPdu a) => Init a e -> ProcessTitle
serverTitle _ = fromString $ prettyTypeableShows (typeRep (Proxy @(ServerPdu a))) "-server"
runEffects :: Init a e -> Eff (ServerEffects a e) x -> Eff e x
default runEffects :: ServerEffects a e ~ e => Init a e -> Eff (ServerEffects a e) x -> Eff e x
runEffects = const id
onEvent :: Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()
default onEvent :: (Show (Init a e), Member Logs (ServerEffects a e)) => Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()
onEvent i e = logInfo ("unhandled: " <> T.pack (show i) <> " " <> T.pack (show e))
start
:: forall a q h
. ( Server a (Processes q)
, Typeable a
, Typeable (ServerPdu a)
, LogsTo h (Processes q)
, SetMember Process (Process q) (ServerEffects a (Processes q))
, Member Interrupts (ServerEffects a (Processes q))
, HasCallStack)
=> Init a (Processes q)
-> Eff (Processes q) (Endpoint (ServerPdu a))
start a = asEndpoint <$> spawn (serverTitle a) (protocolServerLoop a)
startLink
:: forall a q h
. ( Typeable a
, Typeable (ServerPdu a)
, Server a (Processes q)
, LogsTo h (Processes q)
, SetMember Process (Process q) (ServerEffects a (Processes q))
, Member Interrupts (ServerEffects a (Processes q))
, HasCallStack)
=> Init a (Processes q)
-> Eff (Processes q) (Endpoint (ServerPdu a))
startLink a = asEndpoint <$> spawnLink (serverTitle a) (protocolServerLoop a)
protocolServerLoop
:: forall q h a
. ( Server a (Processes q)
, LogsTo h (Processes q)
, SetMember Process (Process q) (ServerEffects a (Processes q))
, Member Interrupts (ServerEffects a (Processes q))
, Typeable a
, Typeable (ServerPdu a)
)
=> Init a (Processes q) -> Eff (Processes q) ()
protocolServerLoop a = do
myEp <- T.pack . show . asEndpoint @(ServerPdu a) <$> self
censorLogs (lmAddEp myEp) $ do
logDebug ("starting")
runEffects a (receiveSelectedLoop sel mainLoop)
return ()
where
lmAddEp myEp = lmProcessId ?~ myEp
sel :: MessageSelector (Event (ServerPdu a))
sel = onRequest <$> selectMessage @(Request (ServerPdu a))
<|> OnDown <$> selectMessage @ProcessDown
<|> OnTimeOut <$> selectMessage @TimerElapsed
<|> OnMessage <$> selectAnyMessage
where
onRequest :: Request (ServerPdu a) -> Event (ServerPdu a)
onRequest (Call o m) = OnCall (replyTarget (MkSerializer toStrictDynamic) o) m
onRequest (Cast m) = OnCast m
handleInt i = onEvent a (OnInterrupt i) *> pure Nothing
mainLoop :: (Typeable a)
=> Either (Interrupt 'Recoverable) (Event (ServerPdu a))
-> Eff (ServerEffects a (Processes q)) (Maybe ())
mainLoop (Left i) = handleInt i
mainLoop (Right i) = onEvent a i *> pure Nothing
data Event a where
OnCall :: forall a r. (Tangible r, TangiblePdu a ('Synchronous r)) => ReplyTarget a r -> Pdu a ('Synchronous r) -> Event a
OnCast :: forall a. TangiblePdu a 'Asynchronous => Pdu a 'Asynchronous -> Event a
OnInterrupt :: (Interrupt 'Recoverable) -> Event a
OnDown :: ProcessDown -> Event a
OnTimeOut :: TimerElapsed -> Event a
OnMessage :: StrictDynamic -> Event a
deriving Typeable
instance Show (Event a) where
showsPrec d e =
showParen (d>=10) $
showString "event: "
. case e of
OnCall o p -> shows (Call (view replyTargetOrigin o) p)
OnCast p -> shows (Cast p)
OnInterrupt r -> shows r
OnDown r -> shows r
OnTimeOut r -> shows r
OnMessage r -> shows r
instance NFData a => NFData (Event a) where
rnf = \case
OnCall o p -> rnf o `seq` rnf p
OnCast p -> rnf p
OnInterrupt r -> rnf r
OnDown r -> rnf r
OnTimeOut r -> rnf r
OnMessage r -> r `seq` ()
type instance ToPretty (Event a) = ToPretty a <+> PutStr "event"
data GenServer tag eLoop e where
MkGenServer
:: (TangibleGenServer tag eLoop e, HasCallStack) =>
{ genServerRunEffects :: forall x . (Eff eLoop x -> Eff (Processes e) x)
, genServerOnEvent :: Event tag -> Eff eLoop ()
} -> GenServer tag eLoop e
deriving Typeable
type TangibleGenServer tag eLoop e =
( LogIo e
, SetMember Process (Process e) eLoop
, Member Interrupts eLoop
, Typeable e
, Typeable eLoop
, Typeable tag
)
newtype GenServerId tag =
MkGenServerId { _fromGenServerId :: T.Text }
deriving (Typeable, NFData, Ord, Eq, IsString)
instance (Typeable k, Typeable (tag :: k)) => Show (GenServerId tag) where
showsPrec d px@(MkGenServerId x) =
showParen
(d >= 10)
(showString (T.unpack x)
. showString " :: "
. prettyTypeableShows (typeOf px)
)
instance (TangibleGenServer tag eLoop e) => Server (GenServer (tag :: Type) eLoop e) (Processes e) where
type ServerPdu (GenServer tag eLoop e) = tag
type ServerEffects (GenServer tag eLoop e) (Processes e) = eLoop
data instance Init (GenServer tag eLoop e) (Processes e) =
GenServerInit
{ genServerCallbacks :: GenServer tag eLoop e
, genServerId :: GenServerId tag
} deriving Typeable
runEffects (GenServerInit cb cId) m =
censorLogs
(lmMessage <>~ (" | " <> _fromGenServerId cId))
(genServerRunEffects cb m)
onEvent (GenServerInit cb _cId) req = genServerOnEvent cb req
instance NFData (Init (GenServer tag eLoop e) (Processes e)) where
rnf (GenServerInit _ x) = rnf x
instance Typeable tag => Show (Init (GenServer tag eLoop e) (Processes e)) where
showsPrec d (GenServerInit _ x) =
showParen (d>=10)
( showsPrec 11 x
. showChar ' ' . prettyTypeableShows (typeRep (Proxy @tag))
. showString " gen-server"
)
genServer
:: forall tag eLoop e .
( HasCallStack
, TangibleGenServer tag eLoop e
, Server (GenServer tag eLoop e) (Processes e)
)
=> (forall x . GenServerId tag -> Eff eLoop x -> Eff (Processes e) x)
-> (GenServerId tag -> Event tag -> Eff eLoop ())
-> GenServerId tag
-> Init (GenServer tag eLoop e) (Processes e)
genServer initCb stepCb i =
GenServerInit
{ genServerId = i
, genServerCallbacks =
MkGenServer { genServerRunEffects = initCb i
, genServerOnEvent = stepCb i
}
}