socketio (empty) → 0.1.0.0
raw patch · 16 files changed
+1118/−0 lines, 16 filesdep +aesondep +ansi-terminaldep +basesetup-changed
Dependencies added: aeson, ansi-terminal, base, bytestring, conduit, containers, http-types, lifted-base, monad-control, mtl, parsec, random, resourcet, text, transformers-base, unordered-containers, wai, warp
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- Web/SocketIO.hs +56/−0
- Web/SocketIO/Connection.hs +131/−0
- Web/SocketIO/Event.hs +18/−0
- Web/SocketIO/Parser.hs +127/−0
- Web/SocketIO/Request.hs +44/−0
- Web/SocketIO/Server.hs +86/−0
- Web/SocketIO/Session.hs +91/−0
- Web/SocketIO/Types.hs +129/−0
- Web/SocketIO/Types/Log.hs +21/−0
- Web/SocketIO/Types/Request.hs +105/−0
- Web/SocketIO/Types/SocketIO.hs +120/−0
- Web/SocketIO/Types/String.hs +70/−0
- Web/SocketIO/Util.hs +22/−0
- socketio.cabal +76/−0
+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2013 Ting-Yen LAI++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/SocketIO.hs view
@@ -0,0 +1,56 @@+module Web.SocketIO+ (+ -- * How to use this module+ -- |+ --+ -- Note that most of the string literals below are of type Text.+ --+ -- >{-\# LANGUAGE OverloadedStrings \#-}+ -- >+ -- >import Web.SocketIO+ -- >+ -- >-- listens to port 4000+ -- >main = server 4000 $ do+ -- >+ -- > -- send something to the client+ -- > emit "some event" ["hey"]+ -- >+ -- > -- ping-pong+ -- > on "ping" $ do+ -- > emit "pong" []+ -- >+ -- > -- do some IO+ -- > on "Kim Jong-Un" $ liftIO launchMissile+ -- > ++ -- * Running a standalone server+ server+ , serverConfig+ , defaultConfig+ , Configuration(..)+ , Port+ , Transport(XHRPolling)+ + -- * Sending and receiving events+ , Subscriber(..)+ , Publisher(..)+ , reply+ , Event++ -- ** Special events+ -- | On disconnection+ -- + -- @+ -- 'on' \"disconnect\" $ do+ -- liftIO $ print \"client disconnected\"+ -- @++ -- * Types+ , HandlerM+ , CallbackM+ + ) where++import Web.SocketIO.Types+import Web.SocketIO.Server+import Web.SocketIO.Event
+ Web/SocketIO/Connection.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.SocketIO.Connection+ ( runConnection+ , newSessionTable+ ) where++--------------------------------------------------------------------------------+import Web.SocketIO.Types+import Web.SocketIO.Util+import Web.SocketIO.Session++--------------------------------------------------------------------------------+import qualified Data.HashMap.Strict as H+import Data.IORef.Lifted+import Control.Applicative ((<$>))+import Control.Concurrent.Lifted (fork)+import Control.Concurrent.Chan.Lifted +import Control.Concurrent.MVar.Lifted+import Control.Monad.Reader +import Control.Monad.Writer +import System.Random (randomRIO)+import System.Timeout.Lifted++--------------------------------------------------------------------------------+newSessionTable :: IO (IORef Table)+newSessionTable = newIORef H.empty++--------------------------------------------------------------------------------+updateSession :: (Table -> Table) -> ConnectionM ()+updateSession update = do+ table <- getSessionTable+ liftIO (modifyIORef table update)++--------------------------------------------------------------------------------+lookupSession :: SessionID -> ConnectionM (Maybe Session)+lookupSession sessionID = do+ table <- getSessionTable+ table <- liftIO (readIORef table)+ return (H.lookup sessionID table)++--------------------------------------------------------------------------------+executeHandler :: HandlerM () -> BufferHub -> ConnectionM [Listener]+executeHandler handler bufferHub = liftIO $ execWriterT (runReaderT (runHandlerM handler) bufferHub)++--------------------------------------------------------------------------------+runConnection :: Env -> Request -> IO Text+runConnection env req = do+ runReaderT (runConnectionM (handleConnection req)) env++--------------------------------------------------------------------------------+handleConnection :: Request -> ConnectionM Text+handleConnection Handshake = do+ globalBuffer <- globalBuffer <$> getEnv+ globalBufferClone <- dupChan globalBuffer+ localBuffer <- newChan+ let bufferHub = BufferHub localBuffer globalBufferClone+ handler <- getHandler+ sessionID <- genSessionID+ listeners <- executeHandler handler bufferHub+ timeout' <- newEmptyMVar++ let session = Session sessionID Connecting bufferHub listeners timeout'++ fork $ setTimeout sessionID timeout'++ updateSession (H.insert sessionID session)++ runSession SessionSyn session+ where genSessionID = liftIO $ fmap (fromString . show) (randomRIO (10000000000000000000, 99999999999999999999 :: Integer)) :: ConnectionM Text++handleConnection (Connect sessionID) = do++ result <- lookupSession sessionID+ clearTimeout sessionID+ case result of+ Just (Session sessionID status buffer listeners timeout') -> do+ let session = Session sessionID Connected buffer listeners timeout'+ case status of+ Connecting -> do+ updateSession (H.insert sessionID session)+ runSession SessionAck session+ Connected ->+ runSession SessionPolling session+ Nothing -> do+ debug . Error $ fromText sessionID ++ " Unable to find session" + runSession SessionError NoSession++handleConnection (Disconnect sessionID) = do++ result <- lookupSession sessionID+ response <- case result of+ Just session -> runSession SessionDisconnect session+ Nothing -> return ""++ clearTimeout sessionID+ updateSession (H.delete sessionID)++ return response++handleConnection (Emit sessionID emitter) = do+ clearTimeout sessionID++ result <- lookupSession sessionID+ case result of+ Just session -> runSession (SessionEmit emitter) session+ Nothing -> runSession SessionError NoSession++--------------------------------------------------------------------------------+setTimeout :: SessionID -> MVar () -> ConnectionM ()+setTimeout sessionID timeout' = do+ configuration <- getConfiguration+ let duration = (closeTimeout configuration) * 1000000+ debug . Debug $ fromText sessionID ++ " Set Timeout"+ result <- timeout duration $ takeMVar timeout'++ case result of+ Just _ -> setTimeout sessionID timeout'+ Nothing -> do+ debug . Debug $ fromText sessionID ++ " Close Session"+ updateSession (H.delete sessionID)++--------------------------------------------------------------------------------+clearTimeout :: SessionID -> ConnectionM ()+clearTimeout sessionID = do+ result <- lookupSession sessionID+ case result of+ Just (Session _ _ _ _ timeout') -> do+ debug . Debug $ fromText sessionID ++ " Clear Timeout"+ putMVar timeout' ()+ Nothing -> return ()
+ Web/SocketIO/Event.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.SocketIO.Event where++import Web.SocketIO.Types++import Control.Monad.Reader++--------------------------------------------------------------------------------+-- | messages carried with the event+--+-- @+-- `on` \"echo\" $ do+-- messages <- reply+-- liftIO $ print messages+-- @+reply :: CallbackM [Text]+reply = ask
+ Web/SocketIO/Parser.hs view
@@ -0,0 +1,127 @@+--------------------------------------------------------------------------------+-- | 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/Request.hs view
@@ -0,0 +1,44 @@+{-# 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)++import qualified Network.Wai as Wai+import Network.HTTP.Types (Method)++import Data.Conduit.List (consume)+import Data.Conduit (($$))+import Data.Monoid (mconcat)++type RequestInfo = (Method, Path, Message)++retrieveRequestInfo :: Wai.Request -> IO RequestInfo+retrieveRequestInfo request = do++ body <- parseHTTPBody request++ let path = parsePath (Wai.rawPathInfo request)++ return + ( Wai.requestMethod request+ , path + , body+ )++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+processRequestInfo _ = error "error parsing http request"+ +processHTTPRequest :: Wai.Request -> IO Request+processHTTPRequest request = fmap processRequestInfo (retrieveRequestInfo request)++parseHTTPBody :: Wai.Request -> IO Message+parseHTTPBody req = parseMessage . fromByteString . mconcat <$> runResourceT (Wai.requestBody req $$ consume)
+ Web/SocketIO/Server.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.SocketIO.Server+ ( server+ , serverConfig+ , defaultConfig+ ) where++import Web.SocketIO.Types+import Web.SocketIO.Connection+import Web.SocketIO.Request++import Control.Concurrent.Chan+import Control.Concurrent (forkIO)+import Control.Monad (forever)+import Control.Monad.Trans (liftIO)+import Network.HTTP.Types (status200)+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 ()+server p h = serverConfig p defaultConfig h++--------------------------------------------------------------------------------+-- | Run a socket.io application with configurations applied.+serverConfig :: Port -> Configuration -> HandlerM () -> IO ()+serverConfig port config handler = do++ tableRef <- newSessionTable++ stdout <- newChan :: IO (Chan String)++ globalChannel <- newChan :: IO (Buffer)++ forkIO . forever $ do+ readChan stdout >>= putStrLn ++ let env = Env tableRef handler config stdout globalChannel++ Warp.run port (httpApp (runConnection env))++--------------------------------------------------------------------------------+httpApp :: (Request -> IO Text) -> Wai.Application+httpApp runConnection' httpRequest = liftIO $ do+ req <- processHTTPRequest httpRequest+ response <- runConnection' req+ text response++--------------------------------------------------------------------------------+-- | Default configurations to be overridden.+ --+ -- > defaultConfig :: Configuration+ -- > defaultConfig = Configuration+ -- > { transports = [XHRPolling]+ -- > , logLevel = 3 + -- > , closeTimeout = 60+ -- > , pollingDuration = 20+ -- > , heartbeats = True+ -- > , heartbeatTimeout = 60+ -- > , heartbeatInterval = 25+ -- > }+ --+defaultConfig :: Configuration+defaultConfig = Configuration+ { transports = [XHRPolling]+ , logLevel = 3+ , heartbeats = True+ , closeTimeout = 60+ , heartbeatTimeout = 60+ , heartbeatInterval = 25+ , pollingDuration = 20+}++--------------------------------------------------------------------------------+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") + ]
+ Web/SocketIO/Session.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.SocketIO.Session (runSession) where++--------------------------------------------------------------------------------+import Web.SocketIO.Types+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+ 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+++handleSession SessionAck = do+ sessionID <- getSessionID+ debug . Info $ fromText sessionID ++ " Connected"+ return "1::"++handleSession SessionPolling = do+ sessionID <- getSessionID+ configuration <- getConfiguration+ bufferHub <- getBufferHub+ + result <- timeout (pollingDuration configuration * 1000000) (readBothChannel bufferHub)+ case result of+ Just r -> do+ let msg = toMessage (MsgEvent NoID NoEndpoint r)+ debug . Debug $ fromText sessionID ++ " Sending Message: " ++ fromText msg+ return msg+ Nothing -> do+ debug . Debug $ fromText sessionID ++ " Polling"+ return "8::"++ where readBothChannel (BufferHub localBuffer globalBuffer) = do+ output <- newEmptyMVar+ _ <- fork (readChan localBuffer >>= putMVar output)+ _ <- fork (readChan globalBuffer >>= putMVar output)+ + takeMVar output++++handleSession (SessionEmit emitter) = do+ sessionID <- getSessionID+ bufferHub <- getBufferHub+ debug . Info $ fromText sessionID ++ " Emit"+ triggerListener emitter bufferHub+ return "1"+handleSession SessionDisconnect = do+ sessionID <- getSessionID+ debug . Info $ fromText sessionID ++ " Disconnected"+ bufferHub <- getBufferHub+ triggerListener (Emitter "disconnect" []) bufferHub+ return "1"+handleSession SessionError = return "7"++--------------------------------------------------------------------------------+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+ -- trigger them all+ forM_ correspondingCallbacks $ \(_, callback) -> fork $ do+ _ <- liftIO $ runReaderT (runReaderT (execWriterT (runCallbackM callback)) reply) channelHub+ return ()+triggerListener NoEmitter _ = error "trigger listeners with any emitters"++--------------------------------------------------------------------------------+runSession :: SessionState -> Session -> ConnectionM Text+runSession state session = runReaderT (runSessionM (handleSession state)) session
+ Web/SocketIO/Types.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Web.SocketIO.Types+ ( 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.Request+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/Log.hs view
@@ -0,0 +1,21 @@+module Web.SocketIO.Types.Log (Log(..)) where++import System.Console.ANSI++--------------------------------------------------------------------------------+-- | Logger+data Log = Error String+ | Warn String+ | Info String+ | Debug String+ deriving (Eq)++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++--------------------------------------------------------------------------------+paint :: Color -> String -> String+paint color s = setSGRCode [SetColor Foreground Vivid color] ++ s ++ setSGRCode []
+ Web/SocketIO/Types/Request.hs view
@@ -0,0 +1,105 @@+--------------------------------------------------------------------------------+-- | 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.SocketIO+++--------------------------------------------------------------------------------+-- | Path of incoming request+type Namespace = Text+type Protocol = Text+type SessionID = Text ++data Path = WithSession Namespace Protocol Transport SessionID+ | WithoutSession Namespace Protocol+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | Incoming request+data Request = Handshake+ | Disconnect SessionID+ | Connect SessionID + | Emit SessionID Emitter+ deriving (Show)++--------------------------------------------------------------------------------+-- | This is how data are encoded by Socket.IO Protocol+data Message = MsgDisconnect Endpoint+ | MsgConnect Endpoint+ | MsgHeartbeat+ | Msg ID Endpoint Data+ | MsgJSON ID Endpoint Data+ | MsgEvent ID Endpoint Emitter+ | MsgACK ID Data+ | MsgError Endpoint Data+ | MsgNoop+ deriving (Show, Eq)++data Endpoint = Endpoint String+ | NoEndpoint+ deriving (Show, Eq)+data ID = ID Int+ | IDPlus Int+ | NoID+ deriving (Show, Eq)+data Data = Data Text+ | NoData+ deriving (Show, Eq)+++--------------------------------------------------------------------------------+-- | 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:::"++instance Msg Transport where+ toMessage WebSocket = "websocket"+ toMessage XHRPolling = "xhr-polling"+ toMessage NoTransport = ""
+ Web/SocketIO/Types/SocketIO.hs view
@@ -0,0 +1,120 @@+--------------------------------------------------------------------------------+-- | 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
@@ -0,0 +1,70 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Web.SocketIO.Types.String (+ S.IsString(..)+ , IsByteString(..)+ , IsLazyByteString(..)+ , IsText(..)+ , Text+ , (<>)+ ) where++--------------------------------------------------------------------------------+import qualified Data.String as S+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as C+import Data.Monoid ((<>))++--------------------------------------------------------------------------------+type Text = TL.Text++--------------------------------------------------------------------------------+class IsByteString a where+ fromByteString :: B.ByteString -> a++--------------------------------------------------------------------------------+instance IsByteString String where+ fromByteString = C.unpack++--------------------------------------------------------------------------------+instance IsByteString TL.Text where+ fromByteString = TL.pack . fromByteString++--------------------------------------------------------------------------------+instance IsByteString BL.ByteString where+ fromByteString = BL.fromStrict++--------------------------------------------------------------------------------+class IsLazyByteString a where+ fromLazyByteString :: BL.ByteString -> a++--------------------------------------------------------------------------------+instance IsLazyByteString String where+ fromLazyByteString = fromByteString . BL.toStrict++--------------------------------------------------------------------------------+instance IsLazyByteString TL.Text where+ fromLazyByteString = fromByteString . BL.toStrict++--------------------------------------------------------------------------------+instance IsLazyByteString B.ByteString where+ fromLazyByteString = BL.toStrict++--------------------------------------------------------------------------------+class IsText a where+ fromText :: TL.Text -> a++--------------------------------------------------------------------------------+instance IsText String where+ fromText = TL.unpack++--------------------------------------------------------------------------------+instance IsText B.ByteString where+ fromText = C.pack . fromText++--------------------------------------------------------------------------------+instance IsText BL.ByteString where+ fromText = BL.fromStrict . C.pack . fromText
+ Web/SocketIO/Util.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.SocketIO.Util ((<>), 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+ 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++ level = levelOf message
+ socketio.cabal view
@@ -0,0 +1,76 @@+-- Initial SocketIO.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: socketio+version: 0.1.0.0+synopsis: Socket.IO server+description: + Socket.IO for Haskell folks.+ .+ [Socket.IO] <http://socket.io/>+ .+ [Protocol] <https://github.com/LearnBoost/socket.io-spec>+ .+ @+ {-# LANGUAGE OverloadedStrings #-}+ .+ import Web.SocketIO+ .+ \-\- listens to port 4000+ main = server 4000 $ do+ .+     \-\- ping pong+     on "ping" $ emit "pong" []+ .+     \-\- reply :: CallbackM [Text]+     on "echo" $ reply >>= emit "pong"+ .+     \-\- do some IO+     on "Kim Jong-Un" $ liftIO launchMissile+ @ + +license: MIT+license-file: LICENSE+author: Ting-Yen Lai+maintainer: banacorn@gmail.com+-- copyright: +stability: experimental+category: Web+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: + Web.SocketIO+ Other-modules:+ Web.SocketIO.Types+ Web.SocketIO.Types.SocketIO+ Web.SocketIO.Types.Log+ Web.SocketIO.Types.String+ Web.SocketIO.Types.Request+ Web.SocketIO.Connection+ Web.SocketIO.Event+ Web.SocketIO.Server+ Web.SocketIO.Parser+ Web.SocketIO.Request+ Web.SocketIO.Session+ 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+ , random ==1.0.*+ , parsec ==3.1.*+ , bytestring ==0.10.0.*+ , aeson ==0.6.1.*+ , wai ==1.4.0.*+ , http-types ==0.8.*+ , warp ==1.3.9.*+ , resourcet ==0.4.7.*+ , conduit ==1.0.7.*+ , monad-control ==0.3.2.*+ , transformers-base ==0.4.*+ , lifted-base ==0.2.1.*