{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Front.Broadcast where
import Bridge
import Conduit
import Control.Concurrent.Async
import Control.Concurrent.STM as STM
import Control.Exception (catch)
import Control.Monad (forever)
import Data.Aeson (Value, decode, toJSON)
import Data.Aeson.Text
import qualified Data.ByteString.Lazy as BL
import Data.Data
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy.Builder (toLazyText)
import Fay.Convert (showToFay)
import Network.WebSockets hiding (Headers)
interact
:: (Data message, Data message2)
=> (Value -> cache model -> ClientId -> IO (Out (Action message)))
-> Connection
-> TChan (Out (Action message))
-> TChan (Out message2)
-> cache model
-> (IO ())
-> ClientId
-> IO ()
interact :: (Value -> cache model -> ClientId -> IO (Out (Action message)))
-> Connection
-> TChan (Out (Action message))
-> TChan (Out message2)
-> cache model
-> IO ()
-> ClientId
-> IO ()
interact onCommand :: Value -> cache model -> ClientId -> IO (Out (Action message))
onCommand stream :: Connection
stream in' :: TChan (Out (Action message))
in' out' :: TChan (Out message2)
out' tvar :: cache model
tvar onClose :: IO ()
onClose client :: ClientId
client = do
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
(Connection
-> TChan (Out (Action message)) -> cache model -> ClientId -> IO ()
readLoop Connection
stream TChan (Out (Action message))
in' cache model
tvar ClientId
client)
(Connection -> TChan (Out message2) -> ClientId -> IO ()
forall message.
Data message =>
Connection -> TChan (Out message) -> ClientId -> IO ()
writeLoop Connection
stream TChan (Out message2)
out' ClientId
client)
where
writeLoop
:: Data message => Connection -> TChan (Out message) -> ClientId -> IO ()
writeLoop :: Connection -> TChan (Out message) -> ClientId -> IO ()
writeLoop _stream :: Connection
_stream _out :: TChan (Out message)
_out _client :: ClientId
_client = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Out message
cmd <- STM (Out message) -> IO (Out message)
forall a. STM a -> IO a
atomically (STM (Out message) -> IO (Out message))
-> STM (Out message) -> IO (Out message)
forall a b. (a -> b) -> a -> b
$ TChan (Out message) -> STM (Out message)
forall a. TChan a -> STM a
readTChan TChan (Out message)
_out
Value
json <- Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> Value -> IO Value
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Out message -> Maybe Value
forall a. Data a => a -> Maybe Value
showToFay Out message
cmd
case Out message
cmd of
EmptyCmd ->
Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
_stream (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder Value
json)
ExecuteClient cid :: ClientId
cid task :: ClientTask message
task strategy :: ExecuteStrategy
strategy -> do
let sid :: ClientId
sid = ClientId
_client
if ClientId
sid ClientId -> ClientId -> Bool
forall a. Eq a => a -> a -> Bool
== ClientId
cid Bool -> Bool -> Bool
&& ExecuteStrategy
strategy ExecuteStrategy -> ExecuteStrategy -> Bool
forall a. Eq a => a -> a -> Bool
== ExecuteStrategy
ExecuteExcept
then do
Value
json2 <- Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> Value -> IO Value
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Out message -> Maybe Value
forall a. Data a => a -> Maybe Value
showToFay (Out message -> Maybe Value) -> Out message -> Maybe Value
forall a b. (a -> b) -> a -> b
$
ClientId -> ClientTask message -> ExecuteStrategy -> Out message
forall a. ClientId -> ClientTask a -> ExecuteStrategy -> Out a
ExecuteClient ClientId
cid ClientTask message
task ExecuteStrategy
ExecuteExcept
Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
_stream (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder Value
json2)
else do
Value
json2 <- Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> Value -> IO Value
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Out message -> Maybe Value
forall a. Data a => a -> Maybe Value
showToFay (Out message -> Maybe Value) -> Out message -> Maybe Value
forall a b. (a -> b) -> a -> b
$
ClientId -> ClientTask message -> ExecuteStrategy -> Out message
forall a. ClientId -> ClientTask a -> ExecuteStrategy -> Out a
ExecuteClient ClientId
cid ClientTask message
task ExecuteStrategy
ExecuteAll
Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
_stream (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder Value
json2)
readLoop :: Connection
-> TChan (Out (Action message)) -> cache model -> ClientId -> IO ()
readLoop _stream :: Connection
_stream _in :: TChan (Out (Action message))
_in _tvar :: cache model
_tvar _client :: ClientId
_client = (IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Text
data' <- Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
_stream
ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ConduitT () Text IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
data' ConduitT () Text IO ()
-> ConduitM Text Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Text -> IO ()) -> ConduitM Text Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (\cmdstr :: Text
cmdstr -> do
case (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe Value) -> ByteString -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [Text -> ByteString
encodeUtf8 Text
cmdstr] :: Maybe Value) of
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error "No JSON provided"
Just cmd :: Value
cmd -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> [Char]
forall a. Show a => a -> [Char]
show Value
cmd
Out (Action message)
res <- Value -> cache model -> ClientId -> IO (Out (Action message))
onCommand Value
cmd cache model
_tvar ClientId
_client
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Out (Action message)) -> Out (Action message) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Out (Action message))
_in Out (Action message)
res)) IO () -> (ConnectionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ConnectionException
_ex :: ConnectionException) -> IO ()
onClose