module Web.SocketIO.Types.Base where
import Web.SocketIO.Types.Log
import Web.SocketIO.Types.String
import Web.SocketIO.Types.Event
import Control.Applicative
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.Chan.Lifted
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Base
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as H
import Data.IORef.Lifted
import Network.HTTP.Types.Header (ResponseHeaders)
import System.IO (Handle)
data Session = Session
{ sessionSessionID :: SessionID
, sessionState :: SessionState
, sessionChannelHub :: ChannelHub
, sessionListener :: [Listener]
, sessionTimeoutVar :: MVar Bool
}
instance Show Session where
show (Session i s _ _ _) = "Session "
++ fromByteString i
++ " [" ++ show s ++ "]"
type SessionID = ByteString
type SessionTable = H.HashMap SessionID Session
data SessionState = Connecting
| Connected
deriving (Show, Eq)
data SessionAction = SessionHandshake
| SessionConnect
| SessionPolling
| SessionEmit Event
| SessionDisconnectByClient
| SessionDisconnectByServer
data Env = Env {
envSessionTableRef :: IORef SessionTable,
envHandler :: HandlerM (),
envConfiguration :: Configuration,
envLogChannel :: Chan ByteString,
envGlobalChannel :: Chan Package
}
data ChannelHub = ChannelHub
{ channelHubLocal :: Chan Package
, channelHubGlobal :: Chan Package
, channelHubOutput :: Chan Package
, channelHubLog :: Chan ByteString
}
data Configuration = Configuration
{ transports :: [Transport]
, logLevel :: Int
, logTo :: Handle
, heartbeats :: Bool
, header :: ResponseHeaders
, closeTimeout :: Int
, heartbeatTimeout :: Int
, heartbeatInterval :: Int
, pollingDuration :: Int
} deriving Show
type Port = Int
type Listener = (EventName, CallbackM ())
class HasSessionID m where
getSessionID :: m SessionID
data HandlerEnv = HandlerEnv
{ handlerEnvChannelHub :: ChannelHub
, handlerEnvSessionID :: SessionID
}
data CallbackEnv = CallbackEnv
{ callbackEnvEventName :: EventName
, callbackEnvPayload :: Payload
, callbackEnvChannelHub :: ChannelHub
, callbackEnvSessionID :: SessionID
}
newtype HandlerM a = HandlerM { runHandlerM :: (ReaderT HandlerEnv (WriterT [Listener] IO)) a }
deriving (Monad, Functor, Applicative, MonadIO, MonadWriter [Listener], MonadReader HandlerEnv, MonadBase IO)
instance HasSessionID HandlerM where
getSessionID = handlerEnvSessionID <$> ask
newtype CallbackM a = CallbackM { runCallbackM :: (WriterT [Event] (ReaderT CallbackEnv IO)) a }
deriving (Monad, Functor, Applicative, MonadIO, MonadWriter [Event], MonadReader CallbackEnv, MonadBase IO)
instance HasSessionID CallbackM where
getSessionID = CallbackM . lift $ callbackEnvSessionID <$> ask
class Publisher m where
emit :: EventName
-> [Aeson.Value]
-> m ()
broadcast :: EventName
-> [Aeson.Value]
-> m ()
instance Publisher HandlerM where
emit eventName reply = do
channel <- channelHubLocal . handlerEnvChannelHub <$> ask
writeChan channel (Private, Event eventName (Payload reply))
broadcast eventName reply = do
channel <- channelHubGlobal . handlerEnvChannelHub <$> ask
sessionID <- handlerEnvSessionID <$> ask
writeChan channel (Broadcast sessionID, Event eventName (Payload reply))
instance Publisher CallbackM where
emit eventName reply = do
channel <- CallbackM . lift $ channelHubLocal . callbackEnvChannelHub <$> ask
writeChan channel (Private, Event eventName (Payload reply))
broadcast eventName reply = do
channel <- CallbackM . lift $ channelHubGlobal . callbackEnvChannelHub <$> ask
sessionID <- CallbackM . lift $ callbackEnvSessionID <$> ask
writeChan channel (Broadcast sessionID, Event eventName (Payload reply))
class Subscriber m where
on :: EventName
-> CallbackM ()
-> m ()
instance Subscriber HandlerM where
on event callback = do
HandlerM . lift . tell $ [(event, callback)]
data Transport = WebSocket | XHRPolling | NoTransport deriving (Eq, Show)
instance Serializable Transport where
serialize WebSocket = "websocket"
serialize XHRPolling = "xhr-polling"
serialize NoTransport = "unknown"