{-# 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 (PacketType
PacketType -> PacketType -> Bounded PacketType
forall a. a -> a -> Bounded a
maxBound :: PacketType
$cmaxBound :: PacketType
minBound :: PacketType
$cminBound :: PacketType
Bounded, Int -> PacketType
PacketType -> Int
PacketType -> [PacketType]
PacketType -> PacketType
PacketType -> PacketType -> [PacketType]
PacketType -> PacketType -> PacketType -> [PacketType]
(PacketType -> PacketType)
-> (PacketType -> PacketType)
-> (Int -> PacketType)
-> (PacketType -> Int)
-> (PacketType -> [PacketType])
-> (PacketType -> PacketType -> [PacketType])
-> (PacketType -> PacketType -> [PacketType])
-> (PacketType -> PacketType -> PacketType -> [PacketType])
-> Enum PacketType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PacketType -> PacketType -> PacketType -> [PacketType]
$cenumFromThenTo :: PacketType -> PacketType -> PacketType -> [PacketType]
enumFromTo :: PacketType -> PacketType -> [PacketType]
$cenumFromTo :: PacketType -> PacketType -> [PacketType]
enumFromThen :: PacketType -> PacketType -> [PacketType]
$cenumFromThen :: PacketType -> PacketType -> [PacketType]
enumFrom :: PacketType -> [PacketType]
$cenumFrom :: PacketType -> [PacketType]
fromEnum :: PacketType -> Int
$cfromEnum :: PacketType -> Int
toEnum :: Int -> PacketType
$ctoEnum :: Int -> PacketType
pred :: PacketType -> PacketType
$cpred :: PacketType -> PacketType
succ :: PacketType -> PacketType
$csucc :: PacketType -> PacketType
Enum, PacketType -> PacketType -> Bool
(PacketType -> PacketType -> Bool)
-> (PacketType -> PacketType -> Bool) -> Eq PacketType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PacketType -> PacketType -> Bool
$c/= :: PacketType -> PacketType -> Bool
== :: PacketType -> PacketType -> Bool
$c== :: PacketType -> PacketType -> Bool
Eq, ReadPrec [PacketType]
ReadPrec PacketType
Int -> ReadS PacketType
ReadS [PacketType]
(Int -> ReadS PacketType)
-> ReadS [PacketType]
-> ReadPrec PacketType
-> ReadPrec [PacketType]
-> Read PacketType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PacketType]
$creadListPrec :: ReadPrec [PacketType]
readPrec :: ReadPrec PacketType
$creadPrec :: ReadPrec PacketType
readList :: ReadS [PacketType]
$creadList :: ReadS [PacketType]
readsPrec :: Int -> ReadS PacketType
$creadsPrec :: Int -> ReadS PacketType
Read, Int -> PacketType -> ShowS
[PacketType] -> ShowS
PacketType -> String
(Int -> PacketType -> ShowS)
-> (PacketType -> String)
-> ([PacketType] -> ShowS)
-> Show PacketType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PacketType] -> ShowS
$cshowList :: [PacketType] -> ShowS
show :: PacketType -> String
$cshow :: PacketType -> String
showsPrec :: Int -> PacketType -> ShowS
$cshowsPrec :: Int -> PacketType -> ShowS
Show)


--------------------------------------------------------------------------------
packetTypeToIndex :: Num i => PacketType -> i
packetTypeToIndex :: PacketType -> i
packetTypeToIndex PacketType
t =
  case PacketType
t of
    PacketType
Open -> i
0
    PacketType
Close -> i
1
    PacketType
Ping -> i
2
    PacketType
Pong -> i
3
    PacketType
Message -> i
4
    PacketType
Upgrade -> i
5
    PacketType
Noop -> i
6
{-# INLINE packetTypeToIndex #-}


--------------------------------------------------------------------------------
packetTypeFromIndex :: (Eq i, MonadPlus m, Num i) => i -> m PacketType
packetTypeFromIndex :: i -> m PacketType
packetTypeFromIndex i
i =
  case i
i of
    i
0 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Open
    i
1 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Close
    i
2 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Ping
    i
3 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Pong
    i
4 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Message
    i
5 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Upgrade
    i
6 -> PacketType -> m PacketType
forall (m :: * -> *) a. Monad m => a -> m a
return PacketType
Noop
    i
_ -> m PacketType
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE packetTypeFromIndex #-}


--------------------------------------------------------------------------------
-- | A single Engine.IO packet.
data Packet = Packet !PacketType !PacketContent
  deriving (Packet -> Packet -> Bool
(Packet -> Packet -> Bool)
-> (Packet -> Packet -> Bool) -> Eq Packet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Packet -> Packet -> Bool
$c/= :: Packet -> Packet -> Bool
== :: Packet -> Packet -> Bool
$c== :: Packet -> Packet -> Bool
Eq, Int -> Packet -> ShowS
[Packet] -> ShowS
Packet -> String
(Int -> Packet -> ShowS)
-> (Packet -> String) -> ([Packet] -> ShowS) -> Show Packet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Packet] -> ShowS
$cshowList :: [Packet] -> ShowS
show :: Packet -> String
$cshow :: Packet -> String
showsPrec :: Int -> Packet -> ShowS
$cshowsPrec :: Int -> Packet -> ShowS
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 (PacketContent -> PacketContent -> Bool
(PacketContent -> PacketContent -> Bool)
-> (PacketContent -> PacketContent -> Bool) -> Eq PacketContent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PacketContent -> PacketContent -> Bool
$c/= :: PacketContent -> PacketContent -> Bool
== :: PacketContent -> PacketContent -> Bool
$c== :: PacketContent -> PacketContent -> Bool
Eq, Int -> PacketContent -> ShowS
[PacketContent] -> ShowS
PacketContent -> String
(Int -> PacketContent -> ShowS)
-> (PacketContent -> String)
-> ([PacketContent] -> ShowS)
-> Show PacketContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PacketContent] -> ShowS
$cshowList :: [PacketContent] -> ShowS
show :: PacketContent -> String
$cshow :: PacketContent -> String
showsPrec :: Int -> PacketContent -> ShowS
$cshowsPrec :: Int -> PacketContent -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Parse bytes as an 'Packet' assuming the packet contents extends to the
-- end-of-input.
parsePacket :: Attoparsec.Parser Packet
parsePacket :: Parser Packet
parsePacket = Parser ByteString -> Parser Packet
parsePacket' Parser ByteString
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' :: Parser ByteString -> Parser Packet
parsePacket' Parser ByteString
body = Parser Packet
parseBase64 Parser Packet -> Parser Packet -> Parser Packet
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Packet
parseBinary Parser Packet -> Parser Packet -> Parser Packet
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Packet
parseText

  where
  parseBase64 :: Parser Packet
parseBase64 = do
    Char
_ <- Char -> Parser Char
AttoparsecC8.char Char
'b'
    PacketType -> PacketContent -> Packet
Packet (PacketType -> PacketContent -> Packet)
-> Parser ByteString PacketType
-> Parser ByteString (PacketContent -> Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString PacketType
c8PacketType
           Parser ByteString (PacketContent -> Packet)
-> Parser ByteString PacketContent -> Parser Packet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Parser ByteString PacketContent)
-> (ByteString -> Parser ByteString PacketContent)
-> Either String ByteString
-> Parser ByteString PacketContent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser ByteString PacketContent
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (PacketContent -> Parser ByteString PacketContent
forall (m :: * -> *) a. Monad m => a -> m a
return (PacketContent -> Parser ByteString PacketContent)
-> (ByteString -> PacketContent)
-> ByteString
-> Parser ByteString PacketContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PacketContent
BinaryPacket) (Either String ByteString -> Parser ByteString PacketContent)
-> (ByteString -> Either String ByteString)
-> ByteString
-> Parser ByteString PacketContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base64.decode (ByteString -> Parser ByteString PacketContent)
-> Parser ByteString -> Parser ByteString PacketContent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser ByteString
body)

  parseBinary :: Parser Packet
