{-# 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)
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
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 =
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)]
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
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
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
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 =
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
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
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")
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>|]
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