module Web.Twain
  ( -- * Twain to WAI
    twain,
    twain',
    twainApp,

    -- * Middleware and Routes.
    middleware,
    get,
    put,
    patch,
    post,
    delete,
    notFound,
    onException,
    addRoute,

    -- * Request and Parameters.
    env,
    param,
    param',
    paramMaybe,
    params,
    file,
    files,
    header,
    headers,
    request,

    -- * Responses.
    send,
    next,
    redirect301,
    redirect302,
    redirect303,
    text,
    html,
    json,
    xml,
    raw,
    status,
    withHeader,
    withCookie,
    withCookie',
    expireCookie,
    module Web.Twain.Types,
    module Network.HTTP.Types,
  )
where

import Control.Exception (SomeException)
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.Text as T
import Data.Text.Encoding
import Data.Time
import Network.HTTP.Types
import Network.Wai (Application, Middleware, Request, Response, mapResponseHeaders, mapResponseStatus, requestHeaders, responseLBS)
import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, runEnv, runSettings, setOnExceptionResponse, setPort)
import Network.Wai.Parse (File, FileInfo, defaultParseRequestBodyOptions)
import System.Environment (lookupEnv)
import Web.Cookie
import Web.Twain.Internal
import Web.Twain.Types

-- | Run a Twain app on `Port` using the given environment.
--
-- If a PORT environment variable is set, it will take precendence.
--
-- > twain 8080 "My App" $ do
-- >   middleware logger
-- >   get "/" $ do
-- >     appTitle <- env
-- >     send $ text ("Hello from " <> appTitle)
-- >   get "/greetings/:name"
-- >     name <- param "name"
-- >     send $ text ("Hello, " <> name)
-- >   notFound $ do
-- >     send $ status status404 $ text "Not Found"
twain :: Port -> e -> TwainM e () -> IO ()
twain :: Port -> e -> TwainM e () -> IO ()
twain Port
port e
env TwainM e ()
m = do
  Maybe String
mp <- String -> IO (Maybe String)
lookupEnv String
"PORT"
  let p :: Port
p = Port -> (String -> Port) -> Maybe String -> Port
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Port
port String -> Port
forall a. Read a => String -> a
read Maybe String
mp
      st :: TwainState e
st = TwainM e () -> e -> TwainState e
forall e a. TwainM e a -> e -> TwainState e
exec TwainM e ()
m e
env
      app :: Application
app = [Middleware] -> Application
composeMiddleware ([Middleware] -> Application) -> [Middleware] -> Application
forall a b. (a -> b) -> a -> b
$ TwainState e -> [Middleware]
forall e. TwainState e -> [Middleware]
middlewares TwainState e
st
      handler :: SomeException -> Response
handler = TwainState e -> SomeException -> Response
forall e. TwainState e -> SomeException -> Response
onExceptionResponse TwainState e
st
      settings' :: Settings
