module Web.Twain
( ResponderM,
get,
put,
patch,
post,
delete,
route,
notFound,
param,
paramEither,
paramMaybe,
params,
file,
fileMaybe,
files,
fromBody,
header,
headers,
request,
send,
next,
redirect301,
redirect302,
redirect303,
text,
html,
json,
xml,
raw,
status,
withHeader,
withCookie,
withCookie',
expireCookie,
HttpError (..),
onException,
withParseBodyOpts,
withMaxBodySize,
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.Handler.Warp hiding (FileInfo)
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 :: PathPattern -> ResponderM a -> Middleware
get = Maybe Method -> PathPattern -> ResponderM a -> Middleware
forall a. Maybe Method -> PathPattern -> ResponderM a -> Middleware
route (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"GET")
put :: PathPattern -> ResponderM a -> Middleware
put :: PathPattern -> ResponderM a -> Middleware
put = Maybe Method -> PathPattern -> ResponderM a -> Middleware
forall a. Maybe Method -> PathPattern -> ResponderM a -> Middleware
route (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"PUT")
patch :: PathPattern -> ResponderM a -> Middleware
patch :: PathPattern -> ResponderM a -> Middleware
patch = Maybe Method -> PathPattern -> ResponderM a -> Middleware
forall a. Maybe Method -> PathPattern -> ResponderM a -> Middleware
route (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"PATCH")
post :: PathPattern -> ResponderM a -> Middleware
post :: PathPattern -> ResponderM a -> Middleware
post = Maybe Method -> PathPattern -> ResponderM a -> Middleware
forall a. Maybe Method -> PathPattern -> ResponderM a -> Middleware
route (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"POST")
delete :: PathPattern -> ResponderM a -> Middleware
delete :: PathPattern -> ResponderM a -> Middleware
delete = Maybe Method -> PathPattern -> ResponderM a -> Middleware
forall a. Maybe Method -> PathPattern -> ResponderM a -> Middleware
route (Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"DELETE")
route :: Maybe Method -> PathPattern -> ResponderM a -> Middleware
route :: Maybe Method -> PathPattern -> ResponderM a -> Middleware
route Maybe Method
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 (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 Method -> PathPattern -> Request -> Maybe [Param]
match Maybe Method
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 = Key ParsedRequest -> ParsedRequest -> 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
notFound :: ResponderM a -> Application
notFound :: 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 = Key ParsedRequest -> ParsedRequest -> 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 -> 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 :: (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 :: Vault
vault = Key ParsedRequest -> ParsedRequest -> 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
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 :: Word64
optsMaxBodySize = Word64
max}
let req' :: Request
req' = Request
req {vault :: Vault
vault = Key ResponderOptions -> ResponderOptions -> 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
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 :: ParseRequestBodyOptions
optsParseBody = ParseRequestBodyOptions
parseBodyOpts}
let req' :: Request
req' = Request
req {vault :: Vault
vault = Key ResponderOptions -> ResponderOptions -> 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
param :: ParsableParam a => Text -> ResponderM a
param :: Text -> ResponderM 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)
-> 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 (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
paramEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)
paramEither :: Text -> ResponderM (Either HttpError a)
paramEither 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)
-> 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 (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
paramMaybe :: ParsableParam a => Text -> ResponderM (Maybe a)
paramMaybe :: Text -> ResponderM (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)
-> 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 (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
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
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 (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
fileMaybe :: Text -> ResponderM (Maybe (FileInfo BL.ByteString))
fileMaybe :: Text -> ResponderM (Maybe (FileInfo ByteString))
fileMaybe Text
name = do
Maybe (FileInfo ByteString)
fM <- ((Method, FileInfo ByteString) -> FileInfo ByteString)
-> Maybe (Method, FileInfo ByteString)
-> Maybe (FileInfo ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Method, FileInfo ByteString) -> FileInfo ByteString
forall a b. (a, b) -> b
snd (Maybe (Method, FileInfo ByteString)
-> Maybe (FileInfo ByteString))
-> ([(Method, FileInfo ByteString)]
-> Maybe (Method, FileInfo ByteString))
-> [(Method, FileInfo ByteString)]
-> Maybe (FileInfo ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Method, FileInfo ByteString) -> Bool)
-> [(Method, FileInfo ByteString)]
-> Maybe (Method, FileInfo 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)
-> ((Method, FileInfo ByteString) -> Method)
-> (Method, FileInfo ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Method, FileInfo ByteString) -> Method
forall a b. (a, b) -> a
fst) ([(Method, FileInfo ByteString)] -> Maybe (FileInfo ByteString))
-> ResponderM [(Method, FileInfo ByteString)]
-> ResponderM (Maybe (FileInfo ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [(Method, 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (FileInfo ByteString)
fM
files :: ResponderM [File BL.ByteString]
files :: ResponderM [(Method, FileInfo ByteString)]
files = Maybe ParsedBody -> [(Method, FileInfo ByteString)]
fs (Maybe ParsedBody -> [(Method, FileInfo ByteString)])
-> (ParsedRequest -> Maybe ParsedBody)
-> ParsedRequest
-> [(Method, FileInfo ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedRequest -> Maybe ParsedBody
preqBody (ParsedRequest -> [(Method, FileInfo ByteString)])
-> ResponderM ParsedRequest
-> ResponderM [(Method, FileInfo ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM ParsedRequest
parseBodyForm
where
fs :: Maybe ParsedBody -> [(Method, FileInfo ByteString)]
fs Maybe ParsedBody
bodyM = case Maybe ParsedBody
bodyM of
Just (FormBody ([Param]
_, [(Method, FileInfo ByteString)]
fs)) -> [(Method, FileInfo ByteString)]
fs
Maybe ParsedBody
_ -> []
fromBody :: JSON.FromJSON a => ResponderM a
fromBody :: 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 (m :: * -> *) e a. (MonadThrow m, 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 (m :: * -> *) a. Monad m => a -> m a
return a
a
header :: Text -> ResponderM (Maybe Text)
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)
-> ResponderM [(CI Method, Method)] -> ResponderM (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM [(CI Method, Method)]
headers
headers :: ResponderM [Header]
= Request -> [(CI Method, Method)]
requestHeaders (Request -> [(CI Method, Method)])
-> ResponderM Request -> ResponderM [(CI Method, Method)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponderM Request
request
request :: ResponderM Request
request :: ResponderM Request
request = ResponderM Request
getRequest
send :: Response -> ResponderM a
send :: 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 (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)
next :: ResponderM a
next :: 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 (m :: * -> *) a. Monad m => a -> m a
return (RouteAction -> Either RouteAction (a, Request)
forall a b. a -> Either a b
Left RouteAction
Next)
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
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
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
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
raw :: Status -> [Header] -> BL.ByteString -> Response
raw :: Status -> [(CI Method, Method)] -> ByteString -> Response
raw Status
status [(CI Method, Method)]
headers ByteString
body =
if ((CI Method, Method) -> Bool) -> [(CI Method, Method)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any ((CI Method
hContentLength CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
==) (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)]
headers
then Status -> [(CI Method, Method)] -> ByteString -> Response
responseLBS Status
status [(CI Method, Method)]
headers ByteString
body
else
let 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
body)))
in Status -> [(CI Method, Method)] -> ByteString -> Response
responseLBS Status
status ((CI Method, Method)
len (CI Method, Method)
-> [(CI Method, Method)] -> [(CI Method, Method)]
forall a. a -> [a] -> [a]
: [(CI Method, Method)]
headers) ByteString
body
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)
withHeader :: Header -> Response -> Response
(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]
:)
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,
setCookiePath :: Maybe Method
setCookiePath = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"/",
setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
}
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
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
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,
setCookiePath :: Maybe Method
setCookiePath = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"/",
setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True,
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
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
""
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
""
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
""