parseBinary = do
    PacketType -> PacketContent -> Packet
Packet (PacketType -> PacketContent -> Packet)
-> Parser ByteString PacketType
-> Parser ByteString (PacketContent -> Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Parser ByteString PacketType
forall i (m :: * -> *).
(Eq i, MonadPlus m, Num i) =>
i -> m PacketType
packetTypeFromIndex (Word8 -> Parser ByteString PacketType)
-> Parser ByteString Word8 -> Parser ByteString PacketType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Word8 -> Bool) -> Parser ByteString Word8
Attoparsec.satisfy ((Word8, Word8) -> Word8 -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Word8
0, Word8
6)))
           Parser ByteString (PacketContent -> Packet)
-> Parser ByteString PacketContent -> Parser Packet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> PacketContent
BinaryPacket (ByteString -> PacketContent)
-> Parser ByteString -> Parser ByteString PacketContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
body)

  parseText :: Parser Packet
parseText = do
    PacketType -> PacketContent -> Packet
Packet (PacketType -> PacketContent -> Packet)
-> Parser ByteString PacketType
-> Parser ByteString (PacketContent -> Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString PacketType
c8PacketType
           Parser ByteString (PacketContent -> Packet)
-> Parser ByteString PacketContent -> Parser Packet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> PacketContent
TextPacket (Text -> PacketContent)
-> (ByteString -> Text) -> ByteString -> PacketContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> PacketContent)
-> Parser ByteString -> Parser ByteString PacketContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
body)

  c8PacketType :: Parser ByteString PacketType
c8PacketType =
    Int -> Parser ByteString PacketType
forall i (m :: * -> *).
(Eq i, MonadPlus m, Num i) =>
i -> m PacketType
packetTypeFromIndex (Int -> Parser ByteString PacketType)
-> (Char -> Int) -> Char -> Parser ByteString PacketType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt  (Char -> Parser ByteString PacketType)
-> Parser Char -> Parser ByteString PacketType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Char
AttoparsecC8.satisfy ((Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'0', Char
'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 :: Bool -> Packet -> Builder
encodePacket Bool
True (Packet PacketType
t (BinaryPacket ByteString
bytes)) =
  Word8 -> Builder
Builder.word8 (PacketType -> Word8
forall i. Num i => PacketType -> i
packetTypeToIndex PacketType
t) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
Builder.byteString ByteString
bytes

encodePacket Bool
False (Packet PacketType
t (BinaryPacket ByteString
bytes)) =
  Char -> Builder
Builder.char8 Char
'b' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Char -> Builder
Builder.char8 (Int -> Char
intToDigit (PacketType -> Int
forall i. Num i => PacketType -> i
packetTypeToIndex PacketType
t)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      ByteString -> Builder
Builder.byteString (ByteString -> ByteString
Base64.encode ByteString
bytes)

encodePacket Bool
_ (Packet PacketType
t (TextPacket Text
bytes)) =
  Char -> Builder
Builder.char8 (Int -> Char
intToDigit (PacketType -> Int
forall i. Num i => PacketType -> i
packetTypeToIndex PacketType
t)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
Builder.byteString (Text -> ByteString
Text.encodeUtf8 Text
bytes)


--------------------------------------------------------------------------------
-- | A 'Payload' is a stream of 0-or-more 'Packet's.
newtype Payload = Payload (V.Vector Packet)
  deriving (Payload -> Payload -> Bool
(Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool) -> Eq Payload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c== :: Payload -> Payload -> Bool
Eq, Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> String
(Int -> Payload -> ShowS)
-> (Payload -> String) -> ([Payload] -> ShowS) -> Show Payload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> String
$cshow :: Payload -> String
showsPrec :: Int -> Payload -> ShowS
$cshowsPrec :: Int -> Payload -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Parse a stream of bytes into a 'Payload'.
parsePayload :: Attoparsec.Parser Payload
parsePayload :: Parser Payload
parsePayload = Vector Packet -> Payload
Payload (Vector Packet -> Payload)
-> Parser ByteString (Vector Packet) -> Parser Payload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString (Vector Packet)
goXHR2 Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Vector Packet)
goXHR)
  where
  goXHR :: Parser ByteString (Vector Packet)
goXHR = do
    Int
len <- Parser Int
forall a. Integral a => Parser a
AttoparsecC8.decimal Parser Int -> Parser Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
AttoparsecC8.char Char
':'
    Packet
packet <- Parser ByteString -> Parser Packet
parsePacket' (Int -> Parser ByteString
Attoparsec.take (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) -- the type consumes 1 byte
    (Packet -> Vector Packet
forall a. a -> Vector a
V.singleton Packet
packet Vector Packet
-> Parser ByteString () -> Parser ByteString (Vector Packet)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Packet -> Vector Packet -> Vector Packet
forall a. a -> Vector a -> Vector a
V.cons Packet
packet (Vector Packet -> Vector Packet)
-> Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Vector Packet)
goXHR)

  goXHR2 :: Parser ByteString (Vector Packet)
goXHR2 = do
    Word8
_ <- (Word8 -> Bool) -> Parser ByteString Word8
Attoparsec.satisfy (Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8
0, Word8
1])
    Int
len <- [Word8] -> Parser Int
forall (m :: * -> *) a b.
(Monad m, Alternative m, Integral a, Num b) =>
[a] -> m b
parseLength ([Word8] -> Parser Int) -> Parser ByteString [Word8] -> Parser Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Attoparsec.many1 ((Word8 -> Bool) -> Parser ByteString Word8
Attoparsec.satisfy ((Word8, Word8) -> Word8 -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Word8
0, Word8
9)))
    Word8
_ <- Word8 -> Parser ByteString Word8
Attoparsec.word8 Word8
forall a. Bounded a => a
maxBound

    Packet
packet <- Parser ByteString -> Parser Packet
parsePacket' (Int -> Parser ByteString
Attoparsec.take (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) -- the type consumes 1 byte
    (Packet -> Vector Packet
forall a. a -> Vector a
V.singleton Packet
packet Vector Packet
-> Parser ByteString () -> Parser ByteString (Vector Packet)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Packet -> Vector Packet -> Vector Packet
forall a. a -> Vector a -> Vector a
V.cons Packet
packet (Vector Packet -> Vector Packet)
-> Parser ByteString (Vector Packet)
-> Parser ByteString (Vector Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Vector Packet)
goXHR2)

  parseLength :: [a] -> m b
parseLength [a]
bytes = do
    Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
319)
    b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ (b -> b -> b) -> b -> [b] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\b
n b
x -> b
n b -> b -> b
forall a. Num a => a -> a -> a
* b
10 b -> b -> b
forall a. Num a => a -> a -> a
+ b
x) b
0 ([b] -> b) -> [b] -> b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral [a]
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 :: Bool -> Payload -> Builder
encodePayload Bool
supportsBinary (Payload Vector Packet
packets) =
  let encodeOne :: Packet -> Builder
encodeOne Packet
packet =
        let bytes :: Builder
bytes = Bool -> Packet -> Builder
encodePacket Bool
supportsBinary Packet
packet
        in [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Word8 -> Builder
Builder.word8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ if Packet -> Bool
isBinaryPacket Packet
packet then Word8
1 else Word8
0
                   , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Char -> Builder) -> String -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Builder
Builder.word8 (Word8 -> Builder) -> (Char -> Word8) -> Char -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Word8
forall a. Read a => String -> a
read (String -> Word8) -> (Char -> String) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (String -> [Builder]) -> String -> [Builder]
forall a b. (a -> b) -> a -> b
$
                       Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
LBS.length (Builder -> ByteString
Builder.toLazyByteString Builder
bytes))
                   , Word8 -> Builder
Builder.word8 Word8
forall a. Bounded a => a
maxBound
                   , Builder
bytes
                   ]

  in (Builder -> Packet -> Builder)
-> Builder -> Vector Packet -> Builder
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl' (\Builder
bytes Packet
p -> Builder
bytes Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Packet -> Builder
encodeOne Packet
p) Builder
forall a. Monoid a => a
mempty Vector Packet
packets

  where
  isBinaryPacket :: Packet -> Bool
