diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,3 @@ +## 1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Oliver Charles + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oliver Charles nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/engine-io.cabal b/engine-io.cabal new file mode 100644 --- /dev/null +++ b/engine-io.cabal @@ -0,0 +1,49 @@ +name: engine-io +version: 1.0.0 +synopsis: A Haskell implementation of Engine.IO +homepage: http://github.com/ocharles/engine.io +license: BSD3 +license-file: LICENSE +author: Oliver Charles +maintainer: ollie@ocharles.org.uk +category: Web +build-type: Simple +cabal-version: >=1.10 +description: + This library provides a Haskell implementation of + , a library for real-time + client-server communication on the web. Engine.IO works with old browsers via + XHR long-polling, and seamlessy upgrades to web sockets. This implementation + supports the majority of the Engine.IO protocol, including text and binary + packets and the upgrading protocol. + +extra-source-files: Changelog.md + +library + exposed-modules: + Network.EngineIO + + other-extensions: + RankNTypes, OverloadedStrings, RecordWildCards + + build-depends: + aeson >=0.7 && <0.8, + async >=2.0 && <2.1, + attoparsec >=0.11 && <0.13, + base >=4.6 && <4.8, + base64-bytestring >=1.0 && <1.1, + bytestring >=0.10.2.0 && <0.11, + either >= 3.4 && <4.4, + monad-loops >=0.4 && <0.5, + mwc-random >=0.13 && <0.14, + stm >=2.4 && <2.5, + text >=0.11 && <1.2, + transformers >=0.2 && <0.5, + unordered-containers >=0.2 && <0.3, + vector >=0.10 && <0.11, + websockets >=0.8 && <0.9 + + hs-source-dirs: src + default-language: Haskell2010 + + ghc-options: -Wall -O2 -fwarn-incomplete-uni-patterns diff --git a/src/Network/EngineIO.hs b/src/Network/EngineIO.hs new file mode 100644 --- /dev/null +++ b/src/Network/EngineIO.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.EngineIO + ( -- $intro + + -- * Example Usage + -- $example + + -- * Running Engine.IO applications + initialize + , handler + , EngineIO + , ServerAPI (..) + , SocketApp(..) + + -- * Interacting with 'Socket's + , send + , receive + , Socket + , SocketId + , socketId + , getOpenSockets + + -- * The Engine.IO Protocol + -- This section of the API is somewhat low-level, and exposes the raw + -- protocol to users. + + -- ** Packets + , Packet(..) + , parsePacket + , encodePacket + , PacketType + + -- ** Packet Contents + , PacketContent(..) + + -- ** Payloads + , Payload(..) + , parsePayload + , encodePayload + + -- ** Transport types + , TransportType(..) + , parseTransportType + ) where + +import Prelude hiding (any) + +import Control.Applicative +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Exception (SomeException(SomeException), try) +import Control.Monad (MonadPlus, forever, guard, mzero, replicateM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Loops (unfoldM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Either (eitherT, left) +import Control.Monad.Trans.Maybe (runMaybeT) +import Data.Aeson ((.=)) +import Data.Char (digitToInt, intToDigit) +import Data.Foldable (asum, for_) +import Data.Function (fix, on) +import Data.Ix (inRange) +import Data.List (foldl') +import Data.Monoid ((<>), mconcat, mempty) +import Data.Ord (comparing) +import Data.Traversable (for) + +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.STM as STM +import qualified Data.Aeson as Aeson +import qualified Data.Attoparsec.ByteString as Attoparsec +import qualified Data.Attoparsec.ByteString.Char8 as AttoparsecC8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +import qualified Network.WebSockets as WebSockets +import qualified System.Random.MWC as Random + +-------------------------------------------------------------------------------- +-- | The possible packet types, as mentioned in the +-- +data PacketType = Open | Close | Ping | Pong | Message | Upgrade | Noop + deriving (Bounded, Enum, Eq, Read, Show) + + +-------------------------------------------------------------------------------- +packetTypeToIndex :: Num i => PacketType -> i +packetTypeToIndex t = + case t of + Open -> 0 + Close -> 1 + Ping -> 2 + Pong -> 3 + Message -> 4 + Upgrade -> 5 + Noop -> 6 +{-# INLINE packetTypeToIndex #-} + + +-------------------------------------------------------------------------------- +packetTypeFromIndex :: (Eq i, MonadPlus m, Num i) => i -> m PacketType +packetTypeFromIndex i = + case i of + 0 -> return Open + 1 -> return Close + 2 -> return Ping + 3 -> return Pong + 4 -> return Message + 5 -> return Upgrade + 6 -> return Noop + _ -> mzero +{-# INLINE packetTypeFromIndex #-} + + +-------------------------------------------------------------------------------- +-- | A single Engine.IO packet. +data Packet = Packet !PacketType !PacketContent + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | The contents attached to a packet. Engine.IO makes a clear distinction +-- between binary data and text data. Clients will receive binary data as a +-- Javascript @ArrayBuffer@, where as 'TextPacket's will be received as UTF-8 +-- strings. +data PacketContent + = BinaryPacket !BS.ByteString + | TextPacket !Text.Text + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | Parse bytes as an 'Packet' assuming the packet contents extends to the +-- end-of-input. +parsePacket :: Attoparsec.Parser Packet +parsePacket = parsePacket' Attoparsec.takeByteString +{-# INLINE parsePacket #-} + + +-------------------------------------------------------------------------------- +-- | Parse a 'Packet', nested another parser for the body of the packet. +parsePacket' :: Attoparsec.Parser BS.ByteString -> Attoparsec.Parser Packet +parsePacket' body = parseBase64 <|> parseBinary <|> parseText + + where + parseBase64 = do + _ <- AttoparsecC8.char 'b' + Packet <$> c8PacketType + <*> (either fail (return . BinaryPacket) . Base64.decode =<< body) + + parseBinary = do + Packet <$> (packetTypeFromIndex =<< Attoparsec.satisfy (inRange (0, 6))) + <*> (BinaryPacket <$> body) + + parseText = do + Packet <$> c8PacketType + <*> (TextPacket . Text.decodeUtf8 <$> body) + + c8PacketType = + packetTypeFromIndex . digitToInt =<< AttoparsecC8.satisfy (inRange ('0', '6')) + +{-# INLINE parsePacket' #-} + + +-------------------------------------------------------------------------------- +-- | Encode a 'Packet' to a 'Builder.Builder'. The first argument determines +-- whether or not binary is supported - if not, binary data will be base 64 +-- encoded. +encodePacket + :: Bool + -- ^ If true, all bytes can be used. Otherwise, the packet will be base 64 + -- encoded. + -> Packet + -> Builder.Builder +encodePacket True (Packet t (BinaryPacket bytes)) = + Builder.word8 (packetTypeToIndex t) <> + Builder.byteString bytes + +encodePacket False (Packet t (BinaryPacket bytes)) = + Builder.char8 'b' <> + Builder.char8 (intToDigit (packetTypeToIndex t)) <> + Builder.byteString (Base64.encode bytes) + +encodePacket _ (Packet t (TextPacket bytes)) = + Builder.char8 (intToDigit (packetTypeToIndex t)) <> + Builder.byteString (Text.encodeUtf8 bytes) + + +-------------------------------------------------------------------------------- +-- | A 'Payload' is a stream of 0-or-more 'Packet's. +newtype Payload = Payload (V.Vector Packet) + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | Parse a stream of bytes into a 'Payload'. +parsePayload :: Attoparsec.Parser Payload +parsePayload = Payload <$> go + where + go = do + _ <- Attoparsec.satisfy (`elem` [0, 1]) + len <- parseLength =<< Attoparsec.many1 (Attoparsec.satisfy (inRange (0, 9))) + _ <- Attoparsec.word8 maxBound + + packet <- parsePacket' (Attoparsec.take (len - 1)) -- the type consumes 1 byte + (V.singleton packet <$ Attoparsec.endOfInput) <|> (V.cons packet <$> go) + + parseLength bytes = do + guard (length bytes <= 319) + return $ foldl' (\n x -> n * 10 + x) 0 $ map fromIntegral bytes + + +-------------------------------------------------------------------------------- +-- | Encode a 'Payload' to a 'Builder.Builder'. As with 'encodePacket', the +-- first argument determines whether or not binary transmission is supported. +encodePayload + :: Bool + -- ^ If true, all bytes can be used. Otherwise, the packet will be base 64 + -- encoded. + -> Payload + -> Builder.Builder +encodePayload supportsBinary (Payload packets) = + let encodeOne packet = + let bytes = encodePacket supportsBinary packet + in mconcat [ Builder.word8 $ if isBinaryPacket packet then 1 else 0 + , mconcat $ map (Builder.word8 . read . pure) $ + show (LBS.length (Builder.toLazyByteString bytes)) + , Builder.word8 maxBound + , bytes + ] + + in V.foldl' (\bytes p -> bytes <> encodeOne p) mempty packets + + where + isBinaryPacket (Packet _ (BinaryPacket _)) = True + isBinaryPacket _ = False + + +-------------------------------------------------------------------------------- +-- | The possible types of transports Engine.IO supports. +data TransportType + = Polling + -- ^ XHR long polling. + | Websocket + -- ^ HTML 5 websockets. + deriving (Eq, Show) + +instance Aeson.ToJSON TransportType where + toJSON t = Aeson.toJSON $ (`asTypeOf` show t) $ + case t of + Polling -> "polling" + Websocket -> "websocket" + + +-------------------------------------------------------------------------------- +-- | Attempt to parse a 'TransportType' from its textual representation. +parseTransportType :: Text.Text -> Maybe TransportType +parseTransportType t = + case t of + "polling" -> Just Polling + "websocket" -> Just Websocket + _ -> Nothing +{-# INLINE parseTransportType #-} + + +-------------------------------------------------------------------------------- +-- | The type of unique Engine.IO sessions. This is currently a base64-encoded +-- random identifier. +type SocketId = BS.ByteString + + +-------------------------------------------------------------------------------- +data Transport = Transport + { transIn :: STM.TChan Packet + , transOut :: STM.TChan Packet + , transType :: !TransportType + } + + +-------------------------------------------------------------------------------- +-- | A connected Engine.IO session. +data Socket = Socket + { socketId :: !SocketId + , socketTransport :: STM.TVar Transport + , socketIncomingMessages :: STM.TChan PacketContent + , socketOutgoingMessages :: STM.TChan PacketContent + } + +instance Eq Socket where + (==) = (==) `on` socketId + +instance Ord Socket where + compare = comparing socketId + + +-------------------------------------------------------------------------------- +-- | Receive data from the client, blocking if the input queue is empty. +receive :: Socket -> STM.STM PacketContent +receive Socket{..} = STM.readTChan socketIncomingMessages +{-# INLINE receive #-} + + +-------------------------------------------------------------------------------- +-- | Send a packet to the client. This is a non-blocking write. +send :: Socket -> PacketContent -> STM.STM () +send Socket{..} = STM.writeTChan socketOutgoingMessages +{-# INLINE send #-} + + +-------------------------------------------------------------------------------- +-- | A dictionary of functions that Engine.IO needs in order to provide +-- communication channels. +data ServerAPI m = ServerAPI + { srvGetQueryParams :: m (HashMap.HashMap BS.ByteString [BS.ByteString]) + -- ^ Retrieve the 'HashMap.HashMap' of query parameters in the request path + -- to their zero-or-more values. + + , srvWriteBuilder :: Builder.Builder -> m () + -- ^ Write a 'Builder.Bulider' to the response. + + , srvSetContentType :: BS.ByteString -> m () + -- ^ Set the @Content-Type@ header of the response. + + , srvParseRequestBody :: forall a. Attoparsec.Parser a -> m a + -- ^ Run a 'Attoparsec.Parser' against the request body. + + , srvGetRequestMethod :: m BS.ByteString + -- ^ Get the request method of the current request. The request method + -- should be in uppercase for standard methods (e.g., @GET@). + + , srvRunWebSocket :: WebSockets.ServerApp -> m () + -- ^ Upgrade the current connection to run a WebSocket action. + + , srvSetResponseCode :: Int -> m () + -- ^ Set the response code of the response. + } + + +-------------------------------------------------------------------------------- +-- | An opaque data type representing an open Engine.IO server. +data EngineIO = EngineIO + { eioOpenSessions :: STM.TVar (HashMap.HashMap SocketId Socket) + , eioRng :: MVar Random.GenIO + } + + +-------------------------------------------------------------------------------- +-- | 'initialize' initializes a new Engine.IO server. You can later serve this +-- session by using 'handler'. +initialize :: IO EngineIO +initialize = + EngineIO + <$> STM.newTVarIO mempty + <*> (Random.createSystemRandom >>= newMVar) + + +-------------------------------------------------------------------------------- +-- | Retrieve a list of /all/ currently open Engine.IO sessions. +getOpenSockets :: EngineIO -> STM.STM (HashMap.HashMap SocketId Socket) +getOpenSockets = STM.readTVar . eioOpenSessions + + +-------------------------------------------------------------------------------- +data EngineIOError = BadRequest | TransportUnknown | SessionIdUnknown + deriving (Bounded, Enum, Eq, Show) + + +-------------------------------------------------------------------------------- +-- | The application to run for the duration of a connected socket. +data SocketApp = SocketApp + { saApp :: IO () + -- ^ An IO action to run for the duration of the socket's lifetime. If this + -- action terminates, the connection will be closed. You will likely want + -- to loop 'Control.Monad.forever' and block as appropriate with 'receive'. + + , saOnDisconnect :: IO () + -- ^ An action to execute when the connection is closed, either by 'saApp' + -- terminating, or the client disconnecting. + } + + +-------------------------------------------------------------------------------- +{-| + +Build the necessary handler for Engine.IO. The result of this function is a +computation that you should serve under the @/engine.io/@ path. + +'handler' takes a function as an argument that is called every time a new +session is created. This function runs in the @m@ monad, so you have access to +initial web request, which may be useful for performing authentication or +collecting cookies. This function then returns a 'ServerApp', describing the +main loop and an action to perform on socket disconnection. + +-} +handler :: MonadIO m => EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> m () +handler eio socketHandler api@ServerAPI{..} = do + queryParams <- srvGetQueryParams + eitherT (serveError api) return $ do + reqTransport <- maybe (left TransportUnknown) return $ do + [t] <- HashMap.lookup "transport" queryParams + parseTransportType (Text.decodeUtf8 t) + + socket <- + for (HashMap.lookup "sid" queryParams) $ \sids -> do + sid <- case sids of + [sid] -> return sid + _ -> left SessionIdUnknown + + mSocket <- liftIO (STM.atomically (HashMap.lookup sid <$> getOpenSockets eio)) + case mSocket of + Nothing -> left SessionIdUnknown + Just s -> return s + + supportsBinary <- + case HashMap.lookup "b64" queryParams of + Just ["1"] -> return False + Just ["0"] -> return True + Nothing -> return True + _ -> left BadRequest + + case socket of + Just s -> do + transport <- liftIO $ STM.atomically $ STM.readTVar (socketTransport s) + case transType transport of + Polling + | reqTransport == Polling -> lift (handlePoll api transport supportsBinary) + | reqTransport == Websocket -> lift (upgrade api s) + + _ -> left BadRequest + + Nothing -> + lift (freshSession eio socketHandler api supportsBinary) + + +-------------------------------------------------------------------------------- +freshSession + :: MonadIO m + => EngineIO + -> (Socket -> m SocketApp) + -> ServerAPI m + -> Bool + -> m () +freshSession eio socketHandler api supportsBinary = do + sId <- liftIO (newSocketId eio) + + socket <- liftIO $ + Socket <$> pure sId + <*> (do transport <- Transport <$> STM.newTChanIO + <*> STM.newTChanIO + <*> pure Polling + STM.newTVarIO transport) + <*> STM.newTChanIO + <*> STM.newTChanIO + + liftIO $ STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.insert sId socket)) + + app <- socketHandler socket + userSpace <- liftIO $ Async.async (saApp app) + + brain <- liftIO $ Async.async $ fix $ \loop -> do + mMessage <- STM.atomically $ do + transport <- STM.readTVar (socketTransport socket) + asum + [ do req <- STM.readTChan (transIn transport) + case req of + Packet Message m -> + STM.writeTChan (socketIncomingMessages socket) m + + Packet Ping m -> + STM.writeTChan (transOut transport) (Packet Pong m) + + _ -> + return () + + return (Just req) + + , do STM.readTChan (socketOutgoingMessages socket) + >>= STM.writeTChan (transOut transport) . Packet Message + + return Nothing + ] + + case mMessage of + Just (Packet Close _) -> return () + _ -> loop + + _ <- liftIO $ Async.async $ do + _ <- Async.waitAnyCatchCancel [ userSpace, brain ] + STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.delete sId)) + saOnDisconnect app + + let openMessage = OpenMessage { omSocketId = sId + , omUpgrades = [ Websocket ] + , omPingTimeout = 60000 + , omPingInterval = 25000 + } + + payload = Payload $ V.singleton $ + Packet Open (TextPacket $ Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode openMessage) + + writeBytes api (encodePayload supportsBinary payload) + + +-------------------------------------------------------------------------------- +upgrade :: MonadIO m => ServerAPI m -> Socket -> m () +upgrade ServerAPI{..} socket = srvRunWebSocket go + + where + + go pending = do + conn <- WebSockets.acceptRequest pending + + mWsTransport <- runMaybeT $ do + Packet Ping (TextPacket "probe") <- lift (receivePacket conn) + lift (sendPacket conn (Packet Pong (TextPacket "probe"))) + + (wsIn, wsOut) <- liftIO $ STM.atomically $ do + currentTransport <- STM.readTVar (socketTransport socket) + STM.writeTChan (transOut currentTransport) (Packet Noop (TextPacket Text.empty)) + return (transIn currentTransport, transOut currentTransport) + + Packet Upgrade body <- lift (receivePacket conn) + guard (body == TextPacket Text.empty || body == BinaryPacket BS.empty) + + return (Transport wsIn wsOut Websocket) + + for_ mWsTransport $ \wsTransport@Transport { transIn = wsIn, transOut = wsOut } -> do + -- The client has completed the upgrade, so we can swap out the current + -- transport with a WebSocket transport. + STM.atomically (STM.writeTVar (socketTransport socket) wsTransport) + + reader <- Async.async $ forever $ do + p <- STM.atomically (STM.readTChan wsOut) + sendPacket conn p + + fix $ \loop -> do + e <- try (receivePacket conn >>= STM.atomically . STM.writeTChan wsIn) + case e of + Left (SomeException _) -> + return () + + Right _ -> loop + + Async.cancel reader + STM.atomically (STM.writeTChan wsIn (Packet Close (TextPacket Text.empty))) + + receivePacket conn = do + msg <- WebSockets.receiveDataMessage conn + case msg of + WebSockets.Text bytes -> + case Attoparsec.parseOnly parsePacket (LBS.toStrict bytes) of + Left ex -> do + putStrLn $ "Malformed packet received: " ++ show bytes ++ " (" ++ show ex ++ ")" + receivePacket conn + + Right p -> return p + + other -> do + putStrLn $ "Unknown WebSocket message: " ++ show other + receivePacket conn + + sendPacket conn p@(Packet _ (TextPacket _)) = do + WebSockets.sendTextData conn (Builder.toLazyByteString (encodePacket False p)) + + sendPacket conn p@(Packet _ (BinaryPacket _)) = do + WebSockets.sendBinaryData conn (Builder.toLazyByteString (encodePacket True p)) + + +-------------------------------------------------------------------------------- +handlePoll :: MonadIO m => ServerAPI m -> Transport -> Bool -> m () +handlePoll api@ServerAPI{..} transport supportsBinary = do + requestMethod <- srvGetRequestMethod + case requestMethod of + m | m == "GET" -> poll + m | m == "POST" -> post + _ -> serveError api BadRequest + + where + + poll = do + let out = transOut transport + packets <- liftIO $ + (:) <$> STM.atomically (STM.readTChan out) + <*> unfoldM (STM.atomically (STM.tryReadTChan (transOut transport))) + + writeBytes api (encodePayload supportsBinary (Payload (V.fromList packets))) + + post = do + Payload packets <- srvParseRequestBody parsePayload + liftIO $ STM.atomically (V.mapM_ (STM.writeTChan (transIn transport)) packets) + + +-------------------------------------------------------------------------------- +writeBytes :: Monad m => ServerAPI m -> Builder.Builder -> m () +writeBytes ServerAPI {..} builder = do + srvWriteBuilder builder + srvSetContentType "application/octet-stream" +{-# INLINE writeBytes #-} + + +-------------------------------------------------------------------------------- +newSocketId :: EngineIO -> IO SocketId +newSocketId eio = + Base64.encode . BS.pack + <$> withMVar (eioRng eio) (replicateM 15 . Random.uniformR (0, 63)) +{-# INLINE newSocketId #-} + + +-------------------------------------------------------------------------------- +data OpenMessage = OpenMessage + { omSocketId :: !SocketId + , omUpgrades :: [TransportType] + , omPingTimeout :: !Int + , omPingInterval :: !Int + } + +instance Aeson.ToJSON OpenMessage where + toJSON OpenMessage {..} = Aeson.object + [ "sid" .= Text.decodeUtf8 omSocketId + , "upgrades" .= omUpgrades + , "pingTimeout" .= omPingTimeout + , "pingInterval" .= omPingInterval + ] + + +-------------------------------------------------------------------------------- +serveError :: Monad m => ServerAPI m -> EngineIOError -> m () +serveError ServerAPI{..} e = do + srvSetResponseCode 400 + srvSetContentType "application/json" + srvWriteBuilder $ Builder.lazyByteString $ Aeson.encode $ Aeson.object + [ "code" .= errorCode, "message" .= errorMessage ] + + where + errorCode :: Int + errorCode = case e of + TransportUnknown -> 0 + SessionIdUnknown -> 1 + BadRequest -> 3 + + errorMessage :: Text.Text + errorMessage = case e of + TransportUnknown -> "Transport unknown" + SessionIdUnknown -> "Session ID unknown" + BadRequest -> "Bad request" + + +{- $intro + +@Network.EngineIO@ is a Haskell of implementation of +, a realtime framework for +the web. Engine.IO provides you with an abstraction for doing real-time +communication between a server and a client. Engine.IO abstracts the framing and +transport away, so that you can have real-time communication over long-polling +HTTP requests, which are later upgraded to web sockets, if available. + +@Network.EngineIO@ needs to be provided with a 'ServerAPI' in order to be +ran. 'ServerAPI' informs us how to fetch request headers, write HTTP responses +to the client, and run web socket applications. Hackage contains implementations +of 'ServerAPI' as: + +* for Snap. + +If you write your own implementation of 'ServerAPI', please share it on Hackage +and I will link to it from here. + +-} + +{- $example + +A simple echo server is easy to write with Engine.IO. The following imports will +be required: + +> import Control.Concurrent.STM +> import Control.Monad (forever) +> import Network.EngineIO +> import Network.EngineIO.Snap +> import Snap.Http.Server + +Next, we write the implementation of our per-socket processing logic. For this +application we simply receive from the socket, and then send the result back to +the socket. We wrap this all in 'Control.Monad.forever' as this connection +should never terminate. + +> handleSocket :: Socket -> IO () +> handleSocket s = forever $ atomically $ +> receive s >>= send s + +Finally, we add a @main@ function to our application to launch it. I'll use +@engine-io-snap@ as my server implementation: + +> main :: IO () +> main = do +> eio <- initialize +> quickHttpServe $ handler eio handleSocket + +This means that /any/ URL works as the Engine.IO server, which is sufficient for +our example. In a real production application, you will probably want to nest +the 'handler' under @/engine.io@. + +-}