Added Yesod parameter to Handler

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
 

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 {
+newtype Handler yesod a = Handler {
-    unHandler :: RawRequest -> IO ([Header], HandlerContents a)
+    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
+instance MonadRequestReader (Handler yesod) where
-    askRawRequest = Handler $ \rr -> return ([], HCContent rr)
+    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
+runHandler (Handler handler) rr yesod cts = do
-    (headers, contents) <- handler rr
+    (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 ())

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) _) = "<p class='message'>" ++ encodeHtml s ++
                                  "</p>"
 
-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")]

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 :: Yesod yesod => Handler yesod Plain
-robots (Approot ar) = do
+robots = do
-    return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml"
+    yesod <- getYesod
+    return $ plain $ "Sitemap: " ++ unApproot (approot yesod)
+                                 ++ "sitemap.xml"

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

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)]
 

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.Definitions
---import Yesod.Resource (checkResourceName)
+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 ContentPair = (ContentType, Content)
-type HandlerMap a = [(String, [ContentType] -> Handler a 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 }
+    -- | An absolute URL to the root of the application.
-instance Functor MyIdentity where
+    approot :: a -> Approot
-    fmap f (MyIdentity a) = MyIdentity $ f a
-instance Applicative MyIdentity where
-    pure = MyIdentity
-    (MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a
 
-defaultErrorHandler :: a
+defaultErrorHandler :: Yesod y
-                    -> RawRequest
+                    => ErrorResult
-                    -> ErrorResult
                     -> [ContentType]
-                    -> (ContentType, Content)
+                    -> Handler y ContentPair
-defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $
+defaultErrorHandler NotFound cts = do
-                                   "Not found: " ++ show rr
+    rr <- askRawRequest
-defaultErrorHandler _ _ (Redirect url) =
+    return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts
-        chooseRep $ toHtmlObject $ "Redirect to: " ++ url
+defaultErrorHandler (Redirect url) cts =
-defaultErrorHandler _ _ (InternalError e) =
+    return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts
-        chooseRep $ toHtmlObject $ "Internal server error: " ++ e
+defaultErrorHandler PermissionDenied cts =
-defaultErrorHandler _ _ (InvalidArgs ia) =
+    return $ chooseRep (toHtmlObject "Permission denied") cts
-        chooseRep $ toHtmlObject
+defaultErrorHandler (InvalidArgs ia) cts =
+    return $ chooseRep (toHtmlObject
             [ ("errorMsg", toHtmlObject "Invalid arguments")
             , ("messages", toHtmlObject ia)
-            ]
+            ]) cts
-defaultErrorHandler _ _ PermissionDenied =
+defaultErrorHandler (InternalError e) cts =
-        chooseRep $ toHtmlObject "Permission denied"
+    return $ chooseRep (toHtmlObject
+                [ ("Internal server error", e)
+                ]) cts
 
 toHackApp :: Yesod y => y -> Hack.Application
 toHackApp a env = do