diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 369e4a23..7964db92 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -164,10 +164,9 @@ instance ConvertSuccess (Html, Html) HtmlDoc where , Tag "body" [] b ] ) [] -instance ConvertSuccess (HtmlObject, HtmlObject) HtmlDoc where - convertSuccess (x, y) = cs (cs' x :: Html, cs' y) where - cs' = cs -instance ConvertSuccess (HtmlObject, HtmlObject) JsonDoc where +instance ConvertSuccess (Html, HtmlObject) HtmlDoc where + convertSuccess (x, y) = cs (x, cs y :: Html) +instance ConvertSuccess (Html, HtmlObject) JsonDoc where convertSuccess (_, y) = cs y instance ConvertSuccess HtmlObject Html where diff --git a/Test/Errors.hs b/Test/Errors.hs index ddb07346..9f694b51 100644 --- a/Test/Errors.hs +++ b/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 diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 4a4439d3..c8424fbb 100644 --- a/Test/QuasiResource.hs +++ b/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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 68f7d32c..6078e2c1 100644 --- a/Yesod/Handler.hs +++ b/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" ) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 9fcefe62..f7d42eb0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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 - -justTitle :: String -> HtmlObject -justTitle = cs . Tag "title" [] . cs - -authCheck :: Handler y (HtmlObject, HtmlObject) +authCheck :: Yesod y => Handler y ChooseRep 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 diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 23a27fb1..a1106eee 100644 --- a/Yesod/Response.hs +++ b/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) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f6cb4bf2..da6ae794 100644 --- a/Yesod/Yesod.hs +++ b/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 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 - ( justTitle "Not Found" - , toHtmlObject [("Not found", show rr)] - ) + applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", show rr)] defaultErrorHandler PermissionDenied = - return $ chooseRep - ( justTitle "Permission Denied" - , toHtmlObject "Permission denied" - ) + applyLayout' "Permission Denied" $ cs "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 - [ ("Internal server error", e) - ]) + applyLayout' "Internal Server Error" $ cs $ toHtmlObject + [ ("Internal server error", e) + ] toHackApp :: Yesod y => y -> IO Hack.Application toHackApp a = do