From 31fffcf5d4ca5d7c335df5950042aa9a9bb1d4b6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 6 Jun 2010 01:53:55 +0300 Subject: [PATCH] Migration to hamlet 3 --- Yesod/Hamlet.hs | 26 +++++-------- Yesod/Handler.hs | 4 +- Yesod/Helpers/AtomFeed.hs | 4 +- Yesod/Helpers/Auth.hs | 16 ++++---- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Json.hs | 81 ++++++++++++++++++--------------------- Yesod/Yesod.hs | 15 ++++---- yesod.cabal | 4 +- 8 files changed, 70 insertions(+), 82 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e5f28bf4..34222a33 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -8,7 +8,7 @@ module Yesod.Hamlet Hamlet , hamlet , HtmlContent (..) - , htmlContentToText + , htmlContentToByteString -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -18,7 +18,8 @@ module Yesod.Hamlet where import Text.Hamlet -import Text.Hamlet.Monad (outputHtml, htmlContentToText) +import Text.Hamlet.Monad ( outputHtml, hamletToByteString + , htmlContentToByteString) import Yesod.Content import Yesod.Handler import Data.Convertible.Text @@ -27,32 +28,25 @@ import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- --- > PageContent url -> Hamlet url IO () +-- > PageContent url -> Hamlet url data PageContent url = PageContent { pageTitle :: HtmlContent - , pageHead :: Hamlet url IO () - , pageBody :: Hamlet url IO () + , pageHead :: Hamlet url + , pageBody :: Hamlet url } -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content +hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender - return $ ContentEnum $ go render - where - go render iter seed = do - res <- runHamlet h render seed $ iter' iter - case res of - Left x -> return $ Left x - Right ((), x) -> return $ Right x - iter' iter seed text = iter seed $ cs text + return $ toContent $ hamletToByteString render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml +hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent -instance Monad m => ConvertSuccess String (Hamlet url m ()) where +instance ConvertSuccess String (Hamlet url) where convertSuccess = outputHtml . Unencoded . cs instance ConvertSuccess String HtmlContent where convertSuccess = Unencoded . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 559ecb77..f4c8a0db 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -70,7 +70,7 @@ import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) -import Text.Hamlet.Monad (htmlContentToText) +import Text.Hamlet.Monad (htmlContentToByteString) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -331,7 +331,7 @@ msgKey = "_MSG" -- -- See 'getMessage'. setMessage :: HtmlContent -> GHandler sub master () -setMessage = setSession msgKey . cs . htmlContentToText +setMessage = setSession msgKey . cs . htmlContentToByteString -- | Gets the message in the user's session, if available, and then clears the -- variable. diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index ded93117..85cd0bbc 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -52,7 +52,7 @@ data AtomFeedEntry url = AtomFeedEntry xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" -template :: AtomFeed url -> Hamlet url IO () +template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| %feed!xmlns=$xmlns.arg$ @@ -65,7 +65,7 @@ template arg = [$xhamlet| ^entryTemplate.entry^ |] -entryTemplate :: AtomFeedEntry url -> Hamlet url IO () +entryTemplate :: AtomFeedEntry url -> Hamlet url entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 39c3371c..0cef2369 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,6 +49,7 @@ import Control.Applicative import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt +import Data.Monoid (mempty) class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other @@ -165,7 +166,7 @@ getOpenIdR = do (x:_) -> setUltDestString x rtom <- getRouteToMaster message <- getMessage - applyLayout "Log in via OpenID" (return ()) [$hamlet| + applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@ @@ -247,8 +248,7 @@ getDisplayName extra = getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do creds <- maybeCreds - applyLayoutJson "Authentication Status" - (return ()) (html creds) (json creds) + applyLayoutJson "Authentication Status" mempty (html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status @@ -289,7 +289,7 @@ getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster - applyLayout "Register a new account" (return ()) [$hamlet| + applyLayout "Register a new account" mempty [$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 @@ -314,7 +314,7 @@ postEmailRegisterR = do tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl - applyLayout "Confirmation e-mail sent" (return ()) [$hamlet| + applyLayout "Confirmation e-mail sent" mempty [$hamlet| %p A confirmation e-mail has been sent to $cs.email$. |] @@ -333,7 +333,7 @@ getEmailVerifyR lid key = do setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> applyLayout "Invalid verification key" (return ()) [$hamlet| + _ -> applyLayout "Invalid verification key" mempty [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -342,7 +342,7 @@ getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster msg <- getMessage - applyLayout "Login" (return ()) [$hamlet| + applyLayout "Login" mempty [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account. @@ -396,7 +396,7 @@ getEmailPasswordR = do setMessage $ cs "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage - applyLayout "Set password" (return ()) [$hamlet| + applyLayout "Set password" mempty [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 443209b3..077d038b 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -53,7 +53,7 @@ data SitemapUrl url = SitemapUrl sitemapNS :: HtmlContent sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" -template :: [SitemapUrl url] -> Hamlet url IO () +template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet| %urlset!xmlns=$sitemapNS$ $forall urls url diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 80bbebcd..4f63fd28 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -9,9 +9,7 @@ module Yesod.Json -- * Generate Json output , jsonScalar , jsonList - , jsonList' , jsonMap - , jsonMap' #if TEST , testSuite #endif @@ -19,15 +17,14 @@ module Yesod.Json where import Text.Hamlet.Monad -import Control.Applicative -import Data.Text (pack) -import qualified Data.Text as T +import qualified Data.ByteString.Char8 as S8 import Data.Char (isControl) import Yesod.Hamlet -import Control.Monad (when) import Yesod.Handler import Web.Routes.Quasi (Routes) import Numeric (showHex) +import Data.Monoid (Monoid (..)) +import Data.Convertible.Text (cs) #if TEST import Test.Framework (testGroup, Test) @@ -46,17 +43,17 @@ import Yesod.Content -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json url a = Json { unJson :: Hamlet url IO a } - deriving (Functor, Applicative, Monad) +newtype Json url = Json { unJson :: Hamlet url } + deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json (Routes master) () -> GHandler sub master Content +jsonToContent :: Json (Routes master) -> GHandler sub master Content jsonToContent = hamletToContent . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson +jsonToRepJson :: Json (Routes master) -> GHandler sub master RepJson jsonToRepJson = fmap RepJson . jsonToContent -- | Outputs a single scalar. This function essentially: @@ -66,13 +63,14 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: HtmlContent -> Json url () -jsonScalar s = Json $ do - outputString "\"" - output $ encodeJson $ htmlContentToText s - outputString "\"" +jsonScalar :: HtmlContent -> Json url +jsonScalar s = Json $ mconcat + [ outputString "\"" + , output $ encodeJson $ htmlContentToByteString s + , outputString "\"" + ] where - encodeJson = T.concatMap (T.pack . encodeJsonChar) + encodeJson = S8.concatMap (S8.pack . encodeJsonChar) encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f" @@ -90,38 +88,33 @@ jsonScalar s = Json $ do encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json url ()] -> Json url () -jsonList = jsonList' . fromList - --- | Same as 'jsonList', but uses an 'Enumerator' for input. -jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -jsonList' (Enumerator enum) = do - Json $ outputString "[" - _ <- enum go False - Json $ outputString "]" +jsonList :: [Json url] -> Json url +jsonList [] = Json $ outputOctets "[]" +jsonList (x:xs) = mconcat + [ Json $ outputOctets "[" + , x + , mconcat $ map go xs + , Json $ outputOctets "]" + ] where - go putComma j = do - when putComma $ Json $ outputString "," - () <- j - return $ Right True + go j = mappend (Json $ outputOctets ",") j -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json url ())] -> Json url () -jsonMap = jsonMap' . fromList - --- | Same as 'jsonMap', but uses an 'Enumerator' for input. -jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () -jsonMap' (Enumerator enum) = do - Json $ outputString "{" - _ <- enum go False - Json $ outputString "}" +jsonMap :: [(String, Json url)] -> Json url +jsonMap [] = Json $ outputOctets "{}" +jsonMap (x:xs) = mconcat + [ Json $ outputOctets "{" + , go x + , mconcat $ map go' xs + , Json $ outputOctets "}" + ] where - go putComma (k, v) = do - when putComma $ Json $ outputString "," - jsonScalar $ Unencoded $ pack k - Json $ outputString ":" - () <- v - return $ Right True + go' y = mappend (Json $ outputOctets ",") $ go y + go (k, v) = mconcat + [ jsonScalar $ Unencoded $ cs k + , Json $ outputOctets ":" + , v + ] #if TEST diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8cff093..be3679ee 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -21,6 +21,7 @@ import qualified Network.Wai as W import Yesod.Json import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile, Key) +import Data.Monoid (mempty) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -93,8 +94,8 @@ class Yesod a where -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ head - -> Hamlet (Routes master) IO () -- ^ body + -> Hamlet (Routes master) -- ^ head + -> Hamlet (Routes master) -- ^ body -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent @@ -107,9 +108,9 @@ applyLayout t h b = -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ head - -> Hamlet (Routes master) IO () -- ^ body - -> Json (Routes master) () + -> Hamlet (Routes master) -- ^ head + -> Hamlet (Routes master) -- ^ body + -> Json (Routes master) -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do html' <- defaultLayout PageContent @@ -122,9 +123,9 @@ applyLayoutJson t h html json = do applyLayout' :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ body + -> Hamlet (Routes master) -- ^ body -> GHandler sub master ChooseRep -applyLayout' s = fmap chooseRep . applyLayout s (return ()) +applyLayout' s = fmap chooseRep . applyLayout s mempty -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y diff --git a/yesod.cabal b/yesod.cabal index 3d4d0e34..493ae705 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -42,7 +42,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.3 && < 0.4, - hamlet >= 0.2.2 && < 0.3, + hamlet >= 0.3.0 && < 0.4, transformers >= 0.1 && < 0.3, clientsession >= 0.4.0 && < 0.5, MonadCatchIO-transformers >= 0.1 && < 0.3,