{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Network.SocketIO
  ( -- $intro
    -- * Running Socket.IO Applications
    initialize

    -- * Receiving events
  , RoutingTable
  , on
  , on_
  , onJSON
  , appendDisconnectHandler

  -- * Emitting Events
  , EventHandler

  -- ** To One Client
  , emit
  , emitJSON
  , emitTo
  , emitJSONTo

    -- ** To Many Clients
  , broadcast
  , broadcastJSON

    -- * Sockets
  , Socket
  , socketId
  , engineIOSocket

  -- * Protocol Types
  -- ** Packet Types
  , PacketType(..)
  , parsePacketType
  , encodePacketType

    -- ** Packets
  , Packet(..)
  , parsePacket
  , encodePacket
  ) where

import Control.Applicative
import Control.Monad (forever, guard, mzero, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ask, asks)
import Control.Monad.State (MonadState, modify)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Control.Monad.Trans.State.Strict (StateT, execStateT)
import Data.Char (isDigit)
import Data.Foldable (asum, forM_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Ord (comparing)

import qualified Control.Concurrent.STM as STM
import qualified Data.Aeson as Aeson
import qualified Data.Attoparsec.ByteString as Attoparsec
import qualified Data.Attoparsec.ByteString.Char8 as AttoparsecC8
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Function as Function
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.EngineIO as EIO

--------------------------------------------------------------------------------
data PacketType = Connect | Disconnect | Event | Ack | Error | BinaryEvent | BinaryAck
  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)


--------------------------------------------------------------------------------
parsePacketType :: Attoparsec.Parser PacketType
parsePacketType :: Parser PacketType
parsePacketType = [Parser PacketType] -> Parser PacketType
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
  [ PacketType
Connect PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'0'
  , PacketType
Disconnect PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'1'
  , PacketType
Event PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'2'
  , PacketType
Ack PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'3'
  , PacketType
Error PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'4'
  , PacketType
BinaryEvent PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'5'
  , PacketType
BinaryAck PacketType -> Parser ByteString Char -> Parser PacketType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AttoparsecC8.char Char
'6'
  ]


--------------------------------------------------------------------------------
encodePacketType :: PacketType -> Builder.Builder
encodePacketType :: PacketType -> Builder
encodePacketType PacketType
t =
  case PacketType
t of
    PacketType
Connect -> Char -> Builder
Builder.char8 Char
'0'
    PacketType
Disconnect -> Char -> Builder
Builder.char8 Char
'1'
    PacketType
Event -> Char -> Builder
Builder.char8 Char
'2'
    PacketType
Ack -> Char -> Builder
Builder.char8 Char
'3'
    PacketType
Error -> Char -> Builder
Builder.char8 Char
'4'
    PacketType
BinaryEvent -> Char -> Builder
Builder.char8 Char
'5'
    PacketType
BinaryAck -> Char -> Builder
Builder.char8 Char
'6'


--------------------------------------------------------------------------------
data Packet = Packet !PacketType !(Maybe Int) !Text.Text !(Maybe Int) !(Maybe Aeson.Value)
  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)


--------------------------------------------------------------------------------
parsePacket :: Attoparsec.Parser Packet
parsePacket :: Parser Packet
parsePacket = do
  PacketType
t <- Parser PacketType
parsePacketType

  Maybe Int
attachments <- if PacketType
t PacketType -> [PacketType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ PacketType
BinaryEvent, PacketType
BinaryAck ]
                   then (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> Parser ByteString Int -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int
numberStr) Parser ByteString (Maybe Int)
-> Parser ByteString Char -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
AttoparsecC8.char Char
'-'
                   else Maybe Int -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing

  Text
namespace <- Parser ByteString Text
parseNamespace Parser ByteString Text
-> Parser ByteString Text -> Parser ByteString Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ByteString Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"/"

  Maybe Int
