applyLayout added to Yesod

Data/Object/Html.hs

@@ -164,10 +164,9 @@ instance ConvertSuccess (Html, Html) HtmlDoc where
             , Tag "body" [] b
             ]
         ) []
-instance ConvertSuccess (HtmlObject, HtmlObject) HtmlDoc where
+instance ConvertSuccess (Html, HtmlObject) HtmlDoc where
-    convertSuccess (x, y) = cs (cs' x :: Html, cs' y) where
+    convertSuccess (x, y) = cs (x, cs y :: Html)
-        cs' = cs
+instance ConvertSuccess (Html, HtmlObject) JsonDoc where
-instance ConvertSuccess (HtmlObject, HtmlObject) JsonDoc where
     convertSuccess (_, y) = cs y
 
 instance ConvertSuccess HtmlObject Html where

Test/Errors.hs

@@ -27,19 +27,19 @@ instance YesodAuth Errors
 denied :: Handler Errors ()
 denied = permissionDenied
 
-needsIdent :: Handler Errors (HtmlObject, HtmlObject)
+needsIdent :: Handler Errors (Html, HtmlObject)
 needsIdent = do
     i <- authIdentifier
-    return $ (toHtmlObject "", toHtmlObject i)
+    return $ (cs "", cs i)
 
-hasArgs :: Handler Errors (HtmlObject, HtmlObject)
+hasArgs :: Handler Errors (Html, HtmlObject)
 hasArgs = do
     {- FIXME wait for new request API
     (a, b) <- runRequest $ (,) <$> getParam "firstParam"
                                <*> getParam "secondParam"
     -}
     let (a, b) = ("foo", "bar")
-    return (toHtmlObject "", toHtmlObject [a :: String, b])
+    return (cs "", cs [a :: String, b])
 
 caseErrorMessages :: Assertion
 caseErrorMessages = do

Test/QuasiResource.hs

@@ -14,29 +14,29 @@ data MyYesod = MyYesod
 
 instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler"
 
-addHead' :: HtmlObject -> (HtmlObject, HtmlObject)
+addHead' :: HtmlObject -> (Html, HtmlObject)
 addHead' x = (cs "", x)
 
-addHead :: Monad m => HtmlObject -> m (HtmlObject, HtmlObject)
+addHead :: Monad m => HtmlObject -> m (Html, HtmlObject)
 addHead = return . addHead'
 
-getStatic :: Verb -> [String] -> Handler MyYesod (HtmlObject, HtmlObject)
+getStatic :: Verb -> [String] -> Handler MyYesod (Html, HtmlObject)
 getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p]
-pageIndex :: Handler MyYesod (HtmlObject, HtmlObject)
+pageIndex :: Handler MyYesod (Html, HtmlObject)
 pageIndex = addHead $ toHtmlObject ["pageIndex"]
 pageAdd :: Handler MyYesod ChooseRep
 pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"]
 pageDetail :: String -> Handler MyYesod ChooseRep
 pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s]
-pageDelete :: String -> Handler MyYesod (HtmlObject, HtmlObject)
+pageDelete :: String -> Handler MyYesod (Html, HtmlObject)
 pageDelete s = addHead $ toHtmlObject ["pageDelete", s]
 pageUpdate :: String -> Handler MyYesod ChooseRep
 pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s]
-userInfo :: Int -> Handler MyYesod (HtmlObject, HtmlObject)
+userInfo :: Int -> Handler MyYesod (Html, HtmlObject)
 userInfo i = addHead $ toHtmlObject ["userInfo", show i]
-userVariable :: Int -> String -> Handler MyYesod (HtmlObject, HtmlObject)
+userVariable :: Int -> String -> Handler MyYesod (Html, HtmlObject)
 userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s]
-userPage :: Int -> [String] -> Handler MyYesod (HtmlObject, HtmlObject)
+userPage :: Int -> [String] -> Handler MyYesod (Html, HtmlObject)
 userPage i p = addHead $ toHtmlObject ["userPage", show i, show p]
 
 instance Show (Verb -> Handler MyYesod ChooseRep) where

Yesod/Handler.hs

@@ -131,7 +131,7 @@ safeEh :: ErrorResponse -> Handler yesod ChooseRep
 safeEh er = do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
     return $ chooseRep $
-        ( toHtmlObject $ Tag "title" [] $ cs "Internal Server Error"
+        ( Tag "title" [] $ cs "Internal Server Error"
         , toHtmlObject "Internal server error"
         )
 

Yesod/Helpers/Auth.hs

@@ -68,7 +68,8 @@ data AuthResource =
 rc :: HasReps x => Handler y x -> Handler y ChooseRep
 rc = fmap chooseRep
 
-authHandler :: YesodAuth y => Verb -> [String] -> Handler y ChooseRep
+authHandler :: YesodAuth y =>
+            Verb -> [String] -> Handler y ChooseRep
 authHandler Get ["check"] = rc authCheck
 authHandler Get ["logout"] = rc authLogout
 authHandler Get ["openid"] = rc authOpenidForm
@@ -105,7 +106,7 @@ getParam :: (Monad m, RequestReader m)
          -> m ParamValue
 getParam = someParam GetParam getParams
 
-authOpenidForm :: Handler y (HtmlObject, HtmlObject)
+authOpenidForm :: Yesod y => Handler y ChooseRep
 authOpenidForm = do
     rr <- getRawRequest
     case getParams rr "dest" of
@@ -124,7 +125,7 @@ authOpenidForm = do
                 , EmptyTag "input" [("type", "submit"), ("value", "Login")]
                 ]
           ]
