From 12437533b68b303601c67c20bdf3a8a60bb6ea3c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 23:41:20 +0200 Subject: [PATCH] TemplateFile rep --- Yesod/Handler.hs | 6 ++-- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Rep.hs | 73 ++++++++++++++++++++++++++++----------- test/rep.st | 1 + 5 files changed, 58 insertions(+), 26 deletions(-) create mode 100644 test/rep.st diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d801a5b..50d2ff16 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -100,9 +100,9 @@ runHandler (Handler handler) eh rr y cts = do Left e -> do Response _ hs ct c <- runHandler (eh e) eh rr y cts return $ Response (getStatus e) hs ct c - Right a -> - let (ct, c) = a cts - in return $ Response 200 headers ct c + Right a -> do + (ct, c) <- a cts + return $ Response 200 headers ct c {- FIXME class ToHandler a where toHandler :: a -> Handler diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 9a4ffaba..1305d4ec 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -34,7 +34,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps = - [ (TypeAtom, cs . show) + [ (TypeAtom, return . cs . show) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 797bd9b6..b6b6d337 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -84,7 +84,7 @@ instance Show SitemapResponse where -- FIXME very ugly, use Text instead instance HasReps SitemapResponse where reps = - [ (TypeXml, cs . show) + [ (TypeXml, return . cs . show) ] sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index ceb64c65..ae5e4998 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -36,6 +36,7 @@ module Yesod.Rep , Plain (..) , plain , Template (..) + , TemplateFile (..) #if TEST , testSuite #endif @@ -105,21 +106,22 @@ instance ConvertSuccess String Content where convertSuccess = Content . cs type ContentPair = (ContentType, Content) -type RepChooser = [ContentType] -> ContentPair +type RepChooser = [ContentType] -> IO ContentPair -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: [(ContentType, a -> Content)] + reps :: [(ContentType, a -> IO Content)] chooseRep :: a -> RepChooser - chooseRep a ts = + chooseRep a ts = do let (ct, c) = case catMaybes $ map helper ts of (x:_) -> x [] -> case reps of [] -> error "Empty reps" (x:_) -> x - in (ct, c a) + c' <- c a + return (ct, c') where --helper :: ContentType -> Maybe ContentPair helper ct = do @@ -132,7 +134,7 @@ instance HasReps RepChooser where instance HasReps [(ContentType, Content)] where reps = error "reps of [(ContentType, Content)]" - chooseRep a cts = + chooseRep a cts = return $ case filter (\(ct, _) -> ct `elem` cts) a of ((ct, c):_) -> (ct, c) _ -> case a of @@ -149,15 +151,28 @@ data Template = Template (StringTemplate String) HtmlObject instance HasReps Template where reps = [ (TypeHtml, \(Template t h) -> - cs $ toString $ setAttribute "o" h t) - , (TypeJson, \(Template _ ho) -> cs $ unJsonDoc $ cs ho) + return $ cs $ toString $ setAttribute "o" h t) + , (TypeJson, \(Template _ ho) -> + return $ cs $ unJsonDoc $ cs ho) + ] + +data TemplateFile = TemplateFile FilePath HtmlObject +instance HasReps TemplateFile where + reps = [ (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) ] -- Useful instances of HasReps instance HasReps HtmlObject where reps = - [ (TypeHtml, cs . unHtmlDoc . cs) - , (TypeJson, cs . unJsonDoc . cs) + [ (TypeHtml, return . cs . unHtmlDoc . cs) + , (TypeJson, return . cs . unJsonDoc . cs) ] #if TEST @@ -167,10 +182,10 @@ caseChooseRepHO = do a = toHtmlObject content htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content jsonbs = Content . cs $ "\"" ++ content ++ "\"" - chooseRep a [TypeHtml] @?= (TypeHtml, htmlbs) - chooseRep a [TypeJson] @?= (TypeJson, jsonbs) - chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs) - chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs) + chooseRep a [TypeHtml] >>= (@?= (TypeHtml, htmlbs)) + chooseRep a [TypeJson] >>= (@?= (TypeJson, jsonbs)) + chooseRep a [TypeHtml, TypeJson] >>= (@?= (TypeHtml, htmlbs)) + chooseRep a [TypeOther "foo", TypeJson] >>= (@?= (TypeJson, jsonbs)) caseChooseRepRaw :: Assertion caseChooseRepRaw = do @@ -178,10 +193,10 @@ caseChooseRepRaw = do foo = TypeOther "foo" bar = TypeOther "bar" hasreps = [(TypeHtml, content), (foo, content)] - chooseRep hasreps [TypeHtml] @?= (TypeHtml, content) - chooseRep hasreps [foo, bar] @?= (foo, content) - chooseRep hasreps [bar, foo] @?= (foo, content) - chooseRep hasreps [bar] @?= (TypeHtml, content) + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, content)) + chooseRep hasreps [foo, bar] >>= (@?= (foo, content)) + chooseRep hasreps [bar, foo] >>= (@?= (foo, content)) + chooseRep hasreps [bar] >>= (@?= (TypeHtml, content)) caseChooseRepTemplate :: Assertion caseChooseRepTemplate = do @@ -193,15 +208,31 @@ caseChooseRepTemplate = do res1 = cs "foo:<fooval>, bar:bar1bar2" res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ "\"foo\":\"<fooval>\"}" - (1, chooseRep hasreps [TypeHtml]) @?= (1, (TypeHtml, res1)) - (2, chooseRep hasreps [TypeJson]) @?= (2, (TypeJson, res2)) - (3, chooseRep hasreps [TypeHtml, TypeJson]) @?= (3, (TypeHtml, res1)) - (4, chooseRep hasreps [TypeJson, TypeHtml]) @?= (4, (TypeJson, res2)) + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) + chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) + +caseChooseRepTemplateFile :: Assertion +caseChooseRepTemplateFile = do + let temp = "test/rep.st" + ho = toHtmlObject [ ("foo", toHtmlObject "") + , ("bar", toHtmlObject ["bar1", "bar2"]) + ] + hasreps = TemplateFile temp ho + res1 = cs "foo:<fooval>, bar:bar1bar2" + res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ + "\"foo\":\"<fooval>\"}" + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) + chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) testSuite :: Test testSuite = testGroup "Yesod.Rep" [ testCase "caseChooseRep HtmlObject" caseChooseRepHO , testCase "caseChooseRep raw" caseChooseRepRaw , testCase "caseChooseRep Template" caseChooseRepTemplate + , testCase "caseChooseRep TemplateFile" caseChooseRepTemplateFile ] #endif diff --git a/test/rep.st b/test/rep.st new file mode 100644 index 00000000..127b7fd7 --- /dev/null +++ b/test/rep.st @@ -0,0 +1 @@ +foo:$o.foo$, bar:$o.bar$