{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Network.SocketIO
(
initialize
, RoutingTable
, on
, on_
, onJSON
, appendDisconnectHandler
, EventHandler
, emit
, emitJSON
, emitTo
, emitJSONTo
, broadcast
, broadcastJSON
, Socket
, socketId
, engineIOSocket
, PacketType(..)
, parsePacketType
, encodePacketType
, 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
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)
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
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
engineIOSocket :: Socket -> EIO.Socket
engineIOSocket :: Socket -> Socket
engineIOSocket = Socket -> Socket
socketEIOSocket
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 ()
}
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
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)}
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" #-}
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 :: (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))
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))
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
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))))
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 :: (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)