{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Web.Spock.Internal.CoreAction
( ActionT
, UploadedFile (..)
, request, header, rawHeader, cookie, cookies, body, jsonBody, jsonBody'
, reqMethod
, files, params, param, param', paramsGet, paramsPost
, setStatus, setHeader, redirect
, setRawMultiHeader, MultiHeader(..)
, CookieSettings(..), CookieEOL(..), defaultCookieSettings
, setCookie, deleteCookie
, jumpNext, middlewarePass, modifyVault, queryVault
, bytes, lazyBytes, text, html, file, json, stream, response
, requireBasicAuth, withBasicAuthData
, getContext, runInContext
, preferredFormat, ClientPreferredFormat(..)
, respondApp, respondMiddleware
)
where
import Web.Spock.Internal.Cookies
import Web.Spock.Internal.Util
import Web.Spock.Internal.Wire
import Control.Monad
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif
import Control.Monad.RWS.Strict (runRWST)
import Control.Monad.Reader
import Control.Monad.State hiding (get, put)
import Data.Maybe
import Data.Monoid
import Data.Time
import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)
import Network.HTTP.Types.Status
import Prelude hiding (head)
import Web.HttpApiData
import qualified Control.Monad.State as ST
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vault.Lazy as V
import qualified Network.Wai as Wai
request :: MonadIO m => ActionCtxT ctx m Wai.Request
request :: ActionCtxT ctx m Request
request = (RequestInfo ctx -> Request) -> ActionCtxT ctx m Request
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> Request
forall ctx. RequestInfo ctx -> Request
ri_request
{-# INLINE request #-}
header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
Text
t =
(Maybe ByteString -> Maybe Text)
-> ActionCtxT ctx m (Maybe ByteString)
-> ActionCtxT ctx m (Maybe Text)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8) (ActionCtxT ctx m (Maybe ByteString)
-> ActionCtxT ctx m (Maybe Text))
-> ActionCtxT ctx m (Maybe ByteString)
-> ActionCtxT ctx m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ HeaderName -> ActionCtxT ctx m (Maybe ByteString)
forall (m :: * -> *) ctx.
MonadIO m =>
HeaderName -> ActionCtxT ctx m (Maybe ByteString)
rawHeader (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
T.encodeUtf8 Text
t))
{-# INLINE header #-}
rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)
HeaderName
t =
(Request -> Maybe ByteString)
-> ActionCtxT ctx m Request -> ActionCtxT ctx m (Maybe ByteString)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
t ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
Wai.requestHeaders) ActionCtxT ctx m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
request
{-# INLINE rawHeader #-}
preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat
preferredFormat :: ActionCtxT ctx m ClientPreferredFormat
preferredFormat =
do Maybe Text
mAccept <- Text -> ActionCtxT ctx m (Maybe Text)
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> ActionCtxT ctx m (Maybe Text)
header Text
"accept"
case Maybe Text
mAccept of
Maybe Text
Nothing -> ClientPreferredFormat -> ActionCtxT ctx m ClientPreferredFormat
forall (m :: * -> *) a. Monad m => a -> m a
return ClientPreferredFormat
PrefUnknown
Just Text
t ->
ClientPreferredFormat -> ActionCtxT ctx m ClientPreferredFormat
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientPreferredFormat -> ActionCtxT ctx m ClientPreferredFormat)
-> ClientPreferredFormat -> ActionCtxT ctx m ClientPreferredFormat
forall a b. (a -> b) -> a -> b
$ Text -> ClientPreferredFormat
detectPreferredFormat Text
t
{-# INLINE preferredFormat #-}
reqMethod :: MonadIO m => ActionCtxT ctx m SpockMethod
reqMethod :: ActionCtxT ctx m SpockMethod
reqMethod = (RequestInfo ctx -> SpockMethod) -> ActionCtxT ctx m SpockMethod
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> SpockMethod
forall ctx. RequestInfo ctx -> SpockMethod
ri_method
{-# INLINE reqMethod #-}
body :: MonadIO m => ActionCtxT ctx m BS.ByteString
body :: ActionCtxT ctx m ByteString
body =
do RequestBody
b <- (RequestInfo ctx -> RequestBody) -> ActionCtxT ctx m RequestBody
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> RequestBody
forall ctx. RequestInfo ctx -> RequestBody
ri_reqBody
IO ByteString -> ActionCtxT ctx m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ActionCtxT ctx m ByteString)
-> IO ByteString -> ActionCtxT ctx m ByteString
forall a b. (a -> b) -> a -> b
$ CacheVar ByteString -> IO ByteString
forall v. CacheVar v -> IO v
loadCacheVar (RequestBody -> CacheVar ByteString
rb_value RequestBody
b)
{-# INLINE body #-}
jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a)
jsonBody :: ActionCtxT ctx m (Maybe a)
jsonBody =
do ByteString
b <- ActionCtxT ctx m ByteString
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m ByteString
body
Maybe a -> ActionCtxT ctx m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ActionCtxT ctx m (Maybe a))
-> Maybe a -> ActionCtxT ctx m (Maybe a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict ByteString
b
{-# INLINE jsonBody #-}
jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a
jsonBody' :: ActionCtxT ctx m a
jsonBody' =
do ByteString
b <- ActionCtxT ctx m ByteString
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m ByteString
body
case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecodeStrict' ByteString
b of
Left String
err ->
do Status -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
setStatus Status
status400
Text -> ActionCtxT ctx m a
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
text (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse json: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Right a
val ->
a -> ActionCtxT ctx m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
{-# INLINE jsonBody' #-}
files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)
files :: ActionCtxT ctx m (HashMap Text UploadedFile)
files =
do RequestBody
b <- (RequestInfo ctx -> RequestBody) -> ActionCtxT ctx m RequestBody
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> RequestBody
forall ctx. RequestInfo ctx -> RequestBody
ri_reqBody
IO (HashMap Text UploadedFile)
-> ActionCtxT ctx m (HashMap Text UploadedFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap Text UploadedFile)
-> ActionCtxT ctx m (HashMap Text UploadedFile))
-> IO (HashMap Text UploadedFile)
-> ActionCtxT ctx m (HashMap Text UploadedFile)
forall a b. (a -> b) -> a -> b
$ CacheVar (HashMap Text UploadedFile)
-> IO (HashMap Text UploadedFile)
forall v. CacheVar v -> IO v
loadCacheVar (RequestBody -> CacheVar (HashMap Text UploadedFile)
rb_files RequestBody
b)
{-# INLINE files #-}
paramsGet :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
paramsGet :: ActionCtxT ctx m [(Text, Text)]
paramsGet = (RequestInfo ctx -> [(Text, Text)])
-> ActionCtxT ctx m [(Text, Text)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> [(Text, Text)]
forall ctx. RequestInfo ctx -> [(Text, Text)]
ri_getParams
{-# INLINE paramsGet #-}
paramsPost :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
paramsPost :: ActionCtxT ctx m [(Text, Text)]
paramsPost =
do RequestBody
b <- (RequestInfo ctx -> RequestBody) -> ActionCtxT ctx m RequestBody
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> RequestBody
forall ctx. RequestInfo ctx -> RequestBody
ri_reqBody
IO [(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> ActionCtxT ctx m [(Text, Text)])
-> IO [(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ CacheVar [(Text, Text)] -> IO [(Text, Text)]
forall v. CacheVar v -> IO v
loadCacheVar (RequestBody -> CacheVar [(Text, Text)]
rb_postParams RequestBody
b)
{-# INLINE paramsPost #-}
params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
params :: ActionCtxT ctx m [(Text, Text)]
params =
do [(Text, Text)]
g <- ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) ctx.
MonadIO m =>
ActionCtxT ctx m [(Text, Text)]
paramsGet
[(Text, Text)]
p <- ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) ctx.
MonadIO m =>
ActionCtxT ctx m [(Text, Text)]
paramsPost
[(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)] -> ActionCtxT ctx m [(Text, Text)])
-> [(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
g [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
p
{-# INLINE params #-}
param :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p)
param :: Text -> ActionCtxT ctx m (Maybe p)
param Text
k =
do [(Text, Text)]
qp <- ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) ctx.
MonadIO m =>
ActionCtxT ctx m [(Text, Text)]
params
Maybe p -> ActionCtxT ctx m (Maybe p)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe p -> ActionCtxT ctx m (Maybe p))
-> Maybe p -> ActionCtxT ctx m (Maybe p)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe p) -> Maybe p
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe p) -> Maybe p) -> Maybe (Maybe p) -> Maybe p
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe p) -> Maybe Text -> Maybe (Maybe p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe p) -> (p -> Maybe p) -> Either Text p -> Maybe p
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe p -> Text -> Maybe p
forall a b. a -> b -> a
const Maybe p
forall a. Maybe a
Nothing) p -> Maybe p
forall a. a -> Maybe a
Just (Either Text p -> Maybe p)
-> (Text -> Either Text p) -> Text -> Maybe p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text p
forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam) (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Text)]
qp)
{-# INLINE param #-}
param' :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m p
param' :: Text -> ActionCtxT ctx m p
param' Text
k =
do Maybe p
mParam <- Text -> ActionCtxT ctx m (Maybe p)
forall p (m :: * -> *) ctx.
(FromHttpApiData p, MonadIO m) =>
Text -> ActionCtxT ctx m (Maybe p)
param Text
k
case Maybe p
mParam of
Maybe p
Nothing ->
do Status -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
setStatus Status
status500
Text -> ActionCtxT ctx m p
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
text ([Text] -> Text
T.concat [ Text
"Missing parameter ", Text
k ])
Just p
val ->
p -> ActionCtxT ctx m p
forall (m :: * -> *) a. Monad m => a -> m a
return p
val
{-# INLINE param' #-}
setStatus :: MonadIO m => Status -> ActionCtxT ctx m ()
setStatus :: Status -> ActionCtxT ctx m ()
setStatus Status
s =
(ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseState -> ResponseState) -> ActionCtxT ctx m ())
-> (ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ \ResponseState
rs -> ResponseState
rs { rs_status :: Status
rs_status = Status
s }
{-# INLINE setStatus #-}
setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
Text
k Text
v = HeaderName -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
HeaderName -> ByteString -> ActionCtxT ctx m ()
setRawHeader (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
k) (Text -> ByteString
T.encodeUtf8 Text
v)
{-# INLINE setHeader #-}
setRawHeader :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()
HeaderName
k ByteString
v =
case HeaderName -> HashMap HeaderName MultiHeader -> Maybe MultiHeader
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup HeaderName
k HashMap HeaderName MultiHeader
multiHeaderMap of
Just MultiHeader
mhk ->
MultiHeader -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
MultiHeader -> ByteString -> ActionCtxT ctx m ()
setRawMultiHeader MultiHeader
mhk ByteString
v
Maybe MultiHeader
Nothing ->
HeaderName -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
HeaderName -> ByteString -> ActionCtxT ctx m ()
setRawHeaderUnsafe HeaderName
k ByteString
v
setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()
MultiHeader
k Text
v = MultiHeader -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
MultiHeader -> ByteString -> ActionCtxT ctx m ()
setRawMultiHeader MultiHeader
k (Text -> ByteString
T.encodeUtf8 Text
v)
{-# INLINE setMultiHeader #-}
setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()
MultiHeader
k ByteString
v =
(ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseState -> ResponseState) -> ActionCtxT ctx m ())
-> (ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ \ResponseState
rs ->
ResponseState
rs
{ rs_multiResponseHeaders :: HashMap MultiHeader [ByteString]
rs_multiResponseHeaders =
([ByteString] -> [ByteString] -> [ByteString])
-> MultiHeader
-> [ByteString]
-> HashMap MultiHeader [ByteString]
-> HashMap MultiHeader [ByteString]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
(++) MultiHeader
k [ByteString
v] (ResponseState -> HashMap MultiHeader [ByteString]
rs_multiResponseHeaders ResponseState
rs)
}
setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
Text
k Text
v = HeaderName -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
HeaderName -> ByteString -> ActionCtxT ctx m ()
setRawHeaderUnsafe (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
k) (Text -> ByteString
T.encodeUtf8 Text
v)
{-# INLINE setHeaderUnsafe #-}
setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()
HeaderName
k ByteString
v =
(ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseState -> ResponseState) -> ActionCtxT ctx m ())
-> (ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ \ResponseState
rs ->
ResponseState
rs
{ rs_responseHeaders :: HashMap HeaderName ByteString
rs_responseHeaders =
HeaderName
-> ByteString
-> HashMap HeaderName ByteString
-> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert HeaderName
k ByteString
v (ResponseState -> HashMap HeaderName ByteString
rs_responseHeaders ResponseState
rs)
}
jumpNext :: MonadIO m => ActionCtxT ctx m a
jumpNext :: ActionCtxT ctx m a
jumpNext = ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ActionInterupt
ActionTryNext
{-# INLINE jumpNext #-}
redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a
redirect :: Text -> ActionCtxT ctx m a
redirect = ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ActionInterupt -> ActionCtxT ctx m a)
-> (Text -> ActionInterupt) -> Text -> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ActionInterupt
ActionRedirect
{-# INLINE redirect #-}
respondApp :: Monad m => Wai.Application -> ActionCtxT ctx m a
respondApp :: Application -> ActionCtxT ctx m a
respondApp = ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ActionInterupt -> ActionCtxT ctx m a)
-> (Application -> ActionInterupt)
-> Application
-> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Application -> ActionInterupt
ActionApplication (IO Application -> ActionInterupt)
-> (Application -> IO Application) -> Application -> ActionInterupt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return
respondMiddleware :: Monad m => Wai.Middleware -> ActionCtxT ctx m a
respondMiddleware :: Middleware -> ActionCtxT ctx m a
respondMiddleware = ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ActionInterupt -> ActionCtxT ctx m a)
-> (Middleware -> ActionInterupt)
-> Middleware
-> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Middleware -> ActionInterupt
ActionMiddleware (IO Middleware -> ActionInterupt)
-> (Middleware -> IO Middleware) -> Middleware -> ActionInterupt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return
middlewarePass :: MonadIO m => ActionCtxT ctx m a
middlewarePass :: ActionCtxT ctx m a
middlewarePass = ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ActionInterupt
ActionMiddlewarePass
{-# INLINE middlewarePass #-}
modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m ()
modifyVault :: (Vault -> Vault) -> ActionCtxT ctx m ()
modifyVault Vault -> Vault
f =
do VaultIf
vaultIf <- (RequestInfo ctx -> VaultIf) -> ActionCtxT ctx m VaultIf
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> VaultIf
forall ctx. RequestInfo ctx -> VaultIf
ri_vaultIf
IO () -> ActionCtxT ctx m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionCtxT ctx m ()) -> IO () -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ VaultIf -> (Vault -> Vault) -> IO ()
vi_modifyVault VaultIf
vaultIf Vault -> Vault
f
{-# INLINE modifyVault #-}
queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a)
queryVault :: Key a -> ActionCtxT ctx m (Maybe a)
queryVault Key a
k =
do VaultIf
vaultIf <- (RequestInfo ctx -> VaultIf) -> ActionCtxT ctx m VaultIf
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> VaultIf
forall ctx. RequestInfo ctx -> VaultIf
ri_vaultIf
IO (Maybe a) -> ActionCtxT ctx m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> ActionCtxT ctx m (Maybe a))
-> IO (Maybe a) -> ActionCtxT ctx m (Maybe a)
forall a b. (a -> b) -> a -> b
$ VaultIf -> Key a -> IO (Maybe a)
VaultIf -> forall a. Key a -> IO (Maybe a)
vi_lookupKey VaultIf
vaultIf Key a
k
{-# INLINE queryVault #-}
response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a
response :: (Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
response Status -> [(HeaderName, ByteString)] -> Response
val =
do (ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseState -> ResponseState) -> ActionCtxT ctx m ())
-> (ResponseState -> ResponseState) -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ \ResponseState
rs -> ResponseState
rs { rs_responseBody :: ResponseBody
rs_responseBody = (Status -> [(HeaderName, ByteString)] -> Response) -> ResponseBody
ResponseBody Status -> [(HeaderName, ByteString)] -> Response
val }
ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ActionInterupt
ActionDone
{-# INLINE response #-}
bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a
bytes :: ByteString -> ActionCtxT ctx m a
bytes ByteString
val =
ByteString -> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
lazyBytes (ByteString -> ActionCtxT ctx m a)
-> ByteString -> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
val
{-# INLINE bytes #-}
lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a
lazyBytes :: ByteString -> ActionCtxT ctx m a
lazyBytes ByteString
val =
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
response ((Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a)
-> (Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ \Status
status [(HeaderName, ByteString)]
headers -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
Wai.responseLBS Status
status [(HeaderName, ByteString)]
headers ByteString
val
{-# INLINE lazyBytes #-}
text :: MonadIO m => T.Text -> ActionCtxT ctx m a
text :: Text -> ActionCtxT ctx m a
text Text
val =
do Text -> Text -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> ActionCtxT ctx m ()
setHeaderUnsafe Text
"Content-Type" Text
"text/plain; charset=utf-8"
ByteString -> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
bytes (ByteString -> ActionCtxT ctx m a)
-> ByteString -> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
val
{-# INLINE text #-}
html :: MonadIO m => T.Text -> ActionCtxT ctx m a
html :: Text -> ActionCtxT ctx m a
html Text
val =
do Text -> Text -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> ActionCtxT ctx m ()
setHeaderUnsafe Text
"Content-Type" Text
"text/html; charset=utf-8"
ByteString -> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
bytes (ByteString -> ActionCtxT ctx m a)
-> ByteString -> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
val
{-# INLINE html #-}
file :: MonadIO m => T.Text -> FilePath -> ActionCtxT ctx m a
file :: Text -> String -> ActionCtxT ctx m a
file Text
contentType String
filePath =
do Text -> Text -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> ActionCtxT ctx m ()
setHeaderUnsafe Text
"Content-Type" Text
contentType
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
response ((Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a)
-> (Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ \Status
status [(HeaderName, ByteString)]
headers -> Status
-> [(HeaderName, ByteString)]
-> String
-> Maybe FilePart
-> Response
Wai.responseFile Status
status [(HeaderName, ByteString)]
headers String
filePath Maybe FilePart
forall a. Maybe a
Nothing
{-# INLINE file #-}
json :: (A.ToJSON a, MonadIO m) => a -> ActionCtxT ctx m b
json :: a -> ActionCtxT ctx m b
json a
val =
do Text -> Text -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> ActionCtxT ctx m ()
setHeaderUnsafe Text
"Content-Type" Text
"application/json; charset=utf-8"
ByteString -> ActionCtxT ctx m b
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
lazyBytes (ByteString -> ActionCtxT ctx m b)
-> ByteString -> ActionCtxT ctx m b
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
val
{-# INLINE json #-}
stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a
stream :: StreamingBody -> ActionCtxT ctx m a
stream StreamingBody
val =
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
(Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
response ((Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a)
-> (Status -> [(HeaderName, ByteString)] -> Response)
-> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ \Status
status [(HeaderName, ByteString)]
headers -> Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
Wai.responseStream Status
status [(HeaderName, ByteString)]
headers StreamingBody
val
{-# INLINE stream #-}
requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> ActionCtxT ctx m b) -> (b -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
requireBasicAuth :: Text
-> (Text -> Text -> ActionCtxT ctx m b)
-> (b -> ActionCtxT ctx m a)
-> ActionCtxT ctx m a
requireBasicAuth Text
realmTitle Text -> Text -> ActionCtxT ctx m b
authFun b -> ActionCtxT ctx m a
cont =
(Maybe (Text, Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
forall (m :: * -> *) ctx a.
MonadIO m =>
(Maybe (Text, Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
withBasicAuthData ((Maybe (Text, Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a)
-> (Maybe (Text, Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ \Maybe (Text, Text)
mAuthHeader ->
case Maybe (Text, Text)
mAuthHeader of
Maybe (Text, Text)
Nothing ->
Maybe Text -> ActionCtxT ctx m a
forall (m :: * -> *) ctx b.
MonadIO m =>
Maybe Text -> ActionCtxT ctx m b
authFailed Maybe Text
forall a. Maybe a
Nothing
Just (Text
user, Text
pass) ->
Text -> Text -> ActionCtxT ctx m b
authFun Text
user Text
pass ActionCtxT ctx m b
-> (b -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ActionCtxT ctx m a
cont
where
authFailed :: Maybe Text -> ActionCtxT ctx m b
authFailed Maybe Text
mMore =
do Status -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
setStatus Status
status401
MultiHeader -> Text -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
MultiHeader -> Text -> ActionCtxT ctx m ()
setMultiHeader MultiHeader
MultiHeaderWWWAuth (Text
"Basic realm=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
realmTitle Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
Text -> ActionCtxT ctx m b
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
text (Text -> ActionCtxT ctx m b) -> Text -> ActionCtxT ctx m b
forall a b. (a -> b) -> a -> b
$ Text
"Authentication required. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mMore
withBasicAuthData :: MonadIO m => (Maybe (T.Text, T.Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
withBasicAuthData :: (Maybe (Text, Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
withBasicAuthData Maybe (Text, Text) -> ActionCtxT ctx m a
handler =
do Maybe Text
mAuthHeader <- Text -> ActionCtxT ctx m (Maybe Text)
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> ActionCtxT ctx m (Maybe Text)
header Text
"Authorization"
case Maybe Text
mAuthHeader of
Maybe Text
Nothing ->
Maybe (Text, Text) -> ActionCtxT ctx m a
handler Maybe (Text, Text)
forall a. Maybe a
Nothing
Just Text
authHeader ->
let (Text
_, Text
rawValue) =
Text -> Text -> (Text, Text)
T.breakOn Text
" " Text
authHeader
(Text
user, Text
rawPass) =
(Text -> Text -> (Text, Text)
T.breakOn Text
":" (Text -> (Text, Text)) -> (Text -> Text) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) Text
rawValue
pass :: Text
pass = Int -> Text -> Text
T.drop Int
1 Text
rawPass
in Maybe (Text, Text) -> ActionCtxT ctx m a
handler ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
user, Text
pass))
getContext :: MonadIO m => ActionCtxT ctx m ctx
getContext :: ActionCtxT ctx m ctx
getContext = (RequestInfo ctx -> ctx) -> ActionCtxT ctx m ctx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestInfo ctx -> ctx
forall ctx. RequestInfo ctx -> ctx
ri_context
{-# INLINE getContext #-}
runInContext :: MonadIO m => ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a
runInContext :: ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a
runInContext ctx'
newCtx ActionCtxT ctx' m a
action =
do RequestInfo ctx
currentEnv <- ActionCtxT ctx m (RequestInfo ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
ResponseState
currentRespState <- ActionCtxT ctx m ResponseState
forall s (m :: * -> *). MonadState s m => m s
ST.get
(Either ActionInterupt a
r, ResponseState
newRespState, ()
_) <-
m (Either ActionInterupt a, ResponseState, ())
-> ActionCtxT ctx m (Either ActionInterupt a, ResponseState, ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ActionInterupt a, ResponseState, ())
-> ActionCtxT ctx m (Either ActionInterupt a, ResponseState, ()))
-> m (Either ActionInterupt a, ResponseState, ())
-> ActionCtxT ctx m (Either ActionInterupt a, ResponseState, ())
forall a b. (a -> b) -> a -> b
$
do let env :: RequestInfo ctx'
env =
RequestInfo ctx
currentEnv
{ ri_context :: ctx'
ri_context = ctx'
newCtx
}
RWST
(RequestInfo ctx') () ResponseState m (Either ActionInterupt a)
-> RequestInfo ctx'
-> ResponseState
-> m (Either ActionInterupt a, ResponseState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (ExceptT
ActionInterupt (RWST (RequestInfo ctx') () ResponseState m) a
-> RWST
(RequestInfo ctx') () ResponseState m (Either ActionInterupt a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runErrorT (ExceptT
ActionInterupt (RWST (RequestInfo ctx') () ResponseState m) a
-> RWST
(RequestInfo ctx') () ResponseState m (Either ActionInterupt a))
-> ExceptT
ActionInterupt (RWST (RequestInfo ctx') () ResponseState m) a
-> RWST
(RequestInfo ctx') () ResponseState m (Either ActionInterupt a)
forall a b. (a -> b) -> a -> b
$ ActionCtxT ctx' m a
-> ExceptT
ActionInterupt (RWST (RequestInfo ctx') () ResponseState m) a
forall ctx (m :: * -> *) a.
ActionCtxT ctx m a
-> ErrorT
ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
runActionCtxT ActionCtxT ctx' m a
action) RequestInfo ctx'
env ResponseState
currentRespState
ResponseState -> ActionCtxT ctx m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
ST.put ResponseState
newRespState
case Either ActionInterupt a
r of
Left ActionInterupt
interupt ->
ActionInterupt -> ActionCtxT ctx m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ActionInterupt
interupt
Right a
d -> a -> ActionCtxT ctx m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
d
{-# INLINE runInContext #-}
setCookie :: MonadIO m => T.Text -> T.Text -> CookieSettings -> ActionCtxT ctx m ()
setCookie :: Text -> Text -> CookieSettings -> ActionCtxT ctx m ()
setCookie Text
name Text
value CookieSettings
cs =
do UTCTime
now <- IO UTCTime -> ActionCtxT ctx m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
MultiHeader -> ByteString -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
MultiHeader -> ByteString -> ActionCtxT ctx m ()
setRawMultiHeader MultiHeader
MultiHeaderSetCookie (ByteString -> ActionCtxT ctx m ())
-> ByteString -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$
Text -> Text -> CookieSettings -> UTCTime -> ByteString
generateCookieHeaderString Text
name Text
value CookieSettings
cs UTCTime
now
{-# INLINE setCookie #-}
deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()
deleteCookie :: Text -> ActionCtxT ctx m ()
deleteCookie Text
name =
Text -> Text -> CookieSettings -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> CookieSettings -> ActionCtxT ctx m ()
setCookie Text
name Text
T.empty CookieSettings
cs
where
cs :: CookieSettings
cs = CookieSettings
defaultCookieSettings { cs_EOL :: CookieEOL
cs_EOL = UTCTime -> CookieEOL
CookieValidUntil UTCTime
epoch }
epoch :: UTCTime
epoch = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
1970 Int
1 Int
1) (Integer -> DiffTime
secondsToDiffTime Integer
0)
{-# INLINE deleteCookie #-}
cookies :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
cookies :: ActionCtxT ctx m [(Text, Text)]
cookies =
do Request
req <- ActionCtxT ctx m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
request
[(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)] -> ActionCtxT ctx m [(Text, Text)])
-> [(Text, Text)] -> ActionCtxT ctx m [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
[(Text, Text)]
-> (ByteString -> [(Text, Text)])
-> Maybe ByteString
-> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [(Text, Text)]
parseCookies (Maybe ByteString -> [(Text, Text)])
-> Maybe ByteString -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"cookie" (Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req)
{-# INLINE cookies #-}
cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
cookie :: Text -> ActionCtxT ctx m (Maybe Text)
cookie Text
name =
do [(Text, Text)]
allCookies <- ActionCtxT ctx m [(Text, Text)]
forall (m :: * -> *) ctx.
MonadIO m =>
ActionCtxT ctx m [(Text, Text)]
cookies
Maybe Text -> ActionCtxT ctx m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ActionCtxT ctx m (Maybe Text))
-> Maybe Text -> ActionCtxT ctx m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, Text)]
allCookies
{-# INLINE cookie #-}