From ac54b644bc2848e042bfa329324bf557d6f7dbf5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 09:50:43 +0200 Subject: [PATCH] Added Yesod parameter to Handler --- Yesod/Application.hs | 4 +-- Yesod/Handler.hs | 43 ++++++++++++++++-------------- Yesod/Helpers/Auth.hs | 14 +++++----- Yesod/Helpers/Sitemap.hs | 11 +++++--- Yesod/Helpers/Static.hs | 4 +-- Yesod/Resource.hs | 5 +++- Yesod/Yesod.hs | 57 ++++++++++++++++++++-------------------- 7 files changed, 74 insertions(+), 64 deletions(-) diff --git a/Yesod/Application.hs b/Yesod/Application.hs index aa97a4f7..e2907a94 100644 --- a/Yesod/Application.hs +++ b/Yesod/Application.hs @@ -102,7 +102,7 @@ takeJusts (Just x:rest) = x : takeJusts rest toHackApplication :: RestfulApp resourceName => resourceName - -> (resourceName -> Verb -> Handler [(ContentType, Content)]) + -> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)]) -> Hack.Application toHackApplication sampleRN hm env = do -- The following is safe since we run cleanPath as middleware @@ -117,7 +117,7 @@ toHackApplication sampleRN hm env = do let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept r <- - runHandler handler rr ctypes' >>= + runHandler handler rr sampleRN ctypes' >>= either (applyErrorHandler sampleRN rr ctypes') return responseToHackResponse (rawLanguages rr) r diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ee0d456d..0d5ffc93 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -19,6 +19,7 @@ module Yesod.Handler ( -- * Handler monad Handler + , getYesod , runHandler , liftIO --, ToHandler (..) @@ -44,20 +45,20 @@ import Control.Monad.Attempt --import Data.Typeable ------ Handler monad -newtype Handler a = Handler { - unHandler :: RawRequest -> IO ([Header], HandlerContents a) +newtype Handler yesod a = Handler { + unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a) } data HandlerContents a = forall e. Exception e => HCError e | HCSpecial ErrorResult | HCContent a -instance Functor Handler where +instance Functor (Handler yesod) where fmap = liftM -instance Applicative Handler where +instance Applicative (Handler yesod) where pure = return (<*>) = ap -instance Monad Handler where +instance Monad (Handler yesod) where fail = failureString -- We want to catch all exceptions anyway return x = Handler $ \_ -> return ([], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do @@ -68,23 +69,27 @@ instance Monad Handler where (HCSpecial e) -> return $ ([], HCSpecial e) (HCContent a) -> unHandler (f a) rr return (headers ++ headers', c') -instance MonadIO Handler where +instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') -instance Exception e => Failure e Handler where +instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) -instance MonadRequestReader Handler where - askRawRequest = Handler $ \rr -> return ([], HCContent rr) +instance MonadRequestReader (Handler yesod) where + askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr) invalidParam _pt _pn _pe = error "invalidParam" authRequired = error "authRequired" +getYesod :: Handler yesod yesod +getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) + -- FIXME this is a stupid signature runHandler :: HasReps a - => Handler a + => Handler yesod a -> RawRequest + -> yesod -> [ContentType] -> IO (Either (ErrorResult, [Header]) Response) -runHandler (Handler handler) rr cts = do - (headers, contents) <- handler rr +runHandler (Handler handler) rr yesod cts = do + (headers, contents) <- handler (rr, yesod) case contents of HCError e -> return $ Left (InternalError $ show e, headers) HCSpecial e -> return $ Left (e, headers) @@ -171,15 +176,15 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do -} ------ Special handlers -errorResult :: ErrorResult -> Handler a +errorResult :: ErrorResult -> Handler yesod a errorResult er = Handler $ \_ -> return ([], HCSpecial er) -- | Redirect to the given URL. -redirect :: String -> Handler a +redirect :: String -> Handler yesod a redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. -notFound :: Handler a +notFound :: Handler yesod a notFound = errorResult NotFound ------- Headers @@ -187,16 +192,16 @@ notFound = errorResult NotFound addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value - -> Handler () + -> Handler yesod () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> Handler () +deleteCookie :: String -> Handler yesod () deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. -header :: String -> String -> Handler () +header :: String -> String -> Handler yesod () header a = addHeader . Header a -addHeader :: Header -> Handler () +addHeader :: Header -> Handler yesod () addHeader h = Handler $ \_ -> return ([h], HCContent ()) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e722e21b..96229ce6 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -60,7 +60,7 @@ instance Enumerable AuthResource where newtype RpxnowApiKey = RpxnowApiKey String -authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler HtmlObject +authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler y HtmlObject authHandler _ Check Get = authCheck authHandler _ Logout Get = authLogout authHandler _ Openid Get = authOpenidForm @@ -88,7 +88,7 @@ instance Show OIDFormReq where show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ "

