module Web.DDP.Deadpan.Callbacks where
import Web.DDP.Deadpan.DSL
import Control.Concurrent.MVar
import Control.Monad.State
import Data.Monoid
pingCallback :: Callback
pingCallback = sendMessage "pong"
. maybe (ejobject []) makeEJsonId
. ejson2guid
clientDataSub :: GUID -> Text -> [ EJsonValue ] -> DeadpanApp GUID
clientDataSub subid name params = do
sendMessage "sub" $ makeEJsonId subid
<> ejobject [ ("name", ejstring name)
, ("params", ejarray params) ]
return subid
subscribe :: Text -> [ EJsonValue ] -> DeadpanApp GUID
subscribe name params = newID >>= \guid -> clientDataSub guid name params
subscribeWaitId :: Text -> [EJsonValue] -> DeadpanApp (Either EJsonValue (GUID, EJsonValue))
subscribeWaitId name params = do
mv <- liftIO newEmptyMVar
subId <- newID
handlerIdL <- setMatchHandler (guid2NoSub subId) (handlerL mv)
handlerIdR <- setMatchHandler (guid2SubReady subId) (handlerR subId mv)
_ <- clientDataSub subId name params
res <- liftIO $ readMVar mv
deleteHandlerID handlerIdR
deleteHandlerID handlerIdL
return res
where
handlerR subId mv itm = liftIO $ putMVar mv $ Right (subId, itm)
handlerL mv itm = forOf_ (_EJObjectKey "error" . _Just) itm $ liftIO . putMVar mv . Left
subscribeWait :: Text -> [EJsonValue] -> DeadpanApp (Either EJsonValue EJsonValue)
subscribeWait name params = fmap (right' snd)
(subscribeWaitId name params)
clientDataUnsub :: GUID -> DeadpanApp ()
clientDataUnsub subid = sendMessage "unsub" (makeEJsonId subid)
unsubscribe :: GUID -> DeadpanApp ()
unsubscribe = clientDataUnsub
clientRPCMethod :: Text -> [EJsonValue] -> GUID -> Maybe Text -> DeadpanApp GUID
clientRPCMethod method params rpcid seed = do
let msg = [ ("method", ejstring method)
, ("params", ejarray params) ]
&~ (forOf_ _Just seed $ \v -> modify (("seed", ejstring v):))
sendMessage "method" (makeEJsonId rpcid <> ejobject msg)
return rpcid
rpc :: Text -> [EJsonValue] -> DeadpanApp GUID
rpc method params = newID >>= \guid -> clientRPCMethod method params guid Nothing
rpcWait :: Text -> [EJsonValue] -> DeadpanApp (Either EJsonValue EJsonValue)
rpcWait method params = do
mv <- liftIO newEmptyMVar
rpcId <- newID
handlerId <- setMatchHandler (makeEJsonId rpcId) (handler mv)
_ <- clientRPCMethod method params rpcId Nothing
res <- liftIO $ readMVar mv
deleteHandlerID handlerId
return res
where
handler mv itm = do forOf_ (_EJObjectKey "error" . _Just) itm $ liftIO . putMVar mv . Left
forOf_ (_EJObjectKey "result" . _Just) itm $ liftIO . putMVar mv . Right