diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Web/SocketIO.hs b/Web/SocketIO.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO.hs
@@ -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
diff --git a/Web/SocketIO/Connection.hs b/Web/SocketIO/Connection.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Connection.hs
@@ -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 ()
diff --git a/Web/SocketIO/Event.hs b/Web/SocketIO/Event.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Event.hs
@@ -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
diff --git a/Web/SocketIO/Parser.hs b/Web/SocketIO/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Parser.hs
@@ -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)
diff --git a/Web/SocketIO/Request.hs b/Web/SocketIO/Request.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Request.hs
@@ -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)
diff --git a/Web/SocketIO/Server.hs b/Web/SocketIO/Server.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Server.hs
@@ -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")
+ ]
diff --git a/Web/SocketIO/Session.hs b/Web/SocketIO/Session.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Session.hs
@@ -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
diff --git a/Web/SocketIO/Types.hs b/Web/SocketIO/Types.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Types.hs
@@ -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
diff --git a/Web/SocketIO/Types/Log.hs b/Web/SocketIO/Types/Log.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Types/Log.hs
@@ -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 []
diff --git a/Web/SocketIO/Types/Request.hs b/Web/SocketIO/Types/Request.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Types/Request.hs
@@ -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 = ""
diff --git a/Web/SocketIO/Types/SocketIO.hs b/Web/SocketIO/Types/SocketIO.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Types/SocketIO.hs
@@ -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)]
diff --git a/Web/SocketIO/Types/String.hs b/Web/SocketIO/Types/String.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Types/String.hs
@@ -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
diff --git a/Web/SocketIO/Util.hs b/Web/SocketIO/Util.hs
new file mode 100644
--- /dev/null
+++ b/Web/SocketIO/Util.hs
@@ -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
diff --git a/socketio.cabal b/socketio.cabal
new file mode 100644
--- /dev/null
+++ b/socketio.cabal
@@ -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]
+ .
+ [Protocol]
+ .
+ @
+ {-# 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.*