module Web.Simple.Controller.Trans where
import Control.Monad.IO.Class
import Control.Monad.IO.Peel
import Control.Monad.Trans.Class
import Control.Applicative
import Control.Exception.Peel
import Control.Monad hiding (guard)
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
type ControllerState r = (r, Request)
newtype ControllerT s m a = ControllerT
{ runController :: ControllerState s ->
m (Either Response a, ControllerState s) }
instance (Monad m, Functor m) => Functor (ControllerT s m) where
fmap f (ControllerT act) = ControllerT $ \st0 -> do
(eaf, st) <- act st0
case eaf of
Left resp -> return (Left resp, st)
Right result -> return (Right $ f result, st)
instance (Monad m, Applicative 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 -> do
(eres, st) <- act st0
case eres of
Left resp -> return (Left resp, st)
Right result -> do
let (ControllerT fres) = fn result
fres st
instance MonadTrans (ControllerT s) where
lift act = ControllerT $ \st -> act >>= \r -> return (Right r, st)
instance MonadIO m => MonadIO (ControllerT s m) where
liftIO = lift . liftIO
instance MonadPeelIO (ControllerT s IO) where
peelIO = do
r <- controllerState
req <- request
return $ \ctrl -> do
res <- fst `fmap` runController ctrl (r, req)
return $ hoistEither res
hoistEither :: Monad m => Either Response a -> ControllerT s m a
hoistEither eith = ControllerT $ \st -> return (eith, st)
ask :: Monad m => ControllerT s m (s, Request)
ask = ControllerT $ \rd -> return (Right rd, rd)
request :: Monad m => ControllerT s m Request
request = liftM snd ask
local :: Monad m
=> ((s, Request) -> (s, Request)) -> ControllerT s m a -> ControllerT s m a
local f (ControllerT act) = ControllerT $ \st@(_, r) -> do
(eres, (req, _)) <- act (f st)
return (eres, (req, r))
localRequest :: Monad m
=> (Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest f = local (\(r,req) -> (r, f req))
controllerState :: Monad m => ControllerT s m s
controllerState = liftM fst ask
putState :: Monad m => s -> ControllerT s m ()
putState r = ControllerT $ \(_, req) -> return (Right (), (r, req))
controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m
controllerApp r ctrl req =
runController ctrl (r, req) >>=
either return (const $ return notFound) . fst
pass :: Monad m => ControllerT s m ()
pass = ControllerT $ \st -> return (Right (), st)
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 ->
host == (fromMaybe "" $ 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
=> S.ByteString -> ControllerT s m a -> ControllerT s m ()
routePattern pattern route =
let patternParts = map T.unpack $ decodePathSegments pattern
in foldr mkRoute (route >> return ()) patternParts
where mkRoute (':':varName) = routeVar (S8.pack varName)
mkRoute name = routeName (S8.pack name)
routeName :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()
routeName name next = do
req <- request
if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req
then localRequest popHdr next >> return ()
else pass
where popHdr req = req { pathInfo = (tail . pathInfo $ req) }
routeVar :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()
routeVar varName next = do
req <- request
case pathInfo req of
[] -> pass
x:_ | T.null x -> pass
| otherwise -> localRequest popHdr next >> return ()
where popHdr req = req {
pathInfo = (tail . pathInfo $ req)
, queryString = (varName, Just (varVal req)):(queryString req)}
varVal req = S8.pack . T.unpack . 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 pass
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