Added ioTextToContent, fixed json/html order
This commit is contained in:
parent
43c847ff93
commit
f1184a1f66
@ -24,6 +24,7 @@ module Yesod.Response
|
||||
, ChooseRep
|
||||
, HasReps (..)
|
||||
, defChooseRep
|
||||
, ioTextToContent
|
||||
-- ** Convenience wrappers
|
||||
, staticRep
|
||||
-- * Response type
|
||||
@ -90,6 +91,12 @@ instance ConvertSuccess XmlDoc Content where
|
||||
|
||||
type ChooseRep = [ContentType] -> IO (ContentType, Content)
|
||||
|
||||
-- | It would be nice to simplify 'Content' to the point where this is
|
||||
-- unnecesary.
|
||||
ioTextToContent :: IO Text -> Content
|
||||
ioTextToContent iotext =
|
||||
Content $ \f a -> iotext >>= foldM f a . toChunks . cs
|
||||
|
||||
-- | Any type which can be converted to representations.
|
||||
class HasReps a where
|
||||
chooseRep :: a -> ChooseRep
|
||||
|
||||
@ -21,8 +21,6 @@ import Web.Mime
|
||||
import Yesod.Response
|
||||
import Yesod.Yesod
|
||||
import Yesod.Handler
|
||||
import Control.Monad (foldM)
|
||||
import Data.ByteString.Lazy (toChunks)
|
||||
|
||||
type Template = StringTemplate Text
|
||||
type TemplateGroup = STGroup Text
|
||||
@ -44,8 +42,8 @@ template tn ho f = do
|
||||
Nothing -> failure $ NoSuchTemplate tn
|
||||
Just x -> return x
|
||||
return $ chooseRep
|
||||
[ (TypeJson, cs $ unJsonDoc $ cs ho)
|
||||
, (TypeHtml, tempToContent t ho f)
|
||||
[ (TypeHtml, tempToContent t ho f)
|
||||
, (TypeJson, cs $ unJsonDoc $ cs ho)
|
||||
]
|
||||
newtype NoSuchTemplate = NoSuchTemplate String
|
||||
deriving (Show, Typeable)
|
||||
@ -57,10 +55,6 @@ tempToContent :: Template
|
||||
-> Content
|
||||
tempToContent t ho f = ioTextToContent $ fmap render $ f ho t
|
||||
|
||||
ioTextToContent :: IO Text -> Content
|
||||
ioTextToContent iotext =
|
||||
Content $ \f a -> iotext >>= foldM f a . toChunks . cs
|
||||
|
||||
data TemplateFile = TemplateFile FilePath HtmlObject
|
||||
instance HasReps TemplateFile where
|
||||
chooseRep (TemplateFile fp (Mapping m)) _ = do
|
||||
|
||||
@ -75,8 +75,8 @@ applyLayoutJson :: Yesod y
|
||||
applyLayoutJson t b = do
|
||||
y <- getYesod
|
||||
return $ chooseRep
|
||||
[ (TypeJson, cs $ unJsonDoc $ cs b)
|
||||
, (TypeHtml, applyLayout y t $ cs b)
|
||||
[ (TypeHtml, applyLayout y t $ cs b)
|
||||
, (TypeJson, cs $ unJsonDoc $ cs b)
|
||||
]
|
||||
|
||||
getApproot :: YesodApproot y => Handler y Approot
|
||||
|
||||
Loading…
Reference in New Issue
Block a user