socketio 0.1.0.1 → 0.1.1
raw patch · 21 files changed
+1305/−691 lines, 21 filesdep +HUnitdep +QuickCheckdep +test-frameworkdep −conduitdep −containersdep −resourcetdep ~aesondep ~ansi-terminaldep ~bytestring
Dependencies added: HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2
Dependencies removed: conduit, containers, resourcet
Dependency ranges changed: aeson, ansi-terminal, bytestring, lifted-base, monad-control, text, unordered-containers, wai, warp
Files
- Web/SocketIO.hs +11/−3
- Web/SocketIO/Channel.hs +76/−0
- Web/SocketIO/Connection.hs +116/−82
- Web/SocketIO/Event.hs +15/−4
- Web/SocketIO/Parser.hs +0/−127
- Web/SocketIO/Protocol.hs +155/−0
- Web/SocketIO/Request.hs +35/−25
- Web/SocketIO/Server.hs +66/−35
- Web/SocketIO/Session.hs +61/−51
- Web/SocketIO/Timeout.hs +71/−0
- Web/SocketIO/Types.hs +9/−116
- Web/SocketIO/Types/Base.hs +210/−0
- Web/SocketIO/Types/Event.hs +59/−0
- Web/SocketIO/Types/Layer.hs +83/−0
- Web/SocketIO/Types/Log.hs +18/−11
- Web/SocketIO/Types/Request.hs +90/−61
- Web/SocketIO/Types/SocketIO.hs +0/−120
- Web/SocketIO/Types/String.hs +135/−22
- Web/SocketIO/Util.hs +29/−13
- socketio.cabal +53/−21
- test/main.hs +13/−0
Web/SocketIO.hs view
@@ -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
+ Web/SocketIO/Channel.hs view
@@ -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 ()
Web/SocketIO/Connection.hs view
@@ -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
Web/SocketIO/Event.hs view
@@ -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
− Web/SocketIO/Parser.hs
@@ -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)
+ Web/SocketIO/Protocol.hs view
@@ -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)
Web/SocketIO/Request.hs view
@@ -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
Web/SocketIO/Server.hs view
@@ -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", <origin-of-the-reqeust>)] + -- > , ("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
Web/SocketIO/Session.hs view
@@ -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
+ Web/SocketIO/Timeout.hs view
@@ -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+
Web/SocketIO/Types.hs view
@@ -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
+ Web/SocketIO/Types/Base.hs view
@@ -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. <https://github.com/LearnBoost/socket.io-spec#transport-id socket.io-spec#transport-id>+data Transport = WebSocket | XHRPolling | NoTransport deriving (Eq, Show)++instance Serializable Transport where+ serialize WebSocket = "websocket" + serialize XHRPolling = "xhr-polling" + serialize NoTransport = "unknown"
+ Web/SocketIO/Types/Event.hs view
@@ -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)
+ Web/SocketIO/Types/Layer.hs view
@@ -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
Web/SocketIO/Types/Log.hs view
@@ -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 []
Web/SocketIO/Types/Request.hs view
@@ -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 <https://github.com/LearnBoost/socket.io-spec#socketio-http-requests socket.io-spec#socketio-http-requests> 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 <https://github.com/LearnBoost/socket.io-spec#messages socket.io-spec#messages>+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 = ""
− Web/SocketIO/Types/SocketIO.hs
@@ -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)]
Web/SocketIO/Types/String.hs view
@@ -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)
Web/SocketIO/Util.hs view
@@ -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)
socketio.cabal view
@@ -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.*
+ test/main.hs view
@@ -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+ ]