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

-- | Retrieve all path captures
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

-- | Retrieve a particular capture
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

-- | Set response status
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}

-- | Append given header to the response headers
addHeader :: Header -> WebbyM appEnv ()
addHeader :: forall appEnv. Header -> WebbyM appEnv ()
addHeader 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]}

-- | Similar to 'addHeader' but replaces a header
setHeader :: Header -> WebbyM appEnv ()
setHeader :: forall appEnv. Header -> WebbyM appEnv ()
setHeader (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

-- | Get all request query params as a list of key-value pairs
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

-- | Checks if the request contains the given query param
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

-- | Gets the given query param's value
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

-- | Similar to 'param' except that it returns the handler with a '400
-- BadRequest' if the query param is missing.
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

-- | Get the given header value
header :: HeaderName -> WebbyM appEnv (Maybe Text)
header :: forall appEnv. HeaderName -> WebbyM appEnv (Maybe Text)
header 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

-- | Get the 'Network.Wai.Request' of the handler
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

-- | Returns an action that returns successive chunks of the rquest
-- body. It returns an empty bytestring after the request body is
-- consumed.
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

-- | Get all the request headers
headers :: WebbyM appEnv [Header]
headers :: forall appEnv. WebbyM appEnv ResponseHeaders
headers = Request -> ResponseHeaders
requestHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall appEnv. WebbyM appEnv Request
request

-- | Returns request body size in bytes
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

-- | Used to return early from an API handler
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

-- | Send an image in the response body. Also
-- sets @Content-Type@ header to @mimeType
-- e.g. image/svg+xml
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

-- | Send a binary stream in the response body. Also
-- sets @Content-Type@ header to @application/octet-stream@
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

-- | Send a binary stream in the response body. Doesn't
-- set @Content-Type@ header
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}

-- | Send plain-text in the response body. Also
-- sets @Content-Type@ header to @text/plain; charset=utf-8@
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
          }

-- | Return the raw request body as a lazy bytestring
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

-- | Parse the request body as a JSON object and return it. Raises
-- 'WebbyJSONParseError' exception if parsing is unsuccessful.
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

-- | Set the body of the response to the JSON encoding of the given value. Also
-- sets @Content-Type@ header to @application/json; charset=utf-8@
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
          }

-- | Set the body of the response to a StreamingBody. Doesn't set the
-- @Content-Type@ header, so you probably want to do that on your own with
-- 'setHeader'.
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."

-- | Use this function to create a WAI application. It takes a user/application
-- defined @appEnv@ data type and a list of routes. Routes are matched in the
-- given order. If none of the requests match a request, a default 404 response
-- is returned.
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 =
      [ -- Handler for FinishThrown exception to guide
        -- short-circuiting handlers to early completion
        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` [
                      -- Handles Webby' exceptions while parsing parameters
                      -- and request body
                      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
                        ),
                      -- Handles Webby's finish statement
                      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

-- | Create a route for a user-provided HTTP request method, pattern
-- and handler function.
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)

-- | Create a route for a @POST@ request method, given the path pattern
-- and handler.
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

-- | Create a route for a @GET@ request method, given the path pattern
-- and handler.
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

-- | Create a route for a @PUT@ request method, given the path pattern
-- and handler.
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

-- | Create a route for a @DELETE@ request method, given path pattern and handler.
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