content: {-# 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 options req respond actions = do
    -- NOTE: Remember, this is called for both updates AND for page loads
    body <- liftIO $ Wai.consumeRequestBodyLazy req
    rq <- either throwIO pure $ do
      fromWaiRequest req body
    (res, client, rmts) <- runHyperbole rq actions
    liftIO $ sendResponse options rq client res rmts respond
  
  
  sendResponse :: ServerOptions -> Request -> Client -> Response -> [Remote] -> (Wai.Response -> IO ResponseReceived) -> IO Wai.ResponseReceived
  sendResponse options req client res remotes respond = do
    let metas = requestMetadata req <> responseMetadata req.path client remotes
    respond $ response metas res
   where
    response :: Metadata -> Response -> Wai.Response
    response metas = \case
      (Err err) ->
        respondError (errStatus err) [] $ options.serverError err
      (Response _ vw) -> do
        respondHtml status200 (clientHeaders client) $ renderViewResponse metas vw
      (Redirect u) -> do
        let url = uriToText 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 = ("Location", cs url) : clientHeaders client
        respondHtml status200 hs $ renderViewResponse (metaRedirect u <> metas) $ do
          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 = \case
      NotFound -> status404
      ErrParse _ -> status400
      ErrQuery _ -> status400
      ErrSession _ _ -> status400
      ErrAuth _ -> status401
      _ -> status500
  
    -- convert to document if full page request
    addDocument :: BL.ByteString -> BL.ByteString
    addDocument body =
      case req.event of
        Nothing -> options.toDocument body
        _ -> body
  
    renderViewResponse :: Metadata -> View Body () -> BL.ByteString
    renderViewResponse metas vw =
      addDocument $ renderLazyByteString (addContext metas $ scriptMeta metas) <> "\n\n" <> renderLazyByteString (addContext Body vw)
  
    respondError s hs serr = respondHtml s hs $ renderViewResponse (metaError serr.message) serr.body
    respondHtml s hs = Wai.responseLBS s (contentType ContentHtml : 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 = setCookies
     where
      setCookies clnt =
        fmap setCookie $ Cookie.toList clnt.session
  
      setCookie :: Cookie -> (HeaderName, BS.ByteString)
      setCookie cookie =
        ("Set-Cookie", Cookie.render req.path cookie)
  
  
  scriptMeta :: Metadata -> View Metadata ()
  scriptMeta m =
    script' @ type_ "application/hyp.metadata" . att "id" "hyp.metadata" $
      cs $
        "\n" <> renderMetadata m <> "\n"
  
  
  messageFromBody :: BL.ByteString -> Either MessageError Message
  messageFromBody inp = do
    first (\e -> InvalidMessage e (cs inp)) $ parseActionMessage (cs inp)
  
  
  fromWaiRequest :: Wai.Request -> BL.ByteString -> Either MessageError Request
  fromWaiRequest wr body = do
    let pth = path $ cs $ Wai.rawPathInfo wr
        query = Wai.queryString wr
        headers = Wai.requestHeaders wr
        cookie = fromMaybe "" $ L.lookup "Cookie" headers
        host = Host $ fromMaybe "" $ L.lookup "Host" headers
        requestId = RequestId $ cs $ fromMaybe "" $ L.lookup "Hyp-RequestId" headers
        method = Wai.requestMethod wr
        event = lookupEvent headers
  
    cookies <- fromCookieHeader cookie
  
    pure $
      Request
        { body = body
        , path = pth
        , event
        , query
        , method
        , cookies
        , host
        , requestId
        }
   where
    lookupEvent :: [Header] -> Maybe (Event TargetViewId Encoded)
    lookupEvent headers = do
      viewId <- TargetViewId . cs <$> L.lookup "Hyp-ViewId" headers
      actText <- cs <$> L.lookup "Hyp-Action" headers
      case encodedParseText actText of
        Left _ -> Nothing
        Right a -> pure $ Event viewId a
  
  
  -- Client only returns ONE Cookie header, with everything concatenated
  fromCookieHeader :: BS.ByteString -> Either MessageError Cookies
  fromCookieHeader h =
    case Cookie.parse (Web.Cookie.parseCookies h) of
      Left err -> Left $ InvalidCookie h err
      Right a -> pure a
  
  
  contentType :: ContentType -> (HeaderName, BS.ByteString)
  contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")
  contentType ContentText = ("Content-Type", "text/plain; charset=utf-8")
  