module Web.Spock.Internal.CoreAction
( ActionT
, UploadedFile (..)
, request, header, rawHeader, cookie, body, jsonBody, jsonBody'
, reqMethod
, files, params, param, param', setStatus, setHeader, redirect
, jumpNext, middlewarePass, modifyVault, queryVault
, setCookie, setCookie', deleteCookie
, bytes, lazyBytes, text, html, file, json, stream, response
, requireBasicAuth
, getContext, runInContext
, preferredFormat, ClientPreferredFormat(..)
)
where
import Web.Spock.Internal.Util
import Web.Spock.Internal.Wire
import Control.Arrow (first)
import Control.Monad
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif
import Control.Monad.Reader
import Control.Monad.RWS.Strict (runRWST)
import Control.Monad.State hiding (get, put)
import qualified Control.Monad.State as ST
import Data.Monoid
import Data.Time
import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Prelude hiding (head)
#if MIN_VERSION_time(1,5,0)
#else
import System.Locale (defaultTimeLocale)
#endif
import Web.PathPieces
import Web.Routing.AbstractRouter
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
header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
header t =
liftM (fmap T.decodeUtf8) $ rawHeader (CI.mk (T.encodeUtf8 t))
rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)
rawHeader t =
liftM (lookup t . Wai.requestHeaders) request
cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)
cookie name =
do req <- request
return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . T.decodeUtf8
where
parseCookies :: T.Text -> [(T.Text, T.Text)]
parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words
parseCookie = first T.init . T.breakOnEnd "="
preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat
preferredFormat =
do mAccept <- header "accept"
case mAccept of
Nothing -> return PrefUnknown
Just t ->
return $ detectPreferredFormat t
reqMethod :: MonadIO m => ActionCtxT ctx m StdMethod
reqMethod = asks ri_method
body :: MonadIO m => ActionCtxT ctx m BS.ByteString
body =
do req <- request
let parseBody = liftIO $ Wai.requestBody req
parseAll chunks =
do bs <- parseBody
if BS.null bs
then return chunks
else parseAll (chunks `BS.append` bs)
parseAll BS.empty
jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a)
jsonBody =
do b <- body
return $ A.decodeStrict b
jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a
jsonBody' =
do b <- body
case A.eitherDecodeStrict' b of
Left err ->
do setStatus status500
text (T.pack $ "Failed to parse json: " ++ err)
Right val ->
return val
files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)
files =
asks ri_files
params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]
params =
do p <- asks ri_params
qp <- asks ri_queryParams
return (qp ++ map (first unCaptureVar) (HM.toList p))
param :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p)
param k =
do p <- asks ri_params
qp <- asks ri_queryParams
case HM.lookup (CaptureVar k) p of
Just val ->
case fromPathPiece val of
Nothing ->
do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")
jumpNext
Just pathPieceVal ->
return $ Just pathPieceVal
Nothing ->
return $ join $ fmap fromPathPiece (lookup k qp)
param' :: (PathPiece 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
setStatus :: MonadIO m => Status -> ActionCtxT ctx m ()
setStatus s =
modify $ \rs -> rs { rs_status = s }
setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeader k v =
do let ciVal = CI.mk $ T.encodeUtf8 k
case HM.lookup ciVal multiHeaderMap of
Just mhk ->
setMultiHeader mhk v
Nothing ->
setHeaderUnsafe k v
setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()
setMultiHeader k v =
modify $ \rs ->
rs
{ rs_multiResponseHeaders =
HM.insertWith (++) k [T.encodeUtf8 v] (rs_multiResponseHeaders rs)
}
setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()
setHeaderUnsafe k v =
modify $ \rs ->
rs
{ rs_responseHeaders =
HM.insert (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v) (rs_responseHeaders rs)
}
jumpNext :: MonadIO m => ActionCtxT ctx m a
jumpNext = throwError ActionTryNext
redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a
redirect = throwError . ActionRedirect
middlewarePass :: MonadIO m => ActionCtxT ctx m a
middlewarePass = throwError ActionMiddlewarePass
modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m ()
modifyVault f =
do vaultIf <- asks ri_vaultIf
liftIO $ vi_modifyVault vaultIf f
queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a)
queryVault k =
do vaultIf <- asks ri_vaultIf
liftIO $ vi_lookupKey vaultIf k
setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionCtxT ctx m ()
setCookie name value validSeconds =
do now <- liftIO getCurrentTime
setCookie' name value (validSeconds `addUTCTime` now)
deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()
deleteCookie name = setCookie' name T.empty epoch
where
epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)
setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionCtxT ctx m ()
setCookie' name value validUntil =
setMultiHeader MultiHeaderSetCookie rendered
where
rendered =
let formattedTime =
T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
in T.concat [ name
, "="
, value
, "; path=/; expires="
, formattedTime
, ";"
]
response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a
response val =
do modify $ \rs -> rs { rs_responseBody = ResponseBody val }
throwError ActionDone
bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a
bytes val =
lazyBytes $ BSL.fromStrict val
lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a
lazyBytes val =
response $ \status headers -> Wai.responseLBS status headers val
text :: MonadIO m => T.Text -> ActionCtxT ctx m a
text val =
do setHeaderUnsafe "Content-Type" "text/plain; charset=utf-8"
bytes $ T.encodeUtf8 val
html :: MonadIO m => T.Text -> ActionCtxT ctx m a
html val =
do setHeaderUnsafe "Content-Type" "text/html; charset=utf-8"
bytes $ T.encodeUtf8 val
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
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
stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a
stream val =
response $ \status headers -> Wai.responseStream status headers val
requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionCtxT ctx m a -> ActionCtxT ctx m a
requireBasicAuth realmTitle authFun cont =
do mAuthHeader <- header "Authorization"
case mAuthHeader of
Nothing ->
authFailed
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 do isOk <- lift $ authFun user pass
if isOk
then cont
else authFailed
where
authFailed =
do setStatus status401
setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")
html "<h1>Authentication required.</h1>"
getContext :: MonadIO m => ActionCtxT ctx m ctx
getContext = asks ri_context
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