templateHtml and templateHtmlJson

Yesod/Response.hs

@@ -25,8 +25,13 @@ module Yesod.Response
     , HasReps (..)
     , defChooseRep
     , ioTextToContent
+    , hoToJsonContent
       -- ** Convenience wrappers
     , staticRep
+      -- ** Specific content types
+    , RepHtml (..)
+    , RepJson (..)
+    , RepHtmlJson (..)
       -- * Response type
     , Response (..)
       -- * Special responses
@@ -98,6 +103,9 @@ type ChooseRep = [ContentType] -> IO (ContentType, Content)
 ioTextToContent :: IO Text -> Content
 ioTextToContent t = ContentEnum $ WE.fromLBS' $ fmap DTLE.encodeUtf8 t
 
+hoToJsonContent :: HtmlObject -> Content
+hoToJsonContent = cs . unJsonDoc . cs
+
 -- | Any type which can be converted to representations.
 class HasReps a where
     chooseRep :: a -> ChooseRep
@@ -146,6 +154,19 @@ staticRep :: ConvertSuccess x Content
           -> [(ContentType, Content)]
 staticRep ct x = [(ct, cs x)]
 
+newtype RepHtml = RepHtml Content
+instance HasReps RepHtml where
+    chooseRep (RepHtml c) _ = return (TypeHtml, c)
+newtype RepJson = RepJson Content
+instance HasReps RepJson where
+    chooseRep (RepJson c) _ = return (TypeJson, c)
+data RepHtmlJson = RepHtmlJson Content Content
+instance HasReps RepHtmlJson where
+    chooseRep (RepHtmlJson html json) = chooseRep
+        [ (TypeHtml, html)
+        , (TypeJson, json)
+        ]
+
 data Response = Response W.Status [Header] ContentType Content
 
 -- | Different types of redirects.

Yesod/Template.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 module Yesod.Template
     ( YesodTemplate (..)
-    , template
     , NoSuchTemplate
     , Template
     , TemplateGroup
-    , TemplateFile (..)
-    , setAttribute
     , loadTemplateGroup
+      -- * HTML templates
+    , HtmlTemplate (..)
+    , templateHtml
+    , templateHtmlJson
+    , setHtmlAttrib
     ) where
 
 import Data.Object.Html
@@ -16,8 +18,6 @@ import Data.Typeable (Typeable)
 import Control.Exception (Exception)
 import Data.Object.Text (Text)
 import Text.StringTemplate
-import Data.Object.Json
-import Web.Mime
 import Yesod.Response
 import Yesod.Yesod
 import Yesod.Handler
@@ -27,41 +27,52 @@ type TemplateGroup = STGroup Text
 
 class Yesod y => YesodTemplate y where
     getTemplateGroup :: y -> TemplateGroup
+    -- FIXME defaultTemplateAttribs :: y -> HtmlTemplate -> Handler y HtmlTemplate
 
 getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup
 getTemplateGroup' = getTemplateGroup `fmap` getYesod
 