settings' = (SomeException -> Response) -> Settings -> Settings
setOnExceptionResponse SomeException -> Response
handler (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Port -> Settings -> Settings
setPort Port
p Settings
defaultSettings
  Settings -> Application -> IO ()
runSettings Settings
settings' Application
app

-- | Run a Twain app passing Warp `Settings`.
twain' :: Settings -> e -> TwainM e () -> IO ()
twain' :: Settings -> e -> TwainM e () -> IO ()
twain' Settings
settings e
env TwainM e ()
m = do
  let st :: TwainState e
st = TwainM e () -> e -> TwainState e
forall e a. TwainM e a -> e -> TwainState e
exec TwainM e ()
m e
env
      app :: Application
app = [Middleware] -> Application
composeMiddleware ([Middleware] -> Application) -> [Middleware] -> Application
forall a b. (a -> b) -> a -> b
$ TwainState e -> [Middleware]
forall e. TwainState e -> [Middleware]
middlewares TwainState e
st
      settings' :: Settings
settings' = (SomeException -> Response) -> Settings -> Settings
setOnExceptionResponse (TwainState e -> SomeException -> Response
forall e. TwainState e -> SomeException -> Response
onExceptionResponse TwainState e
st) Settings
settings
  Settings -> Application -> IO ()
runSettings Settings
settings' Application
app

-- | Create a WAI `Application` from a Twain app and environment.
twainApp :: e -> TwainM e () -> Application
twainApp :: e -> TwainM e () -> Application
twainApp e
env TwainM e ()
m = [Middleware] -> Application
composeMiddleware ([Middleware] -> Application) -> [Middleware] -> Application
forall a b. (a -> b) -> a -> b
$ TwainState e -> [Middleware]
forall e. TwainState e -> [Middleware]
middlewares (TwainState e -> [Middleware]) -> TwainState e -> [Middleware]
forall a b. (a -> b) -> a -> b
$ TwainM e () -> e -> TwainState e
forall e a. TwainM e a -> e -> TwainState e
exec TwainM e ()
m e
env

-- | Use the given middleware. The first declared is the outermost middleware
-- (it has first access to request and last action on response).
middleware :: Middleware -> TwainM e ()
middleware :: Middleware -> TwainM e ()
middleware Middleware
m = (TwainState e -> TwainState e) -> TwainM e ()
forall e. (TwainState e -> TwainState e) -> TwainM e ()
modify (\TwainState e
st -> TwainState e
st {middlewares :: [Middleware]
middlewares = Middleware
m Middleware -> [Middleware] -> [Middleware]
forall a. a -> [a] -> [a]
: TwainState e -> [Middleware]
forall e. TwainState e -> [Middleware]
middlewares TwainState e
st})

get :: PathPattern -> RouteM e a -> TwainM e ()
get :: PathPattern -> RouteM e a -> TwainM e ()
get = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"GET")

put :: PathPattern -> RouteM e a -> TwainM e ()
put :: PathPattern -> RouteM e a -> TwainM e ()
put = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"PUT")

patch :: PathPattern -> RouteM e a -> TwainM e ()
patch :: PathPattern -> RouteM e a -> TwainM e ()
patch = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"PATCH")

post :: PathPattern -> RouteM e a -> TwainM e ()
post :: PathPattern -> RouteM e a -> TwainM e ()
post = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"POST")

delete :: PathPattern -> RouteM e a -> TwainM e ()
delete :: PathPattern -> RouteM e a -> TwainM e ()
delete = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"DELETE")

-- | Add a route if nothing else is found. This matches any request, so it
-- should go last.
notFound :: RouteM e a -> TwainM e ()
notFound :: RouteM e a -> TwainM e ()
notFound = Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute Maybe Method
forall a. Maybe a
Nothing ((Request -> Maybe [Param]) -> PathPattern
MatchPath (Maybe [Param] -> Request -> Maybe [Param]
forall a b. a -> b -> a
const ([Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [])))

-- | Render a `Response` on exceptions.
onException :: (SomeException -> Response) -> TwainM e ()
onException :: (SomeException -> Response) -> TwainM e ()
onException SomeException -> Response
handler = (TwainState e -> TwainState e) -> TwainM e ()
forall e. (TwainState e -> TwainState e) -> TwainM e ()
modify ((TwainState e -> TwainState e) -> TwainM e ())
-> (TwainState e -> TwainState e) -> TwainM e ()
forall a b. (a -> b) -> a -> b
$ \TwainState e
st -> TwainState e
st {onExceptionResponse :: SomeException -> Response
onExceptionResponse = SomeException -> Response
handler}

-- | Add a route matching `Method` (optional) and `PathPattern`.
addRoute :: Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute :: Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()
addRoute Maybe Method
method PathPattern
pat RouteM e a
route =
  (TwainState e -> TwainState e) -> TwainM e ()
forall e. (TwainState e -> TwainState e) -> TwainM e ()
modify ((TwainState e -> TwainState e) -> TwainM e ())
-> (TwainState e -> TwainState e) -> TwainM e ()
forall a b. (a -> b) -> a -> b
$ \TwainState e
st ->
    let m :: Middleware
m = Maybe Method -> PathPattern -> RouteM e a -> e -> Middleware
forall e a.
Maybe Method -> PathPattern -> RouteM e a -> e -> Middleware
routeMiddleware Maybe Method
method PathPattern
pat RouteM e a
route (TwainState e -> e
forall e. TwainState e -> e
environment TwainState e
st)
     in TwainState e
st {middlewares :: [Middleware]
middlewares = Middleware
m Middleware -> [Middleware] -> [Middleware]
forall a. a -> [a] -> [a]
: TwainState e -> [Middleware]
forall e. TwainState e -> [Middleware]
middlewares TwainState e
st}

-- | Get the app environment.
env :: RouteM e e
env :: RouteM e e
env = (RouteState e -> IO (Either RouteAction (e, RouteState e)))
-> RouteM e e
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (e, RouteState e)))
 -> RouteM e e)
