diff --git a/Yesod/Response.hs b/Yesod/Response.hs index a6b86c51..90530cfa 100644 --- a/Yesod/Response.hs +++ b/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. diff --git a/Yesod/Template.hs b/Yesod/Template.hs index ee5f910e..afb9fd48 100644 --- a/Yesod/Template.hs +++ b/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) diff --git a/examples/fact.lhs b/examples/fact.lhs index 7debce47..05a7b089 100644 --- a/examples/fact.lhs +++ b/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 diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index f03bcf4a..7e0d7f45 100644 --- a/examples/hellotemplate.lhs +++ b/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 !") - ] +helloWorld :: Handler HelloWorld RepHtml +helloWorld = templateHtml "template" $ return + . setHtmlAttrib "title" "Hello world!" + . setHtmlAttrib "content" "Hey look!! I'm !" -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} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index 1fbd6f73..a676612a 100644 --- a/examples/helloworld.lhs +++ b/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} diff --git a/examples/template.html b/examples/template.st similarity index 89% rename from examples/template.html rename to examples/template.st index 8d1b393d..f71953cf 100644 --- a/examples/template.html +++ b/examples/template.st @@ -2,7 +2,7 @@ - $o.title$ + $title$