{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Effect.Server where

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.Text (Text, pack)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.State.Static.Local
import Network.HTTP.Types (HeaderName, Method, Query, status200, status400, status401, status404, status500, urlDecode, urlEncode)
import Network.Wai qualified as Wai
import Network.Wai.Internal (ResponseReceived (..))
import Network.WebSockets (Connection)
import Network.WebSockets qualified as WS
import Web.Cookie (parseCookies)
import Web.Hyperbole.Data.QueryData as QueryData
import Web.Hyperbole.Data.Session as Cookies
import Web.Hyperbole.Route
import Web.View (Segment, View, renderLazyByteString, renderUrl)


-- | Low level effect mapping request/response to either HTTP or WebSockets
data Server :: Effect where
  LoadRequest :: Server m Request
  SendResponse :: Client -> Response -> Server m ()


type instance DispatchOf Server = 'Dynamic


runServerWai
  :: (IOE :> es)
  => (BL.ByteString -> BL.ByteString)
  -> Wai.Request
  -> (Wai.Response -> IO ResponseReceived)
  -> Eff (Server : es) a
  -> Eff es (Maybe Wai.ResponseReceived)
runServerWai :: forall (es :: [Effect]) a.
(IOE :> es) =>
(ByteString -> ByteString)
-> Request
-> (Response -> IO ResponseReceived)
-> Eff (Server : es) a
-> Eff es (Maybe ResponseReceived)
runServerWai ByteString -> ByteString
toDoc Request
req Response -> IO ResponseReceived
respond =
  (Eff (State (Maybe ResponseReceived) : es) a
 -> Eff es (Maybe ResponseReceived))
-> EffectHandler Server (State (Maybe ResponseReceived) : es)
-> Eff (Server : es) a
-> Eff es (Maybe ResponseReceived)
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 Eff (State (Maybe ResponseReceived) : es) a
-> Eff es (Maybe ResponseReceived)
forall (es :: [Effect]) a.
(IOE :> es) =>
Eff (State (Maybe ResponseReceived) : es) a
-> Eff es (Maybe ResponseReceived)
runLocal (EffectHandler Server (State (Maybe ResponseReceived) : es)
 -> Eff (Server : es) a -> Eff es (Maybe ResponseReceived))
-> EffectHandler Server (State (Maybe ResponseReceived) : es)
-> Eff (Server : es) a
-> Eff es (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (State (Maybe ResponseReceived) : es)
_ -> \case
    Server (Eff localEs) a
LoadRequest -> do
      Request -> Eff (State (Maybe ResponseReceived) : es) Request
forall (m :: * -> *). MonadIO m => Request -> m Request
fromWaiRequest Request
req
    SendResponse Client
client Response
r -> do
      ResponseReceived
rr <- IO ResponseReceived
-> Eff (State (Maybe ResponseReceived) : es) ResponseReceived
forall a. IO a -> Eff (State (Maybe ResponseReceived) : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived
 -> Eff (State (Maybe ResponseReceived) : es) ResponseReceived)
-> IO ResponseReceived
-> Eff (State (Maybe ResponseReceived) : es) ResponseReceived
forall a b. (a -> b) -> a -> b
$ Client -> Response -> IO ResponseReceived
sendResponse Client
client Response
r
      Maybe ResponseReceived
-> Eff (State (Maybe ResponseReceived) : es) ()
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put (ResponseReceived -> Maybe ResponseReceived
forall a. a -> Maybe a
Just ResponseReceived
rr)
 where
  runLocal :: (IOE :> es) => Eff (State (Maybe ResponseReceived) : es) a -> Eff es (Maybe ResponseReceived)
  runLocal :: forall (es :: [Effect]) a.
(IOE :> es) =>
Eff (State (Maybe ResponseReceived) : es) a
-> Eff es (Maybe ResponseReceived)
runLocal = Maybe ResponseReceived
-> Eff (State (Maybe ResponseReceived) : es) a
-> Eff es (Maybe ResponseReceived)
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es s
execState Maybe ResponseReceived
forall a. Maybe a
Nothing

  sendResponse :: Client -> Response -> IO Wai.ResponseReceived
  sendResponse :: Client -> Response -> IO ResponseReceived
sendResponse Client
client Response
r =
    Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> Response
response Response
r
   where
    response :: Response -> Wai.Response
    response :: Response -> Response
response Response
NotFound = Status -> ByteString -> Response
respError Status
status404 ByteString
"Not Found"
    response Response
Empty = Status -> ByteString -> Response
respError Status
status500 ByteString
"Empty Response"
    response (Err (ErrParse Text
e)) = Status -> ByteString -> Response
respError Status
status400 (ByteString
"Parse Error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
e)
    response (Err (ErrQuery Text
e)) = Status -> ByteString -> Response
respError Status
status400 (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ ByteString
"ErrQuery: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
e
    response (Err (ErrSession Param
param Text
e)) = Status -> ByteString -> Response
respError Status
status400 (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ ByteString
"ErrSession: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Param -> String
forall a. Show a => a -> String
show Param
param) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
e
    response (Err (ErrOther Text
e)) = Status -> ByteString -> Response
respError Status
status500 (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ ByteString
"Server Error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
e
    response (Err ResponseError
ErrAuth) = Status -> ByteString -> Response
respError Status
status401 ByteString
"Unauthorized"
    response (Err (ErrNotHandled Event Text Text
e)) = Status -> ByteString -> Response
respError Status
status400 (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Event Text Text -> String
errNotHandled Event Text Text
e
    response (Response TargetViewId
_ View () ()
vw) =
      ByteString -> Response
respHtml (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
        Method -> ByteString -> ByteString
addDocument (Request -> Method
Wai.requestMethod Request
req) (View () () -> ByteString
renderLazyByteString View () ()
vw)
    response (Redirect Url
u) = do
      let url :: Text
url = Url -> Text
renderUrl Url
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 headers :: [(HeaderName, Method)]
headers = (HeaderName
"Location", Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs Text
url) (HeaderName, Method)
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. a -> [a] -> [a]
: ContentType -> (HeaderName, Method)
contentType ContentType
ContentHtml (HeaderName, Method)
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. a -> [a] -> [a]
: [(HeaderName, Method)]
setCookies
      Status -> [(HeaderName, Method)] -> ByteString -> Response
Wai.responseLBS Status
status200 [(HeaderName, Method)]
headers (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ ByteString
"<script>window.location = '" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
url ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"'</script>"

    respError :: Status -> ByteString -> Response
respError Status
s = Status -> [(HeaderName, Method)] -> ByteString -> Response
Wai.responseLBS Status
s [ContentType -> (HeaderName, Method)
contentType ContentType
ContentText]

    respHtml :: ByteString -> Response
respHtml ByteString
body =
      -- always set the session...
      let headers :: [(HeaderName, Method)]
headers = ContentType -> (HeaderName, Method)
contentType ContentType
ContentHtml (HeaderName, Method)
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. a -> [a] -> [a]
: ([(HeaderName, Method)]
setCookies [(HeaderName, Method)]
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. Semigroup a => a -> a -> a
<> QueryData -> [(HeaderName, Method)]
forall {a}. IsString a => QueryData -> [(a, Method)]
setQuery Client
client.query)
       in Status -> [(HeaderName, Method)] -> ByteString -> Response
Wai.responseLBS Status
status200 [(HeaderName, Method)]
headers ByteString
body

    setCookies :: [(HeaderName, Method)]
setCookies =
      (Cookie -> (HeaderName, Method))
-> [Cookie] -> [(HeaderName, Method)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> (HeaderName, Method)
setCookie ([Cookie] -> [(HeaderName, Method)])
-> [Cookie] -> [(HeaderName, Method)]
forall a b. (a -> b) -> a -> b
$ Cookies -> [Cookie]
Cookies.toList Client
client.session

    setCookie :: Cookie -> (HeaderName, BS.ByteString)
    setCookie :: Cookie -> (HeaderName, Method)
setCookie Cookie
cookie =
      (HeaderName
"Set-Cookie", [Text] -> Cookie -> Method
renderCookie (Request -> [Text]
Wai.pathInfo Request
req) Cookie
cookie)

    setQuery :: QueryData -> [(a, Method)]
setQuery QueryData
qd =
      [(a
"Set-Query", QueryData -> Method
QueryData.render QueryData
qd)]

  -- convert to document if full page request. Subsequent POST requests will only include fragments
  addDocument :: Method -> BL.ByteString -> BL.ByteString
  addDocument :: Method -> ByteString -> ByteString
addDocument Method
"GET" ByteString
bd = ByteString -> ByteString
toDoc ByteString
bd
  addDocument Method
_ ByteString
bd = ByteString
bd

  fromWaiRequest :: (MonadIO m) => Wai.Request -> m Request
  fromWaiRequest :: forall (m :: * -> *). MonadIO m => Request -> m Request
fromWaiRequest Request
wr = do
    ByteString
body <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.consumeRequestBodyLazy Request
wr
    let path :: [Text]
path = Request -> [Text]
Wai.pathInfo Request
wr
        query :: Query
query = Request -> Query
Wai.queryString Request
wr
        headers :: [(HeaderName, Method)]
headers = Request -> [(HeaderName, Method)]
Wai.requestHeaders Request
wr
        cookie :: Method
cookie = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
"" (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Cookie" [(HeaderName, Method)]
headers
        host :: Host
host = Method -> Host
Host (Method -> Host) -> Method -> Host
forall a b. (a -> b) -> a -> b
$ Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
"" (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Host" [(HeaderName, Method)]
headers
        cookies :: Cookies
cookies = [(Method, Method)] -> Cookies
cookiesFromHeader (Method -> [(Method, Method)]
parseCookies Method
cookie)
        method :: Method
method = Request -> Method
Wai.requestMethod Request
wr
    Request -> m Request
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request{ByteString
body :: ByteString
body :: ByteString
body, [Text]
path :: [Text]
path :: [Text]
path, Query
query :: Query
query :: Query
query, Method
method :: Method
method :: Method
method, Cookies
cookies :: Cookies
cookies :: Cookies
cookies, Host
host :: Host
host :: Host
host}


renderCookie :: [Segment] -> Cookie -> BS.ByteString
renderCookie :: [Text] -> Cookie -> Method
renderCookie [Text]
requestPath Cookie
cookie =
  let path :: [Text]
path = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [Text]
requestPath Cookie
cookie.path
   in Method
key Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
"=" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Maybe ParamValue -> Method
forall {a} {r}.
(ConvertibleStrings a Method, HasField "text" r a) =>
Maybe r -> Method
value Cookie
cookie.value Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
"; SameSite=None; secure; path=" Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs (Url -> Text
renderUrl ([Text] -> Url
pathUrl [Text]
path))
 where
  key :: Method
key = Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs Cookie
cookie.key.text
  value :: Maybe r -> Method
value Maybe r
Nothing = Method
"; expires=Thu, 01 Jan 1970 00:00:00 GMT"
  value (Just r
val) = Bool -> Method -> Method
urlEncode Bool
True (a -> Method
forall a b. ConvertibleStrings a b => a -> b
cs r
val.text)


cookiesFromHeader :: [(BS.ByteString, BS.ByteString)] -> Cookies
cookiesFromHeader :: [(Method, Method)] -> Cookies
cookiesFromHeader [(Method, Method)]
cks = do
  [Cookie] -> Cookies
Cookies.fromList ([Cookie] -> Cookies) -> [Cookie] -> Cookies
forall a b. (a -> b) -> a -> b
$ ((Method, Method) -> Cookie) -> [(Method, Method)] -> [Cookie]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Method, Method) -> Cookie
forall {a}. ConvertibleStrings a Text => (a, Method) -> Cookie
toCookie [(Method, Method)]
cks
 where
  toCookie :: (a, Method) -> Cookie
toCookie (a
k, Method
v) =
    let value :: ParamValue
value = Text -> ParamValue
ParamValue (Method -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Method -> Method
urlDecode Bool
True Method
v)
        key :: Param
key = Text -> Param
Param (a -> Text
forall a b. ConvertibleStrings a b => a -> b
cs a
k)
     in Param -> Maybe ParamValue -> Maybe [Text] -> Cookie
Cookie Param
key (ParamValue -> Maybe ParamValue
forall a. a -> Maybe a
Just ParamValue
value) Maybe [Text]
forall a. Maybe a
Nothing


runServerSockets
  :: (IOE :> es)
  => Connection
  -> Request
  -> Eff (Server : es) Response
  -> Eff es Response
runServerSockets :: forall (es :: [Effect]).
(IOE :> es) =>
Connection
-> Request -> Eff (Server : es) Response -> Eff es Response
runServerSockets Connection
conn Request
req = (Eff (Error SocketError : es) Response -> Eff es Response)
-> EffectHandler Server (Error SocketError : es)
-> Eff (Server : es) Response
-> Eff es Response
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 Eff (Error SocketError : es) Response -> Eff es Response
runLocal (EffectHandler Server (Error SocketError : es)
 -> Eff (Server : es) Response -> Eff es Response)
-> EffectHandler Server (Error SocketError : es)
-> Eff (Server : es) Response
-> Eff es Response
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Error SocketError : es)
_ -> \case
  Server (Eff localEs) a
LoadRequest -> a -> Eff (Error SocketError : es) a
forall a. a -> Eff (Error SocketError : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Request
req -- receiveRequest conn
  SendResponse Client
client Response
res -> do
    case Response
res of
      (Response TargetViewId
vid View () ()
vw) -> do
        let meta :: Metadata
meta = Cookies -> Metadata
sessionMetas Client
client.session Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> QueryData -> Metadata
queryMeta Client
client.query
        Metadata
-> TargetViewId -> View () () -> Eff (Error SocketError : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Metadata -> TargetViewId -> View () () -> Eff es ()
sendView Metadata
meta TargetViewId
vid View () ()
vw
      (Err ResponseError
r) -> ResponseError -> Eff (Error SocketError : es) ()
forall (es :: [Effect]). (IOE :> es) => ResponseError -> Eff es ()
sendError ResponseError
r
      Response
Empty -> ResponseError -> Eff (Error SocketError : es) ()
forall (es :: [Effect]). (IOE :> es) => ResponseError -> Eff es ()
sendError (ResponseError -> Eff (Error SocketError : es) ())
-> ResponseError -> Eff (Error SocketError : es) ()
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
ErrOther Text
"Empty"
      Response
NotFound -> ResponseError -> Eff (Error SocketError : es) ()
forall (es :: [Effect]). (IOE :> es) => ResponseError -> Eff es ()
sendError (ResponseError -> Eff (Error SocketError : es) ())
-> ResponseError -> Eff (Error SocketError : es) ()
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
ErrOther Text
"NotFound"
      (Redirect Url
url) -> Metadata -> Url -> Eff (Error SocketError : es) ()
forall (es :: [Effect]).
(IOE :> es) =>
Metadata -> Url -> Eff es ()
sendRedirect (Cookies -> Metadata
sessionMetas Client
client.session) Url
url
 where
  runLocal :: Eff (Error SocketError : es) Response -> Eff es Response
runLocal = forall e (es :: [Effect]) a.
HasCallStack =>
(e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
runErrorNoCallStackWith @SocketError SocketError -> Eff es Response
forall (es :: [Effect]).
(IOE :> es) =>
SocketError -> Eff es Response
onSocketError

  onSocketError :: (IOE :> es) => SocketError -> Eff es Response
  onSocketError :: forall (es :: [Effect]).
(IOE :> es) =>
SocketError -> Eff es Response
onSocketError SocketError
e = do
    let r :: ResponseError
r = Text -> ResponseError
ErrOther (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SocketError -> String
forall a. Show a => a -> String
show SocketError
e
    ResponseError -> Eff es ()
forall (es :: [Effect]). (IOE :> es) => ResponseError -> Eff es ()
sendError ResponseError
r
    Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Eff es Response) -> Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ ResponseError -> Response
Err ResponseError
r

  sendMessage :: (MonadIO m) => Metadata -> BL.ByteString -> m ()
  sendMessage :: forall (m :: * -> *). MonadIO m => Metadata -> ByteString -> m ()
sendMessage Metadata
meta ByteString
cnt = do
    let msg :: ByteString
msg = Metadata -> ByteString
renderMetadata Metadata
meta ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cnt
    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
msg

  sendError :: (IOE :> es) => ResponseError -> Eff es ()
  sendError :: forall (es :: [Effect]). (IOE :> es) => ResponseError -> Eff es ()
sendError ResponseError
r = do
    -- TODO: better error handling!
    Metadata -> ByteString -> Eff es ()
forall (m :: * -> *). MonadIO m => Metadata -> ByteString -> m ()
sendMessage (ByteString -> Text -> Metadata
metadata ByteString
"ERROR" (String -> Text
pack (ResponseError -> String
forall a. Show a => a -> String
show ResponseError
r))) ByteString
""

  sendView :: (IOE :> es) => Metadata -> TargetViewId -> View () () -> Eff es ()
  sendView :: forall (es :: [Effect]).
(IOE :> es) =>
Metadata -> TargetViewId -> View () () -> Eff es ()
sendView Metadata
meta TargetViewId
vid View () ()
vw = do
    Metadata -> ByteString -> Eff es ()
forall (m :: * -> *). MonadIO m => Metadata -> ByteString -> m ()
sendMessage (TargetViewId -> Metadata
viewIdMeta TargetViewId
vid Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
meta) (View () () -> ByteString
renderLazyByteString View () ()
vw)

  renderMetadata :: Metadata -> BL.ByteString
  renderMetadata :: Metadata -> ByteString
renderMetadata (Metadata [(ByteString, Text)]
m) = ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, Text) -> ByteString)
-> [(ByteString, Text)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Text -> ByteString)
-> (ByteString, Text) -> ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> Text -> ByteString
metaLine) [(ByteString, Text)]
m

  sendRedirect :: (IOE :> es) => Metadata -> Url -> Eff es ()
  sendRedirect :: forall (es :: [Effect]).
(IOE :> es) =>
Metadata -> Url -> Eff es ()
sendRedirect Metadata
meta Url
u = do
    -- conn <- ask @Connection
    let r :: Metadata
r = ByteString -> Text -> Metadata
metadata ByteString
"REDIRECT" (Url -> Text
renderUrl Url
u)
    Metadata -> ByteString -> Eff es ()
forall (m :: * -> *). MonadIO m => Metadata -> ByteString -> m ()
sendMessage (Metadata
r Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Metadata
meta) ByteString
""

  sessionMetas :: Cookies -> Metadata
  sessionMetas :: Cookies -> Metadata
sessionMetas Cookies
cookies = [Metadata] -> Metadata
forall a. Monoid a => [a] -> a
mconcat ([Metadata] -> Metadata) -> [Metadata] -> Metadata
forall a b. (a -> b) -> a -> b
$ (Cookie -> Metadata) -> [Cookie] -> [Metadata]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> Metadata
cookieMeta ([Cookie] -> [Metadata]) -> [Cookie] -> [Metadata]
forall a b. (a -> b) -> a -> b
$ Cookies -> [Cookie]
Cookies.toList Cookies
cookies

  cookieMeta :: Cookie -> Metadata
  cookieMeta :: Cookie -> Metadata
cookieMeta Cookie
cookie =
    [(ByteString, Text)] -> Metadata
Metadata [(ByteString
"COOKIE", Method -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Text] -> Cookie -> Method
renderCookie Request
req.path Cookie
cookie))]

  queryMeta :: QueryData -> Metadata
  queryMeta :: QueryData -> Metadata
queryMeta QueryData
q =
    [(ByteString, Text)] -> Metadata
Metadata [(ByteString
"QUERY", Method -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ QueryData -> Method
QueryData.render QueryData
q)]

  viewIdMeta :: TargetViewId -> Metadata
  viewIdMeta :: TargetViewId -> Metadata
viewIdMeta (TargetViewId Text
vid) = [(ByteString, Text)] -> Metadata
Metadata [(ByteString
"VIEW-ID", Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
vid)]

  metadata :: BL.ByteString -> Text -> Metadata
  metadata :: ByteString -> Text -> Metadata
metadata ByteString
name Text
value = [(ByteString, Text)] -> Metadata
Metadata [(ByteString
name, Text
value)]

  metaLine :: BL.ByteString -> Text -> BL.ByteString
  metaLine :: ByteString -> Text -> ByteString
metaLine ByteString
name Text
value = ByteString
"|" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"|" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
value


errNotHandled :: Event Text Text -> String
errNotHandled :: Event Text Text -> String
errNotHandled Event Text Text
ev =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate
    String
"\n"
    [ String
"No Handler for Event viewId: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Event Text Text
ev.viewId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" action: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Event Text Text
ev.action
    , String
"<p>Remember to add a `hyper` handler in your page function</p>"
    , String
"<pre>"
    , String
"page :: (Hyperbole :> es) => Page es Response"
    , String
"page = do"
    , String
"  handle contentsHandler"
    , String
"  load $ do"
    , String
"    pure $ hyper Contents contentsView"
    , String
"</pre>"
    ]


data Client = Client
  { Client -> Cookies
session :: Cookies
  , Client -> QueryData
query :: QueryData
  }


data SocketError
  = InvalidMessage Text
  deriving (Int -> SocketError -> String -> String
[SocketError] -> String -> String
SocketError -> String
(Int -> SocketError -> String -> String)
-> (SocketError -> String)
-> ([SocketError] -> String -> String)
-> Show SocketError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SocketError -> String -> String
showsPrec :: Int -> SocketError -> String -> String
$cshow :: SocketError -> String
show :: SocketError -> String
$cshowList :: [SocketError] -> String -> String
showList :: [SocketError] -> String -> String
Show, SocketError -> SocketError -> Bool
(SocketError -> SocketError -> Bool)
-> (SocketError -> SocketError -> Bool) -> Eq SocketError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketError -> SocketError -> Bool
== :: SocketError -> SocketError -> Bool
$c/= :: SocketError -> SocketError -> Bool
/= :: SocketError -> SocketError -> Bool
Eq)


data ContentType
  = ContentHtml
  | ContentText


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


newtype Metadata = Metadata [(BL.ByteString, Text)]
  deriving newtype (NonEmpty Metadata -> Metadata
Metadata -> Metadata -> Metadata
(Metadata -> Metadata -> Metadata)
-> (NonEmpty Metadata -> Metadata)
-> (forall b. Integral b => b -> Metadata -> Metadata)
-> Semigroup Metadata
forall b. Integral b => b -> Metadata -> Metadata
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Metadata -> Metadata -> Metadata
<> :: Metadata -> Metadata -> Metadata
$csconcat :: NonEmpty Metadata -> Metadata
sconcat :: NonEmpty Metadata -> Metadata
$cstimes :: forall b. Integral b => b -> Metadata -> Metadata
stimes :: forall b. Integral b => b -> Metadata -> Metadata
Semigroup, Semigroup Metadata
Metadata
Semigroup Metadata =>
Metadata
-> (Metadata -> Metadata -> Metadata)
-> ([Metadata] -> Metadata)
-> Monoid Metadata
[Metadata] -> Metadata
Metadata -> Metadata -> Metadata
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Metadata
mempty :: Metadata
$cmappend :: Metadata -> Metadata -> Metadata
mappend :: Metadata -> Metadata -> Metadata
$cmconcat :: [Metadata] -> Metadata
mconcat :: [Metadata] -> Metadata
Monoid)


newtype Host = Host {Host -> Method
text :: BS.ByteString}
  deriving (Int -> Host -> String -> String
[Host] -> String -> String
Host -> String
(Int -> Host -> String -> String)
-> (Host -> String) -> ([Host] -> String -> String) -> Show Host
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Host -> String -> String
showsPrec :: Int -> Host -> String -> String
$cshow :: Host -> String
show :: Host -> String
$cshowList :: [Host] -> String -> String
showList :: [Host] -> String -> String
Show)


data Request = Request
  { Request -> Host
host :: Host
  , Request -> [Text]
path :: [Segment]
  , Request -> Query
query :: Query
  , Request -> ByteString
body :: BL.ByteString
  , Request -> Method
method :: Method
  , Request -> Cookies
cookies :: Cookies
  }
  deriving (Int -> Request -> String -> String
[Request] -> String -> String
Request -> String
(Int -> Request -> String -> String)
-> (Request -> String)
-> ([Request] -> String -> String)
-> Show Request
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Request -> String -> String
showsPrec :: Int -> Request -> String -> String
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> String -> String
showList :: [Request] -> String -> String
Show)


-- | Valid responses for a 'Hyperbole' effect. Use 'notFound', etc instead.
data Response
  = Response TargetViewId (View () ())
  | NotFound
  | Redirect Url
  | Err ResponseError
  | Empty


data ResponseError
  = ErrParse Text
  | ErrQuery Text
  | ErrSession Param Text
  | ErrOther Text
  | ErrNotHandled (Event Text Text)
  | ErrAuth
  deriving (Int -> ResponseError -> String -> String
[ResponseError] -> String -> String
ResponseError -> String
(Int -> ResponseError -> String -> String)
-> (ResponseError -> String)
-> ([ResponseError] -> String -> String)
-> Show ResponseError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ResponseError -> String -> String
showsPrec :: Int -> ResponseError -> String -> String
$cshow :: ResponseError -> String
show :: ResponseError -> String
$cshowList :: [ResponseError] -> String -> String
showList :: [ResponseError] -> String -> String
Show)


-- | Serialized ViewId
newtype TargetViewId = TargetViewId Text


-- | An action, with its corresponding id
data Event id act = Event
  { forall id act. Event id act -> id
viewId :: id
  , forall id act. Event id act -> act
action :: act
  }


instance (Show act, Show id) => Show (Event id act) where
  show :: Event id act -> String
show Event id act
e = String
"Event " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> id -> String
forall a. Show a => a -> String
show Event id act
e.viewId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> act -> String
forall a. Show a => a -> String
show Event id act
e.action