isBinaryPacket (Packet PacketType
_ (BinaryPacket ByteString
_)) = Bool
True
  isBinaryPacket Packet
_ = Bool
False


--------------------------------------------------------------------------------
-- | The possible types of transports Engine.IO supports.
data TransportType
  = Polling
    -- ^ XHR long polling.
  | Websocket
    -- ^ HTML 5 websockets.
  deriving (TransportType -> TransportType -> Bool
(TransportType -> TransportType -> Bool)
-> (TransportType -> TransportType -> Bool) -> Eq TransportType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransportType -> TransportType -> Bool
$c/= :: TransportType -> TransportType -> Bool
== :: TransportType -> TransportType -> Bool
$c== :: TransportType -> TransportType -> Bool
Eq, Int -> TransportType -> ShowS
[TransportType] -> ShowS
TransportType -> String
(Int -> TransportType -> ShowS)
-> (TransportType -> String)
-> ([TransportType] -> ShowS)
-> Show TransportType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransportType] -> ShowS
$cshowList :: [TransportType] -> ShowS
show :: TransportType -> String
$cshow :: TransportType -> String
showsPrec :: Int -> TransportType -> ShowS
$cshowsPrec :: Int -> TransportType -> ShowS
Show)

instance Aeson.ToJSON TransportType where
  toJSON :: TransportType -> Value
toJSON TransportType
t = String -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ (String -> ShowS
forall a. a -> a -> a
`asTypeOf` TransportType -> String
forall a. Show a => a -> String
show TransportType
t) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    case TransportType
t of
      TransportType
Polling -> String
"polling"
      TransportType
Websocket -> String
"websocket"


--------------------------------------------------------------------------------
-- | Attempt to parse a 'TransportType' from its textual representation.
parseTransportType :: Text.Text -> Maybe TransportType
parseTransportType :: Text -> Maybe TransportType
parseTransportType Text
t =
  case Text
t of
    Text
"polling" -> TransportType -> Maybe TransportType
forall a. a -> Maybe a
Just TransportType
Polling
    Text
"websocket" -> TransportType -> Maybe TransportType
forall a. a -> Maybe a
Just TransportType
Websocket
    Text
_ -> Maybe TransportType
forall a. Maybe a
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
  { Transport -> TChan Packet
transIn :: STM.TChan Packet
  , Transport -> TChan Packet
transOut :: STM.TChan Packet
  , Transport -> TransportType
transType :: !TransportType
  }


--------------------------------------------------------------------------------
-- | A connected Engine.IO session.
data Socket = Socket
  { Socket -> ByteString
socketId :: !SocketId
  , Socket -> TVar Transport
socketTransport :: STM.TVar Transport
  , Socket -> TChan PacketContent
socketIncomingMessages :: STM.TChan PacketContent
  , Socket -> TChan PacketContent
socketOutgoingMessages :: STM.TChan PacketContent
  , Socket -> TChan Packet
socketRawIncomingBroadcast :: STM.TChan Packet
  }

instance Eq Socket where
  == :: Socket -> Socket -> Bool
(==) = ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ByteString -> ByteString -> Bool)
-> (Socket -> ByteString) -> Socket -> Socket -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Socket -> ByteString
socketId

instance Ord Socket where
  compare :: Socket -> Socket -> Ordering
compare = (Socket -> ByteString) -> Socket -> Socket -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Socket -> ByteString
socketId