pIdStr <- (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> Parser ByteString Int -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int
numberStr) Parser ByteString (Maybe Int)
-> Parser ByteString (Maybe Int) -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int -> Parser ByteString (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing

  PacketType
-> Maybe Int -> Text -> Maybe Int -> Maybe Value -> Packet
Packet PacketType
t Maybe Int
attachments Text
namespace Maybe Int
pIdStr (Maybe Value -> Packet)
-> Parser ByteString (Maybe Value) -> Parser Packet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> Parser ByteString Value -> Parser ByteString (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Value
Aeson.json) Parser ByteString (Maybe Value)
-> Parser ByteString (Maybe Value)
-> Parser ByteString (Maybe Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Value -> Parser ByteString (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing)

  where

  parseNamespace :: Parser ByteString Text
parseNamespace = do
    Parser ByteString Char
AttoparsecC8.peekChar' Parser ByteString Char
-> (Char -> Parser ByteString ()) -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Parser ByteString ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ByteString ())
-> (Char -> Bool) -> Char -> Parser ByteString ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
    ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> Parser ByteString ByteString -> Parser ByteString Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
AttoparsecC8.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')

  numberStr :: Parser ByteString Int
numberStr = String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> Parser ByteString String -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Char -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Attoparsec.many1 ((Char -> Bool) -> Parser ByteString Char
AttoparsecC8.satisfy Char -> Bool
isDigit)


--------------------------------------------------------------------------------
encodePacket :: Packet -> Builder.Builder
encodePacket :: Packet -> Builder
encodePacket (Packet PacketType
pt Maybe Int
attachments Text
n Maybe Int
pId Maybe Value
json) =
  PacketType -> Builder
encodePacketType PacketType
pt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe Builder
forall a. Monoid a => a
mempty (ByteString -> Builder
Builder.lazyByteString (ByteString -> Builder)
-> (Value -> ByteString) -> Value -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Builder) -> Maybe Value -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
json)


--------------------------------------------------------------------------------
type EventHandler a = ReaderT Socket IO a


--------------------------------------------------------------------------------
{-|

This computation initializes a Socket.IO server and /returns/ a computation that
you should call whenever a request comes in to the @/socket.io/@ path. For
example, in a Snap application, you might do:

> handler <- initialize snapAPI mkRoutes
> quickHttpServe $ route [("/socket.io", handler)]

The second argument to this function is an action to build up the routing table,
which determines what happens when clients emit events. It is also an action
that is called every time a client connects, so you can mutate state by taking
advantage of the 'MonadIO' instance. You can build a routing table by using the
convenience 'on' family of functions.

-}
initialize
  :: MonadIO m
  => EIO.ServerAPI m
  -> StateT RoutingTable (ReaderT Socket m) a
  -> IO (m ())
initialize :: ServerAPI m
-> StateT RoutingTable (ReaderT Socket m) a -> IO (m ())
initialize ServerAPI m
api StateT RoutingTable (ReaderT Socket m) a
socketHandler = do
  EngineIO
eio <- IO EngineIO
EIO.initialize

  let
    eioHandler :: Socket -> m SocketApp
eioHandler Socket
socket = do
      let wrappedSocket :: Socket
wrappedSocket = Socket -> EngineIO -> Socket
Socket Socket
socket EngineIO
eio
      RoutingTable
routingTable <- (ReaderT Socket m RoutingTable -> Socket -> m RoutingTable)
-> Socket -> ReaderT Socket m RoutingTable -> m RoutingTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Socket m RoutingTable -> Socket -> m RoutingTable
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Socket
wrappedSocket (ReaderT Socket m RoutingTable -> m RoutingTable)
-> ReaderT Socket m RoutingTable -> m RoutingTable
forall a b. (a -> b) -> a -> b
$
        StateT RoutingTable (ReaderT Socket m) a