-    return $ (justTitle "Log in via OpenID", cs html)
+    applyLayout' "Log in via OpenID" html
 
 authOpenidForward :: YesodAuth y => Handler y ()
 authOpenidForward = do
@@ -192,19 +193,14 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
                         Nothing -> helper xs
                         Just y -> y
 
--- FIXME use templates for all of the following
+authCheck :: Yesod y => Handler y ChooseRep
-
-justTitle :: String -> HtmlObject
-justTitle = cs . Tag "title" [] . cs
-
-authCheck :: Handler y (HtmlObject, HtmlObject)
 authCheck = do
     ident <- maybeIdentifier
     dn <- displayName
-    return $ (justTitle "Authentication Status", toHtmlObject
+    applyLayoutJson "Authentication Status" $ cs
         [ ("identifier", fromMaybe "" ident)
         , ("displayName", fromMaybe "" dn)
-        ])
+        ]
 
 authLogout :: YesodAuth y => Handler y ()
 authLogout = do

Yesod/Response.hs

@@ -124,7 +124,7 @@ instance HasReps [(ContentType, Content)] where
                     (x:_) -> x
                     _ -> error "chooseRep [(ContentType, Content)] of empty"
 
-instance HasReps (HtmlObject, HtmlObject) where
+instance HasReps (Html, HtmlObject) where
     chooseRep = defChooseRep
         [ (TypeHtml, return . cs . unHtmlDoc . cs)
         , (TypeJson, return . cs . unJsonDoc . cs)

Yesod/Yesod.hs

@@ -2,11 +2,14 @@
 module Yesod.Yesod
     ( Yesod (..)
     , YesodApproot (..)
+    , applyLayout'
+    , applyLayoutJson
     , getApproot
     , toHackApp
     ) where
 
 import Data.Object.Html
+import Data.Object.Json (unJsonDoc)
 import Yesod.Response
 import Yesod.Request
 import Yesod.Definitions
@@ -47,39 +50,61 @@ class Yesod a where
     templateDir :: a -> FilePath
     templateDir _ = ""
 
+    -- | Applies some form of layout to <title> and <body> contents of a page.
+    applyLayout :: a
+                -> String -- ^ title
+                -> Html -- ^ body
+                -> Content
+    applyLayout _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)
+
 class Yesod a => YesodApproot a where
     -- | An absolute URL to the root of the application.
     approot :: a -> Approot
 
+-- | A convenience wrapper around 'applyLayout'.
+applyLayout' :: Yesod y
+             => String
+             -> Html
+             -> Handler y ChooseRep
+applyLayout' t b = do
+    y <- getYesod
+    return $ chooseRep
+        [ (TypeHtml, applyLayout y t b)
+        ]
+
+-- | A convenience wrapper around 'applyLayout' which provides a JSON
+-- representation of the body.
+applyLayoutJson :: Yesod y
+                => String
+                -> HtmlObject
+                -> Handler y ChooseRep
+applyLayoutJson t b = do
+    y <- getYesod
+    return $ chooseRep
+        [ (TypeJson, cs $ unJsonDoc $ cs b)
+        , (TypeHtml, applyLayout y t $ cs b)
+        ]
+
 getApproot :: YesodApproot y => Handler y Approot
 getApproot = approot `fmap` getYesod
 
-justTitle :: String -> HtmlObject
-justTitle = cs . Tag "title" [] . cs
-
 defaultErrorHandler :: Yesod y
                     => ErrorResponse
                     -> Handler y ChooseRep
 defaultErrorHandler NotFound = do
     rr <- getRawRequest
-    return $ chooseRep
+    applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", show rr)]
-        ( justTitle "Not Found"
-        , toHtmlObject [("Not found", show rr)]
-        )
 defaultErrorHandler PermissionDenied =
-    return $ chooseRep
+    applyLayout' "Permission Denied" $ cs "Permission denied"
-        ( justTitle "Permission Denied"
-        , toHtmlObject "Permission denied"
-        )
 defaultErrorHandler (InvalidArgs ia) =
-    return $ chooseRep (justTitle "Invalid Arguments", toHtmlObject
+    applyLayout' "Invalid Arguments" $ cs $ toHtmlObject
             [ ("errorMsg", toHtmlObject "Invalid arguments")
             , ("messages", toHtmlObject ia)
-            ])
+            ]
 defaultErrorHandler (InternalError e) =
-    return $ chooseRep (justTitle "Internal Server Error", toHtmlObject
+    applyLayout' "Internal Server Error" $ cs $ toHtmlObject
-                [ ("Internal server error", e)
+        [ ("Internal server error", e)
-                ])
+        ]
 
 toHackApp :: Yesod y => y -> IO Hack.Application
 toHackApp a = do