-- | Twain is a tiny web application framework for WAI
--
-- - `ResponderM` for composing responses with do notation.
-- - Routing with path captures that decompose `ResponderM` into middleware.
-- - Parameter parsing for cookies, path, query, and body.
-- - Helpers for redirects, headers, status codes, and errors.
--
-- @
-- {-# language OverloadedStrings #-}
--
-- import Network.Wai.Handler.Warp (run)
-- import Web.Twain
--
-- main :: IO ()
-- main = do
--   run 8080 $
--     foldr ($)
--       (notFound missing)
--       [ get "/" index
--       , post "/echo/:name" echo
--       ]
--
-- index :: ResponderM a
-- index = send $ html "Hello World!"
--
-- echo :: ResponderM a
-- echo = do
--   name <- param "name"
--   send $ html $ "Hello, " <> name
--
-- missing :: ResponderM a
-- missing = send $ html "Not found..."
-- @
module Web.Twain
  ( ResponderM,

    -- * Routing
    get,
    put,
    patch,
    post,
    delete,
    route,
    notFound,

    -- * Requests
    param,
    paramEither,
    paramMaybe,
    params,
    queryParam,
    queryParamMaybe,
    queryParamEither,
    queryParams,
    pathParam,
    pathParamMaybe,
    pathParamEither,
    pathParams,
    cookieParam,
    cookieParamMaybe,
    cookieParamEither,
    cookieParams,
    file,
    fileMaybe,
    files,
    fromBody,
    header,
    headers,
    request,

    -- * Responses
    send,
    next,
    redirect301,
    redirect302,
    redirect303,
    text,
    html,
    json,
    xml,
    css,
    raw,
    status,
    withHeader,
    withCookie,
    withCookie',
    expireCookie,

    -- * Errors
    HttpError (..),
    onException,

    -- * Middleware
    withParseBodyOpts,
    withMaxBodySize,

    -- * Parameters
    ParsableParam (..),

    -- * Re-exports
    module Network.HTTP.Types,
    module Network.Wai,
    FileInfo (..),
  )
where

import Control.Exception (SomeException, handle)
import Control.Monad.Catch (throwM)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as JSON
import Data.ByteString.Char8 as Char8
import Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import Data.Either.Combinators (rightToMaybe)
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Time
import qualified Data.Vault.Lazy as V
import Data.Word (Word64)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Parse hiding (Param)
import Network.Wai.Request
import System.Environment (lookupEnv)
import Web.Cookie
import Web.Twain.Internal
import Web.Twain.Types

get :: PathPattern -> ResponderM a -> Middleware
get :: forall a. PathPattern -> ResponderM a -> Middleware
get = Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"GET")

put :: PathPattern -> ResponderM a -> Middleware
put :: forall a. PathPattern -> ResponderM a -> Middleware
put = Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"PUT")

patch :: PathPattern -> ResponderM a -> Middleware
patch :: forall a. PathPattern -> ResponderM a -> Middleware
patch = Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"PATCH")

post :: PathPattern -> ResponderM a -> Middleware
post :: forall a. PathPattern -> ResponderM a -> Middleware
post = Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"POST")

delete :: PathPattern -> ResponderM a -> Middleware
delete :: forall a. PathPattern -> ResponderM a -> Middleware
delete = Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"DELETE")

-- | Route request matching optional `Method` and `PathPattern` to `ResponderM`.
route :: Maybe Method -> PathPattern -> ResponderM a -> Middleware
route :: forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route Maybe ByteString
method PathPattern
pat (ResponderM Request -> IO (Either RouteAction (a, Request))
responder) Application
app Request
req Response -> IO ResponseReceived
respond = do
  let maxM :: Maybe Word64
maxM = ResponderOptions -> Word64
optsMaxBodySize (ResponderOptions -> Word64)
-> Maybe ResponderOptions -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key ResponderOptions -> Vault -> Maybe ResponderOptions
forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
  Request
