module Web.Spock.Internal.CoreAction
( ActionT
, UploadedFile (..)
, request, header, cookie, body, jsonBody, jsonBody'
, files, params, param, param', setStatus, setHeader, redirect
, jumpNext
, setCookie, setCookie'
, bytes, lazyBytes, text, html, file, json, blaze
, requireBasicAuth
)
where
import Web.Spock.Internal.Wire
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State hiding (get, put)
import Data.Monoid
import Data.Time
import Network.HTTP.Types.Status
import Prelude hiding (head)
import System.Locale
import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
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 Network.Wai as Wai
request :: MonadIO m => ActionT m Wai.Request
request = asks ri_request
header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
header t =
do req <- request
return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)
cookie :: MonadIO m => T.Text -> ActionT 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 "="
body :: MonadIO m => ActionT 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) => ActionT m (Maybe a)
jsonBody =
do b <- body
return $ A.decodeStrict b
jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT 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 => ActionT m (HM.HashMap T.Text UploadedFile)
files =
asks ri_files
params :: MonadIO m => ActionT m [(T.Text, T.Text)]
params =
do p <- asks ri_params
qp <- asks ri_queryParams
return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))
param :: (PathPiece p, MonadIO m) => T.Text -> ActionT 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 -> ActionT 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 -> ActionT m ()
setStatus s =
modify $ \rs -> rs { rs_status = s }
setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
setHeader k v =
modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }
jumpNext :: MonadIO m => ActionT m a
jumpNext = throwError ActionTryNext
redirect :: MonadIO m => T.Text -> ActionT m a
redirect = throwError . ActionRedirect
setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m ()
setCookie name value validSeconds =
do now <- liftIO getCurrentTime
setCookie' name value (validSeconds `addUTCTime` now)
setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m ()
setCookie' name value validUntil =
setHeader "Set-Cookie" rendered
where
rendered =
let formattedTime =
T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
in T.concat [ name
, "="
, value
, "; path=/; expires="
, formattedTime
, ";"
]
bytes :: MonadIO m => BS.ByteString -> ActionT m a
bytes val =
lazyBytes $ BSL.fromStrict val
lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a
lazyBytes val =
do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }
throwError ActionDone
text :: MonadIO m => T.Text -> ActionT m a
text val =
do setHeader "Content-Type" "text/plain"
bytes $ T.encodeUtf8 val
html :: MonadIO m => T.Text -> ActionT m a
html val =
do setHeader "Content-Type" "text/html"
bytes $ T.encodeUtf8 val
file :: MonadIO m => T.Text -> FilePath -> ActionT m a
file contentType filePath =
do setHeader "Content-Type" contentType
modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }
throwError ActionDone
json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b
json val =
do setHeader "Content-Type" "application/json"
lazyBytes $ A.encode val
blaze :: MonadIO m => Html -> ActionT m a
blaze val =
do setHeader "Content-Type" "text/html"
lazyBytes $ renderHtml val
requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT 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
setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")
html "<h1>Authentication required.</h1>"