module Web.DDP.Deadpan.DSL
( module Web.DDP.Deadpan.DSL
, module Data.EJson
, module Data.EJson.Prism
, module Data.Text
)
where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Applicative
import Network.WebSockets
import Control.Monad.RWS
import Control.Lens
import Data.Text
import Data.Map
import Web.DDP.Deadpan.Comms
import Data.EJson.Prism
import Data.EJson
type Lookup a = Data.Map.Map Text a
data AppState cb = AppState
{ _defaultCallback :: cb
, _callbackSet :: Lookup cb
, _collections :: TVar EJsonValue
}
makeLenses ''AppState
type Callback = EJsonValue -> DeadpanApp ()
newtype DeadpanApp a = DeadpanApp
{ _deadpanApp :: Control.Monad.RWS.RWST
Network.WebSockets.Connection
()
(AppState Callback)
IO
a
}
instance Monad DeadpanApp where
return = DeadpanApp . return
s >>= f = DeadpanApp $ _deadpanApp s >>= _deadpanApp . f
instance Functor DeadpanApp where
fmap f (DeadpanApp m) = DeadpanApp $ fmap f m
instance Applicative DeadpanApp where
pure = DeadpanApp . pure
(DeadpanApp f) <*> (DeadpanApp m) = DeadpanApp (f <*> m)
instance MonadIO DeadpanApp where
liftIO i = DeadpanApp $ liftIO i
makeLenses ''DeadpanApp
runDeadpan :: DeadpanApp a
-> Network.WebSockets.Connection
-> AppState Callback
-> IO (a, AppState Callback)
runDeadpan app conn appState = do
(a,s,_w) <- runRWST (_deadpanApp app) conn appState
return (a,s)
setHandler :: Text -> Callback -> DeadpanApp ()
setHandler k cb = DeadpanApp $ callbackSet %= insert k cb
deleteHandler :: Text -> DeadpanApp ()
deleteHandler k = DeadpanApp $ callbackSet %= delete k
setDefaultHandler :: Callback -> DeadpanApp ()
setDefaultHandler cb = DeadpanApp $ defaultCallback .= cb
sendData :: EJsonValue -> DeadpanApp ()
sendData v = DeadpanApp $ ask >>= liftIO . flip sendEJ v
sendMessage :: Text -> EJsonValue -> DeadpanApp ()
sendMessage key m = sendData messageData
where
messageData = ejobject [("msg", ejstring key)] `mappend` m
getAppState :: DeadpanApp (AppState Callback)
getAppState = DeadpanApp $ get
connect :: DeadpanApp ()
connect = sendMessage "connect" $
ejobject [ ("version", "1")
, ("support", ejarray ["1","pre2","pre1"]) ]
fork :: DeadpanApp a -> DeadpanApp ()
fork app = do
conn <- DeadpanApp ask
appState <- DeadpanApp get
void $ liftIO $ forkIO $ void $ runDeadpan app conn appState
setup :: DeadpanApp ()
setup = do connect
fork $
forever $ do as <- getAppState
message <- getServerMessage
respondToMessage (_callbackSet as) (_defaultCallback as) message
getServerMessage :: DeadpanApp (Maybe EJsonValue)
getServerMessage = DeadpanApp $ ask >>= liftIO . getEJ
respondToMessage :: Lookup Callback -> Callback -> Maybe EJsonValue -> DeadpanApp ()
respondToMessage _ _ Nothing = return ()
respondToMessage cbSet defCb (Just message) = do
let maybeMsgName = message ^? _EJObject "msg" . _EJString
maybeCallback = do msgName <- maybeMsgName
Data.Map.lookup msgName cbSet
case maybeCallback of Just cb -> cb message
Nothing -> defCb message