--------------------------------------------------------------------------------
-- | Receive data from the client, blocking if the input queue is empty.
receive :: Socket -> STM.STM PacketContent
receive :: Socket -> STM PacketContent
receive Socket{ByteString
TVar Transport
TChan PacketContent
TChan Packet
socketRawIncomingBroadcast :: TChan Packet
socketOutgoingMessages :: TChan PacketContent
socketIncomingMessages :: TChan PacketContent
socketTransport :: TVar Transport
socketId :: ByteString
socketRawIncomingBroadcast :: Socket -> TChan Packet
socketOutgoingMessages :: Socket -> TChan PacketContent
socketIncomingMessages :: Socket -> TChan PacketContent
socketTransport :: Socket -> TVar Transport
socketId :: Socket -> ByteString
..} = TChan PacketContent -> STM PacketContent
forall a. TChan a -> STM a
STM.readTChan TChan PacketContent
socketIncomingMessages
{-# INLINE receive #-}


--------------------------------------------------------------------------------
-- | Send a packet to the client. This is a non-blocking write.
send :: Socket -> PacketContent -> STM.STM ()
send :: Socket -> PacketContent -> STM ()
send Socket{ByteString
TVar Transport
TChan PacketContent
TChan Packet
socketRawIncomingBroadcast :: TChan Packet
socketOutgoingMessages :: TChan PacketContent
socketIncomingMessages :: TChan PacketContent
socketTransport :: TVar Transport
socketId :: ByteString
socketRawIncomingBroadcast :: Socket -> TChan Packet
socketOutgoingMessages :: Socket -> TChan PacketContent
socketIncomingMessages :: Socket -> TChan PacketContent
socketTransport :: Socket -> TVar Transport
socketId :: Socket -> ByteString
..} = TChan PacketContent -> PacketContent -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan TChan PacketContent
socketOutgoingMessages
{-# INLINE send #-}


--------------------------------------------------------------------------------
-- | A dictionary of functions that Engine.IO needs in order to provide
-- communication channels.
data ServerAPI m = ServerAPI
  { ServerAPI m -> m (HashMap ByteString [ByteString])
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.

  , ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
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.

  , ServerAPI m -> forall a. Parser a -> m (Either String a)
srvParseRequestBody :: forall a. Attoparsec.Parser a -> m (Either String a)
    -- ^ Run a 'Attoparsec.Parser' against the request body.

  , ServerAPI m -> m ByteString
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@).

  , ServerAPI m -> ServerApp -> m ()
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
  { EngineIO -> TVar (HashMap ByteString Socket)
eioOpenSessions :: STM.TVar (HashMap.HashMap SocketId Socket)
  , EngineIO -> MVar GenIO
eioRng :: MVar Random.GenIO
  }


--------------------------------------------------------------------------------
-- | 'initialize' initializes a new Engine.IO server. You can later serve this
-- session by using 'handler'.
initialize :: IO EngineIO
initialize :: IO EngineIO
initialize =
  TVar (HashMap ByteString Socket)
-> MVar (Gen RealWorld) -> EngineIO
TVar (HashMap ByteString Socket) -> MVar GenIO -> EngineIO
EngineIO
    (TVar (HashMap ByteString Socket)
 -> MVar (Gen RealWorld) -> EngineIO)
-> IO (TVar (HashMap ByteString Socket))
-> IO (MVar (Gen RealWorld) -> EngineIO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap ByteString Socket -> IO (TVar (HashMap ByteString Socket))
forall a. a -> IO (TVar a)
STM.newTVarIO HashMap ByteString Socket
forall a. Monoid a => a
mempty
    IO (MVar (Gen RealWorld) -> EngineIO)
-> IO (MVar (Gen RealWorld)) -> IO EngineIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (IO (Gen RealWorld)
IO GenIO
Random.createSystemRandom IO (Gen RealWorld)
-> (Gen RealWorld -> IO (MVar (Gen RealWorld)))
-> IO (MVar (Gen RealWorld))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Gen RealWorld -> IO (MVar (Gen RealWorld))
forall a. a -> IO (MVar a)
newMVar)


--------------------------------------------------------------------------------
-- | Retrieve a list of /all/ currently open Engine.IO sessions.
getOpenSockets :: EngineIO -> STM.STM (HashMap.HashMap SocketId Socket)
getOpenSockets :: EngineIO -> STM (HashMap ByteString Socket)
getOpenSockets = TVar (HashMap ByteString Socket) -> STM (HashMap ByteString Socket)
forall a. TVar a -> STM a
STM.readTVar (TVar (HashMap ByteString Socket)
 -> STM (HashMap ByteString Socket))
-> (EngineIO -> TVar (HashMap ByteString Socket))
-> EngineIO
-> STM (HashMap ByteString Socket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EngineIO -> TVar (HashMap ByteString Socket)
eioOpenSessions


--------------------------------------------------------------------------------
data EngineIOError = BadRequest | TransportUnknown | SessionIdUnknown
  deriving (EngineIOError
EngineIOError -> EngineIOError -> Bounded EngineIOError
forall a. a -> a -> Bounded a
maxBound :: EngineIOError
$cmaxBound :: EngineIOError
minBound :: EngineIOError
$cminBound :: EngineIOError
Bounded, Int -> EngineIOError
EngineIOError -> Int
EngineIOError -> [EngineIOError]
EngineIOError -> EngineIOError
EngineIOError -> EngineIOError -> [EngineIOError]
EngineIOError -> EngineIOError -> EngineIOError -> [EngineIOError]
(EngineIOError -> EngineIOError)
-> (EngineIOError -> EngineIOError)
-> (Int -> EngineIOError)
-> (EngineIOError -> Int)
-> (EngineIOError -> [EngineIOError])
-> (EngineIOError -> EngineIOError -> [EngineIOError])
-> (EngineIOError -> EngineIOError -> [EngineIOError])
-> (EngineIOError
    -> EngineIOError -> EngineIOError -> [EngineIOError])
-> Enum EngineIOError
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EngineIOError -> EngineIOError -> EngineIOError -> [EngineIOError]
$cenumFromThenTo :: EngineIOError -> EngineIOError -> EngineIOError -> [EngineIOError]
enumFromTo :: EngineIOError -> EngineIOError -> [EngineIOError]
$cenumFromTo :: EngineIOError -> EngineIOError -> [EngineIOError]
enumFromThen :: EngineIOError -> EngineIOError -> [EngineIOError]
$cenumFromThen :: EngineIOError -> EngineIOError -> [EngineIOError]
enumFrom :: EngineIOError -> [EngineIOError]
$cenumFrom :: EngineIOError -> [EngineIOError]
fromEnum :: EngineIOError -> Int
$cfromEnum :: EngineIOError -> Int
toEnum :: Int -> EngineIOError
$ctoEnum :: Int -> EngineIOError
pred :: EngineIOError -> EngineIOError
$cpred :: EngineIOError -> EngineIOError
succ :: EngineIOError -> EngineIOError
$csucc :: EngineIOError -> EngineIOError
Enum, EngineIOError -> EngineIOError -> Bool
(EngineIOError -> EngineIOError -> Bool)
-> (EngineIOError -> EngineIOError -> Bool) -> Eq EngineIOError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EngineIOError -> EngineIOError -> Bool
$c/= :: EngineIOError -> EngineIOError -> Bool
== :: EngineIOError -> EngineIOError -> Bool
$c== :: EngineIOError -> EngineIOError -> Bool
Eq, Int -> EngineIOError -> ShowS
[EngineIOError] -> ShowS
EngineIOError -> String
(Int -> EngineIOError -> ShowS)
-> (EngineIOError -> String)
-> ([EngineIOError] -> ShowS)
-> Show EngineIOError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EngineIOError] -> ShowS
$cshowList :: [EngineIOError] -> ShowS
show :: EngineIOError -> String
$cshow :: EngineIOError -> String
showsPrec :: Int -> EngineIOError -> ShowS
$cshowsPrec :: Int -> EngineIOError -> ShowS
Show)


--------------------------------------------------------------------------------
-- | The application to run for the duration of a connected socket.
data SocketApp = SocketApp
  { SocketApp -> IO ()
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'.

  , SocketApp -> IO ()
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 :: EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> m ()
handler EngineIO
eio Socket -> m SocketApp
socketHandler api :: ServerAPI m
api@ServerAPI{m ByteString
m (HashMap ByteString [ByteString])
Int -> ByteString -> Builder -> forall a. m a
ServerApp -> m ()
forall a. Parser a -> m (Either String a)
srvRunWebSocket :: ServerApp -> m ()
srvGetRequestMethod :: m ByteString
srvParseRequestBody :: forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: m (HashMap ByteString [ByteString])
srvRunWebSocket :: forall (m :: * -> *). ServerAPI m -> ServerApp -> m ()
srvGetRequestMethod :: forall (m :: * -> *). ServerAPI m -> m ByteString
srvParseRequestBody :: forall (m :: * -> *).
ServerAPI m -> forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: forall (m :: * -> *).
ServerAPI m -> m (HashMap ByteString [ByteString])
..} = do
  HashMap ByteString [ByteString]
queryParams <- m (HashMap ByteString [ByteString])
srvGetQueryParams
  (EngineIOError -> m ())
-> (() -> m ()) -> ExceptT EngineIOError m () -> m ()
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> ExceptT a m b -> m c
exceptT (ServerAPI m -> EngineIOError -> m ()
forall (m :: * -> *) a.
Monad m =>
ServerAPI m -> EngineIOError -> m a
serveError ServerAPI m
api) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptT EngineIOError m () -> m ())
-> ExceptT EngineIOError m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    TransportType
reqTransport <- ExceptT EngineIOError m TransportType
-> (TransportType -> ExceptT EngineIOError m TransportType)
-> Maybe TransportType
-> ExceptT EngineIOError m TransportType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EngineIOError -> ExceptT EngineIOError m TransportType
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE EngineIOError
TransportUnknown) TransportType -> ExceptT EngineIOError m TransportType
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TransportType -> ExceptT EngineIOError m TransportType)
-> Maybe TransportType -> ExceptT EngineIOError m TransportType
forall a b. (a -> b) -> a -> b
$ do
      [ByteString
t] <- ByteString -> HashMap ByteString [ByteString] -> Maybe [ByteString]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
"transport" HashMap ByteString [ByteString]
queryParams
      Text -> Maybe TransportType
parseTransportType (ByteString -> Text
Text.decodeUtf8 ByteString
t)

    Maybe Socket
socket <-
      Maybe [ByteString]
-> ([ByteString] -> ExceptT EngineIOError m Socket)
-> ExceptT EngineIOError m (Maybe Socket)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (ByteString -> HashMap ByteString [ByteString] -> Maybe [ByteString]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
"sid" HashMap ByteString [ByteString]
queryParams) (([ByteString] -> ExceptT EngineIOError m Socket)
 -> ExceptT EngineIOError m (Maybe Socket))
-> ([ByteString] -> ExceptT EngineIOError m Socket)
-> ExceptT EngineIOError m (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ \[ByteString]
sids -> do
        ByteString
sid <- case [ByteString]
sids of
                 [ByteString
sid] -> ByteString -> ExceptT EngineIOError m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
sid
                 [ByteString]
_ -> EngineIOError -> ExceptT EngineIOError m ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE EngineIOError
SessionIdUnknown

        Maybe Socket
mSocket <- IO (Maybe Socket) -> ExceptT EngineIOError m (Maybe Socket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
STM.atomically (ByteString -> HashMap ByteString Socket -> Maybe Socket
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
sid (HashMap ByteString Socket -> Maybe Socket)
-> STM (HashMap ByteString Socket) -> STM (Maybe Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EngineIO -> STM (HashMap ByteString Socket)
getOpenSockets EngineIO
eio))
        case Maybe Socket
mSocket of
          Maybe Socket
Nothing -> EngineIOError -> ExceptT EngineIOError m Socket
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE EngineIOError
SessionIdUnknown
          Just Socket
s -> Socket -> ExceptT EngineIOError m Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
s

    Bool
supportsBinary <-
      case ByteString -> HashMap ByteString [ByteString] -> Maybe [ByteString]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
"b64" HashMap ByteString [ByteString]
queryParams of
        Just [ByteString
"1"] -> Bool -> ExceptT EngineIOError m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just [ByteString
"0"] -> Bool -> ExceptT EngineIOError m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe [ByteString]
Nothing    -> Bool -> ExceptT EngineIOError m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe [ByteString]
_          -> EngineIOError -> ExceptT EngineIOError m Bool
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE EngineIOError
BadRequest

    case Maybe Socket
socket of
      Just Socket
s -> do
        Transport
transport <- IO Transport -> ExceptT EngineIOError m Transport
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Transport -> ExceptT EngineIOError m Transport)
-> IO Transport -> ExceptT EngineIOError m Transport
forall a b. (a -> b) -> a -> b
$ STM Transport -> IO Transport
forall a. STM a -> IO a
STM.atomically (STM Transport -> IO Transport) -> STM Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$ TVar Transport -> STM Transport
forall a. TVar a -> STM a
STM.readTVar (Socket -> TVar Transport
socketTransport Socket
s)
        case Transport -> TransportType
transType Transport
transport of
          TransportType
Polling
            | TransportType
reqTransport TransportType -> TransportType -> Bool
forall a. Eq a => a -> a -> Bool
== TransportType
Polling -> m () -> ExceptT EngineIOError m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerAPI m -> Transport -> Bool -> m ()
forall (m :: * -> *).
MonadIO m =>
ServerAPI m -> Transport -> Bool -> m ()
handlePoll ServerAPI m
api Transport
transport Bool
supportsBinary)
            | TransportType
reqTransport TransportType -> TransportType -> Bool
forall a. Eq a => a -> a -> Bool
== TransportType
Websocket -> m () -> ExceptT EngineIOError m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerAPI m -> Socket -> m ()
forall (m :: * -> *). MonadIO m => ServerAPI m -> Socket -> m ()
upgrade ServerAPI m
api Socket
s)

          TransportType
