diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 6492e557..ee342f9d 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -41,9 +41,9 @@ data PageContent url = PageContent -- FIXME some typeclasses for the stuff below? -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content +hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content hamletToContent h = do - render <- getUrlRender + render <- getUrlRenderMaster return $ ContentEnum $ go render where go render iter seed = do @@ -54,7 +54,7 @@ hamletToContent h = do iter' iter seed text = iter seed $ cs text -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Routes sub) IO () -> GHandler sub master RepHtml +hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent instance Monad m => ConvertSuccess String (Hamlet url m ()) where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 00ae8ec4..aafbaeed 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -29,6 +29,7 @@ module Yesod.Handler , getUrlRender , getUrlRenderMaster , getRoute + , getRouteToMaster -- * Special responses , RedirectType (..) , redirect @@ -153,6 +154,11 @@ getUrlRenderMaster = handlerRender <$> getData getRoute :: GHandler sub master (Maybe (Routes sub)) getRoute = handlerRoute <$> getData +-- | Get the function to promote a route for a subsite to a route for the +-- master site. +getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) +getRouteToMaster = handlerToMaster <$> getData + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 373bef34..046e83a8 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -29,7 +29,7 @@ newtype RepAtom = RepAtom Content instance HasReps RepAtom where chooseRep (RepAtom c) _ = return (TypeAtom, c) -atomFeed :: AtomFeed (Routes sub) -> GHandler sub master RepAtom +atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f767c9cb..1a01edf5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -72,15 +72,9 @@ getOpenIdR = do case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - y <- getYesodMaster - let html = template (getParams rr "message", id) - let pc = PageContent - { pageTitle = cs "Log in via OpenID" - , pageHead = return () - , pageBody = html - } - content <- hamletToContent $ applyLayout y pc rr - return $ RepHtml content + rtom <- getRouteToMaster + let html = template (getParams rr "message", rtom) + applyLayout "Log in via OpenID" $ html where urlForward (_, wrapper) = wrapper OpenIdForward hasMessage = not . null . fst diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 542224a2..361791b7 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -65,7 +65,7 @@ template = [$hamlet| %priority $url.priority.show.cs$ |] -sitemap :: [SitemapUrl (Routes sub)] -> GHandler sub master RepXml +sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml sitemap = fmap RepXml . hamletToContent . template robots :: Routes sub -- ^ sitemap url diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs new file mode 100644 index 00000000..0f89fdda --- /dev/null +++ b/Yesod/Internal.hs @@ -0,0 +1,25 @@ +-- | Normal users should never need access to these. +module Yesod.Internal + ( -- * Error responses + ErrorResponse (..) + -- * Header + , Header (..) + ) where + +-- | Responses to indicate some form of an error occurred. These are different +-- from 'SpecialResponse' in that they allow for custom error pages. +data ErrorResponse = + NotFound + | InternalError String + | InvalidArgs [(String, String)] + | PermissionDenied + | BadMethod String + deriving (Show, Eq) + +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int String String + | DeleteCookie String + | Header String String + deriving (Eq, Show) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 6b81db07..e927ab49 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -35,26 +35,26 @@ import Data.Text.Lazy (unpack) import qualified Data.Text as T #endif -newtype Json url m a = Json { unJson :: Hamlet url m a } +newtype Json url a = Json { unJson :: Hamlet url IO a } deriving (Functor, Applicative, Monad) -jsonToContent :: Json (Routes sub) IO () -> GHandler sub master Content +jsonToContent :: Json (Routes master) () -> GHandler sub master Content jsonToContent = hamletToContent . unJson htmlContentToText :: HtmlContent -> Text htmlContentToText (Encoded t) = t htmlContentToText (Unencoded t) = encodeHtml t -jsonScalar :: Monad m => HtmlContent -> Json url m () +jsonScalar :: HtmlContent -> Json url () jsonScalar s = Json $ do outputString "\"" output $ encodeJson $ htmlContentToText s outputString "\"" -jsonList :: Monad m => [Json url m ()] -> Json url m () +jsonList :: [Json url ()] -> Json url () jsonList = jsonList' . fromList -jsonList' :: Monad m => Enumerator (Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonList' (Enumerator enum) = do Json $ outputString "[" _ <- enum go False @@ -65,10 +65,10 @@ jsonList' (Enumerator enum) = do () <- j return $ Right True -jsonMap :: Monad m => [(Json url m (), Json url m ())] -> Json url m () +jsonMap :: [(Json url (), Json url ())] -> Json url () jsonMap = jsonMap' . fromList -jsonMap' :: Monad m => Enumerator (Json url m (), Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonMap' :: Enumerator (Json url (), Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonMap' (Enumerator enum) = do Json $ outputString "{" _ <- enum go False diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index eea29116..ea19619d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,11 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) , YesodSite (..) - , simpleApplyLayout + , applyLayout , applyLayoutJson - , getApproot ) where import Yesod.Content @@ -36,15 +36,18 @@ class YesodSite a => Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep + errorHandler :: Yesod y + => a + -> ErrorResponse + -> Handler y ChooseRep errorHandler _ = defaultErrorHandler -- | Applies some form of layout to and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit. - applyLayout :: a - -> PageContent url -- FIXME not so good, should be Routes y - -> Request - -> Hamlet url IO () - applyLayout _ p _ = [$hamlet| + rawApplyLayout :: a + -> PageContent (Routes a) + -> Request + -> Hamlet (Routes a) IO () + rawApplyLayout _ p _ = [$hamlet| !!! %html %head @@ -62,11 +65,27 @@ class YesodSite a => Yesod a where -- trailing slash. approot :: a -> Approot +-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. +applyLayout :: Yesod master + => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ body + -> GHandler sub master RepHtml +applyLayout t b = do + let pc = PageContent + { pageTitle = cs t + , pageHead = return () + , pageBody = b + } + y <- getYesodMaster + rr <- getRequest + content <- hamletToContent $ rawApplyLayout y pc rr + return $ RepHtml content + applyLayoutJson :: Yesod master => String -- ^ title -> x - -> (x -> Hamlet (Routes sub) IO ()) - -> (x -> Json (Routes sub) IO ()) + -> (x -> Hamlet (Routes master) IO ()) + -> (x -> Json (Routes master) ()) -> GHandler sub master RepHtmlJson applyLayoutJson t x toH toJ = do let pc = PageContent @@ -76,49 +95,32 @@ applyLayoutJson t x toH toJ = do } y <- getYesodMaster rr <- getRequest - html <- hamletToContent $ applyLayout y pc rr + html <- hamletToContent $ rawApplyLayout y pc rr json <- jsonToContent $ toJ x return $ RepHtmlJson html json --- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. -simpleApplyLayout :: Yesod master - => String -- ^ title - -> Hamlet (Routes sub) IO () -- ^ body - -> GHandler sub master RepHtml -simpleApplyLayout t b = do - let pc = PageContent - { pageTitle = cs t - , pageHead = return () - , pageBody = b - } - y <- getYesodMaster - rr <- getRequest - content <- hamletToContent $ applyLayout y pc rr - return $ RepHtml content +applyLayout' :: Yesod master + => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ body + -> GHandler sub master ChooseRep +applyLayout' s = fmap chooseRep . applyLayout s -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 :: Yesod y + => ErrorResponse + -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - simpleApplyLayout' "Not Found" $ [$hamlet| + applyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $helper$ |] r where helper = Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = - simpleApplyLayout' "Permission Denied" $ [$hamlet| + applyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied|] () defaultErrorHandler (InvalidArgs ia) = - simpleApplyLayout' "Invalid Arguments" $ [$hamlet| + applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ias pair @@ -128,12 +130,12 @@ defaultErrorHandler (InvalidArgs ia) = where ias _ = map (cs *** cs) ia defaultErrorHandler (InternalError e) = - simpleApplyLayout' "Internal Server Error" $ [$hamlet| + applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error %p $cs$ |] e defaultErrorHandler (BadMethod m) = - simpleApplyLayout' "Bad Method" $ [$hamlet| + applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported %p Method "$cs$" not supported |] m