module Web.Simple.Controller
(
Controller(..), runController
, controllerApp, controllerState, putState
, request, localRequest, respond
, requestHeader
, routeHost, routeTop, routeMethod, routeAccept
, routePattern, routeName, routeVar
, Parseable
, queryParam, queryParam', queryParams
, readQueryParam, readQueryParam', readQueryParams
, parseForm
, redirectBack
, redirectBackOr
, ControllerException
, module Control.Exception.Peel
, ToApplication(..)
, fromApp
, body
) where
import Control.Applicative
import Control.Exception.Peel
import Control.Monad hiding (guard)
import Control.Monad.IO.Class
import Control.Monad.IO.Peel
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Conduit
import qualified Data.Conduit.List as CL
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 Network.Wai.Parse
import Web.Simple.Responses
type ControllerState r = (r, Request)
newtype Controller r a =
Controller (ControllerState r ->
IO (Either Response a, ControllerState r))
instance Functor (Controller r) where
fmap f (Controller act) = Controller $ \st0 -> do
(eaf, st) <- act st0
case eaf of
Left resp -> return (Left resp, st)
Right result -> return (Right $ f result, st)
instance Applicative (Controller r) where
pure a = Controller $ \st -> return $ (Right a, st)
(<*>) = ap
instance Monad (Controller r) where
return = pure
(Controller act) >>= fn = Controller $ \st0 -> do
(eres, st) <- act st0
case eres of
Left resp -> return (Left resp, st)
Right result -> do
let (Controller fres) = fn result
fres st
instance MonadIO (Controller r) where
liftIO act = Controller $ \st -> liftIO act >>= \r -> return (Right r, st)
hoistEither :: Either Response a -> Controller r a
hoistEither eith = Controller $ \st -> return (eith, st)
instance MonadPeelIO (Controller r) where
peelIO = do
r <- controllerState
req <- request
return $ \ctrl -> do
res <- runController ctrl r req
return $ hoistEither res
ask :: Controller r (r, Request)
ask = Controller $ \rd -> return (Right rd, rd)
request :: Controller r Request
request = liftM snd ask
local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a
local f (Controller act) = Controller $ \st@(_, r) -> do
(eres, (req, _)) <- act (f st)
return (eres, (req, r))
localRequest :: (Request -> Request) -> Controller r a -> Controller r a
localRequest f = local (\(r,req) -> (r, f req))
controllerState :: Controller r r
controllerState = liftM fst ask
putState :: r -> Controller r ()
putState r = Controller $ \(_, req) -> return (Right (), (r, req))
controllerApp :: r -> Controller r a -> Application
controllerApp r ctrl req =
runController ctrl r req >>=
either return (const $ return notFound)
runController :: Controller r a -> r -> Request -> IO (Either Response a)
runController (Controller fun) r req = fst `fmap` fun (r,req)
pass :: Controller r ()
pass = Controller $ \st -> return (Right (), st)
respond :: Response -> Controller r a
respond resp = Controller $ \st -> return (Left resp, st)
fromApp :: ToApplication a => a -> Controller r ()
fromApp app = do
req <- request
resp <- liftIO $ (toApp app) req
respond resp
routeHost :: S.ByteString -> Controller r a -> Controller r ()
routeHost host = guardReq $ \req -> host == (fromMaybe "" $ requestHeaderHost req)
routeTop :: Controller r a -> Controller r ()
routeTop = guardReq $ \req -> null (pathInfo req) ||
(T.length . head $ pathInfo req) == 0
routeMethod :: StdMethod -> Controller r a -> Controller r ()
routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod
routeAccept :: S8.ByteString -> Controller r a -> Controller r ()
routeAccept contentType = guardReq (isJust . find matching . requestHeaders)
where matching hdr = fst hdr == hAccept && snd hdr == contentType
routePattern :: S.ByteString -> Controller r a -> Controller r ()
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 :: S.ByteString -> Controller r a -> Controller r ()
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 :: S.ByteString -> Controller r a -> Controller r ()
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 :: Parseable a
=> S8.ByteString
-> Controller r (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' :: Parseable a
=> S.ByteString -> Controller r a
queryParam' varName =
queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return
queryParams :: Parseable a
=> S.ByteString -> Controller r [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 :: Read a
=> S8.ByteString
-> Controller r (Maybe a)
readQueryParam varName =
queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)
readQueryParam' :: Read a
=> S8.ByteString
-> Controller r a
readQueryParam' varName =
queryParam' varName >>= readParamValue varName
readQueryParams :: Read a
=> S8.ByteString
-> Controller r [a]
readQueryParams varName =
queryParams varName >>= mapM (readParamValue varName)
readParamValue :: Read a => S8.ByteString -> Text -> Controller r 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
parseForm :: Controller r ([Param], [(S.ByteString, FileInfo L.ByteString)])
parseForm = do
req <- request
liftIO $ parseRequestBody lbsBackEnd req
body :: Controller r L8.ByteString
body = do
req <- request
liftIO $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)
requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)
requestHeader name = request >>= return . lookup name . requestHeaders
redirectBack :: Controller r ()
redirectBack = redirectBackOr (redirectTo "/")
redirectBackOr :: Response
-> Controller r ()
redirectBackOr def = do
mrefr <- requestHeader "referer"
case mrefr of
Just refr -> respond $ redirectTo refr
Nothing -> respond def
guard :: Bool -> Controller r a -> Controller r ()
guard b c = if b then c >> return () else pass
guardM :: Controller r Bool -> Controller r a -> Controller r ()
guardM b c = b >>= flip guard c
guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()
guardReq f = guardM (liftM f request)
class ToApplication r where
toApp :: r -> Application
instance ToApplication Application where
toApp = id
instance ToApplication Response where
toApp = const . return
data ControllerException = ControllerException String
deriving (Typeable)
instance Show ControllerException where
show (ControllerException msg) = "Controller: " ++ msg
instance Exception ControllerException
err :: String -> Controller r a
err = throwIO . ControllerException