_ -> EngineIOError -> ExceptT EngineIOError m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE EngineIOError
BadRequest

      Maybe Socket
Nothing ->
        m () -> ExceptT EngineIOError m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> Bool -> m ()
forall (m :: * -> *).
MonadIO m =>
EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> Bool -> m ()
freshSession EngineIO
eio Socket -> m SocketApp
socketHandler ServerAPI m
api Bool
supportsBinary)


--------------------------------------------------------------------------------
freshSession
  :: MonadIO m
  => EngineIO
  -> (Socket -> m SocketApp)
  -> ServerAPI m
  -> Bool
  -> m ()
freshSession :: EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> Bool -> m ()
freshSession EngineIO
eio Socket -> m SocketApp
socketHandler ServerAPI m
api Bool
supportsBinary = do
  Socket
socket <- do
    ByteString -> Socket
mkSocket <- IO (ByteString -> Socket) -> m (ByteString -> Socket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ByteString -> Socket) -> m (ByteString -> Socket))
-> IO (ByteString -> Socket) -> m (ByteString -> Socket)
forall a b. (a -> b) -> a -> b
$ do
      TVar Transport
transport <- Transport -> IO (TVar Transport)
forall a. a -> IO (TVar a)
STM.newTVarIO (Transport -> IO (TVar Transport))
-> IO Transport -> IO (TVar Transport)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TChan Packet -> TChan Packet -> TransportType -> Transport
Transport (TChan Packet -> TChan Packet -> TransportType -> Transport)
-> IO (TChan Packet)
-> IO (TChan Packet -> TransportType -> Transport)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TChan Packet)
forall a. IO (TChan a)
STM.newTChanIO IO (TChan Packet -> TransportType -> Transport)
-> IO (TChan Packet) -> IO (TransportType -> Transport)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TChan Packet)
forall a. IO (TChan a)
STM.newTChanIO IO (TransportType -> Transport) -> IO TransportType -> IO Transport
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TransportType -> IO TransportType
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransportType
Polling)
      TChan PacketContent
incoming <- IO (TChan PacketContent)
forall a. IO (TChan a)
STM.newTChanIO
      TChan PacketContent
outgoing <- IO (TChan PacketContent)
forall a. IO (TChan a)
STM.newTChanIO
      TChan Packet
rawInBroadcast <- IO (TChan Packet)
forall a. IO (TChan a)
STM.newBroadcastTChanIO
      (ByteString -> Socket) -> IO (ByteString -> Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (\ByteString
sId -> ByteString
-> TVar Transport
-> TChan PacketContent
-> TChan PacketContent
-> TChan Packet
-> Socket
Socket ByteString
sId TVar Transport
transport TChan PacketContent
incoming TChan PacketContent
outgoing TChan Packet
rawInBroadcast)

    let
      tryAllocation :: IterT m (Maybe Socket)
tryAllocation = IO (Maybe Socket) -> IterT m (Maybe Socket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Socket) -> IterT m (Maybe Socket))
-> IO (Maybe Socket) -> IterT m (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ do
        ByteString
sId <- EngineIO -> IO ByteString
newSocketId EngineIO
eio
        STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Socket) -> IO (Maybe Socket))
-> STM (Maybe Socket) -> IO (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ MaybeT STM Socket -> STM (Maybe Socket)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT STM Socket -> STM (Maybe Socket))
-> MaybeT STM Socket -> STM (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ do
          HashMap ByteString Socket
openSessions <- STM (HashMap ByteString Socket)
-> MaybeT STM (HashMap ByteString Socket)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TVar (HashMap ByteString Socket) -> STM (HashMap ByteString Socket)
forall a. TVar a -> STM a
STM.readTVar (EngineIO -> TVar (HashMap ByteString Socket)
eioOpenSessions EngineIO
eio))
          Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (ByteString -> HashMap ByteString Socket -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member ByteString
sId HashMap ByteString Socket
openSessions))
          let socket :: Socket
socket = ByteString -> Socket
mkSocket ByteString
sId
          STM () -> MaybeT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TVar (HashMap ByteString Socket)
-> (HashMap ByteString Socket -> HashMap ByteString Socket)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' (EngineIO -> TVar (HashMap ByteString Socket)
eioOpenSessions EngineIO
eio) (ByteString
-> Socket -> HashMap ByteString Socket -> HashMap ByteString Socket
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert ByteString
sId Socket
socket))
          Socket -> MaybeT STM Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
socket

      untilSuccess :: m (Maybe b) -> m b
untilSuccess m (Maybe b)
f = m b -> (b -> m b) -> Maybe b -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (m b -> m b
forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a -> m a
delay (m (Maybe b) -> m b
untilSuccess m (Maybe b)
f)) b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> m b) -> m (Maybe b) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe b)
f

    Maybe Socket
maybeSocket <- IterT m (Maybe Socket) -> m (Maybe Socket)
forall (m :: * -> *) a. Monad m => IterT m a -> m a
retract (Integer -> IterT m Socket -> IterT m (Maybe Socket)
forall (m :: * -> *) a.
Monad m =>
Integer -> IterT m a -> IterT m (Maybe a)
cutoff Integer
10 (IterT m (Maybe Socket) -> IterT m Socket
forall (m :: * -> *) (f :: * -> *) b.
(Monad f, MonadFree f m) =>
m (Maybe b) -> m b
untilSuccess IterT m (Maybe Socket)
tryAllocation))
    m Socket -> (Socket -> m Socket) -> Maybe Socket -> m Socket
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvTerminateWithResponse ServerAPI m
api Int
500 ByteString
"text/plain" Builder
"Session allocation failed")
          Socket -> m Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Socket
maybeSocket

  SocketApp
app <- Socket -> m SocketApp
socketHandler Socket
socket
  Async ()
