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

module Web.Hyperbole.Application
  ( waiApp
  , websocketsOr
  , defaultConnectionOptions
  , liveApp
  , socketApp
  , runServerSockets
  , runServerWai
  , basicDocument
  , routeRequest
  ) where

import Control.Monad (forever)
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 Data.Text (Text, pack)
import Data.Text qualified as T
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.State.Static.Local
import Network.HTTP.Types (HeaderName, Method, parseQuery, status200, status400, status401, status404, status500)
import Network.Wai qualified as Wai
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.Wai.Internal (ResponseReceived (..))
import Network.WebSockets (Connection, PendingConnection, defaultConnectionOptions)
import Network.WebSockets qualified as WS
import Web.Cookie (parseCookies)
import Web.Hyperbole.Effect
import Web.Hyperbole.Embed (cssResetEmbed, scriptEmbed)
import Web.Hyperbole.Route
import Web.Hyperbole.Session
import Web.View (View, renderLazyByteString, renderUrl)


{- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets

> main = do
>   run 3000 $ do
>   liveApp (basicDocument "Example") $ do
>      page mainPage
-}
liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application
liveApp :: (ByteString -> ByteString)
-> Eff '[Hyperbole, Server, IOE] Response -> Application
liveApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, IOE] Response
app =
  ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
    ConnectionOptions
defaultConnectionOptions
    (Eff '[IOE] () -> IO ()
forall a. Eff '[IOE] a -> IO a
runEff (Eff '[IOE] () -> IO ())
-> (PendingConnection -> Eff '[IOE] ()) -> ServerApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[Hyperbole, Server, IOE] Response
-> PendingConnection -> Eff '[IOE] ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Eff (Hyperbole : Server : es) Response
-> PendingConnection -> Eff es ()
socketApp Eff '[Hyperbole, Server, IOE] Response
app)
    ((ByteString -> ByteString)
-> Eff '[Hyperbole, Server, IOE] Response -> Application
waiApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, IOE] Response
app)


socketApp :: (IOE :> es) => Eff (Hyperbole : Server : es) Response -> PendingConnection -> Eff es ()
socketApp :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Eff (Hyperbole : Server : es) Response
-> PendingConnection -> Eff es ()
socketApp Eff (Hyperbole : Server : es) Response
actions PendingConnection
pend = do
  Connection
conn <- IO Connection -> Eff es Connection
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> Eff es Connection)
-> IO Connection -> Eff es Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pend
  Eff es Response -> Eff es ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Eff es Response -> Eff es ()) -> Eff es Response -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
    Connection -> Eff (Server : es) Response -> Eff es Response
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Connection -> Eff (Server : es) Response -> Eff es Response
runServerSockets Connection
conn (Eff (Server : es) Response -> Eff es Response)
-> Eff (Server : es) Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Eff (Hyperbole : Server : es) Response
-> Eff (Server : es) Response
forall (es :: [(* -> *) -> * -> *]).
(Server :> es) =>
Eff (Hyperbole : es) Response -> Eff es Response
runHyperbole Eff (Hyperbole : Server : es) Response
actions


waiApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application
waiApp :: (ByteString -> ByteString)
-> Eff '[Hyperbole, Server, IOE] Response -> Application
waiApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, IOE] Response
actions Request
req Response -> IO ResponseReceived
res = do
  Maybe ResponseReceived
rr <- Eff '[IOE] (Maybe ResponseReceived) -> IO (Maybe ResponseReceived)
forall a. Eff '[IOE] a -> IO a
runEff (Eff '[IOE] (Maybe ResponseReceived)
 -> IO (Maybe ResponseReceived))
-> Eff '[IOE] (Maybe ResponseReceived)
-> IO (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> Request
-> (Response -> IO ResponseReceived)
-> Eff '[Server, IOE] Response
-> Eff '[IOE] (Maybe ResponseReceived)
forall (es :: [(* -> *) -> * -> *]) 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
res (Eff '[Server, IOE] Response
 -> Eff '[IOE] (Maybe ResponseReceived))
-> Eff '[Server, IOE] Response
-> Eff '[IOE] (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Eff '[Hyperbole, Server, IOE] Response
-> Eff '[Server, IOE] Response
forall (es :: [(* -> *) -> * -> *]).
(Server :> es) =>
Eff (Hyperbole : es) Response -> Eff es Response
runHyperbole Eff '[Hyperbole, Server, IOE] Response
actions
  case Maybe ResponseReceived
rr of
    Maybe ResponseReceived
Nothing -> [Char] -> IO ResponseReceived
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing required response in handler"
    Just ResponseReceived
r -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
r


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


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 :: [(* -> *) -> * -> *]) 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))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Server :> localEs) =>
    LocalEnv localEs (State (Maybe ResponseReceived) : es)
    -> Server (Eff localEs) a
    -> Eff (State (Maybe ResponseReceived) : es) a)