req' <- IO Request -> (Word64 -> IO Request) -> Maybe Word64 -> IO Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req) ((Word64 -> Request -> IO Request)
-> Request -> Word64 -> IO Request
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word64 -> Request -> IO Request
requestSizeCheck Request
req) Maybe Word64
maxM
  case Maybe ByteString -> PathPattern -> Request -> Maybe [Param]
match Maybe ByteString
method PathPattern
pat Request
req' of
    Maybe [Param]
Nothing -> Application
app Request
req' Response -> IO ResponseReceived
respond
    Just [Param]
pathParams -> do
      let preq :: ParsedRequest
preq = Request -> ParsedRequest
parseRequest Request
req'
          preq' :: ParsedRequest
preq' = ParsedRequest
preq {preqPathParams = pathParams}
          req'' :: Request
req'' = Request
req' {vault = V.insert parsedReqKey preq' (vault req')}
      Either RouteAction (a, Request)
eres <- Request -> IO (Either RouteAction (a, Request))
responder Request
req''
      case Either RouteAction (a, Request)
eres of
        Left (Respond Response
res) -> Response -> IO ResponseReceived
respond Response
res
        Either RouteAction (a, Request)
_ -> Application
app Request
req'' Response -> IO ResponseReceived
respond

-- | Respond if no other route responds.
--
-- Sets the status to 404.
notFound :: ResponderM a -> Application
notFound :: forall a. ResponderM a -> Application
notFound (ResponderM Request -> IO (Either RouteAction (a, Request))
responder) Request
req Response -> IO ResponseReceived
respond = do
  let preq :: ParsedRequest
preq = Request -> ParsedRequest
parseRequest Request
req
      req' :: Request
req' = Request
req {vault = V.insert parsedReqKey preq (vault req)}
  Either RouteAction (a, Request)
eres <- Request -> IO (Either RouteAction (a, Request))
responder Request
req'
  case Either RouteAction (a, Request)
eres of
    Left (Respond Response
res) -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ (Status -> Status) -> Response -> Response
mapResponseStatus (Status -> Status -> Status
forall a b. a -> b -> a
const Status
status404) Response
res
    Either RouteAction (a, Request)
_ -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> Response -> Response
status Status
status404 (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
text Text
"Not found."

onException :: (SomeException -> ResponderM a) -> Middleware
onException :: forall a. (SomeException -> ResponderM a) -> Middleware
onException SomeException -> ResponderM a
h Application
app Request
req Response -> IO ResponseReceived
respond = do
  (SomeException -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ResponseReceived
handler (IO ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Application
app Request
req Response -> IO ResponseReceived
respond
  where
    handler :: SomeException -> IO ResponseReceived
handler SomeException
err = do
      let preq :: ParsedRequest
preq = Request -> ParsedRequest
parseRequest Request
req
          req' :: Request
req' = Request
req {vault = V.insert parsedReqKey preq (vault req)}
      let (ResponderM Request -> IO (Either RouteAction (a, Request))
responder) = SomeException -> ResponderM a
h SomeException
err
      Either RouteAction (a, Request)
eres <- Request -> IO (Either RouteAction (a, Request))
responder Request
req'
      case Either RouteAction (a, Request)
eres of
        Left (Respond Response
res) -> Response -> IO ResponseReceived
respond Response
res
        Either RouteAction (a, Request)
_ -> Application
app Request
req' Response -> IO ResponseReceived
respond

-- | Specify maximum request body size in bytes.
--
-- Defaults to 64KB.
withMaxBodySize :: Word64 -> Middleware
withMaxBodySize :: Word64 -> Middleware
withMaxBodySize Word64
max Application
app Request
req Response -> IO ResponseReceived
respond = do
  let optsM :: Maybe ResponderOptions
optsM = Key ResponderOptions -> Vault -> Maybe ResponderOptions
forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
      opts :: ResponderOptions
opts = ResponderOptions -> Maybe ResponderOptions -> ResponderOptions
forall a. a -> Maybe a -> a
fromMaybe ResponderOptions
defaultResponderOpts Maybe ResponderOptions
optsM
      opts' :: ResponderOptions
opts' = ResponderOptions
opts {optsMaxBodySize = max}
  let req' :: Request
req' = Request
req {vault = V.insert responderOptsKey opts' (vault req)}
  Application
app Request
req' Response -> IO ResponseReceived
respond

-- | Specify `ParseRequestBodyOptions` to use when parsing request body.
withParseBodyOpts :: ParseRequestBodyOptions -> Middleware
withParseBodyOpts :: ParseRequestBodyOptions -> Middleware
withParseBodyOpts ParseRequestBodyOptions
parseBodyOpts Application
app Request
req Response -> IO ResponseReceived
respond = do
  let optsM :: Maybe ResponderOptions
optsM = Key ResponderOptions -> Vault -> Maybe ResponderOptions
forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
      opts :: ResponderOptions
opts = ResponderOptions -> Maybe ResponderOptions -> ResponderOptions
forall a. a -> Maybe a -> a
fromMaybe ResponderOptions
defaultResponderOpts Maybe ResponderOptions
optsM
      opts' :: ResponderOptions
opts' = ResponderOptions
opts {optsParseBody = parseBodyOpts}
  let req' :: Request
req' = Request
req {vault = V.insert responderOptsKey opts' (vault req)}
  Application
app Request
req' Response -> IO ResponseReceived
respond

-- | Get a parameter. Looks in query, path, cookie, and body (in that order).
--
-- If no parameter is found, or parameter fails to parse, `next` is called
-- which passes control to subsequent routes and middleware.
param :: ParsableParam a => Text -> ResponderM a
param :: forall a. ParsableParam a => Text -> ResponderM a
param Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  ResponderM a
-> (Text -> ResponderM a) -> Maybe Text -> ResponderM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponderM a
forall a. ResponderM a
next ((HttpError -> ResponderM a)
-> (a -> ResponderM a) -> Either HttpError a -> ResponderM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ResponderM a -> HttpError -> ResponderM a
forall a b. a -> b -> a
const ResponderM a
forall a. ResponderM a
next) a -> ResponderM a
forall a. a -> ResponderM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HttpError a -> ResponderM a)
-> (Text -> Either HttpError a) -> Text -> ResponderM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get a parameter or error if missing or parse failure.
paramEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)
paramEither :: forall a.
ParsableParam a =>
Text -> ResponderM (Either HttpError a)
paramEither Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  Either HttpError a -> ResponderM (Either HttpError a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpError a -> ResponderM (Either HttpError a))
-> Either HttpError a -> ResponderM (Either HttpError a)
forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam Text
p

-- | Get an optional parameter.
--
-- Returns `Nothing` for missing parameter.
-- Throws `HttpError` on parse failure.
paramMaybe :: ParsableParam a => Text -> ResponderM (Maybe a)
paramMaybe :: forall a. ParsableParam a => Text -> ResponderM (Maybe a)
paramMaybe Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  Maybe a -> ResponderM (Maybe a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ResponderM (Maybe a))
-> Maybe a -> ResponderM (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> (Text -> Maybe a) -> Maybe Text -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing (Either HttpError a -> Maybe a
forall a b. Either a b -> Maybe b
rightToMaybe (Either HttpError a -> Maybe a)
-> (Text -> Either HttpError a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get all parameters from query, path, cookie, and body (in that order).
params :: ResponderM [Param]
params :: ResponderM [Param]
params = ParsedRequest -> [Param]
concatParams (ParsedRequest -> [Param])
-> ResponderM ParsedRequest -> ResponderM [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm

-- | Get a query parameter.
--
-- If no parameter is found, or parameter fails to parse, `next` is called
-- which passes control to subsequent routes and middleware.
queryParam :: ParsableParam a => Text -> ResponderM a
queryParam :: forall a. ParsableParam a => Text -> ResponderM a
queryParam Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  ResponderM a
-> (Text -> ResponderM a) -> Maybe Text -> ResponderM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponderM a
forall a. ResponderM a
next ((HttpError -> ResponderM a)
-> (a -> ResponderM a) -> Either HttpError a -> ResponderM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ResponderM a -> HttpError -> ResponderM a
forall a b. a -> b -> a
const ResponderM a
forall a. ResponderM a
next) a -> ResponderM a
forall a. a -> ResponderM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HttpError a -> ResponderM a)
-> (Text -> Either HttpError a) -> Text -> ResponderM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get a query parameter or error if missing or parse failure.
queryParamEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)
queryParamEither :: forall a.
ParsableParam a =>
Text -> ResponderM (Either HttpError a)
queryParamEither Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  Either HttpError a -> ResponderM (Either HttpError a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpError a -> ResponderM (Either HttpError a))
-> Either HttpError a -> ResponderM (Either HttpError a)
forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam Text
p

-- | Get an optional query parameter.
--
-- Returns `Nothing` for missing parameter.
-- Throws `HttpError` on parse failure.
queryParamMaybe :: ParsableParam a => Text -> ResponderM (Maybe a)
queryParamMaybe :: forall a. ParsableParam a => Text -> ResponderM (Maybe a)
queryParamMaybe Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  Maybe a -> ResponderM (Maybe a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ResponderM (Maybe a))
-> Maybe a -> ResponderM (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> (Text -> Maybe a) -> Maybe Text -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing (Either HttpError a -> Maybe a
forall a b. Either a b -> Maybe b
rightToMaybe (Either HttpError a -> Maybe a)
-> (Text -> Either HttpError a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get all query parameters.
queryParams :: ResponderM [Param]
queryParams :: ResponderM [Param]
queryParams = ParsedRequest -> [Param]
preqQueryParams (ParsedRequest -> [Param])
-> ResponderM ParsedRequest -> ResponderM [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm

-- | Get a path parameter.
--
-- If no parameter is found, or parameter fails to parse, `next` is called
-- which passes control to subsequent routes and middleware.
pathParam :: ParsableParam a => Text -> ResponderM a
pathParam :: forall a. ParsableParam a => Text -> ResponderM a
pathParam Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  ResponderM a
-> (Text -> ResponderM a) -> Maybe Text -> ResponderM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponderM a
forall a. ResponderM a
next ((HttpError -> ResponderM a)
-> (a -> ResponderM a) -> Either HttpError a -> ResponderM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ResponderM a -> HttpError -> ResponderM a
forall a b. a -> b -> a
const ResponderM a
forall a. ResponderM a
next) a -> ResponderM a
forall a. a -> ResponderM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HttpError a -> ResponderM a)
-> (Text -> Either HttpError a) -> Text -> ResponderM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get a path parameter or error if missing or parse failure.
pathParamEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)
pathParamEither :: forall a.
ParsableParam a =>
Text -> ResponderM (Either HttpError a)
pathParamEither Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  Either HttpError a -> ResponderM (Either HttpError a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpError a -> ResponderM (Either HttpError a))
-> Either HttpError a -> ResponderM (Either HttpError a)
forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam Text
p

-- | Get an optional path parameter.
--
-- Returns `Nothing` for missing parameter.
-- Throws `HttpError` on parse failure.
pathParamMaybe :: ParsableParam a => Text -> ResponderM (Maybe a)
pathParamMaybe :: forall a. ParsableParam a => Text -> ResponderM (Maybe a)
pathParamMaybe Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  Maybe a -> ResponderM (Maybe a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ResponderM (Maybe a))
-> Maybe a -> ResponderM (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> (Text -> Maybe a) -> Maybe Text -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing (Either HttpError a -> Maybe a
forall a b. Either a b -> Maybe b
rightToMaybe (Either HttpError a -> Maybe a)
-> (Text -> Either HttpError a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get all path parameters.
pathParams :: ResponderM [Param]
pathParams :: ResponderM [Param]
pathParams = ParsedRequest -> [Param]
preqPathParams (ParsedRequest -> [Param])
-> ResponderM ParsedRequest -> ResponderM [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm

-- | Get a cookie parameter.
--
-- If no parameter is found, or parameter fails to parse, `next` is called
-- which passes control to subsequent routes and middleware.
cookieParam :: ParsableParam a => Text -> ResponderM a
cookieParam :: forall a. ParsableParam a => Text -> ResponderM a
cookieParam Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  ResponderM a
-> (Text -> ResponderM a) -> Maybe Text -> ResponderM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponderM a
forall a. ResponderM a
next ((HttpError -> ResponderM a)
-> (a -> ResponderM a) -> Either HttpError a -> ResponderM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ResponderM a -> HttpError -> ResponderM a
forall a b. a -> b -> a
const ResponderM a
forall a. ResponderM a
next) a -> ResponderM a
forall a. a -> ResponderM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HttpError a -> ResponderM a)
-> (Text -> Either HttpError a) -> Text -> ResponderM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get a cookie parameter or error if missing or parse failure.
cookieParamEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)
cookieParamEither :: forall a.
ParsableParam a =>
Text -> ResponderM (Either HttpError a)
cookieParamEither Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  Either HttpError a -> ResponderM (Either HttpError a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpError a -> ResponderM (Either HttpError a))
-> Either HttpError a -> ResponderM (Either HttpError a)
forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam Text
p

-- | Get an optional cookie parameter.
--
-- Returns `Nothing` for missing parameter.
-- Throws `HttpError` on parse failure.
cookieParamMaybe :: ParsableParam a => Text -> ResponderM (Maybe a)
cookieParamMaybe :: forall a. ParsableParam a => Text -> ResponderM (Maybe a)
cookieParamMaybe Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Text
forall a b. (a, b) -> b
snd (Maybe Param -> Maybe Text)
-> ([Param] -> Maybe Param) -> [Param] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Bool) -> [Param] -> Maybe Param
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
name (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> a
fst) ([Param] -> Maybe Text)
-> ResponderM [Param] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  Maybe a -> ResponderM (Maybe a)
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ResponderM (Maybe a))
-> Maybe a -> ResponderM (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> (Text -> Maybe a) -> Maybe Text -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing (Either HttpError a -> Maybe a
forall a b. Either a b -> Maybe b
rightToMaybe (Either HttpError a -> Maybe a)
-> (Text -> Either HttpError a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam) Maybe Text
pM

-- | Get all cookie parameters.
cookieParams :: ResponderM [Param]
cookieParams :: ResponderM [Param]
cookieParams = ParsedRequest -> [Param]
preqCookieParams (ParsedRequest -> [Param])
-> ResponderM ParsedRequest -> ResponderM [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm

-- | Get uploaded `FileInfo`.
--
-- If missing parameter or empty file, pass control to subsequent routes and
-- middleware.
file :: Text -> ResponderM (FileInfo BL.ByteString)
file :: Text -> ResponderM (FileInfo ByteString)
file Text
name = ResponderM (FileInfo ByteString)
-> (FileInfo ByteString -> ResponderM (FileInfo ByteString))
-> Maybe (FileInfo ByteString)
-> ResponderM (FileInfo ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponderM (FileInfo ByteString)
forall a. ResponderM a
next FileInfo ByteString -> ResponderM (FileInfo ByteString)
forall a. a -> ResponderM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FileInfo ByteString) -> ResponderM (FileInfo ByteString))
-> ResponderM (Maybe (FileInfo ByteString))
-> ResponderM (FileInfo ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> ResponderM (Maybe (FileInfo ByteString))
fileMaybe Text
name

-- | Get optional uploaded `FileInfo`.
--
-- `Nothing` is returned for missing parameter or empty file content.
fileMaybe :: Text -> ResponderM (Maybe (FileInfo BL.ByteString))
fileMaybe :: Text -> ResponderM (Maybe (FileInfo ByteString))
fileMaybe Text
name = do
  Maybe (FileInfo ByteString)
fM <- ((ByteString, FileInfo ByteString) -> FileInfo ByteString)
-> Maybe (ByteString, FileInfo ByteString)
-> Maybe (FileInfo ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, FileInfo ByteString) -> FileInfo ByteString
forall a b. (a, b) -> b
snd (Maybe (ByteString, FileInfo ByteString)
 -> Maybe (FileInfo ByteString))
-> ([(ByteString, FileInfo ByteString)]
    -> Maybe (ByteString, FileInfo ByteString))
-> [(ByteString, FileInfo ByteString)]
-> Maybe (FileInfo ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, FileInfo ByteString) -> Bool)
-> [(ByteString, FileInfo ByteString)]
-> Maybe (ByteString, FileInfo ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> ByteString
encodeUtf8 Text
name) (ByteString -> Bool)
-> ((ByteString, FileInfo ByteString) -> ByteString)
-> (ByteString, FileInfo ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, FileInfo ByteString) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, FileInfo ByteString)]
 -> Maybe (FileInfo ByteString))
-> ResponderM [(ByteString, FileInfo ByteString)]
-> ResponderM (Maybe (FileInfo ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [(ByteString, FileInfo ByteString)]
files
  case FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent (FileInfo ByteString -> ByteString)
-> Maybe (FileInfo ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FileInfo ByteString)
fM of
    Maybe ByteString
Nothing -> Maybe (FileInfo ByteString)
-> ResponderM (Maybe (FileInfo ByteString))
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FileInfo ByteString)
forall a. Maybe a
Nothing
    Just ByteString
"" -> Maybe (FileInfo ByteString)
-> ResponderM (Maybe (FileInfo ByteString))
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FileInfo ByteString)
forall a. Maybe a
Nothing
    Just ByteString
_ -> Maybe (FileInfo ByteString)
-> ResponderM (Maybe (FileInfo ByteString))
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FileInfo ByteString)
fM

-- | Get all uploaded files.
files :: ResponderM [File BL.ByteString]
files :: ResponderM [(ByteString, FileInfo ByteString)]
files = Maybe ParsedBody -> [(ByteString, FileInfo ByteString)]
fs (Maybe ParsedBody -> [(ByteString, FileInfo ByteString)])
-> (ParsedRequest -> Maybe ParsedBody)
-> ParsedRequest
-> [(ByteString, FileInfo ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedRequest -> Maybe ParsedBody
preqBody (ParsedRequest -> [(ByteString, FileInfo ByteString)])
-> ResponderM ParsedRequest
-> ResponderM [(ByteString, FileInfo ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm
  where
    fs :: Maybe ParsedBody -> [(ByteString, FileInfo ByteString)]
fs Maybe ParsedBody
bodyM = case Maybe ParsedBody
bodyM of
      Just (FormBody ([Param]
_, [(ByteString, FileInfo ByteString)]
fs)) -> [(ByteString, FileInfo ByteString)]
fs
      Maybe ParsedBody
_ -> []

-- | Get the JSON value from request body.
fromBody :: JSON.FromJSON a => ResponderM a
fromBody :: forall a. FromJSON a => ResponderM a
fromBody = do
  Value
json <- ResponderM Value
parseBodyJson
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
json of
    JSON.Error String
msg -> HttpError -> ResponderM a
forall e a. (HasCallStack, Exception e) => e -> ResponderM a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HttpError -> ResponderM a) -> HttpError -> ResponderM a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
msg
    JSON.Success a
a -> a -> ResponderM a
forall a. a -> ResponderM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Get the value of a request `Header`. Header names are case-insensitive.
header :: Text -> ResponderM (Maybe Text)
header :: Text -> ResponderM (Maybe Text)
header Text
name = do
  let ciname :: HeaderName
ciname = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
encodeUtf8 Text
name)
  ((HeaderName, ByteString) -> Text)
-> Maybe (HeaderName, ByteString) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> ((HeaderName, ByteString) -> ByteString)
-> (HeaderName, ByteString)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) (Maybe (HeaderName, ByteString) -> Maybe Text)
-> ([(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString))
-> [(HeaderName, ByteString)]
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) HeaderName
ciname (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) ([(HeaderName, ByteString)] -> Maybe Text)
-> ResponderM [(HeaderName, ByteString)] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [(HeaderName, ByteString)]
headers

-- | Get the request headers.
headers :: ResponderM [Header]
headers :: ResponderM [(HeaderName, ByteString)]
headers = Request -> [(HeaderName, ByteString)]
requestHeaders (Request -> [(HeaderName, ByteString)])
-> ResponderM Request -> ResponderM [(HeaderName, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM Request
request

-- | Get the WAI `Request`.
request :: ResponderM Request
request :: ResponderM Request
request = ResponderM Request
getRequest

-- | Send a `Response`.
--
-- > send $ text "Hello, World!"
--
-- Send an `html` response:
--
-- > send $ html "<h1>Hello, World!</h1>"
--
-- Modify the `status`:
--
-- > send $ status status404 $ text "Not Found"
--
-- Send a response `withHeader`:
--
-- > send $ withHeader (hServer, "Twain + Warp") $ text "Hello"
--
-- Send a response `withCookie`:
--
-- > send $ withCookie "key" "val" $ text "Hello"
send :: Response -> ResponderM a
send :: forall a. Response -> ResponderM a
send Response
res = (Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (a, Request))) -> ResponderM a)
-> (Request -> IO (Either RouteAction (a, Request)))
-> ResponderM a
forall a b. (a -> b) -> a -> b
$ \Request
_ -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either RouteAction (a, Request)
 -> IO (Either RouteAction (a, Request)))
-> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a b. (a -> b) -> a -> b
$ RouteAction -> Either RouteAction (a, Request)
forall a b. a -> Either a b
Left (Response -> RouteAction
Respond Response
res)

-- | Pass control to the next route or middleware.
next :: ResponderM a
next :: forall a. ResponderM a
next = (Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (a, Request))) -> ResponderM a)
-> (Request -> IO (Either RouteAction (a, Request)))
-> ResponderM a
forall a b. (a -> b) -> a -> b
$ \Request
_ -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteAction -> Either RouteAction (a, Request)
forall a b. a -> Either a b
Left RouteAction
Next)

-- | Construct a `Text` response.
--
-- Sets the Content-Type and Content-Length headers.
text :: Text -> Response
text :: Text -> Response
text =
   Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status200 [(HeaderName
hContentType, ByteString
"text/plain; charset=utf-8")] (ByteString -> Response)
-> (Text -> ByteString) -> Text -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Construct an HTML response.
--
-- Sets the Content-Type and Content-Length headers.
html :: BL.ByteString -> Response
html :: ByteString -> Response
html =
   Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status200 [(HeaderName
hContentType, ByteString
"text/html; charset=utf-8")]

-- | Construct a JSON response using `ToJSON`.
--
-- Sets the Content-Type and Content-Length headers.
json :: ToJSON a => a -> Response
json :: forall a. ToJSON a => a -> Response
json =
  Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status200 [(HeaderName
hContentType, ByteString
"application/json; charset=utf-8")] (ByteString -> Response) -> (a -> ByteString) -> a -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode

-- | Construct a CSS response.
--
-- Sets the Content-Type and Content-Length headers.
css :: BL.ByteString -> Response
css :: ByteString -> Response
css =
  Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status200 [(HeaderName
hContentType, ByteString
"text/css; charset=utf-8")]

-- | Construct an XML response.
--
-- Sets the Content-Type and Content-Length headers.
xml :: BL.ByteString -> Response
xml :: ByteString -> Response
xml = Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status200 [(HeaderName
hContentType, ByteString
"application/xml; charset=utf-8")]

-- | Construct a raw response from a lazy `ByteString`.
--
-- Sets the Content-Length header if missing.
raw :: Status -> [Header] -> BL.ByteString -> Response
raw :: Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status [(HeaderName, ByteString)]
headers ByteString
body =
  if ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any ((HeaderName
hContentLength HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, ByteString)]
headers
    then Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status [(HeaderName, ByteString)]
headers ByteString
body
    else
      let len :: (HeaderName, ByteString)
len = (HeaderName
hContentLength, String -> ByteString
Char8.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
body)))
       in Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status ((HeaderName, ByteString)
len (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) ByteString
body

-- | Set the `Status` for a `Response`.
status :: Status -> Response -> Response
status :: Status -> Response -> Response
status Status
s = (Status -> Status) -> Response -> Response
mapResponseStatus (Status -> Status -> Status
forall a b. a -> b -> a
const Status
s)

-- | Add a `Header` to response.
withHeader :: Header -> Response -> Response
withHeader :: (HeaderName, ByteString) -> Response -> Response
withHeader (HeaderName, ByteString)
header = ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
mapResponseHeaders ((HeaderName, ByteString)
header (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
:)

-- | Add a cookie to the response with the given key and value.
--
-- Note: This uses `defaultSetCookie`.
withCookie :: Text -> Text -> Response -> Response
withCookie :: Text -> Text -> Response -> Response
withCookie Text
key Text
val Response
res =
  let setCookie :: SetCookie
setCookie =
        SetCookie
defaultSetCookie
          { setCookieName = encodeUtf8 key,
            setCookieValue = encodeUtf8 val,
            setCookiePath = Just "/",
            setCookieHttpOnly = True
          }
      header :: (HeaderName, ByteString)
header = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"Set-Cookie", SetCookie -> ByteString
setCookieByteString SetCookie
setCookie)
   in ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
mapResponseHeaders ((HeaderName, ByteString)
header (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
:) Response
res

-- | Add a `SetCookie` to the response.
withCookie' :: SetCookie -> Response -> Response
withCookie' :: SetCookie -> Response -> Response
withCookie' SetCookie
setCookie Response
res =
  let header :: (HeaderName, ByteString)
header = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"Set-Cookie", SetCookie -> ByteString
setCookieByteString SetCookie
setCookie)
   in ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
mapResponseHeaders ((HeaderName, ByteString)
header (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
:) Response
res

-- | Add a header to expire (unset) a cookie with the given key.
expireCookie :: Text -> Response -> Response
expireCookie :: Text -> Response -> Response
expireCookie Text
key Response
res = do
  let zeroTime :: UTCTime
zeroTime = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) (Integer -> DiffTime
secondsToDiffTime Integer
0)
      setCookie :: SetCookie
setCookie =
        SetCookie
defaultSetCookie
          { setCookieName = encodeUtf8 key,
            setCookiePath = Just "/",
            setCookieHttpOnly = True,
            setCookieExpires = Just zeroTime
          }
      header :: (HeaderName, ByteString)
header = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"Set-Cookie", SetCookie -> ByteString
setCookieByteString SetCookie
setCookie)
   in ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
mapResponseHeaders ((HeaderName, ByteString)
header (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
:) Response
res

-- | Create a redirect response with 301 status (Moved Permanently).
redirect301 :: Text -> Response
redirect301 :: Text -> Response
redirect301 Text
url = Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status301 [(HeaderName
hLocation, Text -> ByteString
encodeUtf8 Text
url)] ByteString
""

-- | Create a redirect response with 302 status (Found).
redirect302 :: Text -> Response
redirect302 :: Text -> Response
redirect302 Text
url = Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status302 [(HeaderName
hLocation, Text -> ByteString
encodeUtf8 Text
url)] ByteString
""

-- | Create a redirect response 303 status (See Other).
redirect303 :: Text -> Response
redirect303 :: Text -> Response
redirect303 Text
url = Status -> [(HeaderName, ByteString)] -> ByteString -> Response
raw Status
status303 [(HeaderName
hLocation, Text -> ByteString
encodeUtf8 Text
url)] ByteString
""