userSpace <- IO (Async ()) -> m (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (SocketApp -> IO ()
saApp SocketApp
app)

  Delay
pingTimeoutDelay <- IO Delay -> m Delay
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Delay -> m Delay) -> IO Delay -> m Delay
forall a b. (a -> b) -> a -> b
$ Int -> IO Delay
STMDelay.newDelay (Int
pingTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
  Async ()
heartbeat <- IO (Async ()) -> m (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (Delay -> STM ()
STMDelay.waitDelay Delay
pingTimeoutDelay)

  Async ()
brain <- IO (Async ()) -> m (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
    Maybe Packet
mMessage <- STM (Maybe Packet) -> IO (Maybe Packet)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Packet) -> IO (Maybe Packet))
-> STM (Maybe Packet) -> IO (Maybe Packet)
forall a b. (a -> b) -> a -> b
$ do
      Transport
transport <- TVar Transport -> STM Transport
forall a. TVar a -> STM a
STM.readTVar (Socket -> TVar Transport
socketTransport Socket
socket)
      [STM (Maybe Packet)] -> STM (Maybe Packet)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ do Packet
req <- TChan Packet -> STM Packet
forall a. TChan a -> STM a
STM.readTChan (Transport -> TChan Packet
transIn Transport
transport)
             case Packet
req of
               Packet PacketType
Message PacketContent
m ->
                 TChan PacketContent -> PacketContent -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Socket -> TChan PacketContent
socketIncomingMessages Socket
socket) PacketContent
m

               Packet PacketType
Ping PacketContent
m ->
                 TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Transport -> TChan Packet
transOut Transport
transport) (PacketType -> PacketContent -> Packet
Packet PacketType
Pong PacketContent
m)

               Packet
_ ->
                 () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

             TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Socket -> TChan Packet
socketRawIncomingBroadcast Socket
socket) Packet
req
             Maybe Packet -> STM (Maybe Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Packet -> Maybe Packet
forall a. a -> Maybe a
Just Packet
req)

        , do TChan PacketContent -> STM PacketContent
forall a. TChan a -> STM a
STM.readTChan (Socket -> TChan PacketContent
socketOutgoingMessages Socket
socket)
               STM PacketContent -> (PacketContent -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Transport -> TChan Packet
transOut Transport
transport) (Packet -> STM ())
-> (PacketContent -> Packet) -> PacketContent -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacketType -> PacketContent -> Packet
Packet PacketType
Message

             Maybe Packet -> STM (Maybe Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Packet
forall a. Maybe a
Nothing
        ]

    -- If we *received* a message, then we can reset the ping timer.
    Maybe Packet -> (Packet -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Packet
mMessage (IO () -> Packet -> IO ()
forall a b. a -> b -> a
const (Delay -> Int -> IO ()
STMDelay.updateDelay Delay
pingTimeoutDelay (Int
pingTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)))

    -- If we received a close message, terminate. Otherwise, loop.
    case Maybe Packet
mMessage of
      Just (Packet PacketType
Close PacketContent
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Maybe Packet
_ -> IO ()
loop

  Async ()
_ <- IO (Async ()) -> m (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
    (Async (), Either SomeException ())
_ <- [Async ()] -> IO (Async (), Either SomeException ())
forall a. [Async a] -> IO (Async a, Either SomeException a)
Async.waitAnyCatchCancel [ Async ()
userSpace, Async ()
brain, Async ()
heartbeat ]
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TVar (HashMap ByteString Socket)
-> (HashMap ByteString Socket -> HashMap ByteString Socket)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' (EngineIO -> TVar (HashMap ByteString Socket)
eioOpenSessions EngineIO
eio) (ByteString
-> HashMap ByteString Socket -> HashMap ByteString Socket
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete (Socket -> ByteString
socketId Socket
socket)))
    SocketApp -> IO ()
saOnDisconnect SocketApp
app

  let openMessage :: OpenMessage
openMessage = OpenMessage :: ByteString -> [TransportType] -> Int -> Int -> OpenMessage
OpenMessage { omSocketId :: ByteString
omSocketId = Socket -> ByteString
socketId Socket
socket
                                , omUpgrades :: [TransportType]
omUpgrades = [ TransportType
Websocket ]
                                , omPingTimeout :: Int
omPingTimeout = Int
pingTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                                , omPingInterval :: Int
omPingInterval = Int
25000
                                }

      payload :: Payload
payload = Vector Packet -> Payload
Payload (Vector Packet -> Payload) -> Vector Packet -> Payload
forall a b. (a -> b) -> a -> b
$ Packet -> Vector Packet
forall a. a -> Vector a
V.singleton (Packet -> Vector Packet) -> Packet -> Vector Packet
forall a b. (a -> b) -> a -> b
$
                  PacketType -> PacketContent -> Packet
Packet PacketType
Open (Text -> PacketContent
TextPacket (Text -> PacketContent) -> Text -> PacketContent
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ OpenMessage -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode OpenMessage
openMessage)

  ServerAPI m -> Builder -> m ()
forall (m :: * -> *) a. Monad m => ServerAPI m -> Builder -> m a
writeBytes ServerAPI m
api (Bool -> Payload -> Builder
encodePayload Bool
supportsBinary Payload
payload)

  where

  pingTimeout :: Int
pingTimeout = Int
60

--------------------------------------------------------------------------------
upgrade :: MonadIO m => ServerAPI m -> Socket -> m ()
upgrade :: ServerAPI m -> Socket -> m ()
upgrade ServerAPI{m ByteString
m (HashMap ByteString [ByteString])
Int -> ByteString -> Builder -> forall a. m a
ServerApp -> m ()
forall a. Parser a -> m (Either String a)
srvRunWebSocket :: ServerApp -> m ()
srvGetRequestMethod :: m ByteString
srvParseRequestBody :: forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: m (HashMap ByteString [ByteString])
srvRunWebSocket :: forall (m :: * -> *). ServerAPI m -> ServerApp -> m ()
srvGetRequestMethod :: forall (m :: * -> *). ServerAPI m -> m ByteString
srvParseRequestBody :: forall (m :: * -> *).
ServerAPI m -> forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: forall (m :: * -> *).
ServerAPI m -> m (HashMap ByteString [ByteString])
..} Socket
socket = ServerApp -> m ()
srvRunWebSocket ServerApp
go

  where

  go :: ServerApp
go PendingConnection
pending = do
    Connection
conn <- PendingConnection -> IO Connection
WebSockets.acceptRequest (PendingConnection -> IO Connection)
-> PendingConnection -> IO Connection
forall a b. (a -> b) -> a -> b
$
      -- We do our ping/pong, so disable `websockets` doing this.
      PendingConnection
pending { pendingOnAccept :: Connection -> IO ()
WebSockets.pendingOnAccept = (IO () -> Connection -> IO ()
forall a b. a -> b -> a
const (IO () -> Connection -> IO ()) -> IO () -> Connection -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) }

    Maybe Transport
mWsTransport <- MaybeT IO Transport -> IO (Maybe Transport)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Transport -> IO (Maybe Transport))
-> MaybeT IO Transport -> IO (Maybe Transport)
forall a b. (a -> b) -> a -> b
$ do
      Packet PacketType
Ping (TextPacket Text
"probe") <- IO Packet -> MaybeT IO Packet
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Connection -> IO Packet
receivePacket Connection
conn)
      IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Connection -> Packet -> IO ()
sendPacket Connection
conn (PacketType -> PacketContent -> Packet
Packet PacketType
Pong (Text -> PacketContent
TextPacket Text
"probe")))

      (TChan Packet
wsIn, TChan Packet
wsOut) <- IO (TChan Packet, TChan Packet)
-> MaybeT IO (TChan Packet, TChan Packet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan Packet, TChan Packet)
 -> MaybeT IO (TChan Packet, TChan Packet))
-> IO (TChan Packet, TChan Packet)
-> MaybeT IO (TChan Packet, TChan Packet)
forall a b. (a -> b) -> a -> b
$ STM (TChan Packet, TChan Packet) -> IO (TChan Packet, TChan Packet)
forall a. STM a -> IO a
STM.atomically (STM (TChan Packet, TChan Packet)
 -> IO (TChan Packet, TChan Packet))
-> STM (TChan Packet, TChan Packet)
-> IO (TChan Packet, TChan Packet)
forall a b. (a -> b) -> a -> b
$ do
        Transport
