From 911934bff0bbbcd897d3d4949b5147a1b809d445 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 29 Dec 2009 23:07:38 +0200 Subject: [PATCH] Basic implementation of template groups --- Data/Object/Html.hs | 2 +- TODO | 4 +--- Yesod.hs | 4 ++-- Yesod/Handler.hs | 20 ++++++++++++-------- Yesod/Rep.hs | 20 ++++++++++++++------ Yesod/Resource.hs | 3 +-- Yesod/Template.hs | 38 ++++++++++++++++++++++++++++++++++++++ Yesod/Yesod.hs | 12 +++++++++++- examples/hellotemplate.lhs | 11 ++++------- examples/real-template.st | 1 + test/quasi-resource.hs | 3 ++- yesod.cabal | 5 +++-- 12 files changed, 90 insertions(+), 33 deletions(-) create mode 100644 Yesod/Template.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 7fa1e602..8ed6ff77 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -186,7 +186,7 @@ instance ToSElem HtmlObject where #if TEST caseHtmlToText :: Assertion caseHtmlToText = do - let actual = Tag "div" [("id", "foo"), ("class", "bar")] + let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList [ Html $ cs "
Some HTML
" , Text $ cs "<'this should be escaped'>" , EmptyTag "img" [("src", "baz&")] diff --git a/TODO b/TODO index adda8355..e2c54485 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,4 @@ -Cleanup Data.Object.Translate +Some form of i18n. Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). -Native support for HStringTemplate groups. -Use Text for HStringTemplate throughout diff --git a/Yesod.hs b/Yesod.hs index 5e98a749..8f8fa700 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,7 +21,7 @@ module Yesod , module Yesod.Resource , module Data.Object.Html , module Yesod.Rep - , module Yesod.Templates + , module Yesod.Template , module Data.Convertible.Text , Application ) where @@ -34,6 +34,6 @@ import Yesod.Handler import Yesod.Resource import Hack (Application) import Yesod.Rep -import Yesod.Templates +import Yesod.Template import Data.Object.Html import Data.Convertible.Text diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2ba325a6..882e3cb1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -38,6 +38,7 @@ module Yesod.Handler import Yesod.Request import Yesod.Response import Yesod.Rep +import Yesod.Template import Control.Exception hiding (Handler) import Control.Applicative @@ -49,11 +50,10 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html ---import Data.Typeable - ------ Handler monad newtype Handler yesod a = Handler { - unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a) + unHandler :: (RawRequest, yesod, TemplateGroup) + -> IO ([Header], HandlerContents a) } data HandlerContents a = forall e. Exception e => HCError e @@ -81,22 +81,26 @@ instance MonadIO (Handler yesod) where instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance MonadRequestReader (Handler yesod) where - askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr) + askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) invalidParam _pt pn pe = invalidArgs [(pn, pe)] authRequired = permissionDenied getYesod :: Handler yesod yesod -getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) +getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) + +instance HasTemplateGroup (Handler yesod) where + getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) runHandler :: Handler yesod RepChooser -> (ErrorResult -> Handler yesod RepChooser) -> RawRequest -> yesod + -> TemplateGroup -> [ContentType] -> IO Response -runHandler (Handler handler) eh rr y cts = do +runHandler (Handler handler) eh rr y tg cts = do (headers, contents) <- Control.Exception.catch - (handler (rr, y)) + (handler (rr, y, tg)) (\e -> return ([], HCError (e :: Control.Exception.SomeException))) let contents' = case contents of @@ -105,7 +109,7 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - Response _ hs ct c <- runHandler (eh e) specialEh rr y cts + Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c Right a -> do diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 84e42f6b..1b95523d 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -47,7 +47,6 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL import Data.Maybe (mapMaybe) import Data.Function (on) @@ -162,15 +161,24 @@ instance HasReps Plain where plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs -data Template = Template (StringTemplate Text) HtmlObject +data Template = Template (StringTemplate Text) + String + HtmlObject + (IO [(String, HtmlObject)]) instance HasReps Template where reps = [ (TypeHtml, - \(Template t h) -> - return $ cs $ render $ setAttribute "o" h t) - , (TypeJson, \(Template _ ho) -> + \(Template t name ho attrsIO) -> do + attrs <- attrsIO + return + $ cs + $ render + $ setAttribute name ho + $ setManyAttrib attrs t) + , (TypeJson, \(Template _ _ ho _) -> return $ cs $ unJsonDoc $ cs ho) ] +-- FIXME data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where reps = [ (TypeHtml, @@ -231,7 +239,7 @@ caseChooseRepTemplate = do ho = toHtmlObject [ ("foo", toHtmlObject "") , ("bar", toHtmlObject ["bar1", "bar2"]) ] - hasreps = Template temp ho + hasreps = Template temp "o" ho $ return [] res1 = cs "foo:<fooval>, bar:bar1bar2" res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ "\"foo\":\"<fooval>\"}" diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 8e6e5f7c..81a5cf31 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -43,7 +43,7 @@ import Language.Haskell.TH.Ppr import System.IO -} -import Data.Typeable (Typeable) +import Data.Typeable import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Object.Text @@ -62,7 +62,6 @@ import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck import Control.Monad (when) -import Data.Typeable #endif resources :: QuasiQuoter diff --git a/Yesod/Template.hs b/Yesod/Template.hs new file mode 100644 index 00000000..84431566 --- /dev/null +++ b/Yesod/Template.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Template + ( HasTemplateGroup (..) + , template + , NoSuchTemplate + , TemplateGroup + ) where + +import Data.Object.Html +import Data.Typeable (Typeable) +import Control.Exception (Exception) +import Control.Failure +import Yesod.Rep +import Data.Object.Text (Text) +import Text.StringTemplate + +type TemplateGroup = STGroup Text + +class HasTemplateGroup a where + getTemplateGroup :: a TemplateGroup + +-- FIXME better home +template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) + => String -- ^ template name + -> String -- ^ object name + -> HtmlObject -- ^ object + -> IO [(String, HtmlObject)] -- ^ template attributes + -> t Template +template tn on o attrs = do + tg <- getTemplateGroup + t <- case getStringTemplate tn tg of + Nothing -> failure $ NoSuchTemplate tn + Just x -> return x + return $ Template t on o attrs +newtype NoSuchTemplate = NoSuchTemplate String + deriving (Show, Typeable) +instance Exception NoSuchTemplate diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 83ae306f..294fb6db 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -16,6 +16,7 @@ import Yesod.Utils import Data.Maybe (fromMaybe) import Data.Convertible.Text +import Text.StringTemplate import qualified Hack import Hack.Middleware.CleanPath @@ -41,6 +42,10 @@ class Yesod a where errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler + -- | The template directory. Blank means no templates. + templateDir :: a -> FilePath + templateDir _ = "" + class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot @@ -80,7 +85,12 @@ toHackApp' y env = do verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - res <- runHandler handler errorHandler rr y types + -- FIXME don't do the templateDir thing for each request + let td = templateDir y + tg <- if null td + then return nullGroup + else directoryGroupRecursiveLazy td + res <- runHandler handler errorHandler rr y tg types let langs = ["en"] -- FIXME responseToHackResponse langs res diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index eed35ddd..69aa4a87 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -4,7 +4,7 @@ import Yesod import Hack.Handler.SimpleServer -data HelloWorld = HelloWorld TemplateGroup +data HelloWorld = HelloWorld instance Yesod HelloWorld where handlers = [$resources| /: @@ -12,9 +12,7 @@ instance Yesod HelloWorld where /groups: Get: helloGroup |] - -instance YesodTemplates HelloWorld where - templates (HelloWorld g) = g + templateDir _ = "examples" helloWorld :: Handler HelloWorld TemplateFile helloWorld = return $ TemplateFile "examples/template.html" $ cs @@ -22,11 +20,10 @@ helloWorld = return $ TemplateFile "examples/template.html" $ cs , ("content", "Hey look!! I'm !") ] -helloGroup = template "real-template" $ cs "foo" +helloGroup = template "real-template" "foo" (cs "bar") $ return [] main :: IO () main = do putStrLn "Running..." - stg <- loadTemplates "examples" - run 3000 (toHackApp $ HelloWorld stg) + run 3000 $ toHackApp HelloWorld \end{code} diff --git a/examples/real-template.st b/examples/real-template.st index 4348e29e..5adaa77d 100644 --- a/examples/real-template.st +++ b/examples/real-template.st @@ -1 +1,2 @@ This is a more realistic template. +foo: $foo$ diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index c0f03e3a..03c0b88c 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod +import Text.StringTemplate (nullGroup) data MyYesod = MyYesod @@ -54,7 +55,7 @@ ph h = do rr = error "No raw request" y = MyYesod cts = [TypeHtml] - res <- runHandler h eh rr y cts + res <- runHandler h eh rr y nullGroup cts print res main :: IO () diff --git a/yesod.cabal b/yesod.cabal index 05820d8e..d0d71895 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -51,7 +51,8 @@ library HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, - template-haskell + template-haskell, + failure >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Constants Yesod.Rep @@ -62,7 +63,7 @@ library Yesod.Handler Yesod.Resource Yesod.Yesod - Yesod.Templates + Yesod.Template Data.Object.Html Hack.Middleware.MethodOverride Hack.Middleware.ClientSession