{-# 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)

-- | The common way how to use websocket 'Connection' obtained from 'Handler' via 'Conduit'.
-- 'interact' starts two concurrent processes.
-- First one is responsible for reading data from stream, decoding JSON message, executing custom business logic implemented by user and pushing the produced outgoing 'message' to 'TChan'.
-- The second process is constantly reading from 'TChan', encoding the given message and pushing it to all subscribers.
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