diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 8f2a848d..343b664e 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -28,7 +28,7 @@ data PageContent url = PageContent , pageBody :: Hamlet url IO () } -hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content +hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content hamletToContent h = do render <- getUrlRender return $ ContentEnum $ go render diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 61b9d81d..1f15ea75 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -21,13 +21,19 @@ module Yesod.Handler ( -- * Handler monad Handler + , GHandler , getYesod + , getYesodMaster , getUrlRender + , getUrlRenderMaster , getRoute + , getRouteMaster , runHandler , runHandler' + , runHandlerSub , liftIO , YesodApp (..) + , YesodAppSub (..) , Routes -- * Special handlers , redirect @@ -61,11 +67,13 @@ import Data.Convertible.Text (cs) type family Routes y -data HandlerData yesod = HandlerData +data HandlerData sub master = HandlerData { handlerRequest :: Request - , handlerYesod :: yesod - , handlerRoute :: Maybe (Routes yesod) - , handlerRender :: (Routes yesod -> String) + , handlerSub :: sub + , handlerMaster :: master + , handlerRoute :: Maybe (Routes sub) + , handlerRender :: (Routes master -> String) + , handlerToMaster :: Routes sub -> Routes master } newtype YesodApp = YesodApp @@ -76,22 +84,26 @@ newtype YesodApp = YesodApp -> IO Response } +data YesodAppSub master = YesodAppSub + ------ Handler monad -newtype Handler yesod a = Handler { - unHandler :: HandlerData yesod +newtype GHandler sub master a = Handler { + unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) } +type Handler yesod = GHandler yesod yesod + data HandlerContents a = HCSpecial SpecialResponse | HCError ErrorResponse | HCContent a -instance Functor (Handler yesod) where +instance Functor (GHandler sub master) where fmap = liftM -instance Applicative (Handler yesod) where +instance Applicative (GHandler sub master) where pure = return (<*>) = ap -instance Monad (Handler yesod) where +instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway return x = Handler $ \_ -> return ([], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do @@ -102,21 +114,46 @@ instance Monad (Handler yesod) where (HCSpecial e) -> return ([], HCSpecial e) (HCContent a) -> unHandler (f a) rr return (headers ++ headers', c') -instance MonadIO (Handler yesod) where +instance MonadIO (GHandler sub master) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') -instance Failure ErrorResponse (Handler yesod) where +instance Failure ErrorResponse (GHandler sub master) where failure e = Handler $ \_ -> return ([], HCError e) -instance RequestReader (Handler yesod) where +instance RequestReader (GHandler sub master) where getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r) -getYesod :: Handler yesod yesod -getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r) +getData :: GHandler sub master (HandlerData sub master) +getData = Handler $ \r -> return ([], HCContent r) -getUrlRender :: Handler yesod (Routes yesod -> String) -getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r) +getYesod :: GHandler sub master sub +getYesod = handlerSub <$> getData -getRoute :: Handler yesod (Maybe (Routes yesod)) -getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r) +getYesodMaster :: GHandler sub master master +getYesodMaster = handlerMaster <$> getData + +getUrlRender :: GHandler sub master (Routes sub -> String) +getUrlRender = do + d <- getData + return $ handlerRender d . handlerToMaster d + +getUrlRenderMaster :: GHandler sub master (Routes master -> String) +getUrlRenderMaster = handlerRender <$> getData + +getRoute :: GHandler sub master (Maybe (Routes sub)) +getRoute = handlerRoute <$> getData + +getRouteMaster :: GHandler sub master (Maybe (Routes master)) +getRouteMaster = do + d <- getData + return $ handlerToMaster d <$> handlerRoute d + +runHandlerSub :: HasReps c + => GHandler sub master c + -> master + -> (master -> sub) + -> Routes sub + -> (Routes sub -> String) + -> YesodAppSub master +runHandlerSub = error "runHandlerSub" runHandler' :: HasReps c => Handler yesod c @@ -137,7 +174,14 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData rr y route render) + (unHandler handler $ HandlerData + { handlerRequest = rr + , handlerSub = y + , handlerMaster = y + , handlerRoute = route + , handlerRender = render + , handlerToMaster = id + }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts @@ -164,14 +208,14 @@ safeEh er = YesodApp $ \_ _ _ -> do return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error" ------ Special handlers -specialResponse :: SpecialResponse -> Handler yesod a +specialResponse :: SpecialResponse -> GHandler sub master a specialResponse er = Handler $ \_ -> return ([], HCSpecial er) -- | Redirect to the given URL. -redirect :: RedirectType -> String -> Handler yesod a +redirect :: RedirectType -> String -> GHandler sub master a redirect rt = specialResponse . Redirect rt -sendFile :: ContentType -> FilePath -> Handler yesod a +sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct = specialResponse . SendFile ct -- | Return a 404 not found page. Also denotes no handler available. @@ -194,16 +238,16 @@ invalidArgs = failure . InvalidArgs addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value - -> Handler yesod () + -> GHandler sub master () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> Handler yesod () +deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. -header :: String -> String -> Handler yesod () +header :: String -> String -> GHandler sub master () header a = addHeader . Header a -addHeader :: Header -> Handler yesod () +addHeader :: Header -> GHandler sub master () addHeader h = Handler $ \_ -> return ([h], HCContent ()) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 06258fde..c01693aa 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -47,15 +48,14 @@ import Control.Applicative ((<$>)) data LoginType = OpenId | Rpxnow -data Auth = forall y. Yesod y => Auth +data Auth = Auth { defaultDest :: String - , onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth () + --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () , rpxnowApiKey :: Maybe String , defaultLoginType :: LoginType - , parentYesod :: y } -$(mkYesod "Auth" [$parseRoutes| +$(mkYesodSub "Auth" [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -68,13 +68,13 @@ data ExpectedSingleParam = ExpectedSingleParam deriving (Show, Typeable) instance Exception ExpectedSingleParam -getOpenIdR :: Handler Auth RepHtml +getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR = do rr <- getRequest case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - (Auth _ _ _ _ y) <- getYesod + y <- getYesodMaster let html = template (getParams rr "message", id) let pc = PageContent { pageTitle = cs "Log in via OpenID" @@ -97,7 +97,7 @@ $if hasMessage %input!type=submit!value=Login |] -getOpenIdForward :: Handler Auth () +getOpenIdForward :: GHandler Auth master () getOpenIdForward = do rr <- getRequest oid <- case getParams rr "openid" of @@ -112,7 +112,7 @@ getOpenIdForward = do (redirect RedirectTemporary) res -getOpenIdComplete :: Handler Auth () +getOpenIdComplete :: GHandler Auth master () getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr @@ -126,7 +126,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: Handler Auth () +handleRpxnowR :: GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -146,7 +146,10 @@ handleRpxnowR = do (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token auth <- getYesod - onRpxnowLogin auth ident + {- FIXME onRpxnowLogin + case auth of + Auth _ f _ _ _ -> f ident + -} header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest @@ -164,12 +167,12 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y -getCheck :: Handler Auth RepHtml +getCheck :: Yesod master => GHandler Auth master RepHtml getCheck = do ident <- maybeIdentifier dn <- displayName -- FIXME applyLayoutJson - hamletToRepHtml $ [$hamlet| + simpleApplyLayout "Authentication Status" $ [$hamlet| %h1 Authentication Status %dl %dt identifier @@ -178,7 +181,7 @@ getCheck = do %dd $snd$ |] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) -getLogout :: Handler Auth () +getLogout :: GHandler Auth master () getLogout = do y <- getYesod deleteCookie authCookieName @@ -198,12 +201,12 @@ displayName = do -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. -authIdentifier :: Handler Auth String +authIdentifier :: GHandler Auth master String authIdentifier = maybeIdentifier >>= maybe redirectLogin return -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie -- appropriately. -redirectLogin :: Handler Auth a +redirectLogin :: GHandler Auth master a redirectLogin = do y <- getYesod let r = case defaultLoginType y of @@ -228,8 +231,8 @@ requestPath = do -- | Redirect to the given URL, and set a cookie with the current URL so the -- user will ultimately be sent back here. redirectSetDest :: RedirectType - -> Routes y -- ^ redirect page - -> Handler y a + -> Routes sub -- ^ redirect page + -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender curr <- getRoute @@ -242,7 +245,7 @@ redirectSetDest rt dest = do -- | Read the 'destCookieName' cookie and redirect to this destination. If the -- cookie is missing, then use the default path provided. -redirectToDest :: RedirectType -> String -> Handler y a +redirectToDest :: RedirectType -> String -> GHandler sub master a redirectToDest rt def = do rr <- getRequest dest <- case cookies rr destCookieName of diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index feef3780..d65a1d81 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -3,6 +3,7 @@ module Yesod.Resource ( parseRoutes , mkYesod + , mkYesodSub ) where import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) @@ -18,8 +19,20 @@ mkYesod name res = do let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] decs <- createRoutes (name ++ "Routes") - ''YesodApp + (ConT ''YesodApp) name' "runHandler'" res return $ tySyn : yes : decs + +mkYesodSub :: String -> [Resource] -> Q [Dec] +mkYesodSub name res = do + let name' = mkName name + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let yas = ConT ''YesodApp `AppT` VarT (mkName "master") + decs <- createRoutes (name ++ "Routes") + yas + name' + "runHandlerSub" + res + return $ tySyn : decs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f3ec30ea..6762dfc5 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -77,40 +77,44 @@ class YesodSite a => Yesod a where approot :: a -> Approot -- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. -simpleApplyLayout :: Yesod y +simpleApplyLayout :: Yesod master => String -- ^ title - -> Hamlet (Routes y) IO () -- ^ body - -> Handler y ChooseRep + -> Hamlet (Routes sub) IO () -- ^ body + -> GHandler sub master RepHtml simpleApplyLayout t b = do let pc = PageContent { pageTitle = cs t , pageHead = return () , pageBody = b } - y <- getYesod + y <- getYesodMaster rr <- getRequest content <- hamletToContent $ applyLayout y pc rr - return $ chooseRep - [ (TypeHtml, content) - ] + return $ RepHtml content getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod +simpleApplyLayout' :: Yesod master + => String -- ^ title + -> Hamlet (Routes sub) IO () -- ^ body + -> GHandler sub master ChooseRep +simpleApplyLayout' t = fmap chooseRep . simpleApplyLayout t + defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - simpleApplyLayout "Not Found" $ [$hamlet| + simpleApplyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $helper$ |] r where helper = Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = - simpleApplyLayout "Permission Denied" $ [$hamlet| + simpleApplyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied|] () defaultErrorHandler (InvalidArgs ia) = - simpleApplyLayout "Invalid Arguments" $ [$hamlet| + simpleApplyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ias pair @@ -120,12 +124,12 @@ defaultErrorHandler (InvalidArgs ia) = where ias _ = map (cs *** cs) ia defaultErrorHandler (InternalError e) = - simpleApplyLayout "Internal Server Error" $ [$hamlet| + simpleApplyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error %p $cs$ |] e defaultErrorHandler (BadMethod m) = - simpleApplyLayout "Bad Method" $ [$hamlet| + simpleApplyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported %p Method "$cs$" not supported |] m diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index 052d891d..cf889531 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -15,7 +15,7 @@ mkYesod "HelloWorld" [$parseRoutes| instance Yesod HelloWorld where approot _ = "http://localhost:3000" -getHome :: Handler HelloWorld ChooseRep +getHome :: Handler HelloWorld RepHtml getHome = simpleApplyLayout "Hello World" $ cs "Hello world!" main :: IO ()