-> (RouteState e -> IO (Either RouteAction (e, RouteState e)))
-> RouteM e e
forall a b. (a -> b) -> a -> b
$ \RouteState e
st -> Either RouteAction (e, RouteState e)
-> IO (Either RouteAction (e, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either RouteAction (e, RouteState e)
 -> IO (Either RouteAction (e, RouteState e)))
-> Either RouteAction (e, RouteState e)
-> IO (Either RouteAction (e, RouteState e))
forall a b. (a -> b) -> a -> b
$ (e, RouteState e) -> Either RouteAction (e, RouteState e)
forall a b. b -> Either a b
Right (RouteState e -> e
forall e. RouteState e -> e
reqEnv RouteState e
st, RouteState e
st)

-- | 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 -> RouteM e a
param :: Text -> RouteM e a
param Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
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)
-> RouteM e [Param] -> RouteM e (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e [Param]
forall e. RouteM e [Param]
params
  RouteM e a -> (Text -> RouteM e a) -> Maybe Text -> RouteM e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RouteM e a
forall e a. RouteM e a
next ((Text -> RouteM e a)
-> (a -> RouteM e a) -> Either Text a -> RouteM e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (RouteM e a -> Text -> RouteM e a
forall a b. a -> b -> a
const RouteM e a
forall e a. RouteM e a
next) a -> RouteM e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> RouteM e a)
-> (Text -> Either Text a) -> Text -> RouteM e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a. ParsableParam a => Text -> Either Text a
parseParam) Maybe Text
pM