-template :: YesodTemplate y
-         => String -- ^ template name
-         -> HtmlObject -- ^ object
-         -> (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 $ chooseRep
-        [ (TypeHtml, tempToContent t ho f)
-        , (TypeJson, cs $ unJsonDoc $ cs ho)
-        ]
 newtype NoSuchTemplate = NoSuchTemplate String
     deriving (Show, Typeable)
 instance Exception NoSuchTemplate
 
-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 (TemplateFile fp (Mapping m)) _ = do
-        t <- fmap newSTMP $ readFile fp
-        let t' = setManyAttrib m t :: Template
-        return (TypeHtml, cs $ render t')
-    chooseRep _ _ = error "Please fix type of TemplateFile"
-
 loadTemplateGroup :: FilePath -> IO TemplateGroup
 loadTemplateGroup = directoryGroupRecursiveLazy
+
+type TemplateName = String
+newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template }
+
+-- | Return a result using a template generating HTML alone.
+templateHtml :: YesodTemplate y
+             => TemplateName
+             -> (HtmlTemplate -> IO HtmlTemplate)
+             -> Handler y RepHtml
+templateHtml tn f = do
+    tg <- getTemplateGroup'
+    t <- case getStringTemplate tn tg of
+            Nothing -> failure $ NoSuchTemplate tn
+            Just x -> return x
+    return $ RepHtml $ ioTextToContent $ fmap (render . unHtmlTemplate)
+                     $ f $ HtmlTemplate t
+
+setHtmlAttrib :: ConvertSuccess x HtmlObject
+              => String -> x -> HtmlTemplate -> HtmlTemplate
+setHtmlAttrib k v (HtmlTemplate t) =
+    HtmlTemplate $ setAttribute k (toHtmlObject v) t
+
+-- | Return a result using a template and 'HtmlObject' generating either HTML
+-- or JSON output.
+templateHtmlJson :: YesodTemplate y
+                 => TemplateName
+                 -> HtmlObject
+                 -> (HtmlObject -> HtmlTemplate -> IO HtmlTemplate)
+                 -> Handler y RepHtmlJson
+templateHtmlJson tn ho f = do
+    tg <- getTemplateGroup'
+    t <- case getStringTemplate tn tg of
+            Nothing -> failure $ NoSuchTemplate tn
+            Just x -> return x
+    return $ RepHtmlJson
+            (ioTextToContent $ fmap (render . unHtmlTemplate)
+                     $ f ho $ HtmlTemplate t)
+            (hoToJsonContent ho)

examples/fact.lhs

@@ -7,13 +7,13 @@ signatures.
 > {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
 There are only two imports: Yesod includes all of the code we need for creating
-a web application, while Hack.Handler.SimpleServer allows us to test our
-application easily. A Yesod app can in general run on any Hack handler, so this
+a web application, while Network.Wai.Handler.SimpleServer allows us to test our
+application easily. A Yesod app can in general run on any WAI handler, so this
 application is easily convertible to CGI, FastCGI, or even run on the Happstack
 server.
 
 > import Yesod
-> import Hack.Handler.SimpleServer
+> import Network.Wai.Handler.SimpleServer
 
 The easiest way to start writing a Yesod app is to follow the Yesod typeclass.
 You define some data type which will contain all the specific settings and data
@@ -100,9 +100,9 @@ factRedirect.
 
 >     return ()
 
-You could replace this main to use any Hack handler you want. For production,
+You could replace this main to use any WAI handler you want. For production,
 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..." >> toHackApp Fact >>= run 3000
+> main = putStrLn "Running..." >> toWaiApp Fact >>= run 3000

examples/hellotemplate.lhs

@@ -2,7 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 import Yesod
-import Hack.Handler.SimpleServer
+import Network.Wai.Handler.SimpleServer
 
 data HelloWorld = HelloWorld TemplateGroup
 instance YesodTemplate HelloWorld where
@@ -15,18 +15,17 @@ instance Yesod HelloWorld where
     Get: helloGroup
 |]
 
-helloWorld :: Handler HelloWorld TemplateFile
-helloWorld = return $ TemplateFile "examples/template.html" $ cs
-                [ ("title", "Hello world!")
-                , ("content", "Hey look!! I'm <auto escaped>!")
-                ]
+helloWorld :: Handler HelloWorld RepHtml
+helloWorld = templateHtml "template" $ return
+  . setHtmlAttrib "title" "Hello world!"
+  . setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!"
 
-helloGroup :: YesodTemplate y => Handler y ChooseRep
-helloGroup = template "real-template" (cs "bar") $ \ho ->
-    return . setAttribute "foo" ho
+helloGroup :: YesodTemplate y => Handler y RepHtmlJson
+helloGroup = templateHtmlJson "real-template" (cs "bar") $ \ho ->
+    return . setHtmlAttrib "foo" ho
 
 main :: IO ()
 main = do
     putStrLn "Running..."
-    loadTemplateGroup "examples" >>= toHackApp . HelloWorld >>= run 3000
+    loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000
 \end{code}

examples/helloworld.lhs

@@ -2,7 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 import Yesod
-import Hack.Handler.SimpleServer
+import Network.Wai.Handler.SimpleServer
 
 data HelloWorld = HelloWorld
 instance Yesod HelloWorld where
@@ -15,5 +15,5 @@ helloWorld :: Handler HelloWorld ChooseRep
 helloWorld = applyLayout' "Hello World" $ cs "Hello world!"
 
 main :: IO ()
-main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000
+main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000
 \end{code}

examples/template.st

@@ -2,7 +2,7 @@
 <html>
   <head>
     <meta charset="utf-8">
-    <title>$o.title$</title>
+    <title>$title$</title>
     <style>
       body {
         background-color: #ffc;
@@ -20,7 +20,7 @@
   </head>
   <body>
     <div id="wrapper">
-      $o.content$
+      $content$
     </div>
   </body>
 </html>

yesod.cabal

@@ -4,7 +4,7 @@ license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
 maintainer:      Michael Snoyman <michael@snoyman.com>
-synopsis:        A Restful front controller built on Hack.
+synopsis:        A library for creating RESTful web applications.
 description:     This package stradles the line between framework and simply a controller. It provides minimal support for model and view, mostly focusing on making a controller which adheres strictly to RESTful principles.
 category:        Web
 stability:       unstable
@@ -17,7 +17,7 @@ flag buildtests
   default: False
 
 flag buildsamples
-  description: Build the executable to run unit tests
+  description: Build the executable sample applications.
   default: False
 
 flag nolib
@@ -85,21 +85,12 @@ executable             runtests
     ghc-options:     -Wall
     main-is:         runtests.hs
 
-executable             quasi-test
-  if flag(buildsamples)
-    Buildable: True
-  else
-    Buildable: False
-  ghc-options:         -Wall
-  main-is:             test/quasi-resource.hs
-
 executable             helloworld
   if flag(buildsamples)
     Buildable: True
   else
     Buildable: False
   ghc-options:         -Wall
-  build-depends:       hack-handler-simpleserver >= 0.2.0 && < 0.3
   main-is:             examples/helloworld.lhs
 
 executable             hellotemplate