module Web.SocketIO.Connection
( runConnection
, newSessionTable
) where
import Web.SocketIO.Types
import Web.SocketIO.Util
import Web.SocketIO.Session
import qualified Data.HashMap.Strict as H
import Data.IORef.Lifted
import Control.Applicative ((<$>))
import Control.Concurrent.Lifted (fork)
import Control.Concurrent.Chan.Lifted
import Control.Concurrent.MVar.Lifted
import Control.Monad.Reader
import Control.Monad.Writer
import System.Random (randomRIO)
import System.Timeout.Lifted
newSessionTable :: IO (IORef Table)
newSessionTable = newIORef H.empty
updateSession :: (Table -> Table) -> ConnectionM ()
updateSession update = do
table <- getSessionTable
liftIO (modifyIORef table update)
lookupSession :: SessionID -> ConnectionM (Maybe Session)
lookupSession sessionID = do
table <- getSessionTable
table <- liftIO (readIORef table)
return (H.lookup sessionID table)
executeHandler :: HandlerM () -> BufferHub -> ConnectionM [Listener]
executeHandler handler bufferHub = liftIO $ execWriterT (runReaderT (runHandlerM handler) bufferHub)
runConnection :: Env -> Request -> IO Text
runConnection env req = do
runReaderT (runConnectionM (handleConnection req)) env
handleConnection :: Request -> ConnectionM Text
handleConnection Handshake = do
globalBuffer <- globalBuffer <$> getEnv
globalBufferClone <- dupChan globalBuffer
localBuffer <- newChan
let bufferHub = BufferHub localBuffer globalBufferClone
handler <- getHandler
sessionID <- genSessionID
listeners <- executeHandler handler bufferHub
timeout' <- newEmptyMVar
let session = Session sessionID Connecting bufferHub listeners timeout'
fork $ setTimeout sessionID timeout'
updateSession (H.insert sessionID session)
runSession SessionSyn session
where genSessionID = liftIO $ fmap (fromString . show) (randomRIO (10000000000000000000, 99999999999999999999 :: Integer)) :: ConnectionM Text
handleConnection (Connect sessionID) = do
result <- lookupSession sessionID
clearTimeout sessionID
case result of
Just (Session sessionID status buffer listeners timeout') -> do
let session = Session sessionID Connected buffer listeners timeout'
case status of
Connecting -> do
updateSession (H.insert sessionID session)
runSession SessionAck session
Connected ->
runSession SessionPolling session
Nothing -> do
debug . Error $ fromText sessionID ++ " Unable to find session"
runSession SessionError NoSession
handleConnection (Disconnect sessionID) = do
result <- lookupSession sessionID
response <- case result of
Just session -> runSession SessionDisconnect session
Nothing -> return ""
clearTimeout sessionID
updateSession (H.delete sessionID)
return response
handleConnection (Emit sessionID emitter) = do
clearTimeout sessionID
result <- lookupSession sessionID
case result of
Just session -> runSession (SessionEmit emitter) session
Nothing -> runSession SessionError NoSession
setTimeout :: SessionID -> MVar () -> ConnectionM ()
setTimeout sessionID timeout' = do
configuration <- getConfiguration
let duration = (closeTimeout configuration) * 1000000
debug . Debug $ fromText sessionID ++ " Set Timeout"
result <- timeout duration $ takeMVar timeout'
case result of
Just _ -> setTimeout sessionID timeout'
Nothing -> do
debug . Debug $ fromText sessionID ++ " Close Session"
updateSession (H.delete sessionID)
clearTimeout :: SessionID -> ConnectionM ()
clearTimeout sessionID = do
result <- lookupSession sessionID
case result of
Just (Session _ _ _ _ timeout') -> do
debug . Debug $ fromText sessionID ++ " Clear Timeout"
putMVar timeout' ()
Nothing -> return ()