currentTransport <- TVar Transport -> STM Transport
forall a. TVar a -> STM a
STM.readTVar (Socket -> TVar Transport
socketTransport Socket
socket)
        (TChan Packet, TChan Packet) -> STM (TChan Packet, TChan Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Transport -> TChan Packet
transIn Transport
currentTransport, Transport -> TChan Packet
transOut Transport
currentTransport)

      -- We wait 100ms to match the reference engine.io Javascript.
      -- See automattic/engine.io socket.js revision d11e17c8.
      Async ()
check <-
        IO (Async ()) -> MaybeT IO (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async
            (do Int -> IO ()
threadDelay Int
100000
                STM () -> IO ()
forall a. STM a -> IO a
STM.atomically
                  (do Transport
t <- TVar Transport -> STM Transport
forall a. TVar a -> STM a
STM.readTVar (Socket -> TVar Transport
socketTransport Socket
socket)
                      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Transport -> TransportType
transType Transport
t TransportType -> TransportType -> Bool
forall a. Eq a => a -> a -> Bool
== TransportType
Polling)
                           (TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Transport -> TChan Packet
transOut Transport
t)
                                           (PacketType -> PacketContent -> Packet
Packet PacketType
Noop (Text -> PacketContent
TextPacket Text
Text.empty))))))

      Packet PacketType
Upgrade PacketContent
body <- IO Packet -> MaybeT IO Packet
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Connection -> IO Packet
receivePacket Connection
conn)
      Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (PacketContent
body PacketContent -> PacketContent -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> PacketContent
TextPacket Text
Text.empty Bool -> Bool -> Bool
|| PacketContent
body PacketContent -> PacketContent -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> PacketContent
BinaryPacket ByteString
BS.empty)

      IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
