module Web.DDP.Deadpan.DSL
( module Web.DDP.Deadpan.DSL
, module Data.EJson
, module Web.DDP.Deadpan.GUID
, Text
, pack
)
where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Applicative
import Network.WebSockets
import Control.Monad.Reader
import Control.Lens
import Data.Monoid
import Data.Foldable
import Data.Text hiding (reverse, map)
import qualified Data.Sequence as Seq
import Web.DDP.Deadpan.Comms
import Web.DDP.Deadpan.GUID
import Data.EJson
data LookupItem a = LI { _ident :: GUID, _body :: a }
makeLenses ''LookupItem
type Lookup a = Seq.Seq ( LookupItem a )
data AppState cb = AppState
{ _callbackSet :: Lookup cb
, _collections :: EJsonValue
, _connection :: Network.WebSockets.Connection
}
makeLenses ''AppState
type Callback = EJsonValue -> DeadpanApp ()
newtype DeadpanApp a = DeadpanApp
{ _deadpanApp :: ReaderT
(TVar (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
data Version = Vpre1 | Vpre2 | V1 deriving (Eq, Ord, Enum, Bounded, Read, Show)
version2string :: Version -> EJsonValue
version2string Vpre1 = ejstring "pre1"
version2string Vpre2 = ejstring "pre2"
version2string V1 = ejstring "1"
reverseVersions :: [EJsonValue]
reverseVersions = map version2string $ reverse [minBound ..]
runDeadpan :: DeadpanApp a
-> TVar (AppState Callback)
-> IO a
runDeadpan app = runReaderT (_deadpanApp app)
newID :: DeadpanApp GUID
newID = liftIO newGuid
addHandler :: LookupItem Callback -> DeadpanApp ()
addHandler i = modifyAppState foo
where foo x = x &~ callbackSet %= (|>i)
setHandler :: GUID -> Callback -> DeadpanApp GUID
setHandler guid cb = addHandler (LI guid cb) >> return guid
onMatches :: EJsonValue -> Callback -> Callback
onMatches val cb e = when (matches val e) (cb e)
setMatchHandler :: EJsonValue -> Callback -> DeadpanApp GUID
setMatchHandler val cb = newID >>= flip setHandler (onMatches val cb)
setIdHandler :: GUID -> Callback -> DeadpanApp GUID
setIdHandler guid cb = newID >>= flip setHandler (onMatches (makeEJsonId guid) cb)
setMsgHandler :: Text -> Callback -> DeadpanApp GUID
setMsgHandler msg cb = newID >>= flip setHandler (onMatches (makeMsg msg) cb)
setCatchAllHandler :: Callback -> DeadpanApp GUID
setCatchAllHandler cb = newID >>= flip setHandler cb
deleteHandlerID :: GUID -> DeadpanApp ()
deleteHandlerID k = modifyAppState $
over callbackSet (Seq.filter ((/= k) . _ident))
modifyAppState :: (AppState Callback -> AppState Callback) -> DeadpanApp ()
modifyAppState f = DeadpanApp $ ask >>= liftIO . atomically . flip modifyTVar f
getAppState :: DeadpanApp (AppState Callback)
getAppState = DeadpanApp $ ask >>= liftIO . atomically . readTVar
getAppStateL :: Prism' (AppState Callback) x -> DeadpanApp (Maybe x)
getAppStateL l = DeadpanApp $ do
v <- ask
w <- liftIO $ atomically $ readTVar v
return $ w ^? l
getCollections :: DeadpanApp EJsonValue
getCollections = fmap _collections getAppState
sendData :: EJsonValue -> DeadpanApp ()
sendData v = getAppState >>= liftIO . flip sendEJ v . _connection
sendMessage :: Text -> EJsonValue -> DeadpanApp ()
sendMessage key m = sendData messageData
where
messageData = makeMsg key `mappend` m
connectVersion :: Version -> DeadpanApp ()
connectVersion v = sendMessage "connect" $ ejobject [ ("version", version2string v)
, ("support", ejarray reverseVersions) ]
connect :: DeadpanApp ()
connect = sendMessage "connect" $ ejobject [ ("version", version2string V1)
, ("support", ejarray reverseVersions) ]
fork :: DeadpanApp a -> DeadpanApp ThreadId
fork app = do
st <- DeadpanApp ask
liftIO $ forkIO $ void $ runDeadpan app st
fetchMessagesThenExit :: DeadpanApp a -> DeadpanApp a
fetchMessagesThenExit app = do tid <- fetchMessages
result <- app
liftIO $ killThread tid
return result
fetchMessages :: DeadpanApp ThreadId
fetchMessages = fork $ forever $ do message <- getServerMessage
as <- getAppState
respondToMessage (_callbackSet as) message
getServerMessage :: DeadpanApp (Maybe EJsonValue)
getServerMessage = getAppState >>= liftIO . getEJ . _connection
respondToMessage :: Lookup Callback -> Maybe EJsonValue -> DeadpanApp ()
respondToMessage _ Nothing = return ()
respondToMessage cbSet (Just m) = for_ cbSet $ \cb -> (fork . _body cb) m