{-# 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 = asks ri_request
{-# INLINE request #-}
header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
header t =
liftM (fmap T.decodeUtf8) $ rawHeader (CI.mk (T.encodeUtf8 t))
{-# INLINE header #-}
rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)
rawHeader t =
liftM (lookup t . Wai.requestHeaders) request
{-# INLINE rawHeader #-}
preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat
preferredFormat =
do mAccept <- header "accept"
case mAccept of
Nothing -> return PrefUnknown
Just t ->
return $ detectPreferredFormat t
{-# INLINE preferredFormat #-}
reqMethod :: MonadIO m => ActionCtxT ctx m SpockMethod
reqMethod = asks ri_method
{-# INLINE reqMethod #-}
body :: MonadIO m => ActionCtxT ctx m BS.ByteString
body =
do b <- asks ri_reqBody
liftIO $ loadCacheVar (rb_value b)
{-# INLINE body #-}
jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a)
jsonBody =
do b <- body
return $ A.decodeStrict b
{-# INLINE jsonBody #-}
jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a
jsonBody' =
do b <- body
case A.eitherDecodeStrict' b of
Left err ->
do setStatus status400
text (T.pack $ "Failed to parse json: " ++ err)
Right val ->
return val
{-# INLINE jsonBody' #-}
files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)
files =
do b <- asks ri_reqBody
liftIO $ loadCacheVar (rb_files b)
{-# INLINE files #-}
paramsGet :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
paramsGet = asks ri_getParams
{-# INLINE paramsGet #-}
paramsPost :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
paramsPost =
do b <- asks ri_reqBody
liftIO $ loadCacheVar (rb_postParams b)
{-# INLINE paramsPost #-}
params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
params =
do g <- paramsGet
p <- paramsPost
return $ g ++ p
{-# INLINE params #-}
param :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p)
param k =
do qp <- params
return $ join $ fmap (either (const Nothing) Just . parseQueryParam) (lookup k qp)
{-# INLINE param #-}
param' :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m p
param' k =
do mParam <- param k
case mParam of
Nothing ->
do setStatus status500
text (T.concat [ "Missing parameter ", k ])
Just val ->
return val
{-# INLINE param' #-}
setStatus :: MonadIO m => Status -> ActionCtxT ctx m ()
setStatus s =
modify $ \rs -> rs { rs_status = s }
{-# INLINE setStatus #-}
setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeader k v = setRawHeader (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)
{-# INLINE setHeader #-}
setRawHeader :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()
setRawHeader k v =
case HM.lookup k multiHeaderMap of
Just mhk ->
setRawMultiHeader mhk v
Nothing ->
setRawHeaderUnsafe k v
setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()
setMultiHeader k v = setRawMultiHeader k (T.encodeUtf8 v)
{-# INLINE setMultiHeader #-}
setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()
setRawMultiHeader k v =
modify $ \rs ->
rs
{ rs_multiResponseHeaders =
HM.insertWith (++) k [v] (rs_multiResponseHeaders rs)
}
setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeaderUnsafe k v = setRawHeaderUnsafe (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)
{-# INLINE setHeaderUnsafe #-}
setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()
setRawHeaderUnsafe k v =
modify $ \rs ->
rs
{ rs_responseHeaders =
HM.insert k v (rs_responseHeaders rs)
}
jumpNext :: MonadIO m => ActionCtxT ctx m a
jumpNext = throwError ActionTryNext
{-# INLINE jumpNext #-}
redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a
redirect = throwError . ActionRedirect
{-# INLINE redirect #-}
respondApp :: Monad m => Wai.Application -> ActionCtxT ctx m a
respondApp = throwError . ActionApplication . return
respondMiddleware :: Monad m => Wai.Middleware -> ActionCtxT ctx m a
respondMiddleware = throwError . ActionMiddleware . return
middlewarePass :: MonadIO m => ActionCtxT ctx m a
middlewarePass = throwError ActionMiddlewarePass
{-# INLINE middlewarePass #-}
modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m ()
modifyVault f =
do vaultIf <- asks ri_vaultIf
liftIO $ vi_modifyVault vaultIf f
{-# INLINE modifyVault #-}
queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a)
queryVault k =
do vaultIf <- asks ri_vaultIf
liftIO $ vi_lookupKey vaultIf k
{-# INLINE queryVault #-}
response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a
response val =
do modify $ \rs -> rs { rs_responseBody = ResponseBody val }
throwError ActionDone
{-# INLINE response #-}
bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a
bytes val =
lazyBytes $ BSL.fromStrict val
{-# INLINE bytes #-}
lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a
lazyBytes val =
response $ \status headers -> Wai.responseLBS status headers val
{-# INLINE lazyBytes #-}
text :: MonadIO m => T.Text -> ActionCtxT ctx m a
text val =
do setHeaderUnsafe "Content-Type" "text/plain; charset=utf-8"
bytes $ T.encodeUtf8 val
{-# INLINE text #-}
html :: MonadIO m => T.Text -> ActionCtxT ctx m a
html val =
do setHeaderUnsafe "Content-Type" "text/html; charset=utf-8"
bytes $ T.encodeUtf8 val
{-# INLINE html #-}
file :: MonadIO m => T.Text -> FilePath -> ActionCtxT ctx m a
file contentType filePath =
do setHeaderUnsafe "Content-Type" contentType
response $ \status headers -> Wai.responseFile status headers filePath Nothing
{-# INLINE file #-}
json :: (A.ToJSON a, MonadIO m) => a -> ActionCtxT ctx m b
json val =
do setHeaderUnsafe "Content-Type" "application/json; charset=utf-8"
lazyBytes $ A.encode val
{-# INLINE json #-}
stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a
stream val =
response $ \status headers -> Wai.responseStream status headers 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 realmTitle authFun cont =
withBasicAuthData $ \mAuthHeader ->
case mAuthHeader of
Nothing ->
authFailed Nothing
Just (user, pass) ->
authFun user pass >>= cont
where
authFailed mMore =
do setStatus status401
setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")
text $ "Authentication required. " <> fromMaybe "" mMore
withBasicAuthData :: MonadIO m => (Maybe (T.Text, T.Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a
withBasicAuthData handler =
do mAuthHeader <- header "Authorization"
case mAuthHeader of
Nothing ->
handler Nothing
Just authHeader ->
let (_, rawValue) =
T.breakOn " " authHeader
(user, rawPass) =
(T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue
pass = T.drop 1 rawPass
in handler (Just (user, pass))
getContext :: MonadIO m => ActionCtxT ctx m ctx
getContext = asks ri_context
{-# INLINE getContext #-}
runInContext :: MonadIO m => ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a
runInContext newCtx action =
do currentEnv <- ask
currentRespState <- ST.get
(r, newRespState, _) <-
lift $
do let env =
currentEnv
{ ri_context = newCtx
}
runRWST (runErrorT $ runActionCtxT action) env currentRespState
ST.put newRespState
case r of
Left interupt ->
throwError interupt
Right d -> return d
{-# INLINE runInContext #-}
setCookie :: MonadIO m => T.Text -> T.Text -> CookieSettings -> ActionCtxT ctx m ()
setCookie name value cs =
do now <- liftIO getCurrentTime
setRawMultiHeader MultiHeaderSetCookie $
generateCookieHeaderString name value cs now
{-# INLINE setCookie #-}
deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()
deleteCookie name =
setCookie name T.empty cs
where
cs = defaultCookieSettings { cs_EOL = CookieValidUntil epoch }
epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)
{-# INLINE deleteCookie #-}
cookies :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
cookies =
do req <- request
return $
maybe [] parseCookies $
lookup "cookie" (Wai.requestHeaders req)
{-# INLINE cookies #-}
cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
cookie name =
do allCookies <- cookies
return $ lookup name allCookies
{-# INLINE cookie #-}