module Web.Hyperbole.Server.Socket where

import Control.Monad (void)
import Data.Bifunctor (first)
import Data.List qualified as L
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Effectful
import Effectful.Concurrent.Async
import Effectful.Exception
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.URI (URI, path)
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Server.Message
import Web.Hyperbole.Server.Options
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response
import Web.Hyperbole.View (View, addContext, renderLazyByteString)


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


handleRequestSocket
  :: (IOE :> es, Concurrent :> es)
  => ServerOptions
  -> Wai.Request
  -> Connection
  -> Eff (Hyperbole : es) Response
  -> Eff es ()
handleRequestSocket :: forall (es :: [Effect]).
(IOE :> es, Concurrent :> es) =>
ServerOptions
-> Request
-> Connection
-> Eff (Hyperbole : es) Response
-> Eff es ()
handleRequestSocket ServerOptions
opts Request
wreq Connection
conn Eff (Hyperbole : es) Response
actions = 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

    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 (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
$ Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall (es :: [Effect]).
Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
runHyperbole Request
req Eff (Hyperbole : es) Response
actions
      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 TargetViewId
_ View Body ()
vw) -> do
              Connection -> Metadata -> View Body () -> Eff es ()
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> View Body () -> Eff es ()
sendUpdateView Connection
conn Metadata
meta View Body ()
vw
            -- (Err (ErrServer m)) -> sendError conn meta (opts.serverError m)
            (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
 where
  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
    MetaKey
t <- Connection -> Eff es MetaKey
forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Eff es MetaKey
receiveText Connection
conn
    case MetaKey -> Either String Message
parseActionMessage MetaKey
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 -> MetaKey -> MessageError
InvalidMessage String
e MetaKey
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 MetaKey
receiveText Connection
_ = do
    -- c <- ask @Connection
    IO MetaKey -> Eff es MetaKey
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MetaKey -> Eff es MetaKey) -> IO MetaKey -> Eff es MetaKey
forall a b. (a -> b) -> a -> b
$ Connection -> IO MetaKey
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 = MetaKey -> Path
path (MetaKey -> Path) -> MetaKey -> Path
forall a b. (a -> b) -> a -> b
$ ByteString -> MetaKey
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> MetaKey) -> ByteString -> MetaKey
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)
-> (MetaKey -> ByteString) -> MetaKey -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaKey -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (MetaKey -> Query)
-> Either MessageError MetaKey -> Either MessageError Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaKey -> Metadata -> Either MessageError MetaKey
requireMeta MetaKey
"Query" Message
msg.metadata
    ByteString
cookie <- MetaKey -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (MetaKey -> ByteString)
-> Either MessageError MetaKey -> Either MessageError ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaKey -> Metadata -> Either MessageError MetaKey
requireMeta MetaKey
"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)
event = Event TargetViewId Encoded -> Maybe (Event TargetViewId 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 :: MetaKey -> Metadata -> Either MessageError MetaKey
requireMeta MetaKey
key Metadata
m =
      Either MessageError MetaKey
-> (MetaKey -> Either MessageError MetaKey)
-> Maybe MetaKey
-> Either MessageError MetaKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MessageError -> Either MessageError MetaKey
forall a b. a -> Either a b
Left (MessageError -> Either MessageError MetaKey)
-> MessageError -> Either MessageError MetaKey
forall a b. (a -> b) -> a -> b
$ String -> MessageError
MissingMeta (MetaKey -> String
forall a b. ConvertibleStrings a b => a -> b
cs MetaKey
key)) MetaKey -> Either MessageError MetaKey
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MetaKey -> Either MessageError MetaKey)
-> Maybe MetaKey -> Either MessageError MetaKey
forall a b. (a -> b) -> a -> b
$ MetaKey -> Metadata -> Maybe MetaKey
lookupMetadata MetaKey
key Metadata
m


sendUpdateView :: (IOE :> es) => Connection -> Metadata -> View Body () -> Eff es ()
sendUpdateView :: forall (es :: [Effect]).
(IOE :> es) =>
Connection -> Metadata -> View Body () -> Eff es ()
sendUpdateView Connection
conn Metadata
meta View Body ()
vw = do
  Connection -> Metadata -> RenderedHtml -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Connection -> Metadata -> RenderedHtml -> m ()
sendMessage Connection
conn Metadata
meta (ByteString -> RenderedHtml
RenderedHtml (ByteString -> RenderedHtml) -> ByteString -> RenderedHtml
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString (View () () -> ByteString) -> View () () -> ByteString
forall a b. (a -> b) -> a -> b
$ Body -> View Body () -> View () ()
forall ctx c. ctx -> View ctx () -> View c ()
addContext Body
Body View Body ()
vw)


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
  Connection -> Metadata -> RenderedHtml -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Connection -> Metadata -> RenderedHtml -> m ()
sendMessage Connection
conn (URI -> Metadata
metaRedirect URI
u Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
meta) RenderedHtml
forall a. Monoid a => a
mempty


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 MetaKey
err View Body ()
body) = do
  Connection -> Metadata -> RenderedHtml -> Eff es ()
forall (m :: * -> *).
MonadIO m =>
Connection -> Metadata -> RenderedHtml -> m ()
sendMessage Connection
conn (MetaKey -> MetaKey -> Metadata
metadata MetaKey
"Error" MetaKey
err Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
meta) (ByteString -> RenderedHtml
RenderedHtml (ByteString -> RenderedHtml) -> ByteString -> RenderedHtml
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString (View () () -> ByteString) -> View () () -> ByteString
forall a b. (a -> b) -> a -> b
$ Body -> View Body () -> View () ()
forall ctx c. ctx -> View ctx () -> View c ()
addContext Body
Body View Body ()
body)


-- low level message. Use sendResponse
sendMessage :: (MonadIO m) => Connection -> Metadata -> RenderedHtml -> m ()
sendMessage :: forall (m :: * -> *).
MonadIO m =>
Connection -> Metadata -> RenderedHtml -> m ()
sendMessage Connection
conn Metadata
meta' (RenderedHtml ByteString
html) = do
  let out :: ByteString
out = ByteString
"|UPDATE|\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> MetaKey -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Metadata -> MetaKey
renderMetadata Metadata
meta') ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
html
  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
out