module Web.Scotty.Action
( addHeader
, body
, file
, files
, html
, json
, jsonData
, next
, param
, params
, raise
, raw
, readEither
, redirect
, reqHeader
, request
, rescue
, setHeader
, source
, status
, text
, Param
, Parsable(..)
, runAction
) where
import Blaze.ByteString.Builder (Builder, fromLazyByteString)
import Control.Monad.Error
import Control.Monad.Reader
import qualified Control.Monad.State as MS
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.CaseInsensitive as CI
import Data.Conduit (Flush, ResourceT, Source)
import Data.Default (def)
import Data.Monoid (mconcat, (<>))
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Types
import Network.Wai
import Web.Scotty.Types
import Web.Scotty.Util
runAction :: Monad m => ActionEnv -> ActionT m () -> m (Maybe Response)
runAction env action = do
(e,r) <- flip MS.runStateT def
$ flip runReaderT env
$ runErrorT
$ runAM
$ action `catchError` defaultHandler
return $ either (const Nothing) (const $ Just r) e
defaultHandler :: Monad m => ActionError -> ActionT m ()
defaultHandler (Redirect url) = do
status status302
setHeader "Location" url
defaultHandler (ActionError msg) = do
status status500
html $ mconcat ["<h1>500 Internal Server Error</h1>", msg]
defaultHandler Next = next
raise :: Monad m => T.Text -> ActionT m a
raise = throwError . ActionError
next :: Monad m => ActionT m a
next = throwError Next
rescue :: Monad m => ActionT m a -> (T.Text -> ActionT m a) -> ActionT m a
rescue action handler = catchError action $ \e -> case e of
ActionError msg -> handler msg
other -> throwError other
redirect :: Monad m => T.Text -> ActionT m a
redirect = throwError . Redirect
request :: Monad m => ActionT m Request
request = liftM getReq ask
files :: Monad m => ActionT m [File]
files = liftM getFiles ask
reqHeader :: Monad m => T.Text -> ActionT m (Maybe T.Text)
reqHeader k = do
hs <- liftM requestHeaders request
return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs
body :: Monad m => ActionT m BL.ByteString
body = liftM getBody ask
jsonData :: (A.FromJSON a, Monad m) => ActionT m a
jsonData = do
b <- body
maybe (raise $ "jsonData - no parse: " <> decodeUtf8 b) return $ A.decode b
param :: (Parsable a, Monad m) => T.Text -> ActionT m a
param k = do
val <- liftM (lookup k . getParams) ask
case val of
Nothing -> raise $ mconcat ["Param: ", k, " not found!"]
Just v -> either (const next) return $ parseParam v
params :: Monad m => ActionT m [Param]
params = liftM getParams ask
class Parsable a where
parseParam :: T.Text -> Either T.Text a
parseParamList :: T.Text -> Either T.Text [a]
parseParamList t = mapM parseParam (T.split (== ',') t)
instance Parsable T.Text where parseParam = Right
instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString
instance Parsable Char where
parseParam t = case T.unpack t of
[c] -> Right c
_ -> Left "parseParam Char: no parse"
parseParamList = Right . T.unpack
instance Parsable () where
parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse"
instance (Parsable a) => Parsable [a] where parseParam = parseParamList
instance Parsable Bool where parseParam = readEither
instance Parsable Double where parseParam = readEither
instance Parsable Float where parseParam = readEither
instance Parsable Int where parseParam = readEither
instance Parsable Integer where parseParam = readEither
readEither :: (Read a) => T.Text -> Either T.Text a
readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of
[x] -> Right x
[] -> Left "readEither: no parse"
_ -> Left "readEither: ambiguous parse"
status :: Monad m => Status -> ActionT m ()
status = MS.modify . setStatus
addHeader :: Monad m => T.Text -> T.Text -> ActionT m ()
addHeader k v = MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)
setHeader :: Monad m => T.Text -> T.Text -> ActionT m ()
setHeader k v = MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)
text :: Monad m => T.Text -> ActionT m ()
text t = do
setHeader "Content-Type" "text/plain"
raw $ encodeUtf8 t
html :: Monad m => T.Text -> ActionT m ()
html t = do
setHeader "Content-Type" "text/html"
raw $ encodeUtf8 t
file :: Monad m => FilePath -> ActionT m ()
file = MS.modify . setContent . ContentFile
json :: (A.ToJSON a, Monad m) => a -> ActionT m ()
json v = do
setHeader "Content-Type" "application/json"
raw $ A.encode v
source :: Monad m => Source (ResourceT IO) (Flush Builder) -> ActionT m ()
source = MS.modify . setContent . ContentSource
raw :: Monad m => BL.ByteString -> ActionT m ()
raw = MS.modify . setContent . ContentBuilder . fromLazyByteString