" -authOpenidForm :: Handler HtmlObject +authOpenidForm :: Handler y HtmlObject authOpenidForm = do m@(OIDFormReq _ dest) <- parseRequest let html = @@ -102,7 +102,7 @@ authOpenidForm = do Nothing -> return () return $ toHtmlObject $ Html $ cs html -authOpenidForward :: Handler HtmlObject +authOpenidForward :: Handler y HtmlObject authOpenidForward = do oid <- getParam "openid" env <- parseEnv @@ -115,7 +115,7 @@ authOpenidForward = do redirect res -authOpenidComplete :: Handler HtmlObject +authOpenidComplete :: Handler y HtmlObject authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" @@ -141,7 +141,7 @@ chopHash ('#':rest) = rest chopHash x = x rpxnowLogin :: String -- ^ api key - -> Handler HtmlObject + -> Handler y HtmlObject rpxnowLogin apiKey = do token <- anyParam "token" postDest <- postParam "dest" @@ -157,7 +157,7 @@ rpxnowLogin apiKey = do header authCookieName $ Rpxnow.identifier ident redirect dest -authCheck :: Handler HtmlObject +authCheck :: Handler y HtmlObject authCheck = do ident <- maybeIdentifier case ident of @@ -167,7 +167,7 @@ authCheck = do , ("ident", i) ] -authLogout :: Handler HtmlObject +authLogout :: Handler y HtmlObject authLogout = do deleteCookie authCookieName return $ toHtmlObject [("status", "loggedout")] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 16a65721..797bd9b6 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -30,6 +30,7 @@ import qualified Hack import Yesod.Request import Data.Time (UTCTime) import Data.Convertible.Text (cs) +import Yesod.Yesod data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always @@ -86,7 +87,7 @@ instance HasReps SitemapResponse where [ (TypeXml, cs . show) ] -sitemap :: IO [SitemapUrl] -> Handler SitemapResponse +sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse sitemap urls' = do env <- parseEnv -- FIXME @@ -94,6 +95,8 @@ sitemap urls' = do urls <- liftIO urls' return $ SitemapResponse req urls -robots :: Approot -> Handler Plain -robots (Approot ar) = do - return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml" +robots :: Yesod yesod => Handler yesod Plain +robots = do + yesod <- getYesod + return $ plain $ "Sitemap: " ++ unApproot (approot yesod) + ++ "sitemap.xml" diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 0d198353..c7c06bc8 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -40,11 +40,11 @@ fileLookupDir dir fp = do then Just <$> B.readFile fp' else return Nothing -serveStatic :: FileLookup -> Verb -> Handler [(ContentType, Content)] +serveStatic :: FileLookup -> Verb -> Handler y [(ContentType, Content)] serveStatic fl Get = getStatic fl serveStatic _ _ = notFound -getStatic :: FileLookup -> Handler [(ContentType, Content)] +getStatic :: FileLookup -> Handler y [(ContentType, Content)] getStatic fl = do fp <- urlParam "filepath" -- FIXME check for .. content <- liftIO $ fl fp diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 3e29f387..024f5a20 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -19,6 +19,7 @@ --------------------------------------------------------- module Yesod.Resource ( ResourceName (..) + , ResourcePatternString , fromString , checkPattern , validatePatterns @@ -92,7 +93,9 @@ class (Show a, Enumerable a) => ResourceName a where resourcePattern :: a -> String -- | Find the handler for each resource name/verb pattern. - getHandler :: a -> Verb -> Handler [(ContentType, Content)] -- FIXME + getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME + +type ResourcePatternString = String type SMap = [(String, String)] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9580d2ce..83a6d64a 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,7 +1,6 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) - , Handler , toHackApp ) where @@ -10,10 +9,10 @@ import Data.Object.Html (toHtmlObject) import Yesod.Response import Yesod.Request import Yesod.Constants ---import Yesod.Definitions ---import Yesod.Resource (checkResourceName) +import Yesod.Definitions +import Yesod.Resource +import Yesod.Handler -import Control.Applicative --import Control.Monad (when) import qualified Hack @@ -23,11 +22,12 @@ import Hack.Middleware.Gzip import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride -type Handler a v = a -> IO v -- FIXME -type HandlerMap a = [(String, [ContentType] -> Handler a Content)] +type ContentPair = (ContentType, Content) class Yesod a where - handlers :: HandlerMap a + handlers :: + [(ResourcePatternString, + [(Verb, [ContentType] -> Handler a ContentPair)])] -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -43,37 +43,36 @@ class Yesod a where ] -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> (ContentType, Content) -- FIXME better type sig? + errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair errorHandler = defaultErrorHandler + -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool checkOverlaps = const True -newtype MyIdentity a = MyIdentity { _unMyIdentity :: a } -instance Functor MyIdentity where - fmap f (MyIdentity a) = MyIdentity $ f a -instance Applicative MyIdentity where - pure = MyIdentity - (MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a + -- | An absolute URL to the root of the application. + approot :: a -> Approot -defaultErrorHandler :: a - -> RawRequest - -> ErrorResult +defaultErrorHandler :: Yesod y + => ErrorResult -> [ContentType] - -> (ContentType, Content) -defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $ - "Not found: " ++ show rr -defaultErrorHandler _ _ (Redirect url) = - chooseRep $ toHtmlObject $ "Redirect to: " ++ url -defaultErrorHandler _ _ (InternalError e) = - chooseRep $ toHtmlObject $ "Internal server error: " ++ e -defaultErrorHandler _ _ (InvalidArgs ia) = - chooseRep $ toHtmlObject + -> Handler y ContentPair +defaultErrorHandler NotFound cts = do + rr <- askRawRequest + return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts +defaultErrorHandler (Redirect url) cts = + return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts +defaultErrorHandler PermissionDenied cts = + return $ chooseRep (toHtmlObject "Permission denied") cts +defaultErrorHandler (InvalidArgs ia) cts = + return $ chooseRep (toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) - ] -defaultErrorHandler _ _ PermissionDenied = - chooseRep $ toHtmlObject "Permission denied" + ]) cts +defaultErrorHandler (InternalError e) cts = + return $ chooseRep (toHtmlObject + [ ("Internal server error", e) + ]) cts toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do