check)

      Transport -> MaybeT IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return (TChan Packet -> TChan Packet -> TransportType -> Transport
Transport TChan Packet
wsIn TChan Packet
wsOut TransportType
Websocket)

    Maybe Transport -> (Transport -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Transport
mWsTransport ((Transport -> IO ()) -> IO ()) -> (Transport -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \wsTransport :: Transport
wsTransport@Transport { transIn :: Transport -> TChan Packet
transIn = TChan Packet
wsIn, transOut :: Transport -> TChan Packet
transOut = TChan Packet
wsOut } -> do
      -- The client has completed the upgrade, so we can swap out the current
      -- transport with a WebSocket transport.
      STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TVar Transport -> Transport -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (Socket -> TVar Transport
socketTransport Socket
socket) Transport
wsTransport)

      Async Any
reader <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
Async.async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
        Packet
p <- STM Packet -> IO Packet
forall a. STM a -> IO a
STM.atomically (TChan Packet -> STM Packet
forall a. TChan a -> STM a
STM.readTChan TChan Packet
wsOut)
        Connection -> Packet -> IO ()
sendPacket Connection
conn Packet
p

      (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
        Either SomeException ()
e <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (Connection -> IO Packet
receivePacket Connection
conn IO Packet -> (Packet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> (Packet -> STM ()) -> Packet -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan TChan Packet
wsIn)
        case Either SomeException ()
e of
          Left (SomeException e
_) ->
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

          Right ()
_ -> IO ()
loop

      Async Any -> IO ()
forall a. Async a -> IO ()
Async.cancel Async Any
reader
      STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan TChan Packet
wsIn (PacketType -> PacketContent -> Packet
Packet PacketType
Close (Text -> PacketContent
TextPacket Text
Text.empty)))

  receivePacket :: Connection -> IO Packet
receivePacket Connection
conn = do
    DataMessage
msg <- Connection -> IO DataMessage
WebSockets.receiveDataMessage Connection
conn
    case DataMessage
msg of
      WebSockets.Text ByteString
bytes Maybe Text
_ ->
        case Parser Packet -> ByteString -> Either String Packet
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly Parser Packet
parsePacket (ByteString -> ByteString
LBS.toStrict ByteString
bytes)  of
          Left String
ex -> do
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Malformed packet received: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
ex String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
            Connection -> IO Packet
receivePacket Connection
conn

          Right Packet
p -> Packet -> IO Packet
forall (m :: * -> *) a. Monad m => a -> m a
return Packet
p

      DataMessage
other -> do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown WebSocket message: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DataMessage -> String
forall a. Show a => a -> String
show DataMessage
other
        Connection -> IO Packet
receivePacket Connection
conn

  sendPacket :: Connection -> Packet -> IO ()
sendPacket Connection
conn (Packet PacketType
t (TextPacket Text
text)) =
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
        String -> Text
Text.pack (Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> String) -> Char -> String
forall a b. (a -> b) -> a -> b
$ Int -> Char
intToDigit (PacketType -> Int
forall i. Num i => PacketType -> i
packetTypeToIndex PacketType
t)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text

  sendPacket Connection
conn p :: Packet
p@(Packet PacketType
_ (BinaryPacket ByteString
_)) = do
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WebSockets.sendBinaryData Connection
conn (Builder -> ByteString
Builder.toLazyByteString (Bool -> Packet -> Builder
encodePacket Bool
True Packet
p))


--------------------------------------------------------------------------------
handlePoll :: MonadIO m => ServerAPI m -> Transport -> Bool -> m ()
handlePoll :: ServerAPI m -> Transport -> Bool -> m ()
handlePoll api :: ServerAPI m
api@ServerAPI{m ByteString
m (HashMap ByteString [ByteString])
Int -> ByteString -> Builder -> forall a. m a
ServerApp -> m ()
forall a. Parser a -> m (Either String a)
srvRunWebSocket :: ServerApp -> m ()
srvGetRequestMethod :: m ByteString
srvParseRequestBody :: forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: m (HashMap ByteString [ByteString])
srvRunWebSocket :: forall (m :: * -> *). ServerAPI m -> ServerApp -> m ()
srvGetRequestMethod :: forall (m :: * -> *). ServerAPI m -> m ByteString
srvParseRequestBody :: forall (m :: * -> *).
ServerAPI m -> forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: forall (m :: * -> *).
ServerAPI m -> m (HashMap ByteString [ByteString])
..} Transport
transport Bool
supportsBinary = do
  ByteString
requestMethod <- m ByteString
srvGetRequestMethod
  case ByteString
requestMethod of
    ByteString
m | ByteString
m ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GET" -> m ()
forall a. m a
poll
    ByteString
m | ByteString
m ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"POST" -> m ()
post
    ByteString
_ -> ServerAPI m -> EngineIOError -> m ()
forall (m :: * -> *) a.
Monad m =>
ServerAPI m -> EngineIOError -> m a
serveError ServerAPI m
api EngineIOError
BadRequest

  where

  poll :: m b
poll = do
    TVar Bool
readTimeout <- IO (TVar Bool) -> m (TVar Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> m (TVar Bool))
-> IO (TVar Bool) -> m (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Bool)
STM.registerDelay (Int
45 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)

    let out :: TChan Packet
out = Transport -> TChan Packet
transOut Transport
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`.
    [Packet]
packets <- IO [Packet] -> m [Packet]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Packet] -> m [Packet]) -> IO [Packet] -> m [Packet]
forall a b. (a -> b) -> a -> b
$ do
      Maybe Packet
p <- STM (Maybe Packet) -> IO (Maybe Packet)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Packet) -> IO (Maybe Packet))
-> STM (Maybe Packet) -> IO (Maybe Packet)
forall a b. (a -> b) -> a -> b
$ do
        let dequeueHead :: STM (Maybe Packet)
dequeueHead = Packet -> Maybe Packet
forall a. a -> Maybe a
Just (Packet -> Maybe Packet) -> STM Packet -> STM (Maybe Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan Packet -> STM Packet
forall a. TChan a -> STM a
STM.readTChan TChan Packet
out
            timeout :: STM (Maybe a)
timeout = Maybe a
forall a. Maybe a
Nothing Maybe a -> STM () -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (TVar Bool -> STM Bool
forall a. TVar a -> STM a
STM.readTVar TVar Bool
readTimeout STM Bool -> (Bool -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
STM.check)

        STM (Maybe Packet)
dequeueHead STM (Maybe Packet) -> STM (Maybe Packet) -> STM (Maybe Packet)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> STM (Maybe Packet)
forall a. STM (Maybe a)
timeout

      case Maybe Packet
p of
        Just Packet
p' ->
          (Packet
p' Packet -> [Packet] -> [Packet]
forall a. a -> [a] -> [a]
:) ([Packet] -> [Packet]) -> IO [Packet] -> IO [Packet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Packet) -> IO [Packet]
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
unfoldM (STM (Maybe Packet) -> IO (Maybe Packet)
forall a. STM a -> IO a
STM.atomically (TChan Packet -> STM (Maybe Packet)
forall a. TChan a -> STM (Maybe a)
STM.tryReadTChan (Transport -> TChan Packet
transOut Transport
transport)))

        Maybe Packet
Nothing ->
          [Packet] -> IO [Packet]
forall (m :: * -> *) a. Monad m => a -> m a
return [ PacketType -> PacketContent -> Packet
Packet PacketType
Ping (ByteString -> PacketContent
BinaryPacket ByteString
forall a. Monoid a => a
mempty) ]

    ServerAPI m -> Builder -> m b
forall (m :: * -> *) a. Monad m => ServerAPI m -> Builder -> m a
writeBytes ServerAPI m
api (Bool -> Payload -> Builder
encodePayload Bool
supportsBinary (Vector Packet -> Payload
Payload ([Packet] -> Vector Packet
forall a. [a] -> Vector a
V.fromList [Packet]
packets)))

  post :: m ()
post = do
    Either String Payload
p <- Parser Payload -> m (Either String Payload)
forall a. Parser a -> m (Either String a)
srvParseRequestBody Parser Payload
parsePayload
    case Either String Payload
p of
      Left String
ex -> do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Parse failure in Network.EngineIO.handlePoll: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
ex
        Int -> ByteString -> Builder -> forall a. m a
srvTerminateWithResponse Int
400 ByteString
"text/plain" Builder
"Empty request body"

      Right (Payload Vector Packet
packets) ->
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically ((Packet -> STM ()) -> Vector Packet -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (TChan Packet -> Packet -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (Transport -> TChan Packet
transIn Transport
transport)) Vector Packet
packets)


--------------------------------------------------------------------------------
writeBytes :: Monad m => ServerAPI m -> Builder.Builder -> m a
writeBytes :: ServerAPI m -> Builder -> m a
writeBytes ServerAPI {m ByteString
m (HashMap ByteString [ByteString])
Int -> ByteString -> Builder -> forall a. m a
ServerApp -> m ()
forall a. Parser a -> m (Either String a)
srvRunWebSocket :: ServerApp -> m ()
srvGetRequestMethod :: m ByteString
srvParseRequestBody :: forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: m (HashMap ByteString [ByteString])
srvRunWebSocket :: forall (m :: * -> *). ServerAPI m -> ServerApp -> m ()
srvGetRequestMethod :: forall (m :: * -> *). ServerAPI m -> m ByteString
srvParseRequestBody :: forall (m :: * -> *).
ServerAPI m -> forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: forall (m :: * -> *).
ServerAPI m -> m (HashMap ByteString [ByteString])
..} Builder
builder = do
  Int -> ByteString -> Builder -> forall a. m a
srvTerminateWithResponse Int
200 ByteString
"application/octet-stream" Builder
builder
{-# INLINE writeBytes #-}


--------------------------------------------------------------------------------
newSocketId :: EngineIO -> IO SocketId
newSocketId :: EngineIO -> IO ByteString
newSocketId EngineIO
eio =
  ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> ([Word8] -> ByteString) -> [Word8] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack
    ([Word8] -> ByteString) -> IO [Word8] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Gen RealWorld) -> (Gen RealWorld -> IO [Word8]) -> IO [Word8]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EngineIO -> MVar GenIO
eioRng EngineIO
eio) (Int -> IO Word8 -> IO [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
15 (IO Word8 -> IO [Word8])
-> (Gen RealWorld -> IO Word8) -> Gen RealWorld -> IO [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, Word8) -> GenIO -> IO Word8
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
Random.uniformR (Word8
0, Word8
63))
{-# INLINE newSocketId #-}


--------------------------------------------------------------------------------
data OpenMessage = OpenMessage
  { OpenMessage -> ByteString
omSocketId :: !SocketId
  , OpenMessage -> [TransportType]
omUpgrades :: [TransportType]
  , OpenMessage -> Int
omPingTimeout :: !Int
  , OpenMessage -> Int
omPingInterval :: !Int
  }

instance Aeson.ToJSON OpenMessage where
  toJSON :: OpenMessage -> Value
toJSON OpenMessage {Int
[TransportType]
ByteString
omPingInterval :: Int
omPingTimeout :: Int
omUpgrades :: [TransportType]
omSocketId :: ByteString
omPingInterval :: OpenMessage -> Int
omPingTimeout :: OpenMessage -> Int
omUpgrades :: OpenMessage -> [TransportType]
omSocketId :: OpenMessage -> ByteString
..} = [Pair] -> Value
Aeson.object
    [ Text
"sid" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 ByteString
omSocketId
    , Text
"upgrades" Text -> [TransportType] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [TransportType]
omUpgrades
    , Text
"pingTimeout" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
omPingTimeout
    , Text
"pingInterval" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
omPingInterval
    ]


--------------------------------------------------------------------------------
serveError :: Monad m => ServerAPI m -> EngineIOError -> m a
serveError :: ServerAPI m -> EngineIOError -> m a
serveError ServerAPI{m ByteString
m (HashMap ByteString [ByteString])
Int -> ByteString -> Builder -> forall a. m a
ServerApp -> m ()
forall a. Parser a -> m (Either String a)
srvRunWebSocket :: ServerApp -> m ()
srvGetRequestMethod :: m ByteString
srvParseRequestBody :: forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: m (HashMap ByteString [ByteString])
srvRunWebSocket :: forall (m :: * -> *). ServerAPI m -> ServerApp -> m ()
srvGetRequestMethod :: forall (m :: * -> *). ServerAPI m -> m ByteString
srvParseRequestBody :: forall (m :: * -> *).
ServerAPI m -> forall a. Parser a -> m (Either String a)
srvTerminateWithResponse :: forall (m :: * -> *).
ServerAPI m -> Int -> ByteString -> Builder -> forall a. m a
srvGetQueryParams :: forall (m :: * -> *).
ServerAPI m -> m (HashMap ByteString [ByteString])
..} EngineIOError
e = Int -> ByteString -> Builder -> forall a. m a
srvTerminateWithResponse Int
400 ByteString
"application/json" (Builder -> forall a. m a) -> Builder -> forall a. m a
forall a b. (a -> b) -> a -> b
$
  ByteString -> Builder
Builder.lazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object
    [ Text
"code" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
errorCode, Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
errorMessage ]

  where
  errorCode :: Int
  errorCode :: Int
errorCode = case EngineIOError
e of
                EngineIOError
TransportUnknown -> Int
0
                EngineIOError
SessionIdUnknown -> Int
1
                EngineIOError
BadRequest -> Int
3

  errorMessage :: Text.Text
  errorMessage :: Text
errorMessage = case EngineIOError
e of
                   EngineIOError
TransportUnknown -> Text
"Transport unknown"
                   EngineIOError
SessionIdUnknown -> Text
"Session ID unknown"
                   EngineIOError
BadRequest -> Text
"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 :: Socket -> IO (STM Packet)
dupRawReader Socket
s = do
  TChan Packet
c <- STM (TChan Packet) -> IO (TChan Packet)
forall a. STM a -> IO a
STM.atomically (TChan Packet -> STM (TChan Packet)
forall a. TChan a -> STM (TChan a)
STM.dupTChan (Socket -> TChan Packet
socketRawIncomingBroadcast Socket
s))
  STM Packet -> IO (STM Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return (TChan Packet -> STM Packet
forall a. TChan a -> STM a
STM.readTChan TChan Packet
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@.

-}