From f102b9882be20b5f8c78e2751d1d0c926db54a07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 22 Aug 2010 16:08:58 +0300 Subject: [PATCH] defaultLayout now works directly on widgets --- Yesod/Helpers/Auth.hs | 25 ++++++--- Yesod/Helpers/Crud.hs | 12 ++-- Yesod/Internal.hs | 43 +++++++++++++++ Yesod/Widget.hs | 110 +------------------------------------ Yesod/Yesod.hs | 124 +++++++++++++++++++++++++++++++----------- 5 files changed, 163 insertions(+), 151 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 6dff278e..fe581f87 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -182,7 +183,9 @@ getOpenIdR = do lookupGetParam "dest" >>= maybe (return ()) setUltDestString rtom <- getRouteToMaster message <- getMessage - applyLayout "Log in via OpenID" mempty [$hamlet| + defaultLayout $ do + setTitle "Log in via OpenID" + addBody [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForwardR@ @@ -262,7 +265,9 @@ getDisplayName extra = getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson getCheckR = do creds <- maybeCreds - applyLayoutJson "Authentication Status" mempty (html creds) (json creds) + defaultLayoutJson (do + setTitle "Authentication Status" + addBody $ html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status @@ -303,7 +308,7 @@ getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster - applyLayout "Register a new account" mempty [$hamlet| + defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.EmailRegisterR@ %label!for=email E-mail @@ -333,7 +338,7 @@ postEmailRegisterR = do tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey sendVerifyEmail ae email verKey verUrl - applyLayout "Confirmation e-mail sent" mempty [$hamlet| + defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| %p A confirmation e-mail has been sent to $email$. |] @@ -350,7 +355,9 @@ getEmailVerifyR lid key = do Nothing) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> applyLayout "Invalid verification key" mempty [$hamlet| + _ -> defaultLayout $ do + setTitle "Invalid verification key" + addBody [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -359,7 +366,9 @@ getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster msg <- getMessage - applyLayout "Login" mempty [$hamlet| + defaultLayout $ do + setTitle "Login" + addBody [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account. @@ -414,7 +423,9 @@ getEmailPasswordR = do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage - applyLayout "Set password" mempty [$hamlet| + defaultLayout $ do + setTitle "Set password" + addBody [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 88431266..d08d1231 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..) @@ -17,7 +18,6 @@ import Yesod.Content import Yesod.Handler import Text.Hamlet import Yesod.Form -import Data.Monoid (mempty) import Language.Haskell.TH.Syntax -- | An entity which can be displayed by the Crud subsite. @@ -53,7 +53,9 @@ getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudListR = do items <- getYesodSub >>= crudSelect toMaster <- getRouteToMaster - applyLayout "Items" mempty [$hamlet| + defaultLayout $ do + setTitle "Items" + addBody [$hamlet| %h1 Items %ul $forall items item @@ -111,7 +113,9 @@ getCrudDeleteR s = do crud <- getYesodSub item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists toMaster <- getRouteToMaster - applyLayout "Confirm delete" mempty [$hamlet| + defaultLayout $ do + setTitle "Confirm delete" + addBody [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$? @@ -151,7 +155,7 @@ crudHelper title me isPost = do redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return () - applyLayoutW $ do + defaultLayout $ do wrapWidget form (wrapForm toMaster enctype) setTitle $ string title where diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 2309904e..ef66e3f5 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses @@ -6,8 +8,23 @@ module Yesod.Internal , Header (..) -- * Cookie names , langKey + -- * Widgets + , Location (..) + , UniqueList (..) + , Script (..) + , Stylesheet (..) + , Title (..) + , Head (..) + , Body (..) + , locationToHamlet + , runUniqueList + , toUnique ) where +import Text.Hamlet (Hamlet, hamlet, Html) +import Data.Monoid (Monoid (..)) +import Data.List (nub) + -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = @@ -28,3 +45,29 @@ data Header = langKey :: String langKey = "_LANG" + +data Location url = Local url | Remote String + deriving (Show, Eq) +locationToHamlet :: Location url -> Hamlet url +locationToHamlet (Local url) = [$hamlet|@url@|] +locationToHamlet (Remote s) = [$hamlet|$s$|] + +newtype UniqueList x = UniqueList ([x] -> [x]) +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y +runUniqueList :: Eq x => UniqueList x -> [x] +runUniqueList (UniqueList x) = nub $ x [] +toUnique :: x -> UniqueList x +toUnique = UniqueList . (:) + +newtype Script url = Script { unScript :: Location url } + deriving (Show, Eq) +newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html } + +newtype Head url = Head (Hamlet url) + deriving Monoid +newtype Body url = Body (Hamlet url) + deriving Monoid diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 263fd8a2..13101494 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,12 +6,9 @@ -- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype - GWidget + GWidget (..) , Widget , liftHandler - -- * Unwrapping - , widgetToPageContent - , applyLayoutW -- * Creating , newIdent , setTitle @@ -31,46 +27,18 @@ module Yesod.Widget , extractBody ) where -import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State -import Yesod.Hamlet (PageContent (..)) import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, getUrlRenderParams) -import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) -import Yesod.Content (RepHtml (..)) +import Yesod.Handler (Route, GHandler) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) - -data Location url = Local url | Remote String - deriving (Show, Eq) -locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [$hamlet|@url@|] -locationToHamlet (Remote s) = [$hamlet|$s$|] - -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -newtype Script url = Script { unScript :: Location url } - deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } -newtype Head url = Head (Hamlet url) - deriving Monoid -newtype Body url = Body (Hamlet url) - deriving Monoid +import Yesod.Internal -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of @@ -151,78 +119,6 @@ addScriptRemote = addJavascript :: Julius (Route master) -> GWidget sub master () addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just --- | Apply the default layout to the given widget. -applyLayoutW :: (Eq (Route m), Yesod m) - => GWidget sub m () -> GHandler sub m RepHtml -applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent (GWidget w) = do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - Last mTitle), - scripts'), - stylesheets'), - style), - jscript), - Head head') = w' - let title = maybe mempty unTitle mTitle - let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' - let stylesheets = map (locationToHamlet . unStylesheet) - $ runUniqueList stylesheets' - let cssToHtml (Css b) = Html b - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = Html b - jelper :: Julius url -> Hamlet url - jelper = fmap jsToHtml - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s - return $ renderLoc x - - let head'' = [$hamlet| -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ - $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ - $nothing - %script ^jelper.j^ -^head'^ -|] - return $ PageContent title head'' body - -- | Modify the given 'GWidget' by wrapping the body tag HTML code with the -- given function. You might also consider using 'extractBody'. wrapWidget :: GWidget s m a diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5f50b5dc..70172f8c 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -18,10 +18,10 @@ module Yesod.Yesod -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs - -- * Convenience functions - , applyLayout - , applyLayoutJson + -- * Utitlities , maybeAuthorized + , widgetToPageContent + , defaultLayoutJson -- * Defaults , defaultErrorHandler -- * Data types @@ -39,6 +39,7 @@ import Yesod.Content import Yesod.Json #endif +import Yesod.Widget import Yesod.Request import Yesod.Hamlet import Yesod.Handler @@ -46,7 +47,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import Data.Monoid (mempty) import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) @@ -55,6 +55,12 @@ import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L import Yesod.WebRoutes +import Data.Monoid +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State hiding (get) +import Text.Hamlet +import Text.Cassius +import Text.Julius #if TEST import Test.Framework (testGroup, Test) @@ -103,8 +109,10 @@ class Eq (Route a) => Yesod a where errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: PageContent (Route a) -> GHandler sub a Content - defaultLayout p = hamletToContent [$hamlet| + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + hamletToRepHtml [$hamlet| !!! %html %head @@ -226,41 +234,24 @@ breadcrumbs = do (title, next) <- breadcrumb this go ((this, title) : back) next --- | Apply the default layout ('defaultLayout') to the given title and body. -applyLayout :: Yesod master - => String -- ^ title - -> Hamlet (Route master) -- ^ head - -> Hamlet (Route master) -- ^ body - -> GHandler sub master RepHtml -applyLayout t h b = - RepHtml `fmap` defaultLayout PageContent - { pageTitle = string t - , pageHead = h - , pageBody = b - } - -- | Provide both an HTML and JSON representation for a piece of data, using -- the default layout for the HTML output ('defaultLayout'). -applyLayoutJson :: Yesod master - => String -- ^ title - -> Hamlet (Route master) -- ^ head - -> Hamlet (Route master) -- ^ body - -> Json - -> GHandler sub master RepHtmlJson -applyLayoutJson t h html json = do - html' <- defaultLayout PageContent - { pageTitle = string t - , pageHead = h - , pageBody = html - } +defaultLayoutJson :: Yesod master + => GWidget sub master () + -> Json + -> GHandler sub master RepHtmlJson +defaultLayoutJson w json = do + RepHtml html' <- defaultLayout w json' <- jsonToContent json return $ RepHtmlJson html' json' applyLayout' :: Yesod master - => String -- ^ title + => Html -- ^ title -> Hamlet (Route master) -- ^ body -> GHandler sub master ChooseRep -applyLayout' s = fmap chooseRep . applyLayout s mempty +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + addBody body -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep @@ -323,6 +314,73 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent (GWidget w) = do + w' <- flip evalStateT 0 + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT w + let ((((((((), + Body body), + Last mTitle), + scripts'), + stylesheets'), + style), + jscript), + Head head') = w' + let title = maybe mempty unTitle mTitle + let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' + let stylesheets = map (locationToHamlet . unStylesheet) + $ runUniqueList stylesheets' + let cssToHtml (Css b) = Html b + celper :: Cassius url -> Hamlet url + celper = fmap cssToHtml + jsToHtml (Javascript b) = Html b + jelper :: Julius url -> Hamlet url + jelper = fmap jsToHtml + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + cssLoc <- + case style of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "css" "text/css; charset=utf-8" + $ renderCassius render s + return $ renderLoc x + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ renderJulius render s + return $ renderLoc x + + let head'' = [$hamlet| +$forall scripts s + %script!src=^s^ +$forall stylesheets s + %link!rel=stylesheet!href=^s^ +$maybe style s + $maybe cssLoc s + %link!rel=stylesheet!href=$s$ + $nothing + %style ^celper.s^ +$maybe jscript j + $maybe jsLoc s + %script!src=$s$ + $nothing + %script ^jelper.j^ +^head'^ +|] + return $ PageContent title head'' body + #if TEST testSuite :: Test testSuite = testGroup "Yesod.Yesod"