-> RoutingTable -> ReaderT Socket m RoutingTable
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT RoutingTable (ReaderT Socket m) a
socketHandler (HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
-> EventHandler () -> RoutingTable
RoutingTable HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
forall a. Monoid a => a
mempty (() -> EventHandler ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

      SocketApp -> m SocketApp
forall (m :: * -> *) a. Monad m => a -> m a
return (SocketApp -> m SocketApp) -> SocketApp -> m SocketApp
forall a b. (a -> b) -> a -> b
$ SocketApp :: IO () -> IO () -> SocketApp
EIO.SocketApp
        { saApp :: IO ()
EIO.saApp = (EventHandler () -> Socket -> IO ())
-> Socket -> EventHandler () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip EventHandler () -> Socket -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Socket
wrappedSocket (EventHandler () -> IO ()) -> EventHandler () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Socket -> Packet -> EventHandler ()
forall (m :: * -> *). MonadIO m => Socket -> Packet -> m ()
emitPacketTo Socket
wrappedSocket (PacketType
-> Maybe Int -> Text -> Maybe Int -> Maybe Value -> Packet
Packet PacketType
Connect Maybe Int
forall a. Maybe a
Nothing Text
"/" Maybe Int
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing)

            EventHandler () -> EventHandler ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (EventHandler () -> EventHandler ())
-> EventHandler () -> EventHandler ()
forall a b. (a -> b) -> a -> b
$ do
              EIO.TextPacket Text
t <- IO PacketContent -> ReaderT Socket IO PacketContent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM PacketContent -> IO PacketContent
forall a. STM a -> IO a
STM.atomically (Socket -> STM PacketContent
EIO.receive Socket
socket))
              case Parser Packet -> ByteString -> Either String Packet
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly Parser Packet
parsePacket (Text -> ByteString
Text.encodeUtf8 Text
t) of
                Right (Packet PacketType
Event Maybe Int
_ Text
_ Maybe Int
_ (Just (Aeson.Array Array
v))) | Bool -> Bool
not (Array -> Bool
forall a. Vector a -> Bool
V.null Array
v) -> do
                  case (Array -> Value
forall a. Vector a -> a
V.unsafeHead Array
v, Array -> Array
forall a. Vector a -> Vector a
V.unsafeTail Array
v) of
                    (Aeson.String Text
name, Array
args) -> do
                      case Text
name Text
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
-> Maybe (Array -> MaybeT (ReaderT Socket IO) ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` RoutingTable
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents RoutingTable
routingTable of
                        Just Array -> MaybeT (ReaderT Socket IO) ()
handler -> ReaderT Socket IO (Maybe ()) -> EventHandler ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (ReaderT Socket IO) () -> ReaderT Socket IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (Array -> MaybeT (ReaderT Socket IO) ()
handler Array
args))
                        Maybe (Array -> MaybeT (ReaderT Socket IO) ())
Nothing -> () -> EventHandler ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    (Value, Array)
other -> String -> EventHandler ()
forall a. HasCallStack => String -> a
error (String -> EventHandler ()) -> String -> EventHandler ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected arguments: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Value, Array) -> String
forall a. Show a => a -> String
show (Value, Array)
other

                Right Packet
e -> String -> EventHandler ()
forall a. HasCallStack => String -> a
error (String -> EventHandler ()) -> String -> EventHandler ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected parse: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Packet -> String
forall a. Show a => a -> String
show Packet
e

                Left String
e -> String -> EventHandler ()
forall a. HasCallStack => String -> a
error (String -> EventHandler ()) -> String -> EventHandler ()
forall a b. (a -> b) -> a -> b
$ String
"Attoparsec failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e

        , saOnDisconnect :: IO ()
EIO.saOnDisconnect = EventHandler () -> Socket -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (RoutingTable -> EventHandler ()
rtDisconnect RoutingTable
routingTable) Socket
wrappedSocket
        }

  m () -> IO (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> m ()
forall (m :: * -> *).
MonadIO m =>
EngineIO -> (Socket -> m SocketApp) -> ServerAPI m -> m ()
EIO.handler EngineIO
eio Socket -> m SocketApp
eioHandler ServerAPI m
api)


--------------------------------------------------------------------------------
-- | A Socket.IO socket (not to be confused with an Engine.IO 'EIO.Socket').
data Socket = Socket { Socket -> Socket
socketEIOSocket :: EIO.Socket
                     , Socket -> EngineIO
socketEIO :: EIO.EngineIO
                     }

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

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

-- | Retrieve the Engine.IO 'EIO.SocketId' for a 'Socket'.
socketId :: Socket -> EIO.SocketId
socketId :: Socket -> ByteString
socketId = Socket -> ByteString
EIO.socketId (Socket -> ByteString)
-> (Socket -> Socket) -> Socket -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> Socket
socketEIOSocket

-- | Retrieve the Engine.IO 'EIO.Socket' that underlies this Socket.IO socket.
-- This is a fairly low-level operation - you should take care when reading or
-- writing directly to this socket, as it is possible to break invariants that
-- Socket.io is expecting.
engineIOSocket :: Socket -> EIO.Socket
engineIOSocket :: Socket -> Socket
engineIOSocket = Socket -> Socket
socketEIOSocket

--------------------------------------------------------------------------------
-- | A per-connection routing table. This table determines what actions to
-- invoke when events are received.
data RoutingTable = RoutingTable
  { RoutingTable
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents :: HashMap.HashMap Text.Text (Aeson.Array -> MaybeT (ReaderT Socket IO) ())
  , RoutingTable -> EventHandler ()
rtDisconnect :: EventHandler ()
  }


--------------------------------------------------------------------------------
-- | When an event with a given name is received, call the associated function
-- with the array of JSON arguments.
onJSON
  :: (MonadState RoutingTable m)
  => Text.Text
  -> (Aeson.Array -> EventHandler a)
  -> m ()
onJSON :: Text -> (Array -> EventHandler a) -> m ()
onJSON Text
eventName Array -> EventHandler a
handler =
  (RoutingTable -> RoutingTable) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RoutingTable -> RoutingTable) -> m ())
-> (RoutingTable -> RoutingTable) -> m ()
forall a b. (a -> b) -> a -> b
$ \RoutingTable
rt -> RoutingTable
rt
    { rtEvents :: HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents =
        ((Array -> MaybeT (ReaderT Socket IO) ())
 -> (Array -> MaybeT (ReaderT Socket IO) ())
 -> Array
 -> MaybeT (ReaderT Socket IO) ())
-> Text
-> (Array -> MaybeT (ReaderT Socket IO) ())
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith (\Array -> MaybeT (ReaderT Socket IO) ()
new Array -> MaybeT (ReaderT Socket IO) ()
old Array
json -> Array -> MaybeT (ReaderT Socket IO) ()
old Array
json MaybeT (ReaderT Socket IO) ()
-> MaybeT (ReaderT Socket IO) () -> MaybeT (ReaderT Socket IO) ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Array -> MaybeT (ReaderT Socket IO) ()
new Array
json)
                           Text
eventName
                           (MaybeT (ReaderT Socket IO) a -> MaybeT (ReaderT Socket IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (ReaderT Socket IO) a -> MaybeT (ReaderT Socket IO) ())
-> (Array -> MaybeT (ReaderT Socket IO) a)
-> Array
-> MaybeT (ReaderT Socket IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventHandler a -> MaybeT (ReaderT Socket IO) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EventHandler a -> MaybeT (ReaderT Socket IO) a)
-> (Array -> EventHandler a)
-> Array
-> MaybeT (ReaderT Socket IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> EventHandler a
handler)
                           (RoutingTable
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents RoutingTable
rt)
    }

--------------------------------------------------------------------------------
class OnArgs a r | a -> r where
  parseArgs :: Aeson.Array -> a -> Maybe r

instance OnArgs a a where
  parseArgs :: Array -> a -> Maybe a
parseArgs Array
v a
m
    | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = a -> Maybe a
forall a. a -> Maybe a
Just a
m
    | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

instance (Aeson.FromJSON a, OnArgs b r) => OnArgs (a -> b) r where
  parseArgs :: Array -> (a -> b) -> Maybe r
parseArgs Array
v a -> b
f
    | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = Maybe r
forall a. Maybe a
Nothing
    | Bool
otherwise = case Value -> Result a
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON (Array -> Value
forall a. Vector a -> a
V.head Array
v) of
                    Aeson.Success a
s -> Array -> b -> Maybe r
forall a r. OnArgs a r => Array -> a -> Maybe r
parseArgs (Array -> Array
forall a. Vector a -> Vector a
V.tail Array
v) (a -> b
f a
s)
                    Aeson.Error String
_ -> Maybe r
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- | When an event with a given name is received, and its argument can be
-- decoded by a 'Aeson.FromJSON' instance, run the associated function
-- after decoding the event argument. Expects exactly one event argument.
on
  :: (MonadState RoutingTable m, OnArgs f (EventHandler a))
  => Text.Text -> f -> m ()
on :: Text -> f -> m ()
on Text
eventName f
handler =
  let eventHandler :: Array -> t (ReaderT Socket IO) a
eventHandler Array
v =
        t (ReaderT Socket IO) a
-> (ReaderT Socket IO a -> t (ReaderT Socket IO) a)
-> Maybe (ReaderT Socket IO a)
-> t (ReaderT Socket IO) a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe t (ReaderT Socket IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero ReaderT Socket IO a -> t (ReaderT Socket IO) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Array -> f -> Maybe (ReaderT Socket IO a)
forall a r. OnArgs a r => Array -> a -> Maybe r
parseArgs Array
v f
handler)
  in (RoutingTable -> RoutingTable) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RoutingTable -> RoutingTable) -> m ())
-> (RoutingTable -> RoutingTable) -> m ()
forall a b. (a -> b) -> a -> b
$
     \RoutingTable
rt ->
       RoutingTable
rt {rtEvents :: HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents =
             ((Array -> MaybeT (ReaderT Socket IO) ())
 -> (Array -> MaybeT (ReaderT Socket IO) ())
 -> Array
 -> MaybeT (ReaderT Socket IO) ())
-> Text
-> (Array -> MaybeT (ReaderT Socket IO) ())
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith (\Array -> MaybeT (ReaderT Socket IO) ()
new Array -> MaybeT (ReaderT Socket IO) ()
old Array
json -> Array -> MaybeT (ReaderT Socket IO) ()
old Array
json MaybeT (ReaderT Socket IO) ()
-> MaybeT (ReaderT Socket IO) () -> MaybeT (ReaderT Socket IO) ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Array -> MaybeT (ReaderT Socket IO) ()
new Array
json)
                                Text
eventName
                                (MaybeT (ReaderT Socket IO) a -> MaybeT (ReaderT Socket IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (ReaderT Socket IO) a -> MaybeT (ReaderT Socket IO) ())
-> (Array -> MaybeT (ReaderT Socket IO) a)
-> Array
-> MaybeT (ReaderT Socket IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> MaybeT (ReaderT Socket IO) a
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadPlus (t (ReaderT Socket IO))) =>
Array -> t (ReaderT Socket IO) a
eventHandler)
                                (RoutingTable
-> HashMap Text (Array -> MaybeT (ReaderT Socket IO) ())
rtEvents RoutingTable
rt)}


--------------------------------------------------------------------------------
-- | When an event is received with a given name and no arguments, run the
-- associated 'EventHandler'.
on_
  :: (MonadState RoutingTable m)
  => Text.Text
  -> EventHandler a
  -> m ()
on_ :: Text -> EventHandler a -> m ()
on_ Text
e EventHandler a
f = Text -> EventHandler () -> m ()
forall (m :: * -> *) f a.
(MonadState RoutingTable m, OnArgs f (EventHandler a)) =>
Text -> f -> m ()
on Text
e (EventHandler a -> EventHandler ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void EventHandler a
f)
{-# DEPRECATED on_ "Use Network.SocketIO.on instead" #-}


--------------------------------------------------------------------------------
-- | Run the given IO action when a client disconnects, along with any other
-- previously register disconnect handlers.
appendDisconnectHandler
  :: MonadState RoutingTable m => EventHandler () -> m ()
appendDisconnectHandler :: EventHandler () -> m ()
appendDisconnectHandler EventHandler ()
handler = (RoutingTable -> RoutingTable) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RoutingTable -> RoutingTable) -> m ())
-> (RoutingTable -> RoutingTable) -> m ()
forall a b. (a -> b) -> a -> b
$ \RoutingTable
rt -> RoutingTable
rt
  { rtDisconnect :: EventHandler ()
rtDisconnect = do RoutingTable -> EventHandler ()
rtDisconnect RoutingTable
rt
                      EventHandler ()
handler
  }

--------------------------------------------------------------------------------
-- | Emit an event and argument data to a 'Socket'. If called from within 'on',
-- this will be the client that emitted the original event.
emit :: (Aeson.ToJSON a, MonadReader Socket m, MonadIO m) => Text.Text -> a -> m ()
emit :: Text -> a -> m ()
emit Text
n a
x = Text -> Array -> m ()
forall (m :: * -> *).
(MonadReader Socket m, MonadIO m) =>
Text -> Array -> m ()
emitJSON Text
n (Value -> Array
forall a. a -> Vector a
V.singleton (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
x))


--------------------------------------------------------------------------------
-- | Emit an event to specific 'Socket'.
emitTo :: (Aeson.ToJSON a, MonadIO m) => Socket -> Text.Text -> a -> m ()
emitTo :: Socket -> Text -> a -> m ()
emitTo Socket
s Text
n a
x = Socket -> Text -> Array -> m ()
forall (m :: * -> *). MonadIO m => Socket -> Text -> Array -> m ()
emitJSONTo Socket
s Text
n (Value -> Array
forall a. a -> Vector a
V.singleton (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
x))


--------------------------------------------------------------------------------
-- | Emit an event with a specific array of 'JSON' arguments.
emitJSON :: (MonadReader Socket m, MonadIO m) => Text.Text -> Aeson.Array -> m ()
emitJSON :: Text -> Array -> m ()
emitJSON Text
n Array
args = m Socket
forall r (m :: * -> *). MonadReader r m => m r
ask m Socket -> (Socket -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Socket
s -> Socket -> Text -> Array -> m ()
forall (m :: * -> *). MonadIO m => Socket -> Text -> Array -> m ()
emitJSONTo Socket
s Text
n Array
args


--------------------------------------------------------------------------------
-- | Emit an event with a specific array of 'JSON' arguments to a specific
-- 'Socket'.
emitJSONTo :: (MonadIO m) => Socket -> Text.Text -> Aeson.Array -> m ()
emitJSONTo :: Socket -> Text -> Array -> m ()
emitJSONTo Socket
s Text
n Array
args =
  Socket -> Packet -> m ()
forall (m :: * -> *). MonadIO m => Socket -> Packet -> m ()
emitPacketTo Socket
s (PacketType
-> Maybe Int -> Text -> Maybe Int -> Maybe Value -> Packet
Packet PacketType
Event Maybe Int
forall a. Maybe a
Nothing Text
"/" Maybe Int
forall a. Maybe a
Nothing (Value -> Maybe Value
forall a. a -> Maybe a
Just (Array -> Value
Aeson.Array (Value -> Array -> Array
forall a. a -> Vector a -> Vector a
V.cons (Text -> Value
Aeson.String Text
n) Array
args))))


--------------------------------------------------------------------------------
emitPacketTo :: (MonadIO m) => Socket -> Packet -> m ()
emitPacketTo :: Socket -> Packet -> m ()
emitPacketTo Socket
socket Packet
packet =
  let bytes :: ByteString
bytes = ByteString -> ByteString
LBS.toStrict (Builder -> ByteString
Builder.toLazyByteString (Packet -> Builder
encodePacket Packet
packet))
  in IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (Socket -> PacketContent -> STM ()
EIO.send (Socket -> Socket
socketEIOSocket Socket
socket) (Text -> PacketContent
EIO.TextPacket (ByteString -> Text
Text.decodeUtf8 ByteString
bytes))))


--------------------------------------------------------------------------------
-- | Broadcast an event with an array of JSON arguments to all /other/
-- 'Socket's.
broadcastJSON :: (MonadReader Socket m, MonadIO m) => Text.Text -> Aeson.Array -> m ()
broadcastJSON :: Text -> Array -> m ()
broadcastJSON Text
n Array
args =
  Packet -> m ()
forall (m :: * -> *).
(MonadReader Socket m, MonadIO m) =>
Packet -> m ()
broadcastPacket (PacketType
-> Maybe Int -> Text -> Maybe Int -> Maybe Value -> Packet
Packet PacketType
Event Maybe Int
forall a. Maybe a
Nothing Text
"/" Maybe Int
forall a. Maybe a
Nothing (Value -> Maybe Value
forall a. a -> Maybe a
Just (Array -> Value
Aeson.Array (Value -> Array -> Array
forall a. a -> Vector a -> Vector a
V.cons (Text -> Value
Aeson.String Text
n) Array
args))))


--------------------------------------------------------------------------------
-- | Broadcast an event to all /other/ 'Socket's.
broadcast :: (Aeson.ToJSON a, MonadReader Socket m, MonadIO m) => Text.Text -> a -> m ()
broadcast :: Text -> a -> m ()
broadcast Text
n a
x = Text -> Array -> m ()
forall (m :: * -> *).
(MonadReader Socket m, MonadIO m) =>
Text -> Array -> m ()
broadcastJSON Text
n (Value -> Array
forall a. a -> Vector a
V.singleton (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
x))


--------------------------------------------------------------------------------
broadcastPacket :: (MonadReader Socket m, MonadIO m) => Packet -> m ()
broadcastPacket :: Packet -> m ()
broadcastPacket Packet
packet = do
  let bytes :: ByteString
bytes = ByteString -> ByteString
LBS.toStrict (Builder -> ByteString
Builder.toLazyByteString (Packet -> Builder
encodePacket Packet
packet))
      eioPacket :: PacketContent
eioPacket = Text -> PacketContent
EIO.TextPacket (ByteString -> Text
Text.decodeUtf8 ByteString
bytes)

  EngineIO
eio <- (Socket -> EngineIO) -> m EngineIO
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Socket -> EngineIO
socketEIO
  Socket
t <- (Socket -> Socket) -> m Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Socket -> Socket
socketEIOSocket
  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 (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    HashMap ByteString Socket
sockets <- 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
EIO.socketId Socket
t) (HashMap ByteString Socket -> HashMap ByteString Socket)
-> STM (HashMap ByteString Socket)
-> STM (HashMap ByteString Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EngineIO -> STM (HashMap ByteString Socket)
EIO.getOpenSockets EngineIO
eio
    HashMap ByteString Socket -> (Socket -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ HashMap ByteString Socket
sockets ((Socket -> PacketContent -> STM ())
-> PacketContent -> Socket -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> PacketContent -> STM ()
EIO.send PacketContent
eioPacket)

{-$intro

This library provides an implementation of <http://socket.io Socket.io> protocol
(version 1). It builds on top of Engine.IO, allowing Socket.io to work with both
long polling XHR requests, and seamlessly upgrading them to HTML 5 web sockets.

-}

{-$limitations

This implementation has the following limitations:

* Namespaces other than @/@ are not supported.
* Binary event data is not yet supported - only JSON events are supported.

If any of these are important to you, don't hesistate to
<http://github.com/ocharles/engine.io raise an issue> and I'll try and make it a
priority.

-}