{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Web.Simple.Controller.Trans where
import Control.Exception
import Control.Monad hiding (guard)
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Applicative
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.List (find)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Web.Simple.Responses
newtype ControllerT s m a = ControllerT
{ runController :: s -> Request ->
m (Either Response a, s) }
instance Functor m => Functor (ControllerT s m) where
fmap f (ControllerT act) = ControllerT $ \st0 req ->
go `fmap` act st0 req
where go (eaf, st) = case eaf of
Left resp -> (Left resp, st)
Right result -> (Right $ f result, st)
instance (Monad m, Functor m) => Applicative (ControllerT s m) where
pure = return
(<*>) = ap
instance Monad m => Monad (ControllerT s m) where
return a = ControllerT $ \st _ -> return $ (Right a, st)
(ControllerT act) >>= fn = ControllerT $ \st0 req -> do
(eres, st) <- act st0 req
case eres of
Left resp -> return (Left resp, st)
Right result -> do
let (ControllerT fres) = fn result
fres st req
instance (Functor m, Monad m) => Alternative (ControllerT s m) where
empty = respond notFound
(<|>) = (>>)
instance Monad m => MonadPlus (ControllerT s m) where
mzero = respond notFound
mplus = flip (>>)
instance MonadTrans (ControllerT s) where
lift act = ControllerT $ \st _ -> act >>= \r -> return (Right r, st)
instance Monad m => MonadState s (ControllerT s m) where
get = ControllerT $ \s _ -> return (Right s, s)
put s = ControllerT $ \_ _ -> return (Right (), s)
instance Monad m => MonadReader Request (ControllerT s m) where
ask = ControllerT $ \st req -> return (Right req, st)
local f (ControllerT act) = ControllerT $ \st req -> act st (f req)
instance MonadIO m => MonadIO (ControllerT s m) where
liftIO = lift . liftIO
instance (Applicative m, Monad m, MonadBase m m) => MonadBase m (ControllerT s m) where
liftBase = liftBaseDefault
instance MonadBaseControl m m => MonadBaseControl m (ControllerT s m) where
type StM (ControllerT s m) a = (Either Response a, s)
liftBaseWith fn = ControllerT $ \st req -> do
res <- fn $ \act -> runController act st req
return (Right res, st)
restoreM (a, s) = ControllerT $ \_ _ -> return (a, s)
hoistEither :: Monad m => Either Response a -> ControllerT s m a
hoistEither eith = ControllerT $ \st _ -> return (eith, st)
request :: Monad m => ControllerT s m Request
request = ask
localRequest :: Monad m
=> (Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest = local
controllerState :: Monad m => ControllerT s m s
controllerState = get
putState :: Monad m => s -> ControllerT s m ()
putState = put
controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m
controllerApp s ctrl req =
runController ctrl s req >>=
either return (const $ return notFound) . fst
respond :: Monad m => Response -> ControllerT s m a
respond resp = hoistEither $ Left resp
fromApp :: Monad m => (Request -> m Response) -> ControllerT s m ()
fromApp app = do
req <- request
resp <- lift $ app req
respond resp
routeHost :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()
routeHost host = guardReq $ \req ->
Just host == requestHeaderHost req
routeTop :: Monad m => ControllerT s m a -> ControllerT s m ()
routeTop = guardReq $ \req -> null (pathInfo req) ||
(T.length . head $ pathInfo req) == 0
routeMethod :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod
routeAccept :: Monad m => S8.ByteString -> ControllerT s m a -> ControllerT s m ()
routeAccept contentType = guardReq (isJust . find matching . requestHeaders)
where matching hdr = fst hdr == hAccept && snd hdr == contentType
routePattern :: Monad m
=> Text -> ControllerT s m a -> ControllerT s m ()
routePattern pattern route =
let patternParts = decodePathSegments (T.encodeUtf8 pattern)
in foldr mkRoute (route >> return ()) patternParts
where mkRoute name = case T.uncons name of
Just (':', varName) -> routeVar varName
_ -> routeName name
routeName :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeName name next = do
req <- request
if (length $ pathInfo req) > 0 && name == (head . pathInfo) req
then localRequest popHdr next >> return ()
else return ()
where popHdr req = req { pathInfo = (tail . pathInfo $ req) }
routeVar :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeVar varName next = do
req <- request
case pathInfo req of
[] -> return ()
x:_ | T.null x -> return ()
| otherwise -> localRequest popHdr next >> return ()
where popHdr req = req {
pathInfo = (tail . pathInfo $ req)
, queryString = (T.encodeUtf8 varName, Just (varVal req)):(queryString req)}
varVal req = T.encodeUtf8 . head . pathInfo $ req
queryParam :: (Monad m, Parseable a)
=> S8.ByteString
-> ControllerT s m (Maybe a)
queryParam varName = do
qr <- liftM queryString request
return $ case lookup varName qr of
Just p -> Just $ parse $ fromMaybe S.empty p
_ -> Nothing
queryParam' :: (Monad m, Parseable a)
=> S.ByteString -> ControllerT s m a
queryParam' varName =
queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return
queryParams :: (Monad m, Parseable a)
=> S.ByteString -> ControllerT s m [a]
queryParams varName = request >>= return .
map (parse . fromMaybe S.empty . snd) .
filter ((== varName) . fst) .
queryString
class Parseable a where
parse :: S8.ByteString -> a
instance Parseable S8.ByteString where
parse = id
instance Parseable String where
parse = S8.unpack
instance Parseable Text where
parse = T.decodeUtf8
readQueryParam :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m (Maybe a)
readQueryParam varName =
queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)
readQueryParam' :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m a
readQueryParam' varName =
queryParam' varName >>= readParamValue varName
readQueryParams :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m [a]
readQueryParams varName =
queryParams varName >>= mapM (readParamValue varName)
readParamValue :: (Monad m, Read a)
=> S8.ByteString -> Text -> ControllerT s m a
readParamValue varName =
maybe (err $ "cannot read parameter: " ++ show varName) return .
readMay . T.unpack
where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of
[x] -> Just x
_ -> Nothing
requestHeader :: Monad m => HeaderName -> ControllerT s m (Maybe S8.ByteString)
requestHeader name = request >>= return . lookup name . requestHeaders
redirectBack :: Monad m => ControllerT s m ()
redirectBack = redirectBackOr (redirectTo "/")
redirectBackOr :: Monad m
=> Response
-> ControllerT s m ()
redirectBackOr def = do
mrefr <- requestHeader "referer"
case mrefr of
Just refr -> respond $ redirectTo refr
Nothing -> respond def
type SimpleApplication m = Request -> m Response
type SimpleMiddleware m = SimpleApplication m -> SimpleApplication m
guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m ()
guard b c = if b then c >> return () else return ()
guardM :: Monad m
=> ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM b c = b >>= flip guard c
guardReq :: Monad m
=> (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq f = guardM (liftM f request)
data ControllerException = ControllerException String
deriving (Typeable)
instance Show ControllerException where
show (ControllerException msg) = "ControllerT: " ++ msg
instance Exception ControllerException
err :: String -> ControllerT s m a
err = throw . ControllerException