-- | 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 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 = forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (forall a. a -> Maybe a
Just ByteString
"GET")

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

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

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

delete :: PathPattern -> ResponderM a -> Middleware
delete :: forall a. PathPattern -> ResponderM a -> Middleware
delete = forall a.
Maybe ByteString -> PathPattern -> ResponderM a -> Middleware
route (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
  Request
req' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req) (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 :: [Param]
preqPathParams = [Param]
pathParams}
          req'' :: Request
req'' = Request
req' {vault :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq' (Request -> Vault
vault Request
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 :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq (Request -> Vault
vault Request
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 forall a b. (a -> b) -> a -> b
$ (Status -> Status) -> Response -> Response
mapResponseStatus (forall a b. a -> b -> a
const Status
status404) Response
res
    Either RouteAction (a, Request)
_ -> Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ Status -> Response -> Response
status Status
status404 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
  forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ResponseReceived
handler 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 :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ParsedRequest
parsedReqKey ParsedRequest
preq (Request -> Vault
vault Request
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 = forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
      opts :: ResponderOptions
opts = forall a. a -> Maybe a -> a
fromMaybe ResponderOptions
defaultResponderOpts Maybe ResponderOptions
optsM
      opts' :: ResponderOptions
opts' = ResponderOptions
opts {optsMaxBodySize :: Word64
optsMaxBodySize = Word64
max}
  let req' :: Request
req' = Request
req {vault :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ResponderOptions
responderOptsKey ResponderOptions
opts' (Request -> Vault
vault Request
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 = forall a. Key a -> Vault -> Maybe a
V.lookup Key ResponderOptions
responderOptsKey (Request -> Vault
vault Request
req)
      opts :: ResponderOptions
opts = forall a. a -> Maybe a -> a
fromMaybe ResponderOptions
defaultResponderOpts Maybe ResponderOptions
optsM
      opts' :: ResponderOptions
opts' = ResponderOptions
opts {optsParseBody :: ParseRequestBodyOptions
optsParseBody = ParseRequestBodyOptions
parseBodyOpts}
  let req' :: Request
req' = Request
req {vault :: Vault
vault = forall a. Key a -> a -> Vault -> Vault
V.insert Key ResponderOptions
responderOptsKey ResponderOptions
opts' (Request -> Vault
vault Request
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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ResponderM a
next (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. ResponderM a
next) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
params
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a b. Either a b -> Maybe b
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ResponderM a
next (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. ResponderM a
next) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
queryParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a b. Either a b -> Maybe b
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ResponderM a
next (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. ResponderM a
next) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
pathParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a b. Either a b -> Maybe b
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ResponderM a
next (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. ResponderM a
next) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
pM of
    Maybe Text
Nothing ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 (String
"missing parameter: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    Just Text
p -> 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [Param]
cookieParams
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a b. Either a b -> Maybe b
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. ResponderM a
next forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) (Text -> ByteString
encodeUtf8 Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [(ByteString, FileInfo ByteString)]
files
  case forall c. FileInfo c -> c
fileContent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FileInfo ByteString)
fM of
    Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just ByteString
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just ByteString
_ -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedRequest -> Maybe ParsedBody
preqBody 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 forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
json of
    JSON.Error String
msg -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
msg
    JSON.Success a
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 = forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
encodeUtf8 Text
name)
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (forall a. Eq a => a -> a -> Bool
(==) HeaderName
ciname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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 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 = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (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")] forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict 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")] forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any ((HeaderName
hContentLength forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 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 (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 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 :: ByteString
setCookieName = Text -> ByteString
encodeUtf8 Text
key,
            setCookieValue :: ByteString
setCookieValue = Text -> ByteString
encodeUtf8 Text
val,
            setCookiePath :: Maybe ByteString
setCookiePath = forall a. a -> Maybe a
Just ByteString
"/",
            setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
          }
      header :: (HeaderName, ByteString)
header = (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 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 = (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 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 :: ByteString
setCookieName = Text -> ByteString
encodeUtf8 Text
key,
            setCookiePath :: Maybe ByteString
setCookiePath = forall a. a -> Maybe a
Just ByteString
"/",
            setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True,
            setCookieExpires :: Maybe UTCTime
setCookieExpires = forall a. a -> Maybe a
Just UTCTime
zeroTime
          }
      header :: (HeaderName, ByteString)
header = (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 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
""