diff --git a/Web/SocketIO.hs b/Web/SocketIO.hs --- a/Web/SocketIO.hs +++ b/Web/SocketIO.hs @@ -1,11 +1,14 @@ +-------------------------------------------------------------------------------- +-- | Socket.IO for Haskell folks. + module Web.SocketIO ( -- * How to use this module -- | -- - -- Note that most of the string literals below are of type Text. + -- Note that most of the string literals below are of type Lazy Text. -- - -- >{-\# LANGUAGE OverloadedStrings \#-} + -- >{-# LANGUAGE OverloadedStrings #-} -- > -- >import Web.SocketIO -- > @@ -22,6 +25,8 @@ -- > -- do some IO -- > on "Kim Jong-Un" $ liftIO launchMissile -- > + -- > -- broadcast + -- > broadcast "UN" "North Korea is best Korea" -- * Running a standalone server server @@ -35,7 +40,10 @@ , Subscriber(..) , Publisher(..) , reply - , Event + , getEventName + , HasSessionID(..) + , EventName + , SessionID -- ** Special events -- | On disconnection diff --git a/Web/SocketIO/Channel.hs b/Web/SocketIO/Channel.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Channel.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------------------- +-- | Unbounded FIFO channel for sessions +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Web.SocketIO.Channel + ( newGlobalChannel + , newLogChannel + , streamToHandle + , streamBothChannelTo + , makeChannelHub + , stderr + ) where + +-------------------------------------------------------------------------------- +import Web.SocketIO.Types + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Concurrent.Chan.Lifted +import Control.Concurrent.Lifted (fork) +import Control.Monad (forever, void) +import Control.Monad.Base (MonadBase) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString.Char8 as BC +import System.IO (Handle, stderr) + +-------------------------------------------------------------------------------- +-- | Server-wide cross-session channel for broadcasting. +newGlobalChannel :: MonadBase IO m => m (Chan Package) +newGlobalChannel = newChan + +-------------------------------------------------------------------------------- +-- | Server-wide cross-session channel for logging. +newLogChannel :: MonadBase IO m => m (Chan ByteString) +newLogChannel = newChan + +-------------------------------------------------------------------------------- +-- | Forks a thread that sucks stuffs from a channel to a handle forever. +streamToHandle :: Handle -> Chan ByteString -> IO () +streamToHandle handle channel = void . fork . forever $ do + readChan channel >>= BC.hPutStrLn handle + +-------------------------------------------------------------------------------- +-- | Initialize a collection of channels for a new `Web.SocketIO.Types.Base.Session` +makeChannelHub :: SessionID -> ConnectionM ChannelHub +makeChannelHub sessionID = do + + globalChannel <- envGlobalChannel <$> getEnv + logChannel <- envLogChannel <$> getEnv + + -- duplicate global channel + globalChannelClone <- dupChan globalChannel + + localChannel <- newChan + outputChannel <- newChan + + streamBothChannelTo sessionID localChannel globalChannelClone outputChannel + + return $ ChannelHub localChannel globalChannelClone outputChannel logChannel + +------------------------------------------------------------------------------ +-- | Merges both local and global (broadcast) data to output channel. +streamBothChannelTo :: (MonadBaseControl IO m, MonadBase IO m) => SessionID -> Chan Package -> Chan Package -> Chan Package -> m () +streamBothChannelTo sessionID local global output = do + -- local + void . fork . forever $ readChan local >>= writeChan output + -- global, drops Broacast package if same sessionID (same origin) + void . fork . forever $ do + package <- readChan global + case package of + (Private, _) -> writeChan output package + (Broadcast sessionID', _) -> do + if sessionID /= sessionID' + then writeChan output package + else return () diff --git a/Web/SocketIO/Connection.hs b/Web/SocketIO/Connection.hs --- a/Web/SocketIO/Connection.hs +++ b/Web/SocketIO/Connection.hs @@ -1,131 +1,165 @@ +-------------------------------------------------------------------------------- +-- | Requests are comsumed and sessions are invoked at this stage. {-# LANGUAGE OverloadedStrings #-} module Web.SocketIO.Connection ( runConnection - , newSessionTable + , newSessionTableRef ) where -------------------------------------------------------------------------------- +import Web.SocketIO.Channel +import Web.SocketIO.Session +import Web.SocketIO.Timeout 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 qualified Data.HashMap.Strict as H +import Data.IORef.Lifted import System.Random (randomRIO) -import System.Timeout.Lifted -------------------------------------------------------------------------------- -newSessionTable :: IO (IORef Table) -newSessionTable = newIORef H.empty +-- +-- # State transitions after handshake +-- +-- Connect Disconnect Emit Timeout +-- ---------------------------------------------------------------------------- +-- +-- Connecting Connected Disconnected Disconnected Disconnected +-- (OK) (OK) (Error) (OK) +-- x +-- Connected Connected Disconnected Connected Disconnected +-- (OK) (OK) (OK) (OK) +-- Noop x +-------------------------------------------------------------------------------- +-- | Initialize session table +newSessionTableRef :: IO (IORef SessionTable) +newSessionTableRef = newIORef H.empty -------------------------------------------------------------------------------- -updateSession :: (Table -> Table) -> ConnectionM () +-- | Session table helper function +updateSession :: (SessionTable -> SessionTable) -> ConnectionM () updateSession update = do - table <- getSessionTable - liftIO (modifyIORef table update) + tableRef <- getSessionTableRef + liftIO (modifyIORef tableRef update) -------------------------------------------------------------------------------- +-- | Session table helper function lookupSession :: SessionID -> ConnectionM (Maybe Session) lookupSession sessionID = do - table <- getSessionTable - table <- liftIO (readIORef table) + tableRef <- getSessionTableRef + table <- liftIO (readIORef tableRef) + --debug Debug $ sessionID <> " [Session] Lookup" return (H.lookup sessionID table) -------------------------------------------------------------------------------- -executeHandler :: HandlerM () -> BufferHub -> ConnectionM [Listener] -executeHandler handler bufferHub = liftIO $ execWriterT (runReaderT (runHandlerM handler) bufferHub) +-- | Runs handler whenever new session comes in +executeHandler :: HandlerM () -> ChannelHub -> SessionID -> ConnectionM [Listener] +executeHandler handler channelHub sessionID = liftIO $ execWriterT (runReaderT (runHandlerM handler) (HandlerEnv channelHub sessionID)) -------------------------------------------------------------------------------- -runConnection :: Env -> Request -> IO Text +-- | Consumes request, hand it to the next stage, and returns its result. +runConnection :: Env -> Request -> IO Message runConnection env req = do - runReaderT (runConnectionM (handleConnection req)) env + runReaderT (runConnectionM (handleConnection =<< (retrieveSession 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 +-- | Explicitly exposes `Web.SocketIO.Types.Base.SessionState` and make use of totality checker. +split :: Maybe Session -> Maybe (Session, SessionState) +split (Just session@(Session _ state _ _ _)) = Just (session, state) +split Nothing = Nothing - let session = Session sessionID Connecting bufferHub listeners timeout' +-------------------------------------------------------------------------------- +-- | Accesses the session table and makes session explicit +retrieveSession :: Request -> ConnectionM (Request, Maybe (Session, SessionState)) +retrieveSession Handshake = do + return (Handshake, Nothing) +retrieveSession (Connect sessionID) = do + result <- lookupSession sessionID + return (Connect sessionID, split result) +retrieveSession (Disconnect sessionID) = do + result <- lookupSession sessionID + return (Disconnect sessionID, split result) +retrieveSession (Emit sessionID e) = do + result <- lookupSession sessionID + return (Emit sessionID e, split result) - fork $ setTimeout sessionID timeout' +-------------------------------------------------------------------------------- +-- | Big time +handleConnection :: (Request, Maybe (Session, SessionState)) -> ConnectionM Message +handleConnection (Handshake, _) = do + -- establish a session + session@(Session sessionID _ _ _ _) <- makeSession + + -- session table management updateSession (H.insert sessionID session) + debugLog Debug session "[Session] Created" + debugLog Debug session "[Request] Handshake" + + -- timeout + setTimeout session - runSession SessionSyn session - where genSessionID = liftIO $ fmap (fromString . show) (randomRIO (10000000000000000000, 99999999999999999999 :: Integer)) :: ConnectionM Text + -- next stage + runSession SessionHandshake session -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 + where genSessionID = liftIO $ serialize <$> randomRIO (100000000000, 999999999999 :: Integer) + makeSession = do -handleConnection (Disconnect sessionID) = do + sessionID <- genSessionID + channelHub <- makeChannelHub sessionID + handler <- getHandler + listeners <- executeHandler handler channelHub sessionID + timeoutVar <- newEmptyMVar - result <- lookupSession sessionID - response <- case result of - Just session -> runSession SessionDisconnect session - Nothing -> return "" + return $ Session sessionID Connecting channelHub listeners timeoutVar - clearTimeout sessionID - updateSession (H.delete sessionID) +handleConnection (Connect sessionID, Just (session, Connecting)) = do + debugLog Debug session "[Request] Connect: ACK" + extendTimeout session + let session' = session { sessionState = Connected } + updateSession (H.insert sessionID session') + runSession SessionConnect session' - return response +handleConnection (Connect _, Just (session, Connected)) = do + debugLog Debug session "[Request] Connect: Polling" + extendTimeout session + runSession SessionPolling session -handleConnection (Emit sessionID emitter) = do - clearTimeout sessionID +handleConnection (Connect sessionID, Nothing) = do + debug Warn $ sessionID <> " [Request] Connect: Session not found" + return $ MsgError NoEndpoint NoData - result <- lookupSession sessionID - case result of - Just session -> runSession (SessionEmit emitter) session - Nothing -> runSession SessionError NoSession +handleConnection (Disconnect sessionID, Just (session, _)) = do + debugLog Debug session "[Request] Disconnect: By client" + clearTimeout session + updateSession (H.delete sessionID) + debugLog Debug session "[Session] Destroyed" + runSession SessionDisconnectByClient session --------------------------------------------------------------------------------- -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' +handleConnection (Disconnect sessionID, Nothing) = do + debug Warn $ sessionID <> " [Request] Disconnect: Session not found" + return MsgNoop - case result of - Just _ -> setTimeout sessionID timeout' - Nothing -> do - debug . Debug $ fromText sessionID ++ " Close Session" - updateSession (H.delete sessionID) +handleConnection (Emit _ _, Just (session, Connecting)) = do + extendTimeout session + debugLog Warn session "[Request] Emit: Session still connecting, not ACKed" + return $ MsgError NoEndpoint NoData --------------------------------------------------------------------------------- -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 () +handleConnection (Emit _ event@(Event eventName payloads), Just (session, Connected)) = do + debugLog Debug session $ "[Request] Emit: " <> serialize eventName <> " " <> serialize payloads + runSession (SessionEmit event) session + +handleConnection (Emit _ NoEvent, Just (session, Connected)) = do + debugLog Warn session $ "[Request] Emit: event malformed" + return $ MsgError NoEndpoint NoData + +handleConnection (Emit sessionID _, Nothing) = do + debug Warn $ sessionID <> " [Request] Emit: Session not found" + return $ MsgError NoEndpoint NoData diff --git a/Web/SocketIO/Event.hs b/Web/SocketIO/Event.hs --- a/Web/SocketIO/Event.hs +++ b/Web/SocketIO/Event.hs @@ -1,18 +1,29 @@ +-------------------------------------------------------------------------------- +-- | Functions exposed to end users in CallbackM {-# LANGUAGE OverloadedStrings #-} module Web.SocketIO.Event where +-------------------------------------------------------------------------------- import Web.SocketIO.Types +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) import Control.Monad.Reader -------------------------------------------------------------------------------- --- | messages carried with the event +-- | Extracts payload carried by the event -- -- @ -- `on` \"echo\" $ do --- messages <- reply --- liftIO $ print messages +-- payload <- reply +-- liftIO $ print payload +-- emit "echo" payload -- @ reply :: CallbackM [Text] -reply = ask +reply = callbackEnvPayload <$> ask + +-------------------------------------------------------------------------------- +-- | Name of the event +getEventName :: CallbackM EventName +getEventName = callbackEnvEventName <$> ask diff --git a/Web/SocketIO/Parser.hs b/Web/SocketIO/Parser.hs deleted file mode 100644 --- a/Web/SocketIO/Parser.hs +++ /dev/null @@ -1,127 +0,0 @@ --------------------------------------------------------------------------------- --- | Parses message body -{-# LANGUAGE OverloadedStrings #-} -module Web.SocketIO.Parser (parseMessage, parsePath) where - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>), (<*>)) -import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL -import Text.ParserCombinators.Parsec --------------------------------------------------------------------------------- -import Web.SocketIO.Types - --------------------------------------------------------------------------------- -instance FromJSON Emitter where - parseJSON (Object v) = Emitter <$> - v .: "name" <*> - v .:? "args" .!= ([] :: [Text]) - --------------------------------------------------------------------------------- -decodeEmitter :: BL.ByteString -> Maybe Emitter -decodeEmitter = decode - --------------------------------------------------------------------------------- -parseMessage :: BL.ByteString -> Message -parseMessage text = case parse parseMessage' "" string of - Left _ -> MsgNoop - Right x -> x - where string = fromLazyByteString text - --------------------------------------------------------------------------------- -parseMessage' :: Parser Message -parseMessage' = do - n <- digit - case n of - '0' -> (parseEndpoint >>= return . MsgDisconnect) - <|> ( return $ MsgDisconnect NoEndpoint) - '1' -> (parseEndpoint >>= return . MsgConnect) - <|> ( return $ MsgConnect NoEndpoint) - '2' -> return MsgHeartbeat - '3' -> parseRegularMessage Msg - '4' -> parseRegularMessage MsgJSON - '5' -> MsgEvent <$> parseID - <*> parseEndpoint - <*> parseEmitter - '6' -> try (do - string ":::" - n <- read <$> number - char '+' - d <- fromString <$> text - return $ MsgACK (ID n) (Data d) - ) <|> (do - string ":::" - n <- read <$> number - return $ MsgACK (ID n) NoData - ) - '7' -> colon >> MsgError <$> parseEndpoint <*> parseData - '8' -> return $ MsgNoop - _ -> return $ MsgNoop - where parseRegularMessage ctr = ctr <$> parseID - <*> parseEndpoint - <*> parseData - --------------------------------------------------------------------------------- -endpoint = many1 $ satisfy (/= ':') -text = many1 anyChar -number = many1 digit -colon = char ':' -textWithoutSlash = many1 $ satisfy (/= '/') -slash = char '/' - --------------------------------------------------------------------------------- -parseID :: Parser ID -parseID = try (colon >> number >>= plus >>= return . IDPlus . read) - <|> try (colon >> number >>= return . ID . read) - <|> (colon >> return NoID) - where plus n = char '+' >> return n - --------------------------------------------------------------------------------- -parseEndpoint :: Parser Endpoint -parseEndpoint = try (colon >> endpoint >>= return . Endpoint) - <|> (colon >> return NoEndpoint) - --------------------------------------------------------------------------------- -parseData :: Parser Data -parseData = try (colon >> text >>= return . Data . fromString) - <|> (colon >> return NoData) - --------------------------------------------------------------------------------- -parseEmitter :: Parser Emitter -parseEmitter = try (do - colon - t <- text - case decodeEmitter (fromString t) of - Just e -> return e - Nothing -> return NoEmitter - ) - <|> (colon >> return NoEmitter) - -------------------------------------------------------------------------------- -parseTransport :: Parser Transport -parseTransport = try (string "websocket" >> return WebSocket) - <|> (string "xhr-polling" >> return XHRPolling) - <|> return NoTransport - --------------------------------------------------------------------------------- -parsePath :: ByteString -> Path -parsePath path = case parse parsePath' "" string of - Left _ -> WithoutSession "" "" - Right x -> x - where string = fromByteString path - --------------------------------------------------------------------------------- -parsePath' :: Parser Path -parsePath' = do - slash - namespace <- fromString <$> textWithoutSlash - slash - protocol <- fromString <$> textWithoutSlash - slash - try (do - transport <- parseTransport - slash - sessionID <- fromString <$> textWithoutSlash - return $ WithSession namespace protocol transport sessionID - ) <|> (return $ WithoutSession namespace protocol) diff --git a/Web/SocketIO/Protocol.hs b/Web/SocketIO/Protocol.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Protocol.hs @@ -0,0 +1,155 @@ +-------------------------------------------------------------------------------- +-- | Socket.IO Protocol 1.0 +{-# LANGUAGE OverloadedStrings #-} + +module Web.SocketIO.Protocol (parseFramedMessage, parsePath) where + +-------------------------------------------------------------------------------- +import Web.SocketIO.Types + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson +import qualified Data.ByteString.Lazy as BL +import Text.Parsec +import Text.Parsec.ByteString.Lazy + +-------------------------------------------------------------------------------- +-- | Parse raw ByteString to Messages +parseFramedMessage :: BL.ByteString -> Framed Message +parseFramedMessage input = if isSingleton + then Framed $ [parseMessage' input] + else Framed $ map parseMessage' splitted + where splitted = split input + parseMessage' x = case parse parseMessage "" x of + Left _ -> MsgNoop + Right a -> a + isSingleton = not (BL.null input) && BL.head input /= 239 +-------------------------------------------------------------------------------- +-- | Split raw ByteString with U+FFFD as delimiter +split :: BL.ByteString -> [BL.ByteString] +split str = map (BL.drop 2) . skipOddIndexed True . filter isDelimiter . BL.split 239 $ str + where isDelimiter x = not (BL.null x) + && (BL.head x == 191) + && (BL.head (BL.tail x) == 189) + skipOddIndexed _ [] = [] + skipOddIndexed True (_:xs) = skipOddIndexed False xs + skipOddIndexed False (x:xs) = x : skipOddIndexed True xs + +-------------------------------------------------------------------------------- +-- | Message, not framed +parseMessage :: Parser Message +parseMessage = do + n <- digit + case n of + '0' -> (parseID >> parseEndpoint >>= return . MsgDisconnect) + <|> ( return $ MsgDisconnect NoEndpoint) + '1' -> (parseID >> parseEndpoint >>= return . MsgConnect) + <|> ( return $ MsgConnect NoEndpoint) + '2' -> return MsgHeartbeat + '3' -> parseRegularMessage Msg + '4' -> parseRegularMessage MsgJSON + '5' -> MsgEvent <$> parseID + <*> parseEndpoint + <*> parseEvent + '6' -> try (do + string ":::" + n' <- read <$> number + char '+' + d <- fromString <$> text + return $ MsgACK (ID n') (Data d) + ) <|> (do + string ":::" + n' <- read <$> number + return $ MsgACK (ID n') NoData + ) + '7' -> colon >> MsgError <$> parseEndpoint <*> parseData + '8' -> return $ MsgNoop + _ -> return $ MsgNoop + where parseRegularMessage ctr = ctr <$> parseID + <*> parseEndpoint + <*> parseData + +-------------------------------------------------------------------------------- +endpoint :: Parser String +endpoint = many1 $ satisfy (/= ':') + +-------------------------------------------------------------------------------- +number :: Parser String +number = many1 digit + +-------------------------------------------------------------------------------- +colon :: Parser Char +colon = char ':' + +-------------------------------------------------------------------------------- +parseID :: Parser ID +parseID = try (colon >> number >>= plus >>= return . IDPlus . read) + <|> try (colon >> number >>= return . ID . read) + <|> (colon >> return NoID) + where plus n = char '+' >> return n + +-------------------------------------------------------------------------------- +parseEndpoint :: Parser Endpoint +parseEndpoint = try (colon >> fromString <$> endpoint >>= return . Endpoint) + <|> (colon >> return NoEndpoint) + +-------------------------------------------------------------------------------- +parseData :: Parser Data +parseData = try (colon >> text >>= return . Data . fromString) + <|> (colon >> return NoData) + +-------------------------------------------------------------------------------- +parseEvent :: Parser Event +parseEvent = try (do + colon + t <- text + case decode (fromString t) of + Just e -> return e + Nothing -> return NoEvent + ) + <|> (colon >> return NoEvent) + + +-------------------------------------------------------------------------------- +-- | Slashes as delimiters +textWithoutSlash :: Parser String +textWithoutSlash = many1 $ satisfy (/= '/') + +slash :: Parser Char +slash = char '/' + +-------------------------------------------------------------------------------- +-- | Non-empty text +text :: Parser String +text = many1 anyChar + +------------------------------------------------------------------------------- +parseTransport :: Parser Transport +parseTransport = try (string "websocket" >> return WebSocket) + <|> (string "xhr-polling" >> return XHRPolling) + <|> (string "unknown" >> return NoTransport) + <|> return NoTransport + +-------------------------------------------------------------------------------- +-- | With wrapper +parsePath :: ByteString -> Path +parsePath path = case parse parsePath' "" (fromByteString path) of + Left _ -> WithoutSession "" "" + Right x -> x + +-------------------------------------------------------------------------------- +-- | Raw Parsec combinator, without wrapper +parsePath' :: Parser Path +parsePath' = do + slash + namespace <- fromString <$> textWithoutSlash + slash + protocol <- fromString <$> textWithoutSlash + slash + try (do + transport <- parseTransport + slash + sessionID <- fromString <$> textWithoutSlash + return $ WithSession namespace protocol transport sessionID + ) <|> (return $ WithoutSession namespace protocol) diff --git a/Web/SocketIO/Request.hs b/Web/SocketIO/Request.hs --- a/Web/SocketIO/Request.hs +++ b/Web/SocketIO/Request.hs @@ -1,44 +1,54 @@ +-------------------------------------------------------------------------------- +-- | Converts HTTP requests to Socket.IO requests {-# LANGUAGE OverloadedStrings #-} -module Web.SocketIO.Request (processHTTPRequest) where - -import Web.SocketIO.Types - -import Web.SocketIO.Parser - -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Resource (runResourceT) +module Web.SocketIO.Request (parseHTTPRequest) where -import qualified Network.Wai as Wai -import Network.HTTP.Types (Method) +-------------------------------------------------------------------------------- +import Web.SocketIO.Types +import Web.SocketIO.Protocol -import Data.Conduit.List (consume) -import Data.Conduit (($$)) -import Data.Monoid (mconcat) +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import qualified Network.Wai as Wai +import Network.HTTP.Types (Method) -type RequestInfo = (Method, Path, Message) +-------------------------------------------------------------------------------- +-- | Information of a HTTP reqeust we need +type RequestInfo = (Method, Path, Framed Message) +-------------------------------------------------------------------------------- +-- | Extracts from HTTP reqeusts retrieveRequestInfo :: Wai.Request -> IO RequestInfo retrieveRequestInfo request = do - body <- parseHTTPBody request + framedMessages <- parseHTTPBody request let path = parsePath (Wai.rawPathInfo request) return ( Wai.requestMethod request , path - , body + , framedMessages ) -processRequestInfo :: RequestInfo -> Request -processRequestInfo ("GET" , (WithoutSession _ _) , _ ) = Handshake -processRequestInfo ("GET" , (WithSession _ _ _ sessionID), _ ) = Connect sessionID -processRequestInfo ("POST", (WithSession _ _ _ sessionID), MsgEvent _ _ emitter) = Emit sessionID emitter -processRequestInfo (_ , (WithSession _ _ _ sessionID), _ ) = Disconnect sessionID +-------------------------------------------------------------------------------- +-- | Converts to SocketIO request +processRequestInfo :: RequestInfo -> [Request] +processRequestInfo ("GET" , (WithoutSession _ _) , _ ) = [Handshake] +processRequestInfo ("GET" , (WithSession _ _ _ sessionID), _ ) = [Connect sessionID] +processRequestInfo ("POST", (WithSession _ _ _ sessionID), Framed messages) = requests + where requests = foldr extractEvent [] messages + extractEvent (MsgEvent _ _ event) acc = Emit sessionID event : acc + extractEvent _ acc = acc +processRequestInfo (_ , (WithSession _ _ _ sessionID), _ ) = [Disconnect sessionID] processRequestInfo _ = error "error parsing http request" -processHTTPRequest :: Wai.Request -> IO Request -processHTTPRequest request = fmap processRequestInfo (retrieveRequestInfo request) +-------------------------------------------------------------------------------- +-- | The request part +parseHTTPRequest :: Wai.Request -> IO [Request] +parseHTTPRequest request = fmap processRequestInfo (retrieveRequestInfo request) -parseHTTPBody :: Wai.Request -> IO Message -parseHTTPBody req = parseMessage . fromByteString . mconcat <$> runResourceT (Wai.requestBody req $$ consume) +-------------------------------------------------------------------------------- +-- | The message part +parseHTTPBody :: Wai.Request -> IO (Framed Message) +parseHTTPBody req = parseFramedMessage <$> Wai.lazyRequestBody req diff --git a/Web/SocketIO/Server.hs b/Web/SocketIO/Server.hs --- a/Web/SocketIO/Server.hs +++ b/Web/SocketIO/Server.hs @@ -1,3 +1,5 @@ +-------------------------------------------------------------------------------- +-- | Servers, standalone or adapted {-# LANGUAGE OverloadedStrings #-} module Web.SocketIO.Server @@ -6,19 +8,19 @@ , defaultConfig ) where -import Web.SocketIO.Types +-------------------------------------------------------------------------------- +import Web.SocketIO.Channel import Web.SocketIO.Connection import Web.SocketIO.Request +import Web.SocketIO.Types -import Control.Concurrent.Chan -import Control.Concurrent (forkIO) -import Control.Monad (forever) +-------------------------------------------------------------------------------- import Control.Monad.Trans (liftIO) -import Network.HTTP.Types (status200) +import Network.HTTP.Types (Status, status200, status403) +import Network.HTTP.Types.Header (ResponseHeaders) import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp - -------------------------------------------------------------------------------- -- | Run a socket.io application, build on top of Warp. server :: Port -> HandlerM () -> IO () @@ -29,44 +31,69 @@ serverConfig :: Port -> Configuration -> HandlerM () -> IO () serverConfig port config handler = do - tableRef <- newSessionTable - - stdout <- newChan :: IO (Chan String) - - globalChannel <- newChan :: IO (Buffer) + -- session table + tableRef <- newSessionTableRef - forkIO . forever $ do - readChan stdout >>= putStrLn + -- output channels + logChannel <- newLogChannel + globalChannel <- newGlobalChannel + streamToHandle (logTo config) logChannel - let env = Env tableRef handler config stdout globalChannel + let vorspann = header config + let env = Env tableRef handler config logChannel globalChannel - Warp.run port (httpApp (runConnection env)) + -- run it with Warp + Warp.run port (httpApp vorspann (runConnection env)) -------------------------------------------------------------------------------- -httpApp :: (Request -> IO Text) -> Wai.Application -httpApp runConnection' httpRequest = liftIO $ do - req <- processHTTPRequest httpRequest - response <- runConnection' req - text response +-- | Wrapped as a HTTP app +httpApp :: ResponseHeaders -> (Request -> IO Message) -> Wai.Application +httpApp headerFields runConnection' httpRequest = liftIO $ do + + let origin = lookupOrigin httpRequest + let headerFields' = insertOrigin headerFields origin + reqs <- parseHTTPRequest httpRequest + mapM runConnection' reqs >>= waiResponse headerFields' + + where lookupOrigin req = case lookup "Origin" (Wai.requestHeaders req) of + Just origin -> origin + Nothing -> "*" + insertOrigin fields origin = case lookup "Access-Control-Allow-Origin" fields of + Just _ -> fields + Nothing -> ("Access-Control-Allow-Origin", origin) : fields -------------------------------------------------------------------------------- --- | Default configurations to be overridden. +-- | Default configuration. -- - -- > defaultConfig :: Configuration -- > defaultConfig = Configuration -- > { transports = [XHRPolling] - -- > , logLevel = 3 - -- > , closeTimeout = 60 - -- > , pollingDuration = 20 + -- > , logLevel = 2 + -- > , logTo = stderr + -- > , header = [("Access-Control-Allow-Credentials", "true")] -- > , heartbeats = True + -- > , closeTimeout = 60 -- > , heartbeatTimeout = 60 -- > , heartbeatInterval = 25 + -- > , pollingDuration = 20 -- > } -- +-- You can override it like so: + -- + -- > myConfig = defaultConfig { logLevel = 0 } + -- +-- Unless specified, the header will be modified to enable cross-origin resource sharing (CORS) like this. + -- + -- > header = + -- > [ ("Access-Control-Allow-Origin", )] + -- > , ("Access-Control-Allow-Credentials", "true") + -- > ] + -- defaultConfig :: Configuration defaultConfig = Configuration { transports = [XHRPolling] - , logLevel = 3 + , logLevel = 2 + , logTo = stderr + , header = [("Access-Control-Allow-Credentials", "true")] , heartbeats = True , closeTimeout = 60 , heartbeatTimeout = 60 @@ -75,12 +102,16 @@ } -------------------------------------------------------------------------------- -text :: Monad m => Text -> m Wai.Response -text = return . Wai.responseLBS status200 header . fromText - where - header = [ - ("Content-Type", "text/plain"), - ("Connection", "keep-alive"), - ("Access-Control-Allow-Credentials", "true"), - ("Access-Control-Allow-Origin", "http://localhost:3000") - ] +-- | Make Wai response +waiResponse :: Monad m => ResponseHeaders -> [Message] -> m Wai.Response +waiResponse vorspann messages = do + return . Wai.responseLBS status vorspann . serialize . Framed $ messages + where status = if status403 `elem` (map toHTTPStatus messages) + then status403 + else status200 + +-------------------------------------------------------------------------------- +-- | Maps SocketIO respond message to HTTP status code +toHTTPStatus :: Message -> Status +toHTTPStatus (MsgError _ _) = status403 +toHTTPStatus _ = status200 diff --git a/Web/SocketIO/Session.hs b/Web/SocketIO/Session.hs --- a/Web/SocketIO/Session.hs +++ b/Web/SocketIO/Session.hs @@ -1,3 +1,5 @@ +-------------------------------------------------------------------------------- +-- | Session Layer {-# LANGUAGE OverloadedStrings #-} module Web.SocketIO.Session (runSession) where @@ -6,86 +8,94 @@ import Web.SocketIO.Util -------------------------------------------------------------------------------- -import Data.List (intersperse) import Control.Monad.Reader import Control.Monad.Writer import Control.Concurrent.Chan.Lifted -import Control.Concurrent.MVar.Lifted import Control.Concurrent.Lifted (fork) import System.Timeout.Lifted -------------------------------------------------------------------------------- -handleSession :: SessionState -> SessionM Text -handleSession SessionSyn = do +-- | The final stage +handleSession :: SessionAction -> SessionM Message +handleSession SessionHandshake = do sessionID <- getSessionID configuration <- getConfiguration - let heartbeatTimeout' = fromString (show (heartbeatTimeout configuration)) - let closeTimeout' = fromString (show (closeTimeout configuration)) - let transportType = mconcat . intersperse "," . map toMessage $ transports configuration - - - - debug . Info $ fromText sessionID ++ " Handshake authorized" - return $ sessionID <> ":" <> heartbeatTimeout' <> ":" <> closeTimeout' <> ":" <> transportType + let heartbeatTimeout' = if heartbeats configuration + then heartbeatTimeout configuration + else 0 + return $ MsgHandshake + sessionID + heartbeatTimeout' + (closeTimeout configuration) + (transports configuration) + -handleSession SessionAck = do - sessionID <- getSessionID - debug . Info $ fromText sessionID ++ " Connected" - return "1::" +handleSession SessionConnect = do + debugSession Info $ "Connected" + return $ MsgConnect NoEndpoint handleSession SessionPolling = do - sessionID <- getSessionID configuration <- getConfiguration - bufferHub <- getBufferHub + ChannelHub _ _ outputChannel _ <- getChannelHub - result <- timeout (pollingDuration configuration * 1000000) (readBothChannel bufferHub) + result <- timeout (pollingDuration configuration * 1000000) (readChan outputChannel) + case result of - Just r -> do - let msg = toMessage (MsgEvent NoID NoEndpoint r) - debug . Debug $ fromText sessionID ++ " Sending Message: " ++ fromText msg - return msg + -- private + Just (Private, Event eventName payloads) -> do + debugSession Info $ "Emit: " <> serialize eventName + return $ MsgEvent NoID NoEndpoint (Event eventName payloads) + -- broadcast + Just (Broadcast _, Event eventName payloads) -> do + -- this log will cause massive overhead, need to be removed + debugSession Info $ "Broadcast: " <> serialize eventName + return $ MsgEvent NoID NoEndpoint (Event eventName payloads) + -- wtf + Just (_, NoEvent) -> do + debugSession Error $ "Event malformed" + return $ MsgEvent NoID NoEndpoint NoEvent + -- no output, keep polling Nothing -> do - debug . Debug $ fromText sessionID ++ " Polling" - return "8::" + return MsgNoop - where readBothChannel (BufferHub localBuffer globalBuffer) = do - output <- newEmptyMVar - _ <- fork (readChan localBuffer >>= putMVar output) - _ <- fork (readChan globalBuffer >>= putMVar output) - - takeMVar output +handleSession (SessionEmit event) = do + case event of + Event eventName _ -> debugSession Info $ "On: " <> serialize eventName + NoEvent -> debugSession Error $ "Event malformed" + triggerEvent event + return $ MsgConnect NoEndpoint +handleSession SessionDisconnectByClient = do + debugSession Info $ "Disconnected by client" + triggerEvent (Event "disconnect" []) + return $ MsgNoop +handleSession SessionDisconnectByServer = do + debugSession Info $ "Disconnected by server" + triggerEvent (Event "disconnect" []) + return $ MsgNoop -handleSession (SessionEmit emitter) = do - sessionID <- getSessionID - bufferHub <- getBufferHub - debug . Info $ fromText sessionID ++ " Emit" - triggerListener emitter bufferHub - return "1" -handleSession SessionDisconnect = do +-------------------------------------------------------------------------------- +-- | Trigger corresponding listeners +triggerEvent :: Event -> SessionM () +triggerEvent (Event eventName payload) = do + sessionID <- getSessionID - debug . Info $ fromText sessionID ++ " Disconnected" - bufferHub <- getBufferHub - triggerListener (Emitter "disconnect" []) bufferHub - return "1" -handleSession SessionError = return "7" + channelHub <- getChannelHub --------------------------------------------------------------------------------- -triggerListener :: Emitter -> BufferHub -> SessionM () -triggerListener (Emitter event reply) channelHub = do -- read listeners <- getListener -- filter out callbacks to be triggered - let correspondingCallbacks = filter ((==) event . fst) listeners + let correspondingCallbacks = filter ((==) eventName . fst) listeners -- trigger them all forM_ correspondingCallbacks $ \(_, callback) -> fork $ do - _ <- liftIO $ runReaderT (runReaderT (execWriterT (runCallbackM callback)) reply) channelHub + _ <- liftIO $ runReaderT (execWriterT (runCallbackM callback)) (CallbackEnv eventName payload channelHub sessionID) return () -triggerListener NoEmitter _ = error "trigger listeners with any emitters" +triggerEvent NoEvent = error "triggering malformed event" -------------------------------------------------------------------------------- -runSession :: SessionState -> Session -> ConnectionM Text -runSession state session = runReaderT (runSessionM (handleSession state)) session +-- | Wrapper +runSession :: SessionAction -> Session -> ConnectionM Message +runSession action session = runReaderT (runSessionM (handleSession action)) session diff --git a/Web/SocketIO/Timeout.hs b/Web/SocketIO/Timeout.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Timeout.hs @@ -0,0 +1,71 @@ +-------------------------------------------------------------------------------- +-- | Timeout management +{-# LANGUAGE OverloadedStrings #-} + +module Web.SocketIO.Timeout + ( setTimeout + , extendTimeout + , clearTimeout + ) 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.MVar.Lifted +import Control.Monad.Trans (liftIO) +import Control.Monad (void) +import System.Timeout.Lifted (timeout) + +-------------------------------------------------------------------------------- +-- | As microseconds +getTimeoutDuration :: ConnectionM Int +getTimeoutDuration = toMicroSec . closeTimeout <$> getConfiguration + where toMicroSec = (*) 1000000 + +-------------------------------------------------------------------------------- +-- | The first parameter indicates whether it is first set timeout or not +primTimeout' :: Bool -> Session -> ConnectionM () +primTimeout' firstTime session@(Session sessionID _ _ _ timeoutVar) = do + + duration <- getTimeoutDuration + + if firstTime + then debug Debug $ sessionID <> " [Session] Set timeout" + else debug Debug $ sessionID <> " [Session] Extend timeout" + result <- timeout duration $ takeMVar timeoutVar + + case result of + -- extend! + Just True -> primTimeout' False session + -- die! + Just False -> clearTimeout session + Nothing -> do + runSession SessionDisconnectByServer session + -- remove session + tableRef <- getSessionTableRef + liftIO (modifyIORef tableRef (H.delete sessionID)) + debug Debug $ sessionID <> " [Session] Destroyed: close timeout" + +---------------------------------------------------------------------------------- +-- | Set timeout +setTimeout :: Session -> ConnectionM () +setTimeout = void . fork . primTimeout' True + +---------------------------------------------------------------------------------- +-- | Extend timeout +extendTimeout :: Session -> ConnectionM () +extendTimeout (Session _ _ _ _ timeoutVar) = putMVar timeoutVar True + +-------------------------------------------------------------------------------- +-- | Clear timeout +clearTimeout :: Session -> ConnectionM () +clearTimeout (Session _ _ _ _ timeoutVar) = do + putMVar timeoutVar False + diff --git a/Web/SocketIO/Types.hs b/Web/SocketIO/Types.hs --- a/Web/SocketIO/Types.hs +++ b/Web/SocketIO/Types.hs @@ -1,129 +1,22 @@ +-------------------------------------------------------------------------------- +-- | Re-exports data types {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Web.SocketIO.Types - ( module Web.SocketIO.Types.Log + ( module Web.SocketIO.Types.Base + , module Web.SocketIO.Types.Event + , module Web.SocketIO.Types.Layer + , module Web.SocketIO.Types.Log , module Web.SocketIO.Types.Request - , module Web.SocketIO.Types.SocketIO , module Web.SocketIO.Types.String - , ConnectionM(..) - , SessionM(..) - , ConnectionLayer(..) - , SessionLayer(..) - , Env(..) - , Session(..) - , SessionState(..) - , Status(..) - , Table ) where -------------------------------------------------------------------------------- +import Web.SocketIO.Types.Base +import Web.SocketIO.Types.Event import Web.SocketIO.Types.Request +import Web.SocketIO.Types.Layer import Web.SocketIO.Types.Log import Web.SocketIO.Types.String -import Web.SocketIO.Types.SocketIO - --------------------------------------------------------------------------------- -import Control.Applicative -import Control.Concurrent.MVar.Lifted -import Control.Concurrent.Chan.Lifted -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Control.Monad.Base - -import qualified Data.HashMap.Strict as H -import Data.IORef.Lifted - --------------------------------------------------------------------------------- -type Table = H.HashMap SessionID Session -data Status = Connecting | Connected | Disconnecting deriving Show - --------------------------------------------------------------------------------- -data SessionState = SessionSyn - | SessionAck - | SessionPolling - | SessionEmit Emitter - | SessionDisconnect - | SessionError - --------------------------------------------------------------------------------- -data Env = Env { - sessionTable :: IORef Table, - handler :: HandlerM (), - configuration :: Configuration, - stdout :: Chan String, - globalBuffer :: Buffer -} - --------------------------------------------------------------------------------- -class ConnectionLayer m where - getEnv :: m Env - getSessionTable :: m (IORef Table) - getHandler :: m (HandlerM ()) - getConfiguration :: m Configuration - --------------------------------------------------------------------------------- -class SessionLayer m where - getSession :: m Session - getSessionID :: m SessionID - getStatus :: m Status - getBufferHub :: m BufferHub - getLocalBuffer :: m Buffer - getGlobalBuffer :: m Buffer - getListener :: m [Listener] - getTimeoutVar :: m (MVar ()) - --------------------------------------------------------------------------------- -newtype ConnectionM a = ConnectionM { runConnectionM :: ReaderT Env IO a } - deriving (Monad, Functor, Applicative, MonadIO, MonadReader Env, MonadBase IO) - --------------------------------------------------------------------------------- -instance ConnectionLayer ConnectionM where - getEnv = ask - getSessionTable = sessionTable <$> ask - getHandler = handler <$> ask - getConfiguration = configuration <$> ask - --------------------------------------------------------------------------------- -instance (MonadBaseControl IO) ConnectionM where - newtype StM ConnectionM a = StMConnection { unStMConnection :: StM (ReaderT Env IO) a } - liftBaseWith f = ConnectionM (liftBaseWith (\run -> f (liftM StMConnection . run . runConnectionM))) - restoreM = ConnectionM . restoreM . unStMConnection - --------------------------------------------------------------------------------- -data Session = Session { - sessionID :: SessionID, - status :: Status, - bufferHub :: BufferHub, - listener :: [Listener], - timeoutVar :: MVar () -} | NoSession - --------------------------------------------------------------------------------- -newtype SessionM a = SessionM { runSessionM :: (ReaderT Session ConnectionM) a } - deriving (Monad, Functor, Applicative, MonadIO, MonadReader Session, MonadBase IO) - --------------------------------------------------------------------------------- -instance ConnectionLayer SessionM where - getEnv = SessionM (lift ask) - getSessionTable = sessionTable <$> getEnv - getHandler = handler <$> getEnv - getConfiguration = configuration <$> getEnv - --------------------------------------------------------------------------------- -instance SessionLayer SessionM where - getSession = ask - getSessionID = sessionID <$> ask - getStatus = status <$> ask - getBufferHub = bufferHub <$> ask - getLocalBuffer = selectLocalBuffer . bufferHub <$> ask - getGlobalBuffer = selectGlobalBuffer . bufferHub <$> ask - getListener = listener <$> ask - getTimeoutVar = timeoutVar <$> ask - --------------------------------------------------------------------------------- -instance (MonadBaseControl IO) SessionM where - newtype StM SessionM a = StMSession { unStMSession :: StM (ReaderT Session ConnectionM) a } - liftBaseWith f = SessionM (liftBaseWith (\run -> f (liftM StMSession . run . runSessionM))) - restoreM = SessionM . restoreM . unStMSession diff --git a/Web/SocketIO/Types/Base.hs b/Web/SocketIO/Types/Base.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Types/Base.hs @@ -0,0 +1,210 @@ +-------------------------------------------------------------------------------- +-- | Cluster fuck of unorganized data types +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +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.HashMap.Strict as H +import Data.IORef.Lifted +import Network.HTTP.Types.Header (ResponseHeaders) +import System.IO (Handle) + +-------------------------------------------------------------------------------- +-- | Information of a individual client; established after `Web.SocketIO.Types.Request.Handshake`, torn down after `Web.SocketIO.Types.Request.Disconnect`. +data Session = Session + { sessionSessionID :: SessionID -- ^ Identifier + , sessionState :: SessionState -- ^ State + , sessionChannelHub :: ChannelHub -- ^ Output channels + , sessionListener :: [Listener] -- ^ Server-side listeners + , sessionTimeoutVar :: MVar Bool -- ^ TTL + } + +instance Show Session where + show (Session i s _ _ _) = "Session " + ++ fromByteString i + ++ " [" ++ show s ++ "]" + +-------------------------------------------------------------------------------- +-- | Session ID +type SessionID = ByteString + +-------------------------------------------------------------------------------- +-- | Session table, consists of `SessionID`, `Session` pairs. +type SessionTable = H.HashMap SessionID Session + +-------------------------------------------------------------------------------- +-- | Session states +data SessionState = Connecting -- ^ after `Web.SocketIO.Types.Request.Handshake` + | Connected -- ^ after `Web.SocketIO.Types.Request.Connect`. + deriving (Show, Eq) + +-------------------------------------------------------------------------------- +-- | Fine-grained session layer requests +data SessionAction = SessionHandshake + | SessionConnect + | SessionPolling + | SessionEmit Event + | SessionDisconnectByClient + | SessionDisconnectByServer + +-------------------------------------------------------------------------------- +-- | Server-wide configurations +data Env = Env { + envSessionTableRef :: IORef SessionTable, + envHandler :: HandlerM (), + envConfiguration :: Configuration, + envLogChannel :: Chan ByteString, + envGlobalChannel :: Chan Package +} + +-------------------------------------------------------------------------------- +-- | Collection of unbounded FIFO channels. +data ChannelHub = ChannelHub + { channelHubLocal :: Chan Package + , channelHubGlobal :: Chan Package + , channelHubOutput :: Chan Package + , channelHubLog :: Chan ByteString + } + +-------------------------------------------------------------------------------- +-- | Defines behaviors of a Socket.IO server +data Configuration = Configuration + { transports :: [Transport] + , logLevel :: Int -- ^ there are 4 levels, from 0 to 3: Error, Warn, Info, Debug + , logTo :: Handle + , heartbeats :: Bool + , header :: ResponseHeaders + , closeTimeout :: Int + , heartbeatTimeout :: Int + , heartbeatInterval :: Int + , pollingDuration :: Int + } deriving Show + +-------------------------------------------------------------------------------- +-- | Port number for a standalone Socket.IO server. +type Port = Int + +-------------------------------------------------------------------------------- +-- | Triggered by an `Web.SocketIO.Types.Request.Event`. +type Listener = (EventName, CallbackM ()) + +-------------------------------------------------------------------------------- +-- | Class for `SessionID` getter. +class HasSessionID m where + getSessionID :: m SessionID + +-------------------------------------------------------------------------------- +-- | Environment carried by `HandlerM` +data HandlerEnv = HandlerEnv + { handlerEnvChannelHub :: ChannelHub + , handlerEnvSessionID :: SessionID + } + +-------------------------------------------------------------------------------- +-- | Environment carried by `CallbackM` +data CallbackEnv = CallbackEnv + { callbackEnvEventName :: EventName + , callbackEnvPayload :: [Payload] + , callbackEnvChannelHub :: ChannelHub + , callbackEnvSessionID :: SessionID + } + +-------------------------------------------------------------------------------- +-- | Capable of both sending and receiving events. +-- +-- Use 'liftIO' if you wanna do some IO here. +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 + +-------------------------------------------------------------------------------- +-- | Capable of only sending events. +-- +-- Use 'liftIO' if you wanna do some IO here. +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 + +-------------------------------------------------------------------------------- +-- | Sends events +class Publisher m where + -- | Sends a message to the socket that starts it. + -- + -- @ + -- `emit` \"launch\" [\"missile\", \"nuke\"] + -- @ + emit :: EventName -- ^ name of event to trigger + -> [Text] -- ^ payload to carry with + -> m () + + -- | Sends a message to everybody except for the socket that starts it. + -- + -- @ + -- `broadcast` \"hide\" [\"nukes coming!\"] + -- @ + broadcast :: EventName -- ^ name of event to trigger + -> [Text] -- ^ payload to carry with + -> m () + + -- | + +instance Publisher HandlerM where + emit event reply = do + channel <- channelHubLocal . handlerEnvChannelHub <$> ask + writeChan channel (Private, Event event reply) + broadcast event reply = do + channel <- channelHubGlobal . handlerEnvChannelHub <$> ask + sessionID <- handlerEnvSessionID <$> ask + writeChan channel (Broadcast sessionID, Event event reply) + +instance Publisher CallbackM where + emit event reply = do + channel <- CallbackM . lift $ channelHubLocal . callbackEnvChannelHub <$> ask + writeChan channel (Private, Event event reply) + broadcast event reply = do + channel <- CallbackM . lift $ channelHubGlobal . callbackEnvChannelHub <$> ask + sessionID <- CallbackM . lift $ callbackEnvSessionID <$> ask + writeChan channel (Broadcast sessionID, Event event reply) + +-------------------------------------------------------------------------------- +-- | Receives events. +class Subscriber m where + -- @ + -- 'on' \"ping\" $ do + -- 'emit' \"pong\" [] + -- @ + on :: EventName -- ^ name of event to listen to + -> CallbackM () -- ^ callback + -> m () + +instance Subscriber HandlerM where + on event callback = do + HandlerM . lift . tell $ [(event, callback)] + +-------------------------------------------------------------------------------- +-- | Now only xhr-polling is supported. +data Transport = WebSocket | XHRPolling | NoTransport deriving (Eq, Show) + +instance Serializable Transport where + serialize WebSocket = "websocket" + serialize XHRPolling = "xhr-polling" + serialize NoTransport = "unknown" diff --git a/Web/SocketIO/Types/Event.hs b/Web/SocketIO/Types/Event.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Types/Event.hs @@ -0,0 +1,59 @@ +-------------------------------------------------------------------------------- +-- | Event data types +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.SocketIO.Types.Event + ( Event(..) + , EventName + , EventType(..) + , Payload + , Package + ) where + +-------------------------------------------------------------------------------- +import Web.SocketIO.Types.String + +---------------------------------------------------------------------------------- +import Control.Applicative +import Data.Aeson + +-------------------------------------------------------------------------------- +-- | Name of an Event +type EventName = Text + +-------------------------------------------------------------------------------- +-- | Payload carried by an Event +type Payload = Text + +-------------------------------------------------------------------------------- +-- | Event +data Event = Event EventName [Payload] + | NoEvent -- ^ some malformed shit + deriving (Show, Eq) + +instance Serializable Event where + serialize = serialize . encode + +instance FromJSON Event where + parseJSON (Object v) = Event <$> + v .: "name" <*> + v .:? "args" .!= [] + parseJSON _ = return NoEvent + +instance ToJSON Event where + toJSON (Event name []) = object ["name" .= name] + toJSON (Event name args) = object ["name" .= name, "args" .= args] + toJSON NoEvent = object [] + +-------------------------------------------------------------------------------- +-- | For internal use only, indicates how Events are be triggered. +data EventType = Private -- ^ `Web.SocketIO.Types.Base.emit` + | Broadcast ByteString -- ^ `Web.SocketIO.Types.Base.broadcast`, with `SessionID` of the sender. + deriving (Show, Eq) + +-------------------------------------------------------------------------------- +-- | Event packed with EventType +type Package = (EventType, Event) diff --git a/Web/SocketIO/Types/Layer.hs b/Web/SocketIO/Types/Layer.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Types/Layer.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------------------- +-- | Layers of abstractions, for internal use only. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Web.SocketIO.Types.Layer + ( ConnectionM(..) + , SessionM(..) + , ConnectionLayer(..) + , SessionLayer(..) + , HasSessionID(..) + ) where + +---------------------------------------------------------------------------------- +import Web.SocketIO.Types.Base + +---------------------------------------------------------------------------------- +import Control.Applicative +import Control.Concurrent.MVar.Lifted +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Control.Monad.Base +import Data.IORef.Lifted + +-------------------------------------------------------------------------------- +-- | Getters for Connection Layer +class ConnectionLayer m where + getEnv :: m Env + getSessionTableRef :: m (IORef SessionTable) + getHandler :: m (HandlerM ()) + getConfiguration :: m Configuration + +-------------------------------------------------------------------------------- +-- | Getters for Session Layer +class SessionLayer m where + getSession :: m Session + getSessionState :: m SessionState + getChannelHub :: m ChannelHub + getListener :: m [Listener] + getTimeoutVar :: m (MVar Bool) + +-------------------------------------------------------------------------------- +-- | Connection Layer +newtype ConnectionM a = ConnectionM { runConnectionM :: ReaderT Env IO a } + deriving (Monad, Functor, Applicative, MonadIO, MonadReader Env, MonadBase IO) + +instance ConnectionLayer ConnectionM where + getEnv = ask + getSessionTableRef = envSessionTableRef <$> ask + getHandler = envHandler <$> ask + getConfiguration = envConfiguration <$> ask + +instance (MonadBaseControl IO) ConnectionM where + newtype StM ConnectionM a = StMConnection { unStMConnection :: StM (ReaderT Env IO) a } + liftBaseWith f = ConnectionM (liftBaseWith (\run -> f (liftM StMConnection . run . runConnectionM))) + restoreM = ConnectionM . restoreM . unStMConnection + +-------------------------------------------------------------------------------- +-- | Session Layer +newtype SessionM a = SessionM { runSessionM :: (ReaderT Session ConnectionM) a } + deriving (Monad, Functor, Applicative, MonadIO, MonadReader Session, MonadBase IO) + +instance ConnectionLayer SessionM where + getEnv = SessionM (lift ask) + getSessionTableRef = envSessionTableRef <$> getEnv + getHandler = envHandler <$> getEnv + getConfiguration = envConfiguration <$> getEnv + +instance SessionLayer SessionM where + getSession = ask + getSessionState = sessionState <$> ask + getChannelHub = sessionChannelHub <$> ask + getListener = sessionListener <$> ask + getTimeoutVar = sessionTimeoutVar <$> ask + +instance (MonadBaseControl IO) SessionM where + newtype StM SessionM a = StMSession { unStMSession :: StM (ReaderT Session ConnectionM) a } + liftBaseWith f = SessionM (liftBaseWith (\run -> f (liftM StMSession . run . runSessionM))) + restoreM = SessionM . restoreM . unStMSession + +instance HasSessionID SessionM where + getSessionID = sessionSessionID <$> getSession diff --git a/Web/SocketIO/Types/Log.hs b/Web/SocketIO/Types/Log.hs --- a/Web/SocketIO/Types/Log.hs +++ b/Web/SocketIO/Types/Log.hs @@ -1,21 +1,28 @@ -module Web.SocketIO.Types.Log (Log(..)) where +-------------------------------------------------------------------------------- +-- | Data types for logging +{-# LANGUAGE OverloadedStrings #-} +module Web.SocketIO.Types.Log (Log(..), Serializable(..)) where + +-------------------------------------------------------------------------------- import System.Console.ANSI +import Web.SocketIO.Types.String -------------------------------------------------------------------------------- -- | Logger -data Log = Error String - | Warn String - | Info String - | Debug String - deriving (Eq) +data Log = Error ByteString + | Warn ByteString + | Info ByteString + | Debug ByteString + deriving (Eq, Show) -instance Show Log where - show (Error message) = " " ++ paint Red "[error] " ++ error message - show (Warn message) = " " ++ paint Yellow "[warn] " ++ message - show (Info message) = " " ++ paint Cyan "[info] " ++ message - show (Debug message) = " " ++ paint Black "[debug] " ++ message +instance Serializable Log where + serialize (Error message) = fromString $ " " ++ (paint Red $ "[error] " ++ error (fromByteString message)) + serialize (Warn message) = fromString $ " " ++ (paint Yellow $ "[warn] " ++ fromByteString message) + serialize (Info message) = fromString $ " " ++ (paint Cyan $ "[info] " ++ fromByteString message) + serialize (Debug message) = fromString $ " " ++ (paint Black $ "[debug] " ++ fromByteString message) -------------------------------------------------------------------------------- +-- | helper function paint :: Color -> String -> String paint color s = setSGRCode [SetColor Foreground Vivid color] ++ s ++ setSGRCode [] diff --git a/Web/SocketIO/Types/Request.hs b/Web/SocketIO/Types/Request.hs --- a/Web/SocketIO/Types/Request.hs +++ b/Web/SocketIO/Types/Request.hs @@ -1,105 +1,134 @@ -------------------------------------------------------------------------------- -- | Types for comsuming incoming data - {-# LANGUAGE OverloadedStrings #-} module Web.SocketIO.Types.Request where -------------------------------------------------------------------------------- -import qualified Data.Aeson as Aeson -import qualified Data.Text.Lazy as TL +import Web.SocketIO.Types.String +import Web.SocketIO.Types.Base +import Web.SocketIO.Types.Event -------------------------------------------------------------------------------- -import Web.SocketIO.Types.String -import Web.SocketIO.Types.SocketIO +import Data.List (intersperse) +import Data.Monoid (mconcat, mempty) +import qualified Data.ByteString as B +-------------------------------------------------------------------------------- +-- | Namespace +type Namespace = ByteString -------------------------------------------------------------------------------- --- | Path of incoming request -type Namespace = Text -type Protocol = Text -type SessionID = Text +-- | Protocol running +type Protocol = ByteString +-------------------------------------------------------------------------------- +-- | The URN part of a HTTP request. +-- Please refer to data Path = WithSession Namespace Protocol Transport SessionID | WithoutSession Namespace Protocol deriving (Eq, Show) +instance Serializable Path where + serialize (WithSession n p t s) = "/" <> serialize n + <> "/" <> serialize p + <> "/" <> serialize t + <> "/" <> serialize s + <> "/" + serialize (WithoutSession n p) = "/" <> serialize n + <> "/" <> serialize p + <> "/" -------------------------------------------------------------------------------- --- | Incoming request +-- | Incoming HTTP request data Request = Handshake | Disconnect SessionID | Connect SessionID - | Emit SessionID Emitter + | Emit SessionID Event deriving (Show) -------------------------------------------------------------------------------- --- | This is how data are encoded by Socket.IO Protocol -data Message = MsgDisconnect Endpoint +-- | Message Framing +data Framed a = Framed [a] + deriving (Show, Eq) + +instance (Show a, Serializable a) => Serializable (Framed a) where + serialize (Framed [message]) = serialize message + serialize (Framed messages) = mconcat $ map frame messages + where frame message = let serialized = serialize message + in "�" <> serialize size <> "�" <> serialized + where size = B.length (serialize message) + +-------------------------------------------------------------------------------- +-- | This is how data are encoded by Socket.IO Protocol. +-- Please refer to +data Message = MsgHandshake SessionID Int Int [Transport] + | MsgDisconnect Endpoint | MsgConnect Endpoint | MsgHeartbeat | Msg ID Endpoint Data | MsgJSON ID Endpoint Data - | MsgEvent ID Endpoint Emitter + | MsgEvent ID Endpoint Event | MsgACK ID Data | MsgError Endpoint Data | MsgNoop deriving (Show, Eq) -data Endpoint = Endpoint String +instance Serializable Message where + serialize (MsgHandshake s a b t) = serialize s <> ":" <> + a' <> ":" <> + serialize b <> ":" <> + serialize transportType + where transportType = fromString $ concat . intersperse "," . map serialize $ t :: ByteString + a' = if a == 0 then mempty else serialize a + serialize (MsgDisconnect NoEndpoint) = "0" + serialize (MsgDisconnect e) = "0::" <> serialize e + serialize (MsgConnect e) = "1::" <> serialize e + serialize MsgHeartbeat = "2::" + serialize (Msg i e d) = "3:" <> serialize i <> + ":" <> serialize e <> + ":" <> serialize d + serialize (MsgJSON i e d) = "4:" <> serialize i <> + ":" <> serialize e <> + ":" <> serialize d + serialize (MsgEvent i e d) = "5:" <> serialize i <> + ":" <> serialize e <> + ":" <> serialize d + serialize (MsgACK i d) = "6:::" <> serialize i <> + "+" <> serialize d + serialize (MsgError e d) = "7::" <> serialize e <> + ":" <> serialize d + serialize MsgNoop = "8:::" + +-------------------------------------------------------------------------------- +-- | Message endpoint +data Endpoint = Endpoint ByteString | NoEndpoint deriving (Show, Eq) + +instance Serializable Endpoint where + serialize (Endpoint s) = serialize s + serialize NoEndpoint = "" + +-------------------------------------------------------------------------------- +-- | The message id is an incremental integer, required for ACKs (can be omitted). +-- If the message id is followed by a +, the ACK is not handled by socket.io, but by the user instead. data ID = ID Int | IDPlus Int | NoID deriving (Show, Eq) -data Data = Data Text - | NoData - deriving (Show, Eq) +instance Serializable ID where + serialize (ID i) = serialize i + serialize (IDPlus i) = serialize i <> "+" + serialize NoID = "" -------------------------------------------------------------------------------- --- | A typeclass for converting everything to Text for output -class Msg m where - toMessage :: m -> Text - -instance Msg Endpoint where - toMessage (Endpoint s) = TL.pack s - toMessage NoEndpoint = "" - -instance Msg ID where - toMessage (ID i) = TL.pack $ show i - toMessage (IDPlus i) = TL.pack $ show i ++ "+" - toMessage NoID = "" - -instance Msg Data where - toMessage (Data s) = s - toMessage NoData = "" - -instance Msg Emitter where - toMessage = fromLazyByteString . Aeson.encode - -instance Msg Message where - toMessage (MsgDisconnect NoEndpoint) = "0" - toMessage (MsgDisconnect e) = "0::" <> toMessage e - toMessage (MsgConnect e) = "1::" <> toMessage e - toMessage MsgHeartbeat = "2::" - toMessage (Msg i e d) = "3:" <> toMessage i <> - ":" <> toMessage e <> - ":" <> toMessage d - toMessage (MsgJSON i e d) = "4:" <> toMessage i <> - ":" <> toMessage e <> - ":" <> toMessage d - toMessage (MsgEvent i e d) = "5:" <> toMessage i <> - ":" <> toMessage e <> - ":" <> toMessage d - toMessage (MsgACK i d) = "6:::" <> toMessage i <> - "+" <> toMessage d - toMessage (MsgError e d) = "7::" <> toMessage e <> - ":" <> toMessage d - toMessage MsgNoop = "8:::" +-- | Message data body +data Data = Data ByteString + | NoData + deriving (Show, Eq) -instance Msg Transport where - toMessage WebSocket = "websocket" - toMessage XHRPolling = "xhr-polling" - toMessage NoTransport = "" +instance Serializable Data where + serialize (Data s) = serialize s + serialize NoData = "" diff --git a/Web/SocketIO/Types/SocketIO.hs b/Web/SocketIO/Types/SocketIO.hs deleted file mode 100644 --- a/Web/SocketIO/Types/SocketIO.hs +++ /dev/null @@ -1,120 +0,0 @@ --------------------------------------------------------------------------------- --- | Datatypes to be exposed to end user -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Web.SocketIO.Types.SocketIO where - --------------------------------------------------------------------------------- -import Control.Applicative (Applicative, (<$>)) -import Control.Concurrent.Chan.Lifted (Chan, writeChan) -import Control.Monad.Base -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Data.Aeson as Aeson - --------------------------------------------------------------------------------- -import Web.SocketIO.Types.String - --------------------------------------------------------------------------------- --- | Now only xhr-polling is supported. -data Transport = WebSocket | XHRPolling | NoTransport deriving (Eq, Show) - --------------------------------------------------------------------------------- -data Configuration = Configuration - { transports :: [Transport] - , logLevel :: Int - , heartbeats :: Bool - , closeTimeout :: Int - , heartbeatTimeout :: Int - , heartbeatInterval :: Int - , pollingDuration :: Int - } deriving Show - --------------------------------------------------------------------------------- -type Port = Int - --------------------------------------------------------------------------------- -type Event = Text -type Buffer = Chan Emitter - -type Listener = (Event, CallbackM ()) -data Emitter = Emitter Event [Text] | NoEmitter deriving (Show, Eq) - -instance Aeson.ToJSON Emitter where - toJSON (Emitter name args) = Aeson.object ["name" Aeson..= name, "args" Aeson..= args] - toJSON NoEmitter = Aeson.object [] - -data BufferHub = BufferHub - { selectLocalBuffer :: Buffer - , selectGlobalBuffer :: Buffer - } - --------------------------------------------------------------------------------- --- | Capable of both sending and receiving events. --- --- Use 'liftIO' if you wanna do some IO here. -newtype HandlerM a = HandlerM { runHandlerM :: (ReaderT BufferHub (WriterT [Listener] IO)) a } - deriving (Monad, Functor, Applicative, MonadIO, MonadWriter [Listener], MonadReader BufferHub, MonadBase IO) - --------------------------------------------------------------------------------- --- | Capable of only sending events. --- --- Use 'liftIO' if you wanna do some IO here. -newtype CallbackM a = CallbackM { runCallbackM :: (WriterT [Emitter] (ReaderT [Text] (ReaderT BufferHub IO))) a } - deriving (Monad, Functor, Applicative, MonadIO, MonadWriter [Emitter], MonadReader [Text], MonadBase IO) - - --------------------------------------------------------------------------------- --- | Sending events -class Publisher m where - -- | Sends a message to the socket that starts it. - -- - -- @ - -- `emit` \"launch\" [\"missile\", \"nuke\"] - -- @ - emit :: Event -- ^ event to trigger - -> [Text] -- ^ message to carry with - -> m () - - -- | Sends a message to everyone else except for the socket that starts it. - -- - -- @ - -- `broadcast` \"hide\" [\"nukes coming!\"] - -- @ - broadcast :: Event -- ^ event to trigger - -> [Text] -- ^ message to carry with - -> m () - - -- | - -instance Publisher HandlerM where - emit event reply = do - channel <- selectLocalBuffer <$> ask - writeChan channel (Emitter event reply) - broadcast event reply = do - channel <- selectGlobalBuffer <$> ask - writeChan channel (Emitter event reply) - -instance Publisher CallbackM where - emit event reply = do - channel <- CallbackM . lift . lift $ selectLocalBuffer <$> ask - writeChan channel (Emitter event reply) - broadcast event reply = do - channel <- CallbackM . lift . lift $ selectGlobalBuffer <$> ask - writeChan channel (Emitter event reply) - --------------------------------------------------------------------------------- --- | Receiving events. -class Subscriber m where - -- @ - -- 'on' \"ping\" $ do - -- 'emit' \"pong\" [] - -- @ - on :: Event -- ^ event to listen to - -> CallbackM () -- ^ callback - -> m () - -instance Subscriber HandlerM where - on event callback = do - HandlerM . lift . tell $ [(event, callback)] diff --git a/Web/SocketIO/Types/String.hs b/Web/SocketIO/Types/String.hs --- a/Web/SocketIO/Types/String.hs +++ b/Web/SocketIO/Types/String.hs @@ -1,3 +1,5 @@ +-------------------------------------------------------------------------------- +-- | String-like data structure utilities {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,65 +8,176 @@ , IsByteString(..) , IsLazyByteString(..) , IsText(..) + , IsLazyText(..) + , Serializable(..) , Text + , StrictText + , ByteString + , LazyByteString , (<>) ) where + -------------------------------------------------------------------------------- import qualified Data.String as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as B +import qualified Data.Text.Lazy.Encoding as TLE +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as C -import Data.Monoid ((<>)) +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Monoid ((<>), Monoid) -------------------------------------------------------------------------------- +-- | Lazy Text as default Text type Text = TL.Text -------------------------------------------------------------------------------- -class IsByteString a where - fromByteString :: B.ByteString -> a +-- | Type synonym of Strict Text +type StrictText = T.Text -------------------------------------------------------------------------------- -instance IsByteString String where - fromByteString = C.unpack +-- | Type synonym of Lazy ByteString +type LazyByteString = BL.ByteString -------------------------------------------------------------------------------- +-- | Class for string-like data structures that can be converted from strict ByteString +class IsByteString a where + fromByteString :: ByteString -> a + +-- | to String +instance IsByteString String where + fromByteString = BC.unpack + +-- | to strict Text +instance IsByteString T.Text where + fromByteString = TE.decodeUtf8 + +-- | to lazy Text instance IsByteString TL.Text where - fromByteString = TL.pack . fromByteString + fromByteString = TLE.decodeUtf8 . BL.fromStrict --------------------------------------------------------------------------------- +-- | to strict ByteString (identity) +instance IsByteString ByteString where + fromByteString = id + +-- | to lazy ByteString instance IsByteString BL.ByteString where fromByteString = BL.fromStrict -------------------------------------------------------------------------------- +-- | Class for string-like data structures that can be converted from lazy ByteString class IsLazyByteString a where fromLazyByteString :: BL.ByteString -> a --------------------------------------------------------------------------------- +-- | to String instance IsLazyByteString String where - fromLazyByteString = fromByteString . BL.toStrict + fromLazyByteString = BLC.unpack --------------------------------------------------------------------------------- +-- | to strict Text +instance IsLazyByteString T.Text where + fromLazyByteString = TE.decodeUtf8 . BL.toStrict + +-- | to lazy Text instance IsLazyByteString TL.Text where - fromLazyByteString = fromByteString . BL.toStrict + fromLazyByteString = TLE.decodeUtf8 --------------------------------------------------------------------------------- -instance IsLazyByteString B.ByteString where +-- | to strict ByteString +instance IsLazyByteString ByteString where fromLazyByteString = BL.toStrict +-- | to lazy ByteString (identity) +instance IsLazyByteString BL.ByteString where + fromLazyByteString = id + -------------------------------------------------------------------------------- +-- | Class for string-like data structures that can be converted from strict Text class IsText a where - fromText :: TL.Text -> a + fromText :: T.Text -> a --------------------------------------------------------------------------------- +-- | to String instance IsText String where - fromText = TL.unpack + fromText = T.unpack +-- | to strict Text (identity) +instance IsText T.Text where + fromText = id + +-- | to lazy Text +instance IsText TL.Text where + fromText = TL.fromStrict + +-- | to strict ByteString +instance IsText ByteString where + fromText = TE.encodeUtf8 + +-- | to lazy ByteString +instance IsText BL.ByteString where + fromText = TLE.encodeUtf8 . TL.fromStrict + -------------------------------------------------------------------------------- -instance IsText B.ByteString where - fromText = C.pack . fromText +-- | Class for string-like data structures that can be converted from lazy Text +class IsLazyText a where + fromLazyText :: TL.Text -> a +-- | to String +instance IsLazyText String where + fromLazyText = TL.unpack + +-- | to strict Text +instance IsLazyText T.Text where + fromLazyText = TL.toStrict + +-- | to lazy Text (identity) +instance IsLazyText TL.Text where + fromLazyText = id + +-- | to strict ByteString +instance IsLazyText ByteString where + fromLazyText = TE.encodeUtf8 . TL.toStrict + +-- | to lazy ByteString +instance IsLazyText BL.ByteString where + fromLazyText = TLE.encodeUtf8 + -------------------------------------------------------------------------------- -instance IsText BL.ByteString where - fromText = BL.fromStrict . C.pack . fromText +-- | Class for string-like data structures +class Serializable a where + -- | converts instances to string-like data structures + serialize :: ( Monoid s + , S.IsString s + , IsText s + , IsLazyText s + , IsByteString s + , IsLazyByteString s + , Show a) => a -> s + serialize = S.fromString . show + +instance Serializable T.Text where + serialize = fromText + +instance Serializable TL.Text where + serialize = fromLazyText + +instance Serializable ByteString where + serialize = fromByteString + +instance Serializable BL.ByteString where + serialize = fromLazyByteString + +instance Serializable Bool +instance Serializable Char +instance Serializable Double +instance Serializable Float +instance Serializable Int +instance Serializable Integer +instance Serializable Ordering +instance Serializable () +instance Serializable a => Serializable [a] +instance Serializable a => Serializable (Maybe a) +instance (Serializable a, Serializable b) => Serializable (Either a b) +instance (Serializable a, Serializable b, Serializable c) => Serializable (a, b, c) +instance (Serializable a, Serializable b, Serializable c, Serializable d) => Serializable (a, b, c, d) +instance (Serializable a, Serializable b, Serializable c, Serializable d, Serializable e) => Serializable (a, b, c, d, e) diff --git a/Web/SocketIO/Util.hs b/Web/SocketIO/Util.hs --- a/Web/SocketIO/Util.hs +++ b/Web/SocketIO/Util.hs @@ -1,22 +1,38 @@ +-------------------------------------------------------------------------------- +-- | Exports some logging utilities and other useful functions {-# LANGUAGE OverloadedStrings #-} -module Web.SocketIO.Util ((<>), debug) where +module Web.SocketIO.Util ((<>), debugLog, debugSession, debug) where -------------------------------------------------------------------------------- -import Control.Concurrent.Chan -import Control.Monad.Trans (liftIO, MonadIO) --------------------------------------------------------------------------------- import Web.SocketIO.Types -------------------------------------------------------------------------------- -debug :: (Functor m, MonadIO m, ConnectionLayer m) => Log -> m () -debug message = do +import Control.Concurrent.Chan +import Control.Monad.Trans (liftIO, MonadIO) + +-------------------------------------------------------------------------------- +-- | Write log to channel according to log level and configurations +debug :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> ByteString -> m () +debug logType message = do logLevel' <- fmap logLevel getConfiguration - stdout' <- fmap stdout getEnv - if level <= logLevel' then liftIO $ writeChan stdout' (show message) else return () - where levelOf (Error _) = 0 - levelOf (Warn _) = 1 - levelOf (Info _) = 2 - levelOf (Debug _) = 3 + logChannel <- fmap envLogChannel getEnv + if level <= logLevel' then liftIO $ writeChan logChannel (serialize log') else return () + where log' = logType message + levelOf (Error _) = 0 + levelOf (Warn _) = 1 + levelOf (Info _) = 2 + levelOf (Debug _) = 3 + level = levelOf log' - level = levelOf message +-------------------------------------------------------------------------------- +-- | Attaches `Web.SocketIO.Types.Base.SessionID` +debugLog :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> Session -> ByteString -> m () +debugLog logType (Session sessionID _ _ _ _) message = debug logType (sessionID <> " " <> serialize message) + +-------------------------------------------------------------------------------- +-- | Attaches `Web.SocketIO.Types.Base.SessionID` automatically +debugSession :: (Functor m, MonadIO m, ConnectionLayer m, SessionLayer m) => (ByteString -> Log) -> ByteString -> m () +debugSession logType message = do + Session sessionID _ _ _ _ <- getSession + debug logType $ fromByteString (sessionID <> " " <> message) diff --git a/socketio.cabal b/socketio.cabal --- a/socketio.cabal +++ b/socketio.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: socketio -version: 0.1.0.1 +version: 0.1.1 synopsis: Socket.IO server description: Socket.IO for Haskell folks. @@ -41,41 +41,73 @@ source-repository head - type: git - location: https://github.com/banacorn/socket.io-haskell + type: git + location: https://github.com/banacorn/socket.io-haskell library - exposed-modules: + ghc-options: -Wall -fno-warn-unused-do-bind + exposed-modules: Web.SocketIO Other-modules: Web.SocketIO.Types - Web.SocketIO.Types.SocketIO + Web.SocketIO.Types.Base + Web.SocketIO.Types.Event + Web.SocketIO.Types.Layer Web.SocketIO.Types.Log - Web.SocketIO.Types.String Web.SocketIO.Types.Request + Web.SocketIO.Types.String Web.SocketIO.Connection + Web.SocketIO.Channel Web.SocketIO.Event - Web.SocketIO.Server - Web.SocketIO.Parser + Web.SocketIO.Protocol Web.SocketIO.Request + Web.SocketIO.Server Web.SocketIO.Session + Web.SocketIO.Timeout Web.SocketIO.Util build-depends: base ==4.6.* - , mtl ==2.1.* - , text ==0.11.* - , ansi-terminal ==0.6 - , containers ==0.5.* - , unordered-containers ==0.2.3.0 + , text ==1.1.* + , bytestring ==0.10.* + , aeson ==0.7.* + , parsec ==3.1.* + , ansi-terminal ==0.6.* + , unordered-containers ==0.2.* , random ==1.0.* + , wai ==2.0.* + , warp ==2.0.* + , http-types ==0.8.* + , mtl ==2.1.* + , transformers-base ==0.4.* + , monad-control ==0.3.* + , lifted-base ==0.2.* + + +test-suite socketio-test + type: exitcode-stdio-1.0 + hs-source-dirs: test . + main-is: main.hs + ghc-options: -Wall -fno-warn-unused-do-bind + + build-depends: base ==4.6.* + , QuickCheck ==2.6.* + , HUnit ==1.2.* + , test-framework ==0.8.* + , test-framework-quickcheck2 ==0.3.* + , test-framework-hunit ==0.3.* + + build-depends: base ==4.6.* + , text ==1.1.* + , bytestring ==0.10.* + , aeson ==0.7.* , parsec ==3.1.* - , bytestring ==0.10.0.* - , aeson ==0.6.1.* - , wai ==1.4.0.* + , ansi-terminal ==0.6.* + , unordered-containers ==0.2.* + , random ==1.0.* + , wai ==2.0.* + , warp ==2.0.* , http-types ==0.8.* - , warp ==1.3.9.* - , resourcet ==0.4.7.* - , conduit ==1.0.7.* - , monad-control ==0.3.2.* + , mtl ==2.1.* , transformers-base ==0.4.* - , lifted-base ==0.2.1.* + , monad-control ==0.3.* + , lifted-base ==0.2.* diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.Framework (defaultMain) +import qualified Test.Protocol +--import qualified Test.Simulator +import qualified Test.Unit + +main :: IO () +main = defaultMain + [ Test.Protocol.test + --, Test.Simulator.test + , Test.Unit.test + ]