{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Socket where

import Control.Monad (void, when)
import Data.Aeson (Value)
import Data.Bifunctor (first)
import Data.List qualified as L
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.String (IsString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Effectful
import Effectful.Concurrent.Async
import Effectful.Concurrent.STM (STM, TVar, atomically, modifyTVar, readTVar, writeTVar)
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static (throwError_)
import Effectful.Exception
import Effectful.State.Static.Local as Local (get, modify)
import Network.HTTP.Types as HTTP (parseQuery)
import Network.Wai qualified as Wai
import Network.WebSockets (Connection)
import Network.WebSockets qualified as WS
import Web.Cookie qualified
import Web.Hyperbole.Data.Cookie qualified as Cookie
import Web.Hyperbole.Data.Encoded (Encoded, encodedToText)
import Web.Hyperbole.Data.URI (URI, path, uriToText)
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Server.Message
import Web.Hyperbole.Server.Options
import Web.Hyperbole.Types.Client
import Web.Hyperbole.Types.Event (Event (..), TargetViewId (..))
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response


data SocketRequest = SocketRequest
  { SocketRequest -> Maybe Request
request :: Maybe Request
  }


type RunningActions = Map TargetViewId (Encoded, RequestId, Async ())


runHyperboleSocket
  :: (IOE :> es)
  => ServerOptions
  -> Connection
  -> Request
  -> Eff (Hyperbole : es) Response
  -> Eff es (Response, Client, [Remote])
runHyperboleSocket :: forall (es :: [Effect]).
(IOE :> es) =>
ServerOptions
-> Connection
-> Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleSocket ServerOptions
_opts Connection
conn Request
req = (Eff
   (Error Response : State Client : Writer [Remote] : es) Response
 -> Eff es (Response, Client, [Remote]))
-> EffectHandler
     Hyperbole (Error Response : State Client : Writer [Remote] : es)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (Request
-> Eff
     (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
forall (es :: [Effect]).
Request
-> Eff
     (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleLocal Request
req) (EffectHandler
   Hyperbole (Error Response : State Client : Writer [Remote] : es)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Response, Client, [Remote]))
-> EffectHandler
     Hyperbole (Error Response : State Client : Writer [Remote] : es)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall a b. (a -> b) -> a -> b
$ \LocalEnv
  localEs (Error Response : State Client : Writer [Remote] : es)
_ -> \case
  Hyperbole (Eff localEs) a
GetRequest -> do
    a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall a.
a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Request
req
  RespondNow Response
r -> do
    Response
-> Eff (Error Response : State Client : Writer [Remote] : es) a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ Response
r
  Hyperbole (Eff localEs) a
GetClient -> do
    forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
Eff es s
Local.get @Client
  ModClient Client -> Client
f -> do
    forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
Local.modify @Client Client -> Client
f
  PushUpdate (ViewUpdate TargetViewId
vid Body
vw) -> do
    Connection
-> Request
-> TargetViewId
-> Body
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> TargetViewId -> Body -> Eff es ()
sendUpdate Connection
conn Request
req TargetViewId
vid Body
vw
  PushTrigger TargetViewId
vid Encoded
act -> do
    Connection
-> Request
-> TargetViewId
-> Encoded
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> TargetViewId -> Encoded -> Eff es ()
sendTrigger Connection
conn Request
req TargetViewId
vid Encoded
act
  PushEvent Text
name Value
dat -> do
    Connection
-> Request
-> Text
-> Value
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> Text -> Value -> Eff es ()
sendEvent Connection
conn Request
req Text
name Value
dat


handleRequestSocket
  :: (IOE :> es, Concurrent :> es)
  => ServerOptions
  -> TVar RunningActions
  -> Wai.Request
  -> Connection
  -> Eff (Hyperbole : es) Response
  -> Eff es ()
handleRequestSocket :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
ServerOptions
-> TVar RunningActions
-> Request
-> Connection
-> Eff (Hyperbole : es) Response
-> Eff es ()
handleRequestSocket ServerOptions
opts TVar RunningActions
actions Request
wreq Connection
conn Eff (Hyperbole : es) Response
eff = do
  (Eff es () -> (MessageError -> Eff es ()) -> Eff es ())
-> (MessageError -> Eff es ()) -> Eff es () -> Eff es ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Eff es () -> (MessageError -> Eff es ()) -> Eff es ()
forall e (es :: [Effect]) a.
Exception e =>
Eff es a -> (e -> Eff es a) -> Eff es a
catch MessageError -> Eff es ()
forall (es :: [Effect]) a. (IOE :> es) => MessageError -> Eff es a
onMessageError (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
    msg <- Eff es Message
forall (es :: [Effect]). (IOE :> es) => Eff es Message
receiveMessage
    req <- parseMessageRequest msg

    a <- async $ do
      res <- trySync $ runHyperboleSocket opts conn req eff
      case res of
        -- TODO: catch socket errors separately from SomeException?
        Left (SomeException
ex :: SomeException) -> do
          -- It's not safe to send SomeException over the wire
          -- log it to the console and send the error to the client
          IO () -> Eff es ()
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
ex
          res2 <- Eff es () -> Eff es (Either SomeException ())
forall (es :: [Effect]) a.
Eff es a -> Eff es (Either SomeException a)
trySync (Eff es () -> Eff es (Either SomeException ()))
-> Eff es () -> Eff es (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Connection -> Metadata -> ServerError -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> ServerError -> Eff es ()
sendError Connection
conn (Request -> Metadata
requestMetadata Request
req) (ServerOptions
opts.serverError ResponseError
ErrInternal)
          case res2 of
            Left SomeException
e -> IO () -> Eff es ()
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Socket Error while sending previous error to client: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
            Right ()
_ -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right (Response
resp, Client
clnt, [Remote]
rmts) -> do
          let meta :: Metadata
meta = Request -> Metadata
requestMetadata Request
req Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Path -> Client -> [Remote] -> Metadata
responseMetadata Request
req.path Client
clnt [Remote]
rmts
          case Response
resp of
            (Response (ViewUpdate TargetViewId
_ Body
vw)) -> do
              Connection -> Metadata -> Body -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> Body -> Eff es ()
sendResponse Connection
conn Metadata
meta Body
vw
            (Err ResponseError
err) -> Connection -> Metadata -> ServerError -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> ServerError -> Eff es ()
sendError Connection
conn Metadata
meta (ServerOptions
opts.serverError ResponseError
err)
            (Redirect URI
url) -> Connection -> Metadata -> URI -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> URI -> Eff es ()
sendRedirect Connection
conn Metadata
meta URI
url

    addRunningAction a req.requestId req.event

    void $ async $ do
      _ <- waitCatch a
      clearRunningAction req.requestId req.event
 where
  addRunningAction :: (IOE :> es, Concurrent :> es) => Async () -> RequestId -> Maybe (Event TargetViewId Encoded Value) -> Eff es ()
  addRunningAction :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
Async ()
-> RequestId
-> Maybe (Event TargetViewId Encoded Value)
-> Eff es ()
addRunningAction Async ()
a RequestId
reqId = \case
    Maybe (Event TargetViewId Encoded Value)
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Event TargetViewId
vid Encoded
act Value
_) -> do
      -- liftIO $ putStrLn $ " [add] (" <> cs reqId <> ") " <> cs clientId.value <> "|" <> show vid
      maold <- STM (Maybe (Encoded, RequestId, Async ()))
-> Eff es (Maybe (Encoded, RequestId, Async ()))
forall (es :: [Effect]) a. (Concurrent :> es) => STM a -> Eff es a
atomically (STM (Maybe (Encoded, RequestId, Async ()))
 -> Eff es (Maybe (Encoded, RequestId, Async ())))
-> STM (Maybe (Encoded, RequestId, Async ()))
-> Eff es (Maybe (Encoded, RequestId, Async ()))
forall a b. (a -> b) -> a -> b
$ do
        -- NOTE: actions is unique per-client, which is why it doesn't require a client id
        m <- forall a. TVar a -> STM a
readTVar @RunningActions TVar RunningActions
actions
        writeTVar actions $ M.insert vid (act, reqId, a) m
        pure $ M.lookup vid m
      case maold of
        Maybe (Encoded, RequestId, Async ())
Nothing -> do
          -- liftIO $ putStrLn $ "nocancel " <> show vid
          () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (Encoded
actold, RequestId Text
rold, Async ()
aold) -> do
          IO () -> Eff es ()
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CANCEL (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
rold String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Encoded -> Text
encodedToText TargetViewId
vid.encoded) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Encoded -> Text
encodedToText Encoded
actold)
          Async () -> Eff es ()
forall (es :: [Effect]) a.
(Concurrent :> es) =>
Async a -> Eff es ()
cancel Async ()
aold

  clearRunningAction :: (IOE :> es, Concurrent :> es) => RequestId -> Maybe (Event TargetViewId Encoded Value) -> Eff es ()
  clearRunningAction :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
RequestId -> Maybe (Event TargetViewId Encoded Value) -> Eff es ()
clearRunningAction RequestId
reqId = \case
    Maybe (Event TargetViewId Encoded Value)
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Event TargetViewId
vid Encoded
_ Value
_) -> STM () -> Eff es ()
forall (es :: [Effect]) a. (Concurrent :> es) => STM a -> Eff es a
atomically (STM () -> Eff es ()) -> STM () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
      active <- TargetViewId -> RequestId -> STM Bool
isActiveRequestId TargetViewId
vid RequestId
reqId
      when active $ do
        _ <- modifyTVar actions $ M.delete vid
        pure ()

  activeRequestId :: TargetViewId -> STM (Maybe RequestId)
  activeRequestId :: TargetViewId -> STM (Maybe RequestId)
activeRequestId TargetViewId
vid = do
    m <- TVar RunningActions -> STM RunningActions
forall a. TVar a -> STM a
readTVar TVar RunningActions
actions
    pure $ do
      (_, r, _) <- M.lookup vid m
      pure r

  isActiveRequestId :: TargetViewId -> RequestId -> STM Bool
  isActiveRequestId :: TargetViewId -> RequestId -> STM Bool
isActiveRequestId TargetViewId
vid RequestId
reqId = do
    r <- TargetViewId -> STM (Maybe RequestId)
activeRequestId TargetViewId
vid
    pure $ r == Just reqId

  onMessageError :: (IOE :> es) => MessageError -> Eff es a
  onMessageError :: forall (es :: [Effect]) a. (IOE :> es) => MessageError -> Eff es a
onMessageError MessageError
e = do
    IO () -> Eff es ()
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn String
"Socket Message Error"
    MessageError -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO MessageError
e

  receiveMessage :: (IOE :> es) => Eff es Message
  receiveMessage :: forall (es :: [Effect]). (IOE :> es) => Eff es Message
receiveMessage = do
    t <- Connection -> Eff es Text
forall (es :: [Effect]). (IOE :> es) => Connection -> Eff es Text
receiveText Connection
conn
    case parseActionMessage (cs t) of
      Left String
e -> MessageError -> Eff es Message
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (MessageError -> Eff es Message) -> MessageError -> Eff es Message
forall a b. (a -> b) -> a -> b
$ String -> Text -> MessageError
InvalidMessage String
e Text
t
      Right Message
msg -> Message -> Eff es Message
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message
msg

  receiveText :: (IOE :> es) => Connection -> Eff es Text
  receiveText :: forall (es :: [Effect]). (IOE :> es) => Connection -> Eff es Text
receiveText Connection
_ = do
    -- c <- ask @Connection
    IO Text -> Eff es Text
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Eff es Text) -> IO Text -> Eff es Text
forall a b. (a -> b) -> a -> b
$ Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn

  parseMessageRequest :: (IOE :> es) => Message -> Eff es Request
  parseMessageRequest :: forall (es :: [Effect]). (IOE :> es) => Message -> Eff es Request
parseMessageRequest Message
msg =
    case Message -> Either MessageError Request
messageRequest Message
msg of
      Left MessageError
e -> MessageError -> Eff es Request
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO MessageError
e
      Right Request
a -> Request -> Eff es Request
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
a

  messageRequest :: Message -> Either MessageError Request
  messageRequest :: Message -> Either MessageError Request
messageRequest Message
msg = do
    let pth :: Path
pth = Text -> Path
path (Text -> Path) -> Text -> Path
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawPathInfo Request
wreq
        host :: Host
host = ByteString -> Host
Host (ByteString -> Host) -> ByteString -> Host
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Host" [(HeaderName, ByteString)]
headers
        headers :: [(HeaderName, ByteString)]
headers = Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
wreq
        method :: ByteString
method = ByteString
"POST"

    -- Parse params as url encoded, ignore files
    let body :: Text
body = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Message
msg.body.value

    query <- ByteString -> Query
HTTP.parseQuery (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query)
-> Either MessageError Text -> Either MessageError Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Metadata -> Either MessageError Text
requireMeta Text
"Query" Message
msg.metadata
    cookie <- cs <$> requireMeta "Cookie" msg.metadata

    cookies <- first (InvalidCookie cookie) <$> Cookie.parse $ Web.Cookie.parseCookies cookie

    pure $
      Request
        { path = pth
        , event = Just msg.event
        , host
        , query
        , form = Form mempty mempty
        , input = body
        , method
        , cookies
        , requestId = msg.requestId
        }
   where
    requireMeta :: MetaKey -> Metadata -> Either MessageError Text
    requireMeta :: Text -> Metadata -> Either MessageError Text
requireMeta Text
key Metadata
m =
      Either MessageError Text
-> (Text -> Either MessageError Text)
-> Maybe Text
-> Either MessageError Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MessageError -> Either MessageError Text
forall a b. a -> Either a b
Left (MessageError -> Either MessageError Text)
-> MessageError -> Either MessageError Text
forall a b. (a -> b) -> a -> b
$ String -> MessageError
MissingMeta (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
key)) Text -> Either MessageError Text
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Either MessageError Text)
-> Maybe Text -> Either MessageError Text
forall a b. (a -> b) -> a -> b
$ Text -> Metadata -> Maybe Text
lookupMetadata Text
key Metadata
m


