haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Integrated Hamlet

Browse Source
This commit is contained in:
Michael Snoyman 2010-04-11 23:14:35 -07:00
parent b0e5cf56e5
commit ef3e7cc538
2 changed files with 48 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
Yesod/Yesod.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE QuasiQuotes #-}
-- | The basic typeclass for a Yesod application. -- | The basic typeclass for a Yesod application.
module Yesod.Yesod module Yesod.Yesod
( Yesod (..) ( Yesod (..)
@ -23,6 +24,8 @@ import Web.Mime
import Web.Encodings (parseHttpAccept) import Web.Encodings (parseHttpAccept)
import Web.Routes (Site (..), encodePathInfo, decodePathInfo) import Web.Routes (Site (..), encodePathInfo, decodePathInfo)
import Data.List (intercalate) import Data.List (intercalate)
import Text.Hamlet hiding (Content, Html) -- FIXME do not export
import qualified Text.Hamlet as Hamlet
import qualified Network.Wai as W import qualified Network.Wai as W
import Network.Wai.Middleware.CleanPath import Network.Wai.Middleware.CleanPath
@ -41,6 +44,19 @@ class YesodSite y where
-> y -> y
-> Site (Routes y) (YesodApp y) -> Site (Routes y) (YesodApp y)
data PageContent url = PageContent
{ pageTitle :: Hamlet url IO Hamlet.Html
, pageHead :: Hamlet url IO ()
, pageBody :: Hamlet url IO ()
}
simpleContent :: String -> Hamlet.Html -> PageContent url
simpleContent title body = PageContent
{ pageTitle = return $ Unencoded $ cs title
, pageHead = return ()
, pageBody = outputHtml body
}
class YesodSite a => Yesod a where class YesodSite a => Yesod a where
-- | The encryption key to be used for encrypting client sessions. -- | The encryption key to be used for encrypting client sessions.
encryptKey :: a -> IO Word256 encryptKey :: a -> IO Word256
@ -57,11 +73,18 @@ class YesodSite a => Yesod a where
-- | Applies some form of layout to <title> and <body> contents of a page. -- | Applies some form of layout to <title> and <body> contents of a page.
applyLayout :: a applyLayout :: a
-> PageContent (Routes a)
-> Request -> Request
-> String -- ^ title -> Hamlet (Routes a) IO ()
-> Html -- ^ body applyLayout _ p _ = [$hamlet|
-> Content <!DOCTYPE html>
applyLayout _ _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc) %html
%head
%title $pageTitle$
^pageHead^
%body
^pageBody^
|] p
-- | Gets called at the beginning of each request. Useful for logging. -- | Gets called at the beginning of each request. Useful for logging.
onRequest :: a -> Request -> IO () onRequest :: a -> Request -> IO ()
@ -77,10 +100,12 @@ applyLayout' :: Yesod y
-> Html -> Html
-> Handler y ChooseRep -> Handler y ChooseRep
applyLayout' t b = do applyLayout' t b = do
let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment $ cs b
y <- getYesod y <- getYesod
rr <- getRequest rr <- getRequest
content <- hamletToContent $ applyLayout y pc rr
return $ chooseRep return $ chooseRep
[ (TypeHtml, applyLayout y rr t b) [ (TypeHtml, content)
] ]
-- | A convenience wrapper around 'applyLayout' which provides a JSON -- | A convenience wrapper around 'applyLayout' which provides a JSON
@ -90,13 +115,28 @@ applyLayoutJson :: Yesod y
-> HtmlObject -> HtmlObject
-> Handler y ChooseRep -> Handler y ChooseRep
applyLayoutJson t b = do applyLayoutJson t b = do
let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment
$ cs (cs b :: Html)
y <- getYesod y <- getYesod
rr <- getRequest rr <- getRequest
htmlcontent <- hamletToContent $ applyLayout y pc rr
return $ chooseRep return $ chooseRep
[ (TypeHtml, applyLayout y rr t $ cs b) [ (TypeHtml, htmlcontent)
, (TypeJson, cs $ unJsonDoc $ cs b) , (TypeJson, cs $ unJsonDoc $ cs b)
] ]
hamletToContent :: Hamlet (Routes y) IO () -> Handler y 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
getApproot :: Yesod y => Handler y Approot getApproot :: Yesod y => Handler y Approot
getApproot = approot `fmap` getYesod getApproot = approot `fmap` getYesod

3
yesod.cabal
View File

@ -60,7 +60,8 @@ library
failure >= 0.0.0 && < 0.1, failure >= 0.0.0 && < 0.1,
safe-failure >= 0.4.0 && < 0.5, safe-failure >= 0.4.0 && < 0.5,
web-routes >= 0.20 && < 0.21, web-routes >= 0.20 && < 0.21,
web-routes-quasi >= 0.0 && < 0.1 web-routes-quasi >= 0.0 && < 0.1,
hamlet >= 0.0 && < 0.1
exposed-modules: Yesod exposed-modules: Yesod
Yesod.Request Yesod.Request
Yesod.Response Yesod.Response