module Network.XMPP.Session ( ClientHandler (..)
, ClientState (..)
, ConnectResult (..)
, Session
, TerminationReason
, OpenStreamResult (..)
, SecureWithTLSResult (..)
, AuthenticateResult (..)
, sendPresence
, sendIQ
, sendMessage
, connect
, openStream
, secureWithTLS
, authenticate
, session
, injectAction ) where
import Network.XMPP.JID
import Network.XMPP.SASL
import Network.XMPP.Stanza
import Network.XMPP.Stream
import Network.XMPP.TLS
import Network.XMPP.Types
import Network.XMPP.Utilities
import qualified Control.Exception as CE
import qualified Control.Exception.Base as CEB
import qualified Control.Monad.Error as CME
import qualified Control.Monad.State as CMS
import qualified Network as N
import Control.Concurrent.MVar
import Codec.Binary.UTF8.String
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.State hiding (State)
import Data.Enumerator (($$), Iteratee, continue, joinI,
run, run_, yield)
import Data.Enumerator.Binary (enumHandle, enumFile)
import Data.Maybe
import Data.String
import Data.XML.Types
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import Network.TLS
import Network.TLS.Cipher
import System.IO (BufferMode, BufferMode(NoBuffering))
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import Text.XML.Enumerator.Document (fromEvents)
import qualified Codec.Binary.Base64.String as CBBS
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.List as DL
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL
data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) }
data MonadIO m => ClientHandler s m =
ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool)
, presenceReceived :: Maybe (Presence -> StateT s m Bool)
, iqReceived :: Maybe (IQ -> StateT s m Bool)
, sessionTerminated :: Maybe (TerminationReason ->
StateT s m ()) }
data TerminationReason = WhateverReason
session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->
(CMS.StateT s m ()) -> m ()
session s h c = do
threadID <- liftIO $ newEmptyMVar
chan <- liftIO $ newChan
((), clientState) <- runStateT c (putSession s $ session_ chan)
(result, _) <- runStateT (stateLoop chan)
(defaultState chan threadID h clientState)
case result of
Just (CE.SomeException e) -> do
liftIO $ putStrLn "Got an exception!"
threadID' <- liftIO $ tryTakeMVar threadID
case threadID' of
Nothing -> do
liftIO $ putStrLn "No thread ID to kill"
Just t -> do
liftIO $ putStrLn "Killing thread"
liftIO $ killThread t
CE.throw e
Nothing ->
return ()
where
session_ c = Session { sessionChannel = c }
defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->
[ClientHandler s m] -> s -> State s m
defaultState c t h s = State { stateClientHandlers = h
, stateClientState = s
, stateChannel = c
, stateConnectionState = Disconnected
, stateStreamState = PreStream
, stateTLSState = NoTLS
, stateOpenStreamCallback = Nothing
, stateSecureWithTLSCallback = Nothing
, stateAuthenticateCallback = Nothing
, stateAuthenticationState = NoAuthentication
, stateResource = Nothing
, stateShouldExit = False
, stateThreadID = t
, statePresenceCallbacks = []
, stateMessageCallbacks = []
, stateIQCallbacks = []
, stateTimeoutStanzaIDs = [] }
connect :: MonadIO m => Session s m -> HostName -> PortNumber ->
Maybe (Certificate, (Certificate -> Bool)) ->
Maybe (UserName, Password, Maybe Resource) ->
(ConnectResult -> StateT s m ()) -> StateT s m ()
connect s h p t a c = openStream s h p connect'
where
connect' r = case r of
OpenStreamSuccess _ _ -> case t of
Just (certificate, certificateValidator) ->
secureWithTLS s certificate certificateValidator connect''
Nothing -> connect'' (SecureWithTLSSuccess 1.0 "")
OpenStreamFailure -> c ConnectOpenStreamFailure
connect'' r = case r of
SecureWithTLSSuccess _ _ -> case a of
Just (userName, password, resource) ->
authenticate s userName password resource connect'''
Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo")
SecureWithTLSFailure -> c ConnectSecureWithTLSFailure
connect''' r = case r of
AuthenticateSuccess streamProperties streamFeatures resource ->
c (ConnectSuccess streamProperties streamFeatures (Just resource))
AuthenticateFailure -> c ConnectAuthenticateFailure
openStream :: MonadIO m => Session s m -> HostName -> PortNumber ->
(OpenStreamResult -> StateT s m ()) -> StateT s m ()
openStream s h p c = CMS.get >>=
(\ state -> lift $ liftIO $ writeChan (sessionChannel s)
(IEC (CEOpenStream h p c)))
secureWithTLS :: MonadIO m => Session s m -> Certificate ->
(Certificate -> Bool) ->
(SecureWithTLSResult -> StateT s m ()) -> StateT s m ()
secureWithTLS s c a c_ = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CESecureWithTLS c a c_)))
authenticate :: MonadIO m => Session s m -> UserName -> Password ->
Maybe Resource -> (AuthenticateResult -> StateT s m ()) ->
StateT s m ()
authenticate s u p r c = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEAuthenticate u p r c)))
sendMessage :: MonadIO m => Session s m -> Message -> Maybe (Message -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
sendMessage se m c t st = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel se)
(IEC (CEMessage m c t st)))
sendPresence :: MonadIO m => Session s m -> Presence -> Maybe (Presence -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
sendPresence se p c t st = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel se)
(IEC (CEPresence p c t st)))
sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
sendIQ se i c t st = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel se)
(IEC (CEIQ i c t st)))
injectAction :: MonadIO m => Session s m -> Maybe (StateT s m Bool) -> StateT s m () -> StateT s m ()
injectAction s p a = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEAction p a)))
class ClientState s m where
putSession :: s -> Session s m -> s
type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ())
type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ())
type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ())
isConnected :: ConnectionState -> Bool
isConnected Disconnected = True
isConnected (Connected _ _) = True
data MonadIO m => State s m =
State { stateClientHandlers :: [ClientHandler s m]
, stateClientState :: s
, stateChannel :: Chan (InternalEvent s m)
, stateConnectionState :: ConnectionState
, stateTLSState :: TLSState
, stateStreamState :: StreamState
, stateOpenStreamCallback :: OpenStreamCallback s m
, stateSecureWithTLSCallback :: SecureWithTLSCallback s m
, stateAuthenticateCallback :: AuthenticateCallback s m
, stateAuthenticationState :: AuthenticationState
, stateResource :: Maybe Resource
, stateShouldExit :: Bool
, stateThreadID :: MVar ThreadId
, statePresenceCallbacks :: [(StanzaID, (Presence -> StateT s m Bool))]
, stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))]
, stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))]
, stateTimeoutStanzaIDs :: [StanzaID]
}
stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) ->
StateT (State s m) m (Maybe CE.SomeException)
stateLoop c = do
event <- lift $ liftIO $ readChan c
lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "."
result <- (processEvent event)
state <- get
case result of
Nothing -> do
case stateShouldExit state of
True ->
return $ Nothing
False ->
stateLoop c
Just e ->
return $ Just e
processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) ->
(StateT (State s m) m) (Maybe CE.SomeException)
processEvent e = get >>= \ state ->
let handleOrTLSCtx = case stateTLSState state of
PostHandshake tlsCtx ->
Right tlsCtx
_ ->
let Connected _ handle = stateConnectionState state in Left handle
in case e of
IEC (CEOpenStream hostName portNumber callback) -> do
CEB.assert (stateConnectionState state == Disconnected) (return ())
let portNumber' = fromIntegral portNumber
connectResult <- liftIO $ CE.try $ N.connectTo hostName
(N.PortNumber portNumber')
case connectResult of
Right handle -> do
put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle
, stateStreamState = PreStream
, stateOpenStreamCallback = Just callback }
lift $ liftIO $ hSetBuffering handle NoBuffering
lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ hostName ++
"' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++
"g/streams' version='1.0'>") (Left handle)
threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)
lift $ liftIO $ putMVar (stateThreadID state) threadID
return Nothing
Left e -> do
let clientState = stateClientState state
((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState
put $ state { stateShouldExit = True }
return $ Just e
IEC (CESecureWithTLS certificate verifyCertificate callback) -> do
let Connected _ handle = stateConnectionState state
lift $ liftIO $ send "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle)
put $ state { stateStreamState = PreStream
, stateSecureWithTLSCallback = Just callback }
return Nothing
IEC (CEAuthenticate userName password resource callback) -> do
put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource
, stateAuthenticateCallback = Just callback }
lift $ liftIO $ send "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>" handleOrTLSCtx
return Nothing
IEE (EnumeratorXML (XEBeginStream stream)) -> do
put $ state { stateStreamState = PreFeatures (1.0) }
return Nothing
IEE (EnumeratorXML (XEFeatures features)) -> do
let PreFeatures streamProperties = stateStreamState state
case stateTLSState state of
NoTLS -> let callback = fromJust $ stateOpenStreamCallback state in do
((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state)
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
_ -> case stateAuthenticationState state of
AuthenticatedUnbound _ resource -> do
case resource of
Nothing -> do
lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx
return ()
_ -> do
lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx
return ()
r <- lift $ liftIO $ getID
lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ r ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx
let callback = fromJust $ stateAuthenticateCallback state in do
((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state)
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
_ -> do
let callback = fromJust $ stateSecureWithTLSCallback state in do
((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state)
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
IEE (EnumeratorXML XEProceed) -> do
let Connected (ServerAddress hostName _) handle = stateConnectionState state
tlsCtx <- lift $ liftIO $ handshake' handle hostName
let tlsCtx_ = fromJust tlsCtx
put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_)
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ swapMVar (stateThreadID state) threadID
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ threadDelay 1000000
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++
hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
"streams' version='1.0'>") (Right tlsCtx_)
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
return Nothing
IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
let serverHost = "jonkristensen.com"
let challenge' = CBBS.decode challenge
case stateAuthenticationState state of
AuthenticatingPreChallenge1 userName password resource -> do
random <- lift $ liftIO $ getID
case replyToChallenge1 challenge' serverHost userName password random of
Left reply -> do
let reply' = (filter (/= '\n') (CBBS.encode reply))
lift $ liftIO $ send ("<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++ reply' ++ "</response>") handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource }
return ()
Right error -> do
lift $ liftIO $ putStrLn $ show error
return ()
AuthenticatingPreChallenge2 userName password resource -> do
lift $ liftIO $ send "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }
return ()
return Nothing
IEE (EnumeratorXML (XESuccess (Succ _))) -> do
let serverHost = "jonkristensen.com"
let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }
return Nothing
IEE EnumeratorDone ->
return Nothing
IEE (EnumeratorXML (XEIQ iqEvent)) ->
case shouldIgnoreIQ iqEvent of
True ->
return Nothing
False -> do
let stanzaID' = stanzaID $ iqStanza $ iqEvent
let newTimeouts = case stanzaID' of
Just stanzaID'' ->
case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
False -> (stateTimeoutStanzaIDs state)
Nothing -> (stateTimeoutStanzaIDs state)
let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f iqEvent)
Nothing -> Nothing) iqReceivedFunctions
let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of
Just f -> (Just (f $ iqEvent)):functions
Nothing -> functions
let clientState = stateClientState state
clientState' <- sendToClient functions' clientState
put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
return Nothing
IEE (EnumeratorXML (XEPresence presenceEvent)) -> do
let stanzaID' = stanzaID $ presenceStanza $ presenceEvent
let newTimeouts = case stanzaID' of
Just stanzaID'' ->
case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
False -> (stateTimeoutStanzaIDs state)
Nothing -> (stateTimeoutStanzaIDs state)
let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f presenceEvent)
Nothing -> Nothing) presenceReceivedFunctions
let clientState = stateClientState state
clientState' <- sendToClient functions clientState
put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
return Nothing
IEE (EnumeratorXML (XEMessage messageEvent)) -> do
let stanzaID' = stanzaID $ messageStanza $ messageEvent
let newTimeouts = case stanzaID' of
Just stanzaID'' ->
case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
False -> (stateTimeoutStanzaIDs state)
Nothing -> (stateTimeoutStanzaIDs state)
let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f messageEvent)
Nothing -> Nothing) messageReceivedFunctions
let clientState = stateClientState state
clientState' <- sendToClient functions clientState
put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
return Nothing
IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do
presence' <- case stanzaID $ presenceStanza presence of
Nothing -> do
id <- lift $ liftIO $ getID
return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
_ -> return presence
case timeoutCallback of
Just (t, timeoutCallback') ->
let stanzaID' = (fromJust $ stanzaID $ presenceStanza presence') in do
registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
Nothing ->
return ()
let xml = presenceToXML presence'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do
message' <- case stanzaID $ messageStanza message of
Nothing -> do
id <- lift $ liftIO $ getID
return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
_ -> return message
case timeoutCallback of
Just (t, timeoutCallback') ->
let stanzaID' = (fromJust $ stanzaID $ messageStanza message') in do
registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
Nothing ->
return ()
let xml = messageToXML message'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do
iq' <- case stanzaID $ iqStanza iq of
Nothing -> do
id <- lift $ liftIO $ getID
return $ case iq of
IQGet {} -> do
iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
IQSet {} -> do
iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
IQResult {} -> do
iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
_ -> return iq
case stanzaCallback of
Just callback' -> case iq of
IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
_ -> return ()
Nothing -> return ()
case timeoutCallback of
Just (t, timeoutCallback') ->
let stanzaID' = (fromJust $ stanzaID $ iqStanza iq') in do
registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
Nothing ->
return ()
let xml = iqToXML iq'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
IEC (CEAction predicate callback) -> do
case predicate of
Just predicate' -> do
result <- runBoolClientCallback predicate'
case result of
True -> do
runUnitClientCallback callback
return Nothing
False -> return Nothing
Nothing -> do
runUnitClientCallback callback
return Nothing
IET (TimeoutEvent i t c) ->
case i `elem` (stateTimeoutStanzaIDs state) of
True -> do
runUnitClientCallback c
return Nothing
False -> return Nothing
e -> do
return Nothing
where
send :: String -> Either Handle TLSCtx -> IO ()
send s o = case o of
Left handle -> do
liftIO $ hPutStr handle $ encodeString $ s
liftIO $ hFlush handle
return ()
Right tlsCtx -> do
liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s
return ()
shouldIgnoreIQ :: IQ -> Bool
shouldIgnoreIQ i = case iqPayload i of
Nothing -> False
Just e -> case nameNamespace $ elementName e of
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True
Just _ -> False
Nothing -> False
registerTimeout :: (ClientState s m, MonadIO m) => Chan (InternalEvent s m) -> StanzaID -> Timeout -> StateT s m () -> StateT (State s m) m ()
registerTimeout ch i t ca = do
liftIO $ threadDelay $ t * 1000
liftIO $ forkIO $ writeChan ch $ IET (TimeoutEvent i t ca)
return ()
runBoolClientCallback :: (ClientState s m, MonadIO m) => StateT s m Bool -> StateT (State s m) m Bool
runBoolClientCallback c = do
state <- get
let clientState = stateClientState state
(bool, clientState') <- lift $ runStateT c clientState
put $ state { stateClientState = clientState' }
return bool
runUnitClientCallback :: (ClientState s m, MonadIO m) => StateT s m () -> StateT (State s m) m ()
runUnitClientCallback c = do
state <- get
let clientState = stateClientState state
((), clientState') <- lift $ runStateT c clientState
put $ state { stateClientState = clientState' }
sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s
sendToClient [] s = return s
sendToClient (Nothing:fs) s = sendToClient fs s
sendToClient ((Just f):fs) s = do
(b, s') <- lift $ runStateT f s
case b of
True -> return s'
False -> sendToClient fs s'