module Web.Welshy.Action where
import Control.Applicative
import Control.Arrow
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import Data.Conduit.Lazy
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import Network.HTTP.Types
import Network.Wai
data Result a = Ok a Response | Halt (Action ()) | Pass
newtype Action a = Action { runAction :: Env -> Response -> IO (Result a) }
instance Functor Action where
fmap f m = Action $ \r s -> runAction m r s >>= \case
Ok a s1 -> return $ Ok (f a) s1
Halt m1 -> return $ Halt m1
Pass -> return $ Pass
instance Applicative Action where
pure = return
(<*>) = ap
instance Alternative Action where
empty = mzero
(<|>) = mplus
instance Monad Action where
return a = Action $ \_ s -> return $ Ok a s
m >>= k = Action $ \r s -> runAction m r s >>= \case
Ok a s1 -> runAction (k a) r s1
Halt s1 -> return $ Halt s1
Pass -> return $ Pass
fail msg = halt $ error msg
instance MonadPlus Action where
mzero = fail "mzero"
m `mplus` n = Action $ \r s -> runAction m r s >>= \case
Ok a s1 -> return $ Ok a s1
Halt __ -> runAction n r s
Pass -> runAction n r s
instance MonadIO Action where
liftIO m = Action $ \_ s -> do
a <- m
return $ Ok a s
catchIO :: Exception e => IO a -> (e -> Action a) -> Action a
catchIO act h = either h return =<< (liftIO $ try $ act)
type Param = (Text, Text)
data Env = Env { _captures :: [Param]
, _queryParams :: [Param]
, _body :: BL.ByteString
, _jsonParams :: Maybe A.Object
, _request :: Request }
mkEnv :: [Param] -> Request -> ResourceT IO Env
mkEnv _captures _request = do
_body <- BL.fromChunks <$> lazyConsume (requestBody _request)
let _queryParams = queryText _request ++ formParams _body _request
_jsonParams = either (const Nothing) Just (A.eitherDecode _body)
return Env {..}
queryText :: Request -> [Param]
queryText = map (second $ fromMaybe "") . queryToQueryText . queryString
formParams :: BL.ByteString -> Request -> [Param]
formParams b req =
case lookup hContentType (requestHeaders req) of
Just "application/x-www-form-urlencoded" ->
map (second $ fromMaybe "") $ queryToQueryText $
parseQuery $ BL.toStrict $ b
_ -> []
execAction :: Action () -> [Param] -> Middleware
execAction act0 caps nextApp req = run act0 =<< mkEnv caps req
where
run :: Action () -> Env -> ResourceT IO Response
run act env = (lift $ runAction act env okRes) >>= \case
Ok _ res -> return res
Halt act' -> run act' env
Pass -> nextApp req
okRes :: Response
okRes = ResponseBuilder ok200 [] mempty
halt :: Action () -> Action a
halt m = Action $ \_ _ -> return $ Halt m
pass :: Action a
pass = Action $ \_ _ -> return Pass
request :: Action Request
request = Action $ \r s -> return $ Ok (_request r) s
queryParams :: Action [Param]
queryParams = Action $ \r s -> return $ Ok (_queryParams r) s
captures :: Action [Param]
captures = Action $ \r s -> return $ Ok (_captures r) s
body :: Action BL.ByteString
body = Action $ \r s -> return $ Ok (_body r) s
modifyResponse :: (Response -> Response) -> Action ()
modifyResponse f = Action $ \_ s -> return $ Ok () (f s)