-> Eff (Server : es) a
-> Eff es (Maybe ResponseReceived)
forall (e :: (* -> *) -> * -> *)
       (handlerEs :: [(* -> *) -> * -> *]) a (es :: [(* -> *) -> * -> *])
       b.
(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 :: [(* -> *) -> * -> *]) a.
(IOE :> es) =>
Eff (State (Maybe ResponseReceived) : es) a
-> Eff es (Maybe ResponseReceived)
runLocal ((forall {a} {localEs :: [(* -> *) -> * -> *]}.
  (HasCallStack, Server :> localEs) =>
  LocalEnv localEs (State (Maybe ResponseReceived) : es)
  -> Server (Eff localEs) a
  -> Eff (State (Maybe ResponseReceived) : es) a)
 -> Eff (Server : es) a -> Eff es (Maybe ResponseReceived))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Server :> localEs) =>
    LocalEnv localEs (State (Maybe ResponseReceived) : es)
    -> Server (Eff localEs) a
    -> Eff (State (Maybe ResponseReceived) : es) a)
-> 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 Session
sess 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
$ Session -> Response -> IO ResponseReceived
sendResponse Session
sess Response
r
      Maybe ResponseReceived
-> Eff (State (Maybe ResponseReceived) : es) ()
forall s (es :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]) 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 :: [(* -> *) -> * -> *]) a.
s -> Eff (State s : es) a -> Eff es s
execState Maybe ResponseReceived
forall a. Maybe a
Nothing

  sendResponse :: Session -> Response -> IO Wai.ResponseReceived
  sendResponse :: Session -> Response -> IO ResponseReceived
sendResponse Session
sess 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 (ErrParam Text
e)) = Status -> ByteString -> Response
respError Status
status400 (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ ByteString
"ErrParam: " 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
$ [Char] -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Event Text Text -> [Char]
errNotHandled Event Text Text
e
    response (Response 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
       in Status -> [(HeaderName, Method)] -> ByteString -> Response
Wai.responseLBS Status
status200 [(HeaderName, Method)]
headers ByteString
body

    setCookies :: [(HeaderName, Method)]
setCookies =
      [(HeaderName
"Set-Cookie", Session -> Method
sessionSetCookie Session
sess)]

  -- 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 -> Cookies
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
$sel:body:Request :: ByteString
body, [Text]
path :: [Text]
$sel:path:Request :: [Text]
path, Query
query :: Query
$sel:query:Request :: Query
query, Method
method :: Method
$sel:method:Request :: Method
method, Cookies
cookies :: Cookies
$sel:cookies:Request :: Cookies
cookies, Host
host :: Host
$sel:host:Request :: Host
host}


runServerSockets
  :: (IOE :> es)
  => Connection
  -> Eff (Server : es) Response
  -> Eff es Response
runServerSockets :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Connection -> Eff (Server : es) Response -> Eff es Response
runServerSockets Connection
conn = (Eff (Error SocketError : es) Response -> Eff es Response)
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Server :> localEs) =>
    LocalEnv localEs (Error SocketError : es)
    -> Server (Eff localEs) a -> Eff (Error SocketError : es) a)
-> Eff (Server : es) Response
-> Eff es Response
forall (e :: (* -> *) -> * -> *)
       (handlerEs :: [(* -> *) -> * -> *]) a (es :: [(* -> *) -> * -> *])
       b.
(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 ((forall {a} {localEs :: [(* -> *) -> * -> *]}.
  (HasCallStack, Server :> localEs) =>
  LocalEnv localEs (Error SocketError : es)
  -> Server (Eff localEs) a -> Eff (Error SocketError : es) a)
 -> Eff (Server : es) Response -> Eff es Response)
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Server :> localEs) =>
    LocalEnv localEs (Error SocketError : es)
    -> Server (Eff localEs) a -> Eff (Error SocketError : es) a)
-> 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 -> Eff (Error SocketError : es) a
Eff (Error SocketError : es) Request
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Error SocketError :> es) =>
Eff es Request
receiveRequest
  SendResponse Session
sess Response
res -> do
    case Response
res of
      (Response View () ()
vw) -> (ByteString -> ByteString)
-> View () () -> Eff (Error SocketError : es) ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
(ByteString -> ByteString) -> View () () -> Eff es ()
sendView (Session -> ByteString -> ByteString
addMetadata Session
sess) View () ()
vw
      (Err ResponseError
r) -> ResponseError -> Eff (Error SocketError : es) ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
ResponseError -> Eff es ()
sendError ResponseError
r
      Response