sendResponse :: (IOE :> es) => Connection -> Metadata -> Body -> Eff es ()
sendResponse :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> Body -> Eff es ()
sendResponse Connection
conn Metadata
meta (Body ByteString
b) = do
  Command -> Connection -> Metadata -> RenderedMessage -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage Command
"RESPONSE" Connection
conn Metadata
meta (ByteString -> RenderedMessage
MessageHtml ByteString
b)


sendUpdate :: (IOE :> es) => Connection -> Request -> TargetViewId -> Body -> Eff es ()
sendUpdate :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> TargetViewId -> Body -> Eff es ()
sendUpdate Connection
conn Request
req TargetViewId
vid (Body ByteString
b) = do
  Command -> Connection -> Metadata -> RenderedMessage -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage Command
"UPDATE" Connection
conn (Request -> Metadata
requestMetadata Request
req Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> TargetViewId -> Metadata
targetViewMetadata TargetViewId
vid) (ByteString -> RenderedMessage
MessageHtml ByteString
b)


sendTrigger :: (IOE :> es) => Connection -> Request -> TargetViewId -> Encoded -> Eff es ()
sendTrigger :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> TargetViewId -> Encoded -> Eff es ()
sendTrigger Connection
conn Request
req TargetViewId
vid Encoded
act = do
  Command -> Connection -> Request -> Remote -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Command -> Connection -> Request -> Remote -> Eff es ()
