module Webby.Server where
import qualified Data.Aeson as A
import qualified Data.Binary.Builder as Bu
import qualified Data.ByteString.Lazy as LB
import qualified Data.HashMap.Strict as H
import qualified Data.List as L
import qualified Data.Text as T
import Network.Mime
import qualified UnliftIO.Concurrent as Conc
import qualified UnliftIO.Exception as E
import Web.HttpApiData
import Webby.Types
import Prelude
asksWEnv :: (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv :: forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv WEnv appEnv -> a
getter = forall appEnv a.
ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a
-> WebbyM appEnv a
WebbyM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WEnv appEnv -> a
getter
captures :: WebbyM appEnv Captures
captures :: forall appEnv. WebbyM appEnv Captures
captures = forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> Captures
weCaptures
getCapture :: (FromHttpApiData a) => Text -> WebbyM appEnv a
getCapture :: forall a appEnv. FromHttpApiData a => Text -> WebbyM appEnv a
getCapture Text
capName = do
Captures
cs <- forall appEnv. WebbyM appEnv Captures
captures
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
capName Captures
cs of
Maybe Text
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> WebbyError
WebbyMissingCapture Text
capName
Just Text
cap ->
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> WebbyError
WebbyParamParseError Text
capName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show)
forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
cap
setStatus :: Status -> WebbyM appEnv ()
setStatus :: forall appEnv. Status -> WebbyM appEnv ()
setStatus Status
sts = do
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$ \WyResp
wr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WyResp
wr {wrStatus :: Status
wrStatus = Status
sts}
addHeader :: Header -> WebbyM appEnv ()
Header
h = do
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr -> do
let hs :: ResponseHeaders
hs = WyResp -> ResponseHeaders
wrHeaders WyResp
wr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WyResp
wr {wrHeaders :: ResponseHeaders
wrHeaders = ResponseHeaders
hs forall a. [a] -> [a] -> [a]
++ [Header
h]}
setHeader :: Header -> WebbyM appEnv ()
(HeaderName
k, ByteString
v) = do
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr -> do
let hs :: ResponseHeaders
hs = WyResp -> ResponseHeaders
wrHeaders WyResp
wr
ohs :: ResponseHeaders
ohs = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= HeaderName
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) ResponseHeaders
hs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WyResp
wr {wrHeaders :: ResponseHeaders
wrHeaders = ResponseHeaders
ohs forall a. [a] -> [a] -> [a]
++ [(HeaderName
k, ByteString
v)]}
resp400 :: Text -> WebbyM appEnv a
resp400 :: forall appEnv a. Text -> WebbyM appEnv a
resp400 Text
msg = do
forall appEnv. Status -> WebbyM appEnv ()
setStatus Status
status400
forall b appEnv. ToJSON b => b -> WebbyM appEnv ()
json forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
A.object [Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text -> Value
A.String Text
msg]
forall appEnv a. WebbyM appEnv a
finish
params :: WebbyM appEnv [(Text, Text)]
params :: forall appEnv. WebbyM appEnv [(Text, Text)]
params = do
QueryText
qparams <- Query -> QueryText
queryToQueryText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv. WebbyM appEnv Request
request
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
q, Maybe Text
mv) -> (,) Text
q forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mv) QueryText
qparams
flag :: Text -> WebbyM appEnv Bool
flag :: forall appEnv. Text -> WebbyM appEnv Bool
flag Text
name = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv. WebbyM appEnv [(Text, Text)]
params
param :: (FromHttpApiData a) => Text -> WebbyM appEnv (Maybe a)
param :: forall a appEnv.
FromHttpApiData a =>
Text -> WebbyM appEnv (Maybe a)
param Text
p = do
[(Text, Text)]
ps <- forall appEnv. WebbyM appEnv [(Text, Text)]
params
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
p [(Text, Text)]
ps of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Text
myParam ->
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> WebbyError
WebbyParamParseError Text
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show)
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
forall a b. (a -> b) -> a -> b
$ forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam Text
myParam
param_ :: (FromHttpApiData a) => Text -> WebbyM appEnv a
param_ :: forall a appEnv. FromHttpApiData a => Text -> WebbyM appEnv a
param_ Text
p = do
Maybe a
myParam <- forall a appEnv.
FromHttpApiData a =>
Text -> WebbyM appEnv (Maybe a)
param Text
p
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall appEnv a. Text -> WebbyM appEnv a
resp400 forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
p, Text
" missing in params"])
forall (m :: * -> *) a. Monad m => a -> m a
return
Maybe a
myParam
header :: HeaderName -> WebbyM appEnv (Maybe Text)
HeaderName
n = do
ResponseHeaders
hs <- Request -> ResponseHeaders
requestHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv. WebbyM appEnv Request
request
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName
n forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) ResponseHeaders
hs
request :: WebbyM appEnv Request
request :: forall appEnv. WebbyM appEnv Request
request = forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> Request
weRequest
getRequestBodyChunkAction :: WebbyM appEnv (WebbyM appEnv ByteString)
getRequestBodyChunkAction :: forall appEnv. WebbyM appEnv (WebbyM appEnv ByteString)
getRequestBodyChunkAction = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO ByteString
getRequestBodyChunk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> Request
weRequest
headers :: WebbyM appEnv [Header]
= Request -> ResponseHeaders
requestHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv. WebbyM appEnv Request
request
requestBodyLength :: WebbyM appEnv (Maybe Int64)
requestBodyLength :: forall appEnv. WebbyM appEnv (Maybe Int64)
requestBodyLength = do
Maybe Text
hMay <- forall appEnv. HeaderName -> WebbyM appEnv (Maybe Text)
header HeaderName
hContentLength
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
Text
val <- Maybe Text
hMay
forall a. Integral a => Text -> Maybe a
parseInt Text
val
finish :: WebbyM appEnv a
finish :: forall appEnv a. WebbyM appEnv a
finish = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO FinishThrown
FinishThrown
image :: ByteString -> MimeType -> WebbyM appEnv ()
image :: forall appEnv. ByteString -> ByteString -> WebbyM appEnv ()
image ByteString
bs ByteString
mimeType = do
forall appEnv. Header -> WebbyM appEnv ()
setHeader (HeaderName
hContentType, ByteString
mimeType)
forall appEnv. ByteString -> WebbyM appEnv ()
raw ByteString
bs
blob :: ByteString -> WebbyM appEnv ()
blob :: forall appEnv. ByteString -> WebbyM appEnv ()
blob ByteString
bs = do
forall appEnv. Header -> WebbyM appEnv ()
setHeader (HeaderName
hContentType, ByteString
"application/octet-stream")
forall appEnv. ByteString -> WebbyM appEnv ()
raw ByteString
bs
raw :: ByteString -> WebbyM appEnv ()
raw :: forall appEnv. ByteString -> WebbyM appEnv ()
raw ByteString
bs = do
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WyResp
wr {wrRespData :: Either StreamingBody Builder
wrRespData = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Bu.fromByteString ByteString
bs}
text :: Text -> WebbyM appEnv ()
text :: forall appEnv. Text -> WebbyM appEnv ()
text Text
txt = do
forall appEnv. Header -> WebbyM appEnv ()
setHeader (HeaderName
hContentType, ByteString
"text/plain; charset=utf-8")
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
WyResp
wr
{ wrRespData :: Either StreamingBody Builder
wrRespData =
forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
ByteString -> Builder
Bu.fromByteString forall a b. (a -> b) -> a -> b
$
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
txt
}
requestBodyLBS :: WebbyM appEnv LByteString
requestBodyLBS :: forall appEnv. WebbyM appEnv LByteString
requestBodyLBS = do
Request
req <- forall appEnv. WebbyM appEnv Request
request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO LByteString
lazyRequestBody Request
req
jsonData :: A.FromJSON a => WebbyM appEnv a
jsonData :: forall a appEnv. FromJSON a => WebbyM appEnv a
jsonData = do
Request
req <- forall appEnv. WebbyM appEnv Request
request
LByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO LByteString
lazyRequestBody Request
req
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> WebbyError
WebbyJSONParseError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => LByteString -> Either String a
A.eitherDecode LByteString
body
json :: A.ToJSON b => b -> WebbyM appEnv ()
json :: forall b appEnv. ToJSON b => b -> WebbyM appEnv ()
json b
j = do
forall appEnv. Header -> WebbyM appEnv ()
setHeader (HeaderName
hContentType, ByteString
"application/json; charset=utf-8")
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
WyResp
wr
{ wrRespData :: Either StreamingBody Builder
wrRespData =
forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
LByteString -> Builder
Bu.fromLazyByteString forall a b. (a -> b) -> a -> b
$
forall a. ToJSON a => a -> LByteString
A.encode b
j
}
stream :: StreamingBody -> WebbyM appEnv ()
stream :: forall appEnv. StreamingBody -> WebbyM appEnv ()
stream StreamingBody
s = do
MVar WyResp
wVar <- forall appEnv a. (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv forall env. WEnv env -> MVar WyResp
weResp
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
Conc.modifyMVar_ MVar WyResp
wVar forall a b. (a -> b) -> a -> b
$
\WyResp
wr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WyResp
wr {wrRespData :: Either StreamingBody Builder
wrRespData = forall a b. a -> Either a b
Left StreamingBody
s}
matchRequest :: Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest :: forall a. Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest Request
_ [] = forall a. Maybe a
Nothing
matchRequest Request
req ((RoutePattern ByteString
method [Text]
pathSegs, a
handler) : [(RoutePattern, a)]
rs) =
if Request -> ByteString
requestMethod Request
req forall a. Eq a => a -> a -> Bool
== ByteString
method
then case [Text] -> [Text] -> Captures -> Maybe Captures
go (Request -> [Text]
pathInfo Request
req) [Text]
pathSegs forall k v. HashMap k v
H.empty of
Maybe Captures
Nothing -> forall a. Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest Request
req [(RoutePattern, a)]
rs
Just Captures
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return (Captures
cs, a
handler)
else forall a. Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest Request
req [(RoutePattern, a)]
rs
where
go :: [Text] -> [Text] -> Captures -> Maybe Captures
go [] [Text]
p Captures
h
| forall a. Monoid a => [a] -> a
mconcat [Text]
p forall a. Eq a => a -> a -> Bool
== Text
"" = forall a. a -> Maybe a
Just Captures
h
| Bool
otherwise = forall a. Maybe a
Nothing
go [Text]
p [] Captures
h
| forall a. Monoid a => [a] -> a
mconcat [Text]
p forall a. Eq a => a -> a -> Bool
== Text
"" = forall a. a -> Maybe a
Just Captures
h
| Bool
otherwise = forall a. Maybe a
Nothing
go (Text
p : [Text]
ps) (Text
l : [Text]
pat) Captures
h
| Text -> Char
T.head Text
l forall a. Eq a => a -> a -> Bool
== Char
':' = [Text] -> [Text] -> Captures -> Maybe Captures
go [Text]
ps [Text]
pat forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert (Int -> Text -> Text
T.drop Int
1 Text
l) Text
p Captures
h
| Text
p forall a. Eq a => a -> a -> Bool
== Text
l = [Text] -> [Text] -> Captures -> Maybe Captures
go [Text]
ps [Text]
pat Captures
h
| Bool
otherwise = forall a. Maybe a
Nothing
errorResponse404 :: WebbyM appEnv ()
errorResponse404 :: forall appEnv. WebbyM appEnv ()
errorResponse404 = forall appEnv. Status -> WebbyM appEnv ()
setStatus Status
status404
invalidRoutesErr :: [Char]
invalidRoutesErr :: String
invalidRoutesErr = String
"Invalid route specification: contains duplicate routes or routes with overlapping capture patterns."
mkWebbyApp :: env -> WebbyServerConfig env -> IO Application
mkWebbyApp :: forall env. env -> WebbyServerConfig env -> IO Application
mkWebbyApp env
env WebbyServerConfig env
wsc =
forall (m :: * -> *) a. Monad m => a -> m a
return forall {b}. Request -> (Response -> IO b) -> IO b
mkApp
where
shortCircuitHandler :: [Handler (WebbyM env) a]
shortCircuitHandler =
[
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler (\(FinishThrown
ex :: FinishThrown) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO FinishThrown
ex)
]
mkApp :: Request -> (Response -> IO b) -> IO b
mkApp Request
req Response -> IO b
respond = do
let defaultHandler :: WebbyM appEnv ()
defaultHandler = forall appEnv. WebbyM appEnv ()
errorResponse404
routes :: [Route env]
routes = forall env. WebbyServerConfig env -> [Route env]
wscRoutes WebbyServerConfig env
wsc
exceptionHandlerMay :: Maybe (WebbyExceptionHandler env)
exceptionHandlerMay = forall env.
WebbyServerConfig env -> Maybe (WebbyExceptionHandler env)
wscExceptionHandler WebbyServerConfig env
wsc
(Captures
cs, WebbyM env ()
handler) =
forall a. a -> Maybe a -> a
fromMaybe (forall k v. HashMap k v
H.empty, forall appEnv. WebbyM appEnv ()
defaultHandler) forall a b. (a -> b) -> a -> b
$
forall a. Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest Request
req [Route env]
routes
WEnv env
wEnv <- do
MVar WyResp
v <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
Conc.newMVar WyResp
defaultWyResp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall env.
MVar WyResp
-> Captures
-> Request
-> env
-> Maybe (WebbyExceptionHandler env)
-> WEnv env
WEnv MVar WyResp
v Captures
cs Request
req env
env Maybe (WebbyExceptionHandler env)
exceptionHandlerMay
( do
forall w a. WEnv w -> WebbyM w a -> IO a
runWebbyM WEnv env
wEnv forall a b. (a -> b) -> a -> b
$
WebbyM env ()
handler
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`E.catches` ( forall {a}. [Handler (WebbyM env) a]
shortCircuitHandler
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(WebbyExceptionHandler e -> WebbyM env ()
e) -> forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler e -> WebbyM env ()
e) (forall a. Maybe a -> [a]
maybeToList Maybe (WebbyExceptionHandler env)
exceptionHandlerMay)
)
forall {m :: * -> *} {env} {b}.
MonadIO m =>
WEnv env -> (Response -> m b) -> m b
webbyReply WEnv env
wEnv Response -> IO b
respond
)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`E.catches` [
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler
( \(WebbyError
ex :: WebbyError) -> case WebbyError
ex of
wmc :: WebbyError
wmc@(WebbyMissingCapture Text
_) ->
Response -> IO b
respond forall a b. (a -> b) -> a -> b
$
Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status404 [] forall a b. (a -> b) -> a -> b
$
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$
forall e. Exception e => e -> String
displayException WebbyError
wmc
WebbyError
_ ->
Response -> IO b
respond forall a b. (a -> b) -> a -> b
$
Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status400 [] forall a b. (a -> b) -> a -> b
$
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$
forall e. Exception e => e -> String
displayException WebbyError
ex
),
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler (\(FinishThrown
_ :: FinishThrown) -> forall {m :: * -> *} {env} {b}.
MonadIO m =>
WEnv env -> (Response -> m b) -> m b
webbyReply WEnv env
wEnv Response -> IO b
respond)
]
webbyReply :: WEnv env -> (Response -> m b) -> m b
webbyReply WEnv env
wEnv Response -> m b
respond' = do
let wVar :: MVar WyResp
wVar = forall env. WEnv env -> MVar WyResp
weResp WEnv env
wEnv
WyResp
wr <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
Conc.takeMVar MVar WyResp
wVar
case WyResp -> Either StreamingBody Builder
wrRespData WyResp
wr of
Left StreamingBody
s -> Response -> m b
respond' forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream (WyResp -> Status
wrStatus WyResp
wr) (WyResp -> ResponseHeaders
wrHeaders WyResp
wr) StreamingBody
s
Right Builder
b -> do
let clen :: Int64
clen = LByteString -> Int64
LB.length forall a b. (a -> b) -> a -> b
$ Builder -> LByteString
Bu.toLazyByteString Builder
b
Response -> m b
respond' forall a b. (a -> b) -> a -> b
$
Status -> ResponseHeaders -> Builder -> Response
responseBuilder
(WyResp -> Status
wrStatus WyResp
wr)
(WyResp -> ResponseHeaders
wrHeaders WyResp
wr forall a. [a] -> [a] -> [a]
++ [(HeaderName
hContentLength, forall b a. (Show a, IsString b) => a -> b
show Int64
clen)])
Builder
b
mkRoute ::
Method ->
Text ->
WebbyM appEnv () ->
(RoutePattern, WebbyM appEnv ())
mkRoute :: forall appEnv.
ByteString
-> Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
mkRoute ByteString
m Text
p WebbyM appEnv ()
h =
let p' :: Text
p' =
if
| Text -> Bool
T.null Text
p -> Text
"/"
| Text -> Char
T.head Text
p forall a. Eq a => a -> a -> Bool
/= Char
'/' -> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
p
| Bool
otherwise -> Text
p
in (ByteString -> [Text] -> RoutePattern
RoutePattern ByteString
m (forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" Text
p'), WebbyM appEnv ()
h)
post :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
post :: forall appEnv.
Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
post = forall appEnv.
ByteString
-> Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
mkRoute ByteString
methodPost
get :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
get :: forall appEnv.
Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
get = forall appEnv.
ByteString
-> Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
mkRoute ByteString
methodGet
put :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
put :: forall appEnv.
Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
put = forall appEnv.
ByteString
-> Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
mkRoute ByteString
methodPut
delete :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
delete :: forall appEnv.
Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
delete = forall appEnv.
ByteString
-> Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
mkRoute ByteString
methodDelete