content: {-# 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
    , dupRawReader
  
      -- * 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 (threadDelay)
  import Control.Concurrent.MVar (MVar, newMVar, withMVar)
  import Control.Error (exceptT, throwE)
  import Control.Exception (SomeException(SomeException), try)
  import Control.Monad (MonadPlus, forever, guard, mzero, replicateM, when)
  import Control.Monad.IO.Class (MonadIO, liftIO)
  import Control.Monad.Loops (unfoldM)
  import Control.Monad.Trans.Class (lift)
  import Control.Monad.Trans.Iter (cutoff, delay, retract)
  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 Control.Concurrent.STM.Delay as STMDelay
  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.Char8 as BSChar8
  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 Network.WebSockets.Connection as WebSockets
  import qualified System.Random.MWC as Random
  
  --------------------------------------------------------------------------------
  -- | The possible packet types, as mentioned in the
  -- <https://github.com/Automattic/engine.io-protocol Engine.IO protocol documentation>
  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 <$> (goXHR2 <|> goXHR)
    where
    goXHR = do
      len <- AttoparsecC8.decimal <* AttoparsecC8.char ':'
      packet <- parsePacket' (Attoparsec.take (len - 1)) -- the type consumes 1 byte
      (V.singleton packet <$ Attoparsec.endOfInput) <|> (V.cons packet <$> goXHR)
  
    goXHR2 = 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 <$> goXHR2)
  
    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
    , socketRawIncomingBroadcast :: STM.TChan Packet
    }
  
  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.
  
    , srvTerminateWithResponse :: Int -> BS.ByteString -> Builder.Builder -> forall a . m a
      -- ^ Send a response with the given status code, content type and body. This
      -- should also terminate the web request entirely, such that further actions
      -- in @m@ have no effect.
  
    , srvParseRequestBody :: forall a. Attoparsec.Parser a -> m (Either String 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.
    }
  
  
  --------------------------------------------------------------------------------
  -- | 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 'SocketApp', 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
    exceptT (serveError api) return $ do
      reqTransport <- maybe (throwE 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
                   _ -> throwE SessionIdUnknown
  
          mSocket <- liftIO (STM.atomically (HashMap.lookup sid <$> getOpenSockets eio))
          case mSocket of
            Nothing -> throwE SessionIdUnknown
            Just s -> return s
  
      supportsBinary <-
        case HashMap.lookup "b64" queryParams of
          Just ["1"] -> return False
          Just ["0"] -> return True
          Nothing    -> return True
          _          -> throwE 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)
  
            _ -> throwE 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
    socket <- do
      mkSocket <- liftIO $ do
        transport <- STM.newTVarIO =<< (Transport <$> STM.newTChanIO <*> STM.newTChanIO <*> pure Polling)
        incoming <- STM.newTChanIO
        outgoing <- STM.newTChanIO
        rawInBroadcast <- STM.newBroadcastTChanIO
        return (\sId -> Socket sId transport incoming outgoing rawInBroadcast)
  
      let
        tryAllocation = liftIO $ do
          sId <- newSocketId eio
          STM.atomically $ runMaybeT $ do
            openSessions <- lift (STM.readTVar (eioOpenSessions eio))
            guard (not (HashMap.member sId openSessions))
            let socket = mkSocket sId
            lift (STM.modifyTVar' (eioOpenSessions eio) (HashMap.insert sId socket))
            return socket
  
        untilSuccess f = maybe (delay (untilSuccess f)) return =<< f
  
      maybeSocket <- retract (cutoff 10 (untilSuccess tryAllocation))
      maybe (srvTerminateWithResponse api 500 "text/plain" "Session allocation failed")
            return maybeSocket
  
    app <- socketHandler socket
    userSpace <- liftIO $ Async.async (saApp app)
  
    pingTimeoutDelay <- liftIO $ STMDelay.newDelay (pingTimeout * 1000000)
    heartbeat <- liftIO $ Async.async $
      STM.atomically (STMDelay.waitDelay pingTimeoutDelay)
  
    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 ()
  
               STM.writeTChan (socketRawIncomingBroadcast socket) req
               return (Just req)
  
          , do STM.readTChan (socketOutgoingMessages socket)
                 >>= STM.writeTChan (transOut transport) . Packet Message
  
               return Nothing
          ]
  
      -- If we *received* a message, then we can reset the ping timer.
      for_ mMessage (const (STMDelay.updateDelay pingTimeoutDelay (pingTimeout * 1000000)))
  
      -- If we received a close message, terminate. Otherwise, loop.
      case mMessage of
        Just (Packet Close _) -> return ()
        _ -> loop
  
    _ <- liftIO $ Async.async $ do
      _ <- Async.waitAnyCatchCancel [ userSpace, brain, heartbeat ]
      STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.delete (socketId socket)))
      saOnDisconnect app
  
    let openMessage = OpenMessage { omSocketId = socketId socket
                                  , omUpgrades = [ Websocket ]
                                  , omPingTimeout = pingTimeout * 1000
                                  , omPingInterval = 25000
                                  }
  
        payload = Payload $ V.singleton $
                    Packet Open (TextPacket $ Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode openMessage)
  
    writeBytes api (encodePayload supportsBinary payload)
  
    where
  
    pingTimeout = 60
  
  --------------------------------------------------------------------------------
  upgrade :: MonadIO m => ServerAPI m -> Socket -> m ()
  upgrade ServerAPI{..} socket = srvRunWebSocket go
  
    where
  
    go pending = do
      conn <- WebSockets.acceptRequest $
        -- We do our ping/pong, so disable `websockets` doing this.
        pending { WebSockets.pendingOnAccept = (const $ return ()) }
  
      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)
          return (transIn currentTransport, transOut currentTransport)
  
        -- We wait 100ms to match the reference engine.io Javascript.
        -- See automattic/engine.io socket.js revision d11e17c8.
        check <-
          liftIO
            (Async.async
              (do threadDelay 100000
                  STM.atomically
                    (do t <- STM.readTVar (socketTransport socket)
                        when (transType t == Polling)
                             (STM.writeTChan (transOut t)
                                             (Packet Noop (TextPacket Text.empty))))))
  
        Packet Upgrade body <- lift (receivePacket conn)
        guard (body == TextPacket Text.empty || body == BinaryPacket BS.empty)
  
        liftIO (Async.cancel check)
  
        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 (Packet t (TextPacket text)) =
      WebSockets.sendTextData conn $
        Text.encodeUtf8 $
          Text.pack (pure $ intToDigit (packetTypeToIndex t)) <> text
  
    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
      readTimeout <- liftIO $ STM.registerDelay (45 * 1000000)
  
      let out = transOut transport
  
      -- Here we attempt to read as much from the transport output as we can.
      -- We also consider the timeout above, such that if we haven't even read
      -- one message by the timeout is reached, we instead emit a `ping`.
      packets <- liftIO $ do
        p <- STM.atomically $ do
          let dequeueHead = Just <$> STM.readTChan out
              timeout = Nothing <$ (STM.readTVar readTimeout >>= STM.check)
  
          dequeueHead <|> timeout
  
        case p of
          Just p' ->
            (p' :) <$> unfoldM (STM.atomically (STM.tryReadTChan (transOut transport)))
  
          Nothing ->
            return [ Packet Ping (BinaryPacket mempty) ]
  
      writeBytes api (encodePayload supportsBinary (Payload (V.fromList packets)))
  
    post = do
      p <- srvParseRequestBody parsePayload
      case p of
        Left ex -> do
          liftIO $ putStrLn $ "WARNING: Parse failure in Network.EngineIO.handlePoll: " ++ show ex
          srvTerminateWithResponse 400 "text/plain" "Empty request body"
  
        Right (Payload packets) ->
          liftIO $ STM.atomically (V.mapM_ (STM.writeTChan (transIn transport)) packets)
  
  
  --------------------------------------------------------------------------------
  writeBytes :: Monad m => ServerAPI m -> Builder.Builder -> m a
  writeBytes ServerAPI {..} builder = do
    srvTerminateWithResponse 200 "application/octet-stream" builder
  {-# 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 a
  serveError ServerAPI{..} e = srvTerminateWithResponse 400 "application/json" $
    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"
  
  
  --------------------------------------------------------------------------------
  -- | Create a new 'IO' action to read the socket's raw incoming communications.
  -- The result of this call is iteslf an STM action, which when called will return
  -- the next unread incoming packet (or block). This provides you with a separate
  -- channel to monitor incoming communications. It may be useful to monitor this to
  -- determine if the socket has activity.
  --
  -- This is a fairly low level operation, so you will receive *all* packets -
  -- including pings and other control codes.
  dupRawReader :: Socket -> IO (STM.STM Packet)
  dupRawReader s = do
    c <- STM.atomically (STM.dupTChan (socketRawIncomingBroadcast s))
    return (STM.readTChan c)
  
  
  {- $intro
  
  @Network.EngineIO@ is a Haskell of implementation of
  <https://github.com/automattic/engine.io Engine.IO>, a real-time 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
  run. '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:
  
  * <http://hackage.haskell.org/package/engine-io-snap engine-io-snap> for Snap.
  * <http://hackage.haskell.org/package/engine-io-yesod engine-io-yesod> for Yesod.
  
  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 :: MonadIO m => Socket -> m SocketApp
  > handleSocket s = return $ SocketApp app onDisconnect
  >   where
  >    app = forever $ STM.atomically $ receive s >>= EIO.send s
  >    onDisconnect = STM.atomically $ send s $ TextPacket "Bye!"
  
  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 snapAPI
  
  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@.
  
  -}
  