Continued refactoring; Yesod.Yesod

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

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

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

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

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

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)

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

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 <title> 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