{-# 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

-- | Get the original Wai Request object
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 #-}

-- | Read a header
header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
header :: Text -> ActionCtxT ctx m (Maybe Text)
header 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 #-}

-- | Read a header without converting it to text
rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)
rawHeader :: HeaderName -> ActionCtxT ctx m (Maybe ByteString)
rawHeader 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 #-}

-- | Tries to dected the preferred format of the response using the Accept header
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 #-}

-- | Returns the current request method, e.g. 'GET'
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 #-}

-- | Get the raw request body
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 #-}

-- | Parse the request body as json
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 #-}

-- | Parse the request body as json and fails with 400 status code on error
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' #-}

-- | Get uploaded files
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 #-}

-- | Get all request GET params
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 #-}

-- | Get all request POST params
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 #-}

-- | Get all request (POST + GET) params
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 #-}

-- | Read a request param. Spock looks POST variables first and then in GET variables
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 #-}

-- | Like 'param', but outputs an error when a param is missing
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' #-}

-- | Set a response status
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 #-}

-- | Set a response header. If the response header
-- is allowed to occur multiple times (as in RFC 2616), it will
-- be appended. Otherwise the previous value is overwritten.
-- See 'setMultiHeader'.
setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeader :: Text -> Text -> ActionCtxT ctx m ()
setHeader 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 ()
setRawHeader :: HeaderName -> ByteString -> ActionCtxT ctx m ()
setRawHeader 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

-- | Set a response header that can occur multiple times. (eg: Cache-Control)
setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()
setMultiHeader :: MultiHeader -> Text -> ActionCtxT ctx m ()
setMultiHeader 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 #-}

-- | Set a response header that can occur multiple times. (eg: Cache-Control)
setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()
setRawMultiHeader :: MultiHeader -> ByteString -> ActionCtxT ctx m ()
setRawMultiHeader 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)
        }

-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)
setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeaderUnsafe :: Text -> Text -> ActionCtxT ctx m ()
setHeaderUnsafe 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 #-}

-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)
setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()
setRawHeaderUnsafe :: HeaderName -> ByteString -> ActionCtxT ctx m ()
setRawHeaderUnsafe 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)
        }

-- | Abort the current action and jump the next one matching the route
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 to a given url
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 #-}

-- | Respond to the request by running an 'Wai.Application'. This is
-- usefull in combination with wildcard routes. This can not be used
-- in combination with other request consuming combinators
-- like 'jsonBody', 'body', 'paramsPost', ...
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

-- | Respond to the request by running a 'Wai.Middleware'. This is
-- usefull in combination with wildcard routes. This can not be used
-- in combination with other request consuming combinators
-- like 'jsonBody', 'body', 'paramsPost', ...
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

-- | If the Spock application is used as a middleware, you can use
-- this to pass request handling to the underlying application.
-- If Spock is not uses as a middleware, or there is no underlying application
-- this will result in 404 error.
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 #-}

-- | Modify the vault (useful for sharing data between middleware and app)
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 #-}

-- | Query the vault
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 #-}

-- | Use a custom 'Wai.Response' generator as response body.
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 #-}

-- | Send a 'ByteString' as response body. Provide your own "Content-Type"
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 #-}

-- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"
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 #-}

-- | Send text as a response body. Content-Type will be "text/plain"
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 #-}

-- | Send a text as response body. Content-Type will be "text/html"
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 #-}

-- | Send a file as response
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 #-}

-- | Send json as response. Content-Type will be "application/json"
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 #-}

-- | Use a 'Wai.StreamingBody' to generate a response.
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 #-}

-- | Convenience Basic authentification
-- provide a title for the prompt and a function to validate
-- user and password. Usage example:
--
-- > get ("auth" <//> var <//> var) $ \user pass ->
-- >       let checker user' pass' =
-- >               unless (user == user' && pass == pass') $
-- >               do setStatus status401
-- >                  text "err"
-- >       in requireBasicAuth "Foo" checker $ \() -> text "ok"
--
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

-- | "Lower level" basic authentification handeling. Does not set any headers that will promt
-- browser users, only looks for an "Authorization" header in the request and breaks it into
-- username and passwort component if present
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))

-- | Get the context of the current request
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 #-}

-- | Run an Action in a different context
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 #-}

-- | Set a cookie. The cookie value will be urlencoded.
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 #-}

-- | Delete a cookie
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 #-}

-- | Read all cookies. The cookie value will already be urldecoded.
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 #-}

-- | Read a cookie. The cookie value will already be urldecoded. Note that it is
-- more efficient to use 'cookies' if you need do access many cookies during a request
-- handler.
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 #-}