-- | Get a parameter or error if missing or parse failure.
param' :: ParsableParam a => Text -> RouteM e (Either Text a)
param' :: Text -> RouteM e (Either Text a)
param' Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
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)
-> RouteM e [Param] -> RouteM e (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e [Param]
forall e. RouteM e [Param]
params
  Either Text a -> RouteM e (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> RouteM e (Either Text a))
-> Either Text a -> RouteM e (Either Text a)
forall a b. (a -> b) -> a -> b
$ Either Text a
-> (Text -> Either Text a) -> Maybe Text -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text a
forall a b. a -> Either a b
Left (Text
"missing parameter: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)) Text -> Either Text a
forall a. ParsableParam a => Text -> Either Text a
parseParam Maybe Text
pM

-- | Get an optional parameter. `Nothing` is returned for missing parameter or
-- parse failure.
paramMaybe :: ParsableParam a => Text -> RouteM e (Maybe a)
paramMaybe :: Text -> RouteM e (Maybe a)
paramMaybe Text
name = do
  Maybe Text
pM <- (Param -> Text) -> Maybe Param -> Maybe Text
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)
-> RouteM e [Param] -> RouteM e (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e [Param]
forall e. RouteM e [Param]
params
  Maybe a -> RouteM e (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> RouteM e (Maybe a)) -> Maybe a -> RouteM e (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 Text a -> Maybe a
forall a b. Either a b -> Maybe b
rightToMaybe (Either Text a -> Maybe a)
-> (Text -> Either Text a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a. ParsableParam a => Text -> Either Text a
parseParam) Maybe Text
pM

-- | Get all parameters from query, path, cookie, and body (in that order).
params :: RouteM e [Param]
params :: RouteM e [Param]
params = ([Param], [File ByteString]) -> [Param]
forall a b. (a, b) -> a
fst (([Param], [File ByteString]) -> [Param])
-> RouteM e ([Param], [File ByteString]) -> RouteM e [Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> RouteM e ([Param], [File ByteString])
forall e.
ParseRequestBodyOptions -> RouteM e ([Param], [File ByteString])
parseBody ParseRequestBodyOptions
defaultParseRequestBodyOptions

-- | Get uploaded `FileInfo`.
file :: Text -> RouteM e (Maybe (FileInfo BL.ByteString))
file :: Text -> RouteM e (Maybe (FileInfo ByteString))
file Text
name = (File ByteString -> FileInfo ByteString)
-> Maybe (File ByteString) -> Maybe (FileInfo ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap File ByteString -> FileInfo ByteString
forall a b. (a, b) -> b
snd (Maybe (File ByteString) -> Maybe (FileInfo ByteString))
-> ([File ByteString] -> Maybe (File ByteString))
-> [File ByteString]
-> Maybe (FileInfo ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (File ByteString -> Bool)
-> [File ByteString] -> Maybe (File ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Method
encodeUtf8 Text
name) (Method -> Bool)
-> (File ByteString -> Method) -> File ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. File ByteString -> Method
forall a b. (a, b) -> a
fst) ([File ByteString] -> Maybe (FileInfo ByteString))
-> RouteM e [File ByteString]
-> RouteM e (Maybe (FileInfo ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e [File ByteString]
forall e. RouteM e [File ByteString]
files

-- | Get all uploaded files.
files :: RouteM e [File BL.ByteString]
files :: RouteM e [File ByteString]
files = ([Param], [File ByteString]) -> [File ByteString]
forall a b. (a, b) -> b
snd (([Param], [File ByteString]) -> [File ByteString])
-> RouteM e ([Param], [File ByteString])
-> RouteM e [File ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> RouteM e ([Param], [File ByteString])
forall e.
ParseRequestBodyOptions -> RouteM e ([Param], [File ByteString])
parseBody ParseRequestBodyOptions
defaultParseRequestBodyOptions

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

-- | Get the request headers.
headers :: RouteM e [Header]
headers :: RouteM e [(CI Method, Method)]
headers = Request -> [(CI Method, Method)]
requestHeaders (Request -> [(CI Method, Method)])
-> RouteM e Request -> RouteM e [(CI Method, Method)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e Request
forall e. RouteM e Request
request

-- | Get the JSON value from request body.
bodyJson :: JSON.FromJSON a => RouteM e (Either String a)
bodyJson :: RouteM e (Either String a)
bodyJson = do
  Either String Value
jsonE <- RouteM e (Either String Value)
forall e. RouteM e (Either String Value)
parseBodyJson
  case Either String Value
jsonE of
    Left String
e -> Either String a -> RouteM e (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
e)
    Right Value
v -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
v of
      JSON.Error String
e -> Either String a -> RouteM e (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
e)
      JSON.Success a
a -> Either String a -> RouteM e (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either String a
forall a b. b -> Either a b
Right a
a)

-- | Get the WAI `Request`.
request :: RouteM e Request
request :: RouteM e Request
request = RouteState e -> Request
forall e. RouteState e -> Request
reqWai (RouteState e -> Request)
-> RouteM e (RouteState e) -> RouteM e Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteM e (RouteState e)
forall e. RouteM e (RouteState e)
routeState

-- | 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 -> RouteM e a
send :: Response -> RouteM e a
send Response
res = (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (a, RouteState e)))
 -> RouteM e a)
-> (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall a b. (a -> b) -> a -> b
$ \RouteState e
_ -> Either RouteAction (a, RouteState e)
-> IO (Either RouteAction (a, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either RouteAction (a, RouteState e)
 -> IO (Either RouteAction (a, RouteState e)))
-> Either RouteAction (a, RouteState e)
-> IO (Either RouteAction (a, RouteState e))
forall a b. (a -> b) -> a -> b
$ RouteAction -> Either RouteAction (a, RouteState e)
forall a b. a -> Either a b
Left (Response -> RouteAction
Respond Response
res)

-- | Pass control to the next route or middleware.
next :: RouteM e a
next :: RouteM e a
next = (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (a, RouteState e)))
 -> RouteM e a)
-> (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall a b. (a -> b) -> a -> b
$ \RouteState e
_ -> Either RouteAction (a, RouteState e)
-> IO (Either RouteAction (a, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteAction -> Either RouteAction (a, RouteState e)
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 Text
body =
  let lbs :: ByteString
lbs = Method -> ByteString
BL.fromStrict (Text -> Method
encodeUtf8 Text
body)
      typ :: (CI Method, Method)
typ = (CI Method
hContentType, Method
"text/plain; charset=utf-8")
      len :: (CI Method, Method)
len = (CI Method
hContentLength, String -> Method
Char8.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
lbs)))
   in Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status200 [(CI Method, Method)
typ, (CI Method, Method)
len] ByteString
lbs

-- | Construct an HTML response.
--
-- Sets the Content-Type and Content-Length headers.
html :: BL.ByteString -> Response
html :: ByteString -> Response
html ByteString
body =
  let lbs :: ByteString
lbs = ByteString
body
      typ :: (CI Method, Method)
typ = (CI Method
hContentType, Method
"text/html; charset=utf-8")
      len :: (CI Method, Method)
len = (CI Method
hContentLength, String -> Method
Char8.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
lbs)))
   in Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status200 [(CI Method, Method)
typ, (CI Method, Method)
len] ByteString
lbs

-- | Construct a JSON response using `ToJSON`.
--
-- Sets the Content-Type and Content-Length headers.
json :: ToJSON a => a -> Response
json :: a -> Response
json a
val =
  let lbs :: ByteString
lbs = a -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode a
val
      typ :: (CI Method, Method)
typ = (CI Method
hContentType, Method
"application/json; charset=utf-8")
      len :: (CI Method, Method)
len = (CI Method
hContentLength, String -> Method
Char8.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
lbs)))
   in Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status200 [(CI Method, Method)
typ, (CI Method, Method)
len] ByteString
lbs

-- | Construct an XML response.
--
-- Sets the Content-Type and Content-Length headers.
xml :: BL.ByteString -> Response
xml :: ByteString -> Response
xml ByteString
body =
  let lbs :: ByteString
lbs = ByteString
body
      typ :: (CI Method, Method)
typ = (CI Method
hContentType, Method
"application/xml; charset=utf-8")
      len :: (CI Method, Method)
len = (CI Method
hContentLength, String -> Method
Char8.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
lbs)))
   in Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status200 [(CI Method, Method)
typ, (CI Method, Method)
len] ByteString
lbs

-- | Construct a raw response from a lazy `ByteString`.
raw :: Status -> [Header] -> BL.ByteString -> Response
raw :: Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status [(CI Method, Method)]
headers ByteString
body = Status -> [(CI Method, Method)] -> ByteString -> Response
responseLBS Status
status [(CI Method, Method)]
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 :: (CI Method, Method) -> Response -> Response
withHeader (CI Method, Method)
header = ([(CI Method, Method)] -> [(CI Method, Method)])
-> Response -> Response
mapResponseHeaders ((CI Method, Method)
header (CI Method, Method)
-> [(CI Method, Method)] -> [(CI Method, Method)]
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 :: Method
setCookieName = Text -> Method
encodeUtf8 Text
key,
            setCookieValue :: Method
setCookieValue = Text -> Method
encodeUtf8 Text
val
          }
      header :: (CI Method, Method)
header = (Method -> CI Method
forall s. FoldCase s => s -> CI s
CI.mk Method
"Set-Cookie", SetCookie -> Method
setCookieByteString SetCookie
setCookie)
   in ([(CI Method, Method)] -> [(CI Method, Method)])
-> Response -> Response
mapResponseHeaders ((CI Method, Method)
header (CI Method, Method)
-> [(CI Method, Method)] -> [(CI Method, Method)]
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 :: (CI Method, Method)
header = (Method -> CI Method
forall s. FoldCase s => s -> CI s
CI.mk Method
"Set-Cookie", SetCookie -> Method
setCookieByteString SetCookie
setCookie)
   in ([(CI Method, Method)] -> [(CI Method, Method)])
-> Response -> Response
mapResponseHeaders ((CI Method, Method)
header (CI Method, Method)
-> [(CI Method, Method)] -> [(CI Method, Method)]
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 :: Method
setCookieName = Text -> Method
encodeUtf8 Text
key,
            setCookieExpires :: Maybe UTCTime
setCookieExpires = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
zeroTime
          }
      header :: (CI Method, Method)
header = (Method -> CI Method
forall s. FoldCase s => s -> CI s
CI.mk Method
"Set-Cookie", SetCookie -> Method
setCookieByteString SetCookie
setCookie)
   in ([(CI Method, Method)] -> [(CI Method, Method)])
-> Response -> Response
mapResponseHeaders ((CI Method, Method)
header (CI Method, Method)
-> [(CI Method, Method)] -> [(CI Method, Method)]
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 -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status301 [(CI Method
hLocation, Text -> Method
encodeUtf8 Text
url)] ByteString
""

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

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