Empty -> ResponseError -> Eff (Error SocketError : es) ()
forall (es :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]).
(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) -> (ByteString -> ByteString)
-> Url -> Eff (Error SocketError : es) ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
(ByteString -> ByteString) -> Url -> Eff es ()
sendRedirect (Session -> ByteString -> ByteString
addMetadata Session
sess) Url
url
 where
  runLocal :: Eff (Error SocketError : es) Response -> Eff es Response
runLocal = forall e (es :: [(* -> *) -> * -> *]) a.
(e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
runErrorNoCallStackWith @SocketError SocketError -> Eff es Response
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
SocketError -> Eff es Response
onSocketError

  onSocketError :: (IOE :> es) => SocketError -> Eff es Response
  onSocketError :: forall (es :: [(* -> *) -> * -> *]).
(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
$ [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SocketError -> [Char]
forall a. Show a => a -> [Char]
show SocketError
e
    ResponseError -> Eff es ()
forall (es :: [(* -> *) -> * -> *]).
(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

  sendError :: (IOE :> es) => ResponseError -> Eff es ()
  sendError :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
ResponseError -> Eff es ()
sendError ResponseError
r = do
    -- conn <- ask @Connection
    -- TODO: better error handling!
    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
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"|ERROR|" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (ResponseError -> [Char]
forall a. Show a => a -> [Char]
show ResponseError
r)

  sendView :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> View () () -> Eff es ()
  sendView :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
(ByteString -> ByteString) -> View () () -> Eff es ()
sendView ByteString -> ByteString
addMeta View () ()
vw = do
    -- conn <- ask @Connection
    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
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
addMeta (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString View () ()
vw

  sendRedirect :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> Url -> Eff es ()
  sendRedirect :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
(ByteString -> ByteString) -> Url -> Eff es ()
sendRedirect ByteString -> ByteString
addMeta Url
u = do
    -- conn <- ask @Connection
    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
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
addMeta (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"|REDIRECT|" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Url -> Text
renderUrl Url
u)

  addMetadata :: Session -> BL.ByteString -> BL.ByteString
  addMetadata :: Session -> ByteString -> ByteString
addMetadata Session
sess ByteString
cont =
    -- you may have 1 or more lines containing metadata followed by a view
    -- \|SESSION| key=value; another=woot;
    -- <div ...>
    ByteString
sessionLine ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cont
   where
    metaLine :: a -> a -> a
metaLine a
name a
value = a
"|" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"|" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
value

    sessionLine :: BL.ByteString
    sessionLine :: ByteString
sessionLine = ByteString -> ByteString -> ByteString
forall {a}. (Semigroup a, IsString a) => a -> a -> a
metaLine ByteString
"SESSION" (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Method -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Session -> Method
sessionSetCookie Session
sess)

  receiveRequest :: (IOE :> es, Error SocketError :> es) => Eff es Request
  receiveRequest :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Error SocketError :> es) =>
Eff es Request
receiveRequest = do
    Text
t <- Eff es Text
forall (es :: [(* -> *) -> * -> *]). (IOE :> es) => Eff es Text
receiveText
    case Text -> Either SocketError Request
parseMessage Text
t of
      Left SocketError
e -> SocketError -> Eff es Request
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError SocketError
e
      Right Request
r -> Request -> Eff es Request
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r

  receiveText :: (IOE :> es) => Eff es Text
  receiveText :: forall (es :: [(* -> *) -> * -> *]). (IOE :> es) => Eff es Text
receiveText = 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

  parseMessage :: Text -> Either SocketError Request
  parseMessage :: Text -> Either SocketError Request
parseMessage Text
t = do
    case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
t of
      [Text
url, Text
host, Text
cook, Text
body] -> Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
host (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
body)
      [Text
url, Text
host, Text
cook] -> Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
host Maybe Text
forall a. Maybe a
Nothing
      [Text]
_ -> SocketError -> Either SocketError Request
forall a b. a -> Either a b
Left (SocketError -> Either SocketError Request)
-> SocketError -> Either SocketError Request
forall a b. (a -> b) -> a -> b
$ Text -> SocketError
InvalidMessage Text
t
   where
    parseUrl :: Text -> Either SocketError (Text, Text)
    parseUrl :: Text -> Either SocketError (Text, Text)
parseUrl Text
u =
      case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"?" Text
u of
        [Text
url, Text
query] -> (Text, Text) -> Either SocketError (Text, Text)
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
url, Text
query)
        [Text]
_ -> SocketError -> Either SocketError (Text, Text)
forall a b. a -> Either a b
Left (SocketError -> Either SocketError (Text, Text))
-> SocketError -> Either SocketError (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> SocketError
InvalidMessage Text
u

    parse :: Text -> Text -> Text -> Maybe Text -> Either SocketError Request
    parse :: Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
hst Maybe Text
mbody = do
      (Text
u, Text
q) <- Text -> Either SocketError (Text, Text)
parseUrl Text
url
      let path :: [Text]
path = Text -> [Text]
paths Text
u
          query :: Query
query = Method -> Query
parseQuery (Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs Text
q)
          cookies :: Cookies
cookies = Method -> Cookies
parseCookies (Method -> Cookies) -> Method -> Cookies
forall a b. (a -> b) -> a -> b
$ Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ Text -> Text
header Text
cook
          host :: Host
host = Method -> Host
Host (Method -> Host) -> Method -> Host
forall a b. (a -> b) -> a -> b
$ Text -> Method
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ Text -> Text
header Text
hst
          method :: Method
method = Method
"POST"
          body :: ByteString
body = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mbody
      Request -> Either SocketError Request
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Either SocketError Request)
-> Request -> Either SocketError Request
forall a b. (a -> b) -> a -> b
$ Request{[Text]
$sel:path:Request :: [Text]
path :: [Text]
path, Host
$sel:host:Request :: Host
host :: Host
host, Query
$sel:query:Request :: Query
query :: Query
query, ByteString
$sel:body:Request :: ByteString
body :: ByteString
body, Method
$sel:method:Request :: Method
method :: Method
method, Cookies
$sel:cookies:Request :: Cookies
cookies :: Cookies
cookies}

    paths :: Text -> [Text]
paths Text
p = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
p

    -- drop up to the colon, then ': '
    header :: Text -> Text
header = Int -> Text -> Text
T.drop Int
2 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')


data SocketError
  = InvalidMessage Text
  deriving (Int -> SocketError -> [Char] -> [Char]
[SocketError] -> [Char] -> [Char]
SocketError -> [Char]
(Int -> SocketError -> [Char] -> [Char])
-> (SocketError -> [Char])
-> ([SocketError] -> [Char] -> [Char])
-> Show SocketError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> SocketError -> [Char] -> [Char]
showsPrec :: Int -> SocketError -> [Char] -> [Char]
$cshow :: SocketError -> [Char]
show :: SocketError -> [Char]
$cshowList :: [SocketError] -> [Char] -> [Char]
showList :: [SocketError] -> [Char] -> [Char]
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")


{- | wrap HTML fragments in a simple document with a custom title and include required embeds

@
'liveApp' (basicDocument "App Title") ('routeRequest' router)
@

You may want to specify a custom document function instead:

> myDocument :: ByteString -> ByteString
> myDocument content =
>   [i|<html>
>     <head>
>       <title>#{title}</title>
>       <script type="text/javascript">#{scriptEmbed}</script>
>       <style type type="text/css">#{cssResetEmbed}</style>
>     </head>
>     <body>#{content}</body>
>   </html>|]
-}
basicDocument :: Text -> BL.ByteString -> BL.ByteString
basicDocument :: Text -> ByteString -> ByteString
basicDocument Text
title ByteString
cnt =
  [i|<html>
      <head>
        <title>#{title}</title>
        <script type="text/javascript">#{scriptEmbed}</script>
        <style type type="text/css">#{cssResetEmbed}</style>
      </head>
      <body>#{cnt}</body>
  </html>|]


{- | Route URL patterns to different pages


@
import Page.Messages qualified as Messages
import Page.Users qualified as Users

data AppRoute
  = Main
  | Messages
  | Users UserId
  deriving (Eq, Generic, 'Route')

router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'
router Messages = 'page' Messages.page
router (Users uid) = 'page' $ Users.page uid
router Main = do
  'view' $ do
    'el_' "click a link below to visit a page"
    'route' Messages id \"Messages\"

main = do
  'run' 3000 $ do
    'liveApp' ('basicDocument' \"Example\") (routeRequest router)
@
-}
routeRequest :: (Hyperbole :> es, Route route) => (route -> Eff es Response) -> Eff es Response
routeRequest :: forall (es :: [(* -> *) -> * -> *]) route.
(Hyperbole :> es, Route route) =>
(route -> Eff es Response) -> Eff es Response
routeRequest route -> Eff es Response
actions = do
  [Text]
path <- Eff es [Text]
forall (es :: [(* -> *) -> * -> *]).
(Hyperbole :> es) =>
Eff es [Text]
reqPath
  case [Text] -> Maybe route
forall a. Route a => [Text] -> Maybe a
findRoute [Text]
path of
    Maybe route
Nothing -> Hyperbole (Eff es) Response -> Eff es Response
forall (e :: (* -> *) -> * -> *) (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) Response -> Eff es Response)
-> Hyperbole (Eff es) Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Response -> Hyperbole (Eff es) Response
forall (a :: * -> *) b. Response -> Hyperbole a b
RespondEarly Response
NotFound
    Just route
rt -> route -> Eff es Response
actions route
rt