diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index c8424fbb..8e7908b1 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -4,7 +4,6 @@ module Test.QuasiResource (testSuite) where import Yesod -import Text.StringTemplate (nullGroup) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) @@ -67,7 +66,7 @@ ph ss h = do rr = error "No raw request" y = MyYesod cts = [TypeHtml] - res <- runHandler h eh rr y nullGroup cts + res <- runHandler h eh rr y cts res' <- myShow res mapM_ (helper res') ss where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6078e2c1..46ad998f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -38,7 +38,6 @@ module Yesod.Handler import Yesod.Request import Yesod.Response -import Yesod.Template import Web.Mime import Control.Exception hiding (Handler) @@ -52,9 +51,11 @@ import System.IO import Data.Object.Html import qualified Data.ByteString.Lazy as BL +data HandlerData yesod = HandlerData RawRequest yesod + ------ Handler monad newtype Handler yesod a = Handler { - unHandler :: (RawRequest, yesod, TemplateGroup) + unHandler :: HandlerData yesod -> IO ([Header], HandlerContents a) } data HandlerContents a = @@ -83,32 +84,29 @@ instance MonadIO (Handler yesod) where instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e) instance RequestReader (Handler yesod) where - getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) + getRawRequest = Handler $ \(HandlerData rr _) + -> return ([], HCContent rr) invalidParams = invalidArgs . map helper where helper ((_pt, pn, _pvs), e) = (pn, show e) getYesod :: Handler yesod yesod -getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) - -instance HasTemplateGroup (Handler yesod) where - getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) +getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod) runHandler :: Handler yesod ChooseRep -> (ErrorResponse -> Handler yesod ChooseRep) -> RawRequest -> yesod - -> TemplateGroup -> [ContentType] -> IO Response -runHandler (Handler handler) eh rr y tg cts = do +runHandler handler eh rr y cts = do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (handler (rr, y, tg)) + (unHandler handler $ HandlerData rr y) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts + Response _ hs ct c <- runHandler (eh e) safeEh rr y cts let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c let sendFile' ct fp = do diff --git a/Yesod/Template.hs b/Yesod/Template.hs index a13db2fa..e52c8dfb 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -1,71 +1,59 @@ --- FIXME this whole module needs to be rethought {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Template - ( HasTemplateGroup (..) + ( YesodTemplate (..) , template , NoSuchTemplate + , Template , TemplateGroup - , Template (..) - , TemplateFile (..) ) where import Data.Object.Html import Data.Typeable (Typeable) import Control.Exception (Exception) -import Control.Failure import Data.Object.Text (Text) import Text.StringTemplate import Data.Object.Json import Web.Mime import Yesod.Response +import Yesod.Yesod +import Yesod.Handler +import Control.Monad (foldM) +import Data.ByteString.Lazy (toChunks) +type Template = StringTemplate Text type TemplateGroup = STGroup Text -class HasTemplateGroup a where - getTemplateGroup :: a TemplateGroup +class Yesod y => YesodTemplate y where + getTemplateGroup :: y -> TemplateGroup -template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) +getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup +getTemplateGroup' = getTemplateGroup `fmap` getYesod + +template :: YesodTemplate y => String -- ^ template name - -> String -- ^ object name -> HtmlObject -- ^ object - -> IO [(String, HtmlObject)] -- ^ template attributes - -> t Template -template tn on o attrs = do - tg <- getTemplateGroup + -> (HtmlObject -> Template -> IO Template) + -> Handler y ChooseRep +template tn ho f = do + tg <- getTemplateGroup' t <- case getStringTemplate tn tg of Nothing -> failure $ NoSuchTemplate tn Just x -> return x - return $ Template t on o attrs + return $ chooseRep + [ (TypeJson, cs $ unJsonDoc $ cs ho) + , (TypeHtml, tempToContent t ho f) + ] newtype NoSuchTemplate = NoSuchTemplate String deriving (Show, Typeable) instance Exception NoSuchTemplate -data Template = Template (StringTemplate Text) - String - HtmlObject - (IO [(String, HtmlObject)]) -instance HasReps Template where - chooseRep = defChooseRep [ (TypeHtml, - \(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) - ] +tempToContent :: Template + -> HtmlObject + -> (HtmlObject -> Template -> IO Template) + -> Content +tempToContent t ho f = ioTextToContent $ fmap render $ f ho t -data TemplateFile = TemplateFile FilePath HtmlObject -instance HasReps TemplateFile where - chooseRep = defChooseRep [ (TypeHtml, - \(TemplateFile fp h) -> do - contents <- readFile fp - let t = newSTMP contents - return $ cs $ toString $ setAttribute "o" h t - ) - , (TypeJson, \(TemplateFile _ ho) -> - return $ cs $ unJsonDoc $ cs ho) - ] +ioTextToContent :: IO Text -> Content +ioTextToContent iotext = Content $ \f a -> iotext >>= \t -> + foldM f a $ toChunks $ cs t diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index da6ae794..9c8c9713 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -14,10 +14,8 @@ import Yesod.Response import Yesod.Request import Yesod.Definitions import Yesod.Handler -import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) -import Text.StringTemplate import Web.Mime import Web.Encodings (parseHttpAccept) @@ -46,10 +44,6 @@ class Yesod a where errorHandler :: ErrorResponse -> Handler a ChooseRep errorHandler = defaultErrorHandler - -- | The template directory. Blank means no templates. - templateDir :: a -> FilePath - templateDir _ = "" - -- | Applies some form of layout to and <body> contents of a page. applyLayout :: a -> String -- ^ title @@ -109,7 +103,7 @@ defaultErrorHandler (InternalError e) = toHackApp :: Yesod y => y -> IO Hack.Application toHackApp a = do key <- encryptKey a - app' <- toHackApp' a + let app' = toHackApp' a let mins = clientSessionDuration a return $ gzip $ cleanPath @@ -118,22 +112,14 @@ toHackApp a = do $ clientsession encryptedCookies key mins $ app' -toHackApp' :: Yesod y => y -> IO Hack.Application -toHackApp' y = do - let td = templateDir y - tg <- if null td - then return nullGroup - else directoryGroupRecursiveLazy td - return $ toHackApp'' y tg - -toHackApp'' :: Yesod y => y -> TemplateGroup -> Hack.Env -> IO Hack.Response -toHackApp'' y tg env = do +toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response +toHackApp' y env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - res <- runHandler handler errorHandler rr y tg types + res <- runHandler handler errorHandler rr y types responseToHackResponse res httpAccept :: Hack.Env -> [ContentType]