sendRemote Command
"TRIGGER" Connection
conn Request
req (Remote -> Eff es ()) -> Remote -> Eff es ()
forall a b. (a -> b) -> a -> b
$ TargetViewId -> Encoded -> Remote
RemoteAction TargetViewId
vid Encoded
act


sendEvent :: (IOE :> es) => Connection -> Request -> Text -> Value -> Eff es ()
sendEvent :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Request -> Text -> Value -> Eff es ()
sendEvent Connection
conn Request
req Text
nm Value
val = do
  Command -> Connection -> Request -> Remote -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Command -> Connection -> Request -> Remote -> Eff es ()
sendRemote Command
"EVENT" Connection
conn Request
req (Remote -> Eff es ()) -> Remote -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Remote
RemoteEvent Text
nm Value
val


sendRedirect :: (IOE :> es) => Connection -> Metadata -> URI -> Eff es ()
sendRedirect :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> URI -> Eff es ()
sendRedirect Connection
conn Metadata
meta URI
u = do
  Command -> Connection -> Metadata -> RenderedMessage -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage Command
"REDIRECT" Connection
conn Metadata
meta (Text -> RenderedMessage
MessageText (Text -> RenderedMessage) -> Text -> RenderedMessage
forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText URI
u)


sendError :: (IOE :> es) => Connection -> Metadata -> ServerError -> Eff es ()
sendError :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> ServerError -> Eff es ()
sendError Connection
conn Metadata
meta (ServerError Text
err (Body ByteString
body)) = do
  Command -> Connection -> Metadata -> RenderedMessage -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage Command
"UPDATE" Connection
conn (Text -> Text -> Metadata
metadata Text
"Error" Text
err Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
meta) (ByteString -> RenderedMessage
MessageHtml ByteString
body)


newtype Command = Command Text
  deriving newtype (String -> Command
(String -> Command) -> IsString Command
forall a. (String -> a) -> IsString a
$cfromString :: String -> Command
fromString :: String -> Command
IsString)


sendRemote :: (IOE :> es) => Command -> Connection -> Request -> Remote -> Eff es ()
sendRemote :: forall (es :: [Effect]).
(IOE :> es) =>
Command -> Connection -> Request -> Remote -> Eff es ()
sendRemote Command
cmd Connection
conn Request
req Remote
remote = do
  Command -> Connection -> Metadata -> RenderedMessage -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage Command
cmd Connection
conn (Request -> Metadata
requestMetadata Request
req Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Remote -> Metadata
metaRemote Remote
remote) RenderedMessage
MessageNone


-- low level message. Use sendResponse
sendMessage :: (MonadIO m) => Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage :: forall (m :: * -> *).
MonadIO m =>
Command -> Connection -> Metadata -> RenderedMessage -> m ()
sendMessage (Command Text
cmd) Connection
conn Metadata
meta' RenderedMessage
msg = do
  let header :: ByteString
header = ByteString
"|" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
cmd ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"|\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Metadata -> Text
renderMetadata Metadata
meta')

  let body :: ByteString
body = case RenderedMessage
msg of
        MessageHtml ByteString
html -> ByteString
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
html
        MessageText Text
t -> ByteString
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
t
        RenderedMessage
MessageNone -> ByteString
""

  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (ByteString
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
body)