From b460e9d4778614ddbed0827de47f7f4b56b38a92 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 24 Jan 2010 00:56:08 +0200
Subject: [PATCH] Does not reload template dir on each request

---
 Yesod/Yesod.hs             | 35 ++++++++++++++++++++++-------------
 examples/fact.lhs          |  4 ++--
 examples/hellotemplate.lhs |  2 +-
 examples/helloworld.lhs    |  2 +-
 4 files changed, 26 insertions(+), 17 deletions(-)

diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 6344bf3e..0a5e0d32 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -14,6 +14,7 @@ import Yesod.Constants
 import Yesod.Definitions
 import Yesod.Handler
 import Yesod.Utils
+import Yesod.Template (TemplateGroup)
 
 import Data.Maybe (fromMaybe)
 import Data.Convertible.Text
@@ -27,7 +28,8 @@ import Hack.Middleware.Jsonp
 import Hack.Middleware.MethodOverride
 
 class Yesod a where
-    -- | Please use the Quasi-Quoter, you\'ll be happier. FIXME more info.
+    -- | Please use the Quasi-Quoter, you\'ll be happier. For more information,
+    -- see the examples/fact.lhs sample.
     handlers :: Resource -> Verb -> Handler a RepChooser
 
     -- | The encryption key to be used for encrypting client sessions.
@@ -74,26 +76,33 @@ defaultErrorHandler (InternalError e) =
                 [ ("Internal server error", e)
                 ]
 
-toHackApp :: Yesod y => y -> Hack.Application
-toHackApp a env = do
+toHackApp :: Yesod y => y -> IO Hack.Application
+toHackApp a = do
     key <- encryptKey a
-    let app' = toHackApp' a
+    app' <- toHackApp' a
     let mins = clientSessionDuration a
-    (gzip $ cleanPath $ jsonp $ methodOverride
-          $ clientsession encryptedCookies key mins $ app') env
+    return $ gzip
+           $ cleanPath
+           $ jsonp
+           $ methodOverride
+           $ clientsession encryptedCookies key mins
+           $ app'
 
-toHackApp' :: Yesod y => y -> Hack.Application
-toHackApp' y env = do
+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
     let (Right resource) = splitPath $ Hack.pathInfo env
         types = httpAccept env
         verb = cs $ Hack.requestMethod env
         handler = handlers resource verb
         rr = cs env
-    -- 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/fact.lhs b/examples/fact.lhs
index 49a6f867..9b1e7e31 100644
--- a/examples/fact.lhs
+++ b/examples/fact.lhs
@@ -89,7 +89,7 @@ one piece of data.
 
 > factRedirect :: Handler y ()
 > factRedirect = do
->     i <- getParam "num"
+>     i <- runRequest $ getParam "num"
 >     redirect $ "../" ++ i ++ "/"
 
 The following line would be unnecesary if we had a type signature on
@@ -102,4 +102,4 @@ you could use CGI, FastCGI or a more powerful server. Just check out Hackage
 for options (any package starting hack-handler- should suffice).
 
 > main :: IO ()
-> main = putStrLn "Running..." >> run 3000 (toHackApp Fact)
+> main = putStrLn "Running..." >> toHackApp Fact >>= run 3000
diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs
index 6bb06cb3..b5ee0924 100644
--- a/examples/hellotemplate.lhs
+++ b/examples/hellotemplate.lhs
@@ -26,5 +26,5 @@ helloGroup = template "real-template" "foo" (cs "bar") $ return []
 main :: IO ()
 main = do
     putStrLn "Running..."
-    run 3000 $ toHackApp HelloWorld
+    toHackApp HelloWorld >>= run 3000
 \end{code}
diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs
index de8a90de..371e8a04 100644
--- a/examples/helloworld.lhs
+++ b/examples/helloworld.lhs
@@ -15,5 +15,5 @@ helloWorld :: Handler HelloWorld HtmlObject
 helloWorld = return $ cs "Hello world!"
 
 main :: IO ()
-main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld)
+main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000
 \end{code}