{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Socket where

import Control.Monad (void)
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 (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 Effectful.Writer.Static.Local (tell)
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, 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]))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> 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) ((forall {a} {localEs :: [Effect]}.
  (HasCallStack, Hyperbole :> localEs) =>
  LocalEnv
    localEs (Error Response : State Client : Writer [Remote] : es)
  -> Hyperbole (Eff localEs) a
  -> Eff (Error Response : State Client : Writer [Remote] : es) a)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Response, Client, [Remote]))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> 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
  PushUpdate (ViewUpdate TargetViewId
vid Body
vw) -> do
    Connection
-> Metadata
-> Body
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> Body -> Eff es ()
sendUpdate Connection
conn (TargetViewId -> Metadata
targetViewMetadata TargetViewId
vid Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Request -> Metadata
requestMetadata Request
req) Body
vw
  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
  TriggerAction TargetViewId
vid Encoded
act -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [Effect]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [TargetViewId -> Encoded -> Remote
RemoteAction TargetViewId
vid Encoded
act]
  TriggerEvent Text
name Value
dat -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [Effect]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [Text -> Value -> Remote
RemoteEvent 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
    Message
msg <- Eff es Message
forall (es :: [Effect]). (IOE :> es) => Eff es Message
receiveMessage
    Request
req <- Message -> Eff es Request
forall (es :: [Effect]). (IOE :> es) => Message -> Eff es Request
parseMessageRequest Message
msg

    Async ()
a <- Eff es () -> Eff es (Async ())
forall (es :: [Effect]) a.
(HasCallStack, Concurrent :> es) =>
Eff es a -> Eff es (Async a)
async (Eff es () -> Eff es (Async ())) -> Eff es () -> Eff es (Async ())
forall a b. (a -> b) -> a -> b
$ do
      -- is one already running?
      Either SomeException (Response, Client, [Remote])
res <- Eff es (Response, Client, [Remote])
-> Eff es (Either SomeException (Response, Client, [Remote]))
forall (es :: [Effect]) a.
Eff es a -> Eff es (Either SomeException a)
trySync (Eff es (Response, Client, [Remote])
 -> Eff es (Either SomeException (Response, Client, [Remote])))
-> Eff es (Response, Client, [Remote])
-> Eff es (Either SomeException (Response, Client, [Remote]))
forall a b. (a -> b) -> a -> b
$ ServerOptions
-> Connection
-> Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
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 (Hyperbole : es) Response
eff
      case Either SomeException (Response, Client, [Remote])
res of
        -- TODO: catch socket errors separately from SomeException?
        Left (SomeException
ex :: SomeException) -> do
          -- It's not safe to send any exception 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
          Either SomeException ()
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 Either SomeException ()
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

    Async ()
-> RequestId
-> Maybe (Event TargetViewId Encoded Encoded)
-> Eff es ()
forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
Async ()
-> RequestId
-> Maybe (Event TargetViewId Encoded Encoded)
-> Eff es ()
addRunningAction Async ()
a Request
req.requestId Request
req.event

    Eff es (Async ()) -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff es (Async ()) -> Eff es ()) -> Eff es (Async ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Eff es () -> Eff es (Async ())
forall (es :: [Effect]) a.
(HasCallStack, Concurrent :> es) =>
Eff es a -> Eff es (Async a)
async (Eff es () -> Eff es (Async ())) -> Eff es () -> Eff es (Async ())
forall a b. (a -> b) -> a -> b
$ do
      Either SomeException ()
_ <- Async () -> Eff es (Either SomeException ())
forall (es :: [Effect]) a.
(Concurrent :> es) =>
Async a -> Eff es (Either SomeException a)
waitCatch Async ()
a
      RequestId
-> Maybe (Event TargetViewId Encoded Encoded) -> Eff es ()
forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
RequestId
-> Maybe (Event TargetViewId Encoded Encoded) -> Eff es ()
clearRunningAction Request
req.requestId Request
req.event
 where
  addRunningAction :: (IOE :> es, Concurrent :> es) => Async () -> RequestId -> Maybe (Event TargetViewId Encoded Encoded) -> Eff es ()
  addRunningAction :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
Async ()
-> RequestId
-> Maybe (Event TargetViewId Encoded Encoded)
-> Eff es ()
addRunningAction Async ()
a (RequestId Text
reqId) = \case
    Maybe (Event TargetViewId Encoded Encoded)
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Event TargetViewId
vid Encoded
act Encoded
_) -> do
      -- liftIO $ putStrLn $ " [add] (" <> cs reqId <> ") " <> cs clientId.value <> "|" <> show vid
      Maybe (Encoded, Async ())
maold <- STM (Maybe (Encoded, Async ()))
-> Eff es (Maybe (Encoded, Async ()))
forall (es :: [Effect]) a. (Concurrent :> es) => STM a -> Eff es a
atomically (STM (Maybe (Encoded, Async ()))
 -> Eff es (Maybe (Encoded, Async ())))
-> STM (Maybe (Encoded, Async ()))
-> Eff es (Maybe (Encoded, Async ()))
forall a b. (a -> b) -> a -> b
$ do
        RunningActions
m <- forall a. TVar a -> STM a
readTVar @RunningActions TVar RunningActions
actions
        TVar RunningActions -> RunningActions -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar RunningActions
actions (RunningActions -> STM ()) -> RunningActions -> STM ()
forall a b. (a -> b) -> a -> b
$ TargetViewId
-> (Encoded, Async ()) -> RunningActions -> RunningActions
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TargetViewId
vid (Encoded
act, Async ()
a) RunningActions
m
        Maybe (Encoded, Async ()) -> STM (Maybe (Encoded, Async ()))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Encoded, Async ()) -> STM (Maybe (Encoded, Async ())))
-> Maybe (Encoded, Async ()) -> STM (Maybe (Encoded, Async ()))
forall a b. (a -> b) -> a -> b
$ TargetViewId -> RunningActions -> Maybe (Encoded, Async ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TargetViewId
vid RunningActions
m
      case Maybe (Encoded, Async ())
maold of
        Maybe (Encoded, Async ())
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (Encoded
actold, 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
reqId 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 Encoded) -> Eff es ()
  clearRunningAction :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
RequestId
-> Maybe (Event TargetViewId Encoded Encoded) -> Eff es ()
clearRunningAction (RequestId Text
_) = \case
    Maybe (Event TargetViewId Encoded Encoded)
Nothing -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Event TargetViewId
vid Encoded
_ Encoded
_) -> do
      ()
_ <- 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
$ TVar RunningActions -> (RunningActions -> RunningActions) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar RunningActions
actions ((RunningActions -> RunningActions) -> STM ())
-> (RunningActions -> RunningActions) -> STM ()
forall a b. (a -> b) -> a -> b
$ TargetViewId -> RunningActions -> RunningActions
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TargetViewId
vid
      () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  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
    Text
t <- Connection -> Eff es Text
forall (es :: [Effect]). (IOE :> es) => Connection -> Eff es Text
receiveText Connection
conn
    case Text -> Either String Message
parseActionMessage Text
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"

        body :: ByteString
body = Message
msg.body.value

    Query
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
    ByteString
cookie <- Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString)
-> Either MessageError Text -> Either MessageError ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Metadata -> Either MessageError Text
requireMeta Text
"Cookie" Message
msg.metadata

    Cookies
cookies <- (String -> MessageError)
-> Either String Cookies -> Either MessageError Cookies
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> String -> MessageError
InvalidCookie ByteString
cookie) (Either String Cookies -> Either MessageError Cookies)
-> (Cookies -> Either String Cookies)
-> Cookies
-> Either MessageError Cookies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cookies -> Either String Cookies
Cookie.parse (Cookies -> Either MessageError Cookies)
-> Cookies -> Either MessageError Cookies
forall a b. (a -> b) -> a -> b
$ ByteString -> Cookies
Web.Cookie.parseCookies ByteString
cookie

    Request -> Either MessageError Request
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Either MessageError Request)
-> Request -> Either MessageError Request
forall a b. (a -> b) -> a -> b
$
      Request
        { $sel:path:Request :: Path
path = Path
pth
        , $sel:event:Request :: Maybe (Event TargetViewId Encoded Encoded)
event = Event TargetViewId Encoded Encoded
-> Maybe (Event TargetViewId Encoded Encoded)
forall a. a -> Maybe a
Just Message
msg.event
        , Host
host :: Host
$sel:host:Request :: Host
host
        , Query
query :: Query
$sel:query:Request :: Query
query
        , ByteString
body :: ByteString
$sel:body:Request :: ByteString
body
        , ByteString
method :: ByteString
$sel:method:Request :: ByteString
method
        , Cookies
cookies :: Cookies
$sel:cookies:Request :: Cookies
cookies
        , $sel:requestId:Request :: RequestId
requestId = Message
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 -> Metadata -> Body -> Eff es ()
sendUpdate :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> Body -> Eff es ()
sendUpdate 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
"UPDATE" Connection
conn Metadata
meta (ByteString -> RenderedMessage
MessageHtml ByteString
b)


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)


-- 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
html
        MessageText Text
t -> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
t

  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
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
body)