haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

TemplateFile rep

Browse Source
This commit is contained in:
Michael Snoyman 2009-12-14 23:41:20 +02:00
parent c23984b154
commit 12437533b6
5 changed files with 58 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Yesod/Handler.hs
View File

@ -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

2
Yesod/Helpers/AtomFeed.hs
View File

@ -34,7 +34,7 @@ data AtomFeed = AtomFeed
}
instance HasReps AtomFeed where
reps =
[ (TypeAtom, cs . show)
[ (TypeAtom, return . cs . show)
]
data AtomFeedEntry = AtomFeedEntry

2
Yesod/Helpers/Sitemap.hs
View File

@ -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

73
Yesod/Rep.hs
View File

@ -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:&lt;fooval&gt;, bar:bar1bar2"
res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++
"\"foo\":\"&lt;fooval&gt;\"}"
(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 "<fooval>")
, ("bar", toHtmlObject ["bar1", "bar2"])
]
hasreps = TemplateFile temp ho
res1 = cs "foo:&lt;fooval&gt;, bar:bar1bar2"
res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++
"\"foo\":\"&lt;fooval&gt;\"}"
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

1
test/rep.st Normal file
View File

@ -0,0 +1 @@
foo:$o.foo$, bar:$o.bar$