{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}

module Web.Hyperbole.Server.Wai where

import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.List qualified as L
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.String.Interpolate (i)
import Effectful
import Effectful.Exception (throwIO)
import Network.HTTP.Types (Header, HeaderName, status200, status400, status401, status404, status500)
import Network.Wai qualified as Wai
import Network.Wai.Internal (ResponseReceived (..))
import Web.Atomic (att, (@))
import Web.Cookie qualified
import Web.Hyperbole.Data.Cookie (Cookie, Cookies)
import Web.Hyperbole.Data.Cookie qualified as Cookie
import Web.Hyperbole.Data.Encoded (Encoded, encodedParseText)
import Web.Hyperbole.Data.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
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response
import Web.Hyperbole.View (View, addContext, renderLazyByteString, script', type_)


handleRequestWai
  :: (IOE :> es)
  => ServerOptions
  -> Wai.Request
  -> (Wai.Response -> IO ResponseReceived)
  -> Eff (Hyperbole : es) Response
  -> Eff es Wai.ResponseReceived
handleRequestWai :: forall (es :: [Effect]).
(IOE :> es) =>
ServerOptions
-> Request
-> (Response -> IO ResponseReceived)
-> Eff (Hyperbole : es) Response
-> Eff es ResponseReceived
handleRequestWai ServerOptions
options Request
req Response -> IO ResponseReceived
respond Eff (Hyperbole : es) Response
actions = do
  -- NOTE: Remember, this is called for both updates AND for page loads
  ByteString
body <- IO ByteString -> Eff es ByteString
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Eff es ByteString)
-> IO ByteString -> Eff es ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.consumeRequestBodyLazy Request
req
  Request
rq <- (MessageError -> Eff es Request)
-> (Request -> Eff es Request)
-> Either MessageError Request
-> Eff es Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MessageError -> Eff es Request
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO Request -> Eff es Request
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MessageError Request -> Eff es Request)
-> Either MessageError Request -> Eff es Request
forall a b. (a -> b) -> a -> b
$ do
    Request -> ByteString -> Either MessageError Request
fromWaiRequest Request
req ByteString
body
  (Response
res, Client
client, [Remote]
rmts) <- 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
rq Eff (Hyperbole : es) Response
actions
  IO ResponseReceived -> Eff es ResponseReceived
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Eff es ResponseReceived)
-> IO ResponseReceived -> Eff es ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerOptions
-> Request
-> Client
-> Response
-> [Remote]
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
sendResponse ServerOptions
options Request
rq Client
client Response
res [Remote]
rmts Response -> IO ResponseReceived
respond


sendResponse :: ServerOptions -> Request -> Client -> Response -> [Remote] -> (Wai.Response -> IO ResponseReceived) -> IO Wai.ResponseReceived
sendResponse :: ServerOptions
-> Request
-> Client
-> Response
-> [Remote]
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
sendResponse ServerOptions
options Request
req Client
client Response
res [Remote]
remotes Response -> IO ResponseReceived
respond = do
  let metas :: Metadata
metas = Request -> Metadata
requestMetadata Request
req Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Path -> Client -> [Remote] -> Metadata
responseMetadata Request
req.path Client
client [Remote]
remotes
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Metadata -> Response -> Response
response Metadata
metas Response
res
 where
  response :: Metadata -> Response -> Wai.Response
  response :: Metadata -> Response -> Response
response Metadata
metas = \case
    (Err ResponseError
err) ->
      Status -> [Header] -> ServerError -> Response
forall {r}.
(HasField "message" r Text, HasField "body" r (View Body ())) =>
Status -> [Header] -> r -> Response
respondError (ResponseError -> Status
errStatus ResponseError
err) [] (ServerError -> Response) -> ServerError -> Response
forall a b. (a -> b) -> a -> b
$ ServerOptions
options.serverError ResponseError
err
    (Response TargetViewId
_ View Body ()
vw) -> do
      Status -> [Header] -> ByteString -> Response
respondHtml Status
status200 (Client -> [Header]
clientHeaders Client
client) (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> View Body () -> ByteString
renderViewResponse Metadata
metas View Body ()
vw
    (Redirect URI
u) -> do
      let url :: Text
url = URI -> Text
uriToText URI
u
      -- We have to use a 200 javascript redirect because javascript
      -- will redirect the fetch(), while we want to redirect the whole page
      -- see index.ts sendAction()
      let hs :: [Header]
hs = (HeaderName
"Location", Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
url) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: Client -> [Header]
clientHeaders Client
client
      Status -> [Header] -> ByteString -> Response
respondHtml Status
status200 [Header]
hs (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> View Body () -> ByteString
renderViewResponse (URI -> Metadata
metaRedirect URI
u Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
metas) (View Body () -> ByteString) -> View Body () -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> View Body ()
forall c. ByteString -> View c ()
script'
          -- static script is safe to execute
          [i|
            let metaInput = document.getElementById("hyp.metadata").innerText;
            let meta = Hyperbole.parseMetadata(metaInput)
            if (meta.redirect) {
              window.location = meta.redirect
            }
            else {
              console.error("Invalid Redirect", meta.rediect)
            }
          |]

  errStatus :: ResponseError -> Status
errStatus = \case
    ResponseError
NotFound -> Status
status404
    ErrParse String
_ -> Status
status400
    ErrQuery String
_ -> Status
status400
    ErrSession Text
_ String
_ -> Status
status400
    ErrAuth Text
_ -> Status
status401
    ResponseError
_ -> Status
status500

  -- convert to document if full page request
  addDocument :: BL.ByteString -> BL.ByteString
  addDocument :: ByteString -> ByteString
addDocument ByteString
body =
    case Request
req.event of
      Maybe (Event TargetViewId Encoded)
Nothing -> ServerOptions
options.toDocument ByteString
body
      Maybe (Event TargetViewId Encoded)
_ -> ByteString
body

  renderViewResponse :: Metadata -> View Body () -> BL.ByteString
  renderViewResponse :: Metadata -> View Body () -> ByteString
renderViewResponse Metadata
metas View Body ()
vw =
    ByteString -> ByteString
addDocument (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString (Metadata -> View Metadata () -> View () ()
forall ctx c. ctx -> View ctx () -> View c ()
addContext Metadata
metas (View Metadata () -> View () ()) -> View Metadata () -> View () ()
forall a b. (a -> b) -> a -> b
$ Metadata -> View Metadata ()
scriptMeta Metadata
metas) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> View () () -> ByteString
renderLazyByteString (Body -> View Body () -> View () ()
forall ctx c. ctx -> View ctx () -> View c ()
addContext Body
Body View Body ()
vw)

  respondError :: Status -> [Header] -> r -> Response
respondError Status
s [Header]
hs r
serr = Status -> [Header] -> ByteString -> Response
respondHtml Status
s [Header]
hs (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> View Body () -> ByteString
renderViewResponse (Text -> Metadata
metaError r
serr.message) r
serr.body
  respondHtml :: Status -> [Header] -> ByteString -> Response
respondHtml Status
s [Header]
hs = Status -> [Header] -> ByteString -> Response
Wai.responseLBS Status
s (ContentType -> Header
contentType ContentType
ContentHtml Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
hs)
  -- respondText s hs = Wai.responseLBS s (contentType ContentText : hs)

  -- via HTTP, we want to manually set some headers rather than just rely on the client
  clientHeaders :: Client -> [Header]
  clientHeaders :: Client -> [Header]
clientHeaders = Client -> [Header]
forall {r}. HasField "session" r Cookies => r -> [Header]
setCookies
   where
    setCookies :: r -> [Header]
setCookies r
clnt =
      (Cookie -> Header) -> [Cookie] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> Header
setCookie ([Cookie] -> [Header]) -> [Cookie] -> [Header]
forall a b. (a -> b) -> a -> b
$ Cookies -> [Cookie]
Cookie.toList r
clnt.session

    setCookie :: Cookie -> (HeaderName, BS.ByteString)
    setCookie :: Cookie -> Header
setCookie Cookie
cookie =
      (HeaderName
"Set-Cookie", Path -> Cookie -> ByteString
Cookie.render Request
req.path Cookie
cookie)


scriptMeta :: Metadata -> View Metadata ()
scriptMeta :: Metadata -> View Metadata ()
scriptMeta Metadata
m =
  ByteString -> View Metadata ()
forall c. ByteString -> View c ()
script' (ByteString -> View Metadata ())
-> (Attributes (ByteString -> View Metadata ())
    -> Attributes (ByteString -> View Metadata ()))
-> ByteString
-> View Metadata ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
type_ Text
"application/hyp.metadata" (Attributes (ByteString -> View Metadata ())
 -> Attributes (ByteString -> View Metadata ()))
-> (Attributes (ByteString -> View Metadata ())
    -> Attributes (ByteString -> View Metadata ()))
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Text
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"id" Text
"hyp.metadata" (ByteString -> View Metadata ()) -> ByteString -> View Metadata ()
forall a b. (a -> b) -> a -> b
$
    Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
      Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Metadata -> Text
renderMetadata Metadata
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"


messageFromBody :: BL.ByteString -> Either MessageError Message
messageFromBody :: ByteString -> Either MessageError Message
messageFromBody ByteString
inp = do
  (String -> MessageError)
-> Either String Message -> Either MessageError Message
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 (\String
e -> String -> Text -> MessageError
InvalidMessage String
e (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
inp)) (Either String Message -> Either MessageError Message)
-> Either String Message -> Either MessageError Message
forall a b. (a -> b) -> a -> b
$ Text -> Either String Message
parseActionMessage (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
inp)


fromWaiRequest :: Wai.Request -> BL.ByteString -> Either MessageError Request
fromWaiRequest :: Request -> ByteString -> Either MessageError Request
fromWaiRequest Request
wr ByteString
body = 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
wr
      query :: Query
query = Request -> Query
Wai.queryString Request
wr
      headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
wr
      cookie :: ByteString
cookie = 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 -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Cookie" [Header]
headers
      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 -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Host" [Header]
headers
      requestId :: RequestId
requestId = Text -> RequestId
RequestId (Text -> RequestId) -> Text -> RequestId
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
$ 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 -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-RequestId" [Header]
headers
      method :: ByteString
method = Request -> ByteString
Wai.requestMethod Request
wr
      event :: Maybe (Event TargetViewId Encoded)
event = [Header] -> Maybe (Event TargetViewId Encoded)
lookupEvent [Header]
headers

  Cookies
cookies <- ByteString -> Either MessageError Cookies
fromCookieHeader 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:body:Request :: ByteString
body = ByteString
body
      , $sel:path:Request :: Path
path = Path
pth
      , Maybe (Event TargetViewId Encoded)
event :: Maybe (Event TargetViewId Encoded)
$sel:event:Request :: Maybe (Event TargetViewId Encoded)
event
      , Query
query :: Query
$sel:query:Request :: Query
query
      , ByteString
method :: ByteString
$sel:method:Request :: ByteString
method
      , Cookies
cookies :: Cookies
$sel:cookies:Request :: Cookies
cookies
      , Host
host :: Host
$sel:host:Request :: Host
host
      , RequestId
requestId :: RequestId
$sel:requestId:Request :: RequestId
requestId
      }
 where
  lookupEvent :: [Header] -> Maybe (Event TargetViewId Encoded)
  lookupEvent :: [Header] -> Maybe (Event TargetViewId Encoded)
lookupEvent [Header]
headers = do
    TargetViewId
viewId <- Text -> TargetViewId
TargetViewId (Text -> TargetViewId)
-> (ByteString -> Text) -> ByteString -> TargetViewId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> TargetViewId)
-> Maybe ByteString -> Maybe TargetViewId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-ViewId" [Header]
headers
    Text
actText <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-Action" [Header]
headers
    case Text -> Either String Encoded
encodedParseText Text
actText of
      Left String
_ -> Maybe (Event TargetViewId Encoded)
forall a. Maybe a
Nothing
      Right Encoded
a -> Event TargetViewId Encoded -> Maybe (Event TargetViewId Encoded)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event TargetViewId Encoded -> Maybe (Event TargetViewId Encoded))
-> Event TargetViewId Encoded -> Maybe (Event TargetViewId Encoded)
forall a b. (a -> b) -> a -> b
$ TargetViewId -> Encoded -> Event TargetViewId Encoded
forall id act. id -> act -> Event id act
Event TargetViewId
viewId Encoded
a


-- Client only returns ONE Cookie header, with everything concatenated
fromCookieHeader :: BS.ByteString -> Either MessageError Cookies
fromCookieHeader :: ByteString -> Either MessageError Cookies
fromCookieHeader ByteString
h =
  case [(ByteString, ByteString)] -> Either String Cookies
Cookie.parse (ByteString -> [(ByteString, ByteString)]
Web.Cookie.parseCookies ByteString
h) of
    Left String
err -> MessageError -> Either MessageError Cookies
forall a b. a -> Either a b
Left (MessageError -> Either MessageError Cookies)
-> MessageError -> Either MessageError Cookies
forall a b. (a -> b) -> a -> b
$ ByteString -> String -> MessageError
InvalidCookie ByteString
h String
err
    Right Cookies
a -> Cookies -> Either MessageError Cookies
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cookies
a


contentType :: ContentType -> (HeaderName, BS.ByteString)
contentType :: ContentType -> Header
contentType ContentType
ContentHtml = (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
contentType ContentType
ContentText = (HeaderName
"Content-Type", ByteString
"text/plain; charset=utf-8")