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

TypedContent

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-11 10:45:01 +02:00
parent d2f5ca449d
commit 1d0cac6e03
10 changed files with 149 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
yesod-core/Yesod/Content.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
@ -31,22 +33,26 @@ module Yesod.Content
-- * Evaluation strategy
, DontFullyEvaluate (..)
-- * Representations
, ChooseRep
, HasReps (..)
, defChooseRep
, TypedContent (..)
, ToTypedContent (..)
, HasContentType (..)
-- ** Specific content types
, RepHtml (..)
, RepJson (..)
, RepHtmlJson (..)
, RepPlain (..)
, RepXml (..)
-- ** Smart constructors
, repHtml
, repJson
, repPlain
, repXml
) where
import Data.Maybe (mapMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T
import Control.Monad (liftM)
import qualified Data.Text.Encoding
import qualified Data.Text.Lazy.Encoding
@ -80,6 +86,8 @@ emptyContent = ContentBuilder mempty $ Just 0
class ToContent a where
toContent :: a -> Content
instance ToContent Content where
toContent = id
instance ToContent Builder where
toContent = flip ContentBuilder Nothing
instance ToContent B.ByteString where
@ -94,6 +102,12 @@ instance ToContent String where
toContent = toContent . pack
instance ToContent Html where
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
instance ToContent () where
toContent () = toContent B.empty
instance ToContent (ContentType, Content) where
toContent = snd
instance ToContent TypedContent where
toContent (TypedContent _ c) = c
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
toContent src = ContentSource $ mapOutput toFlushBuilder src
@ -106,61 +120,37 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
-- | Any type which can be converted to representations.
class HasReps a where
chooseRep :: a -> ChooseRep
repHtml :: ToContent a => a -> RepHtml
repHtml = RepHtml . toContent
-- | A helper method for generating 'HasReps' instances.
--
-- This function should be given a list of pairs of content type and conversion
-- functions. If none of the content types match, the first pair is used.
defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep
defChooseRep reps a ts = do
let (ct, c) =
case mapMaybe helper ts of
(x:_) -> x
[] -> case reps of
[] -> error "Empty reps to defChooseRep"
(x:_) -> x
c' <- c a
return (ct, c')
where
helper ct = do
c <- lookup ct reps
return (ct, c)
repJson :: ToContent a => a -> RepJson
repJson = RepJson . toContent
instance HasReps ChooseRep where
chooseRep = id
repPlain :: ToContent a => a -> RepPlain
repPlain = RepPlain . toContent
instance HasReps () where
chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]
repXml :: ToContent a => a -> RepXml
repXml = RepXml . toContent
instance HasReps (ContentType, Content) where
chooseRep = const . return
class ToTypedContent a => HasContentType a where
getContentType :: Monad m => m a -> ContentType
instance HasReps [(ContentType, Content)] where
chooseRep a cts = return $
case filter (\(ct, _) -> go ct `elem` map go cts) a of
((ct, c):_) -> (ct, c)
_ -> case a of
(x:_) -> x
_ -> error "chooseRep [(ContentType, Content)] of empty"
where
go = simpleContentType
instance HasContentType RepHtml where
getContentType _ = typeHtml
deriving instance ToContent RepHtml
instance HasContentType RepJson where
getContentType _ = typeJson
deriving instance ToContent RepJson
instance HasContentType RepPlain where
getContentType _ = typePlain
deriving instance ToContent RepPlain
instance HasContentType RepXml where
getContentType _ = typeXml
deriving instance ToContent RepXml
instance HasReps RepHtml where
chooseRep (RepHtml c) _ = return (typeHtml, c)
instance HasReps RepJson where
chooseRep (RepJson c) _ = return (typeJson, c)
instance HasReps RepHtmlJson where
chooseRep (RepHtmlJson html json) = chooseRep
[ (typeHtml, html)
, (typeJson, json)
]
instance HasReps RepPlain where
chooseRep (RepPlain c) _ = return (typePlain, c)
instance HasReps RepXml where
chooseRep (RepXml c) _ = return (typeXml, c)
typeHtml :: ContentType
typeHtml = "text/html; charset=utf-8"
@ -215,8 +205,8 @@ typeOctet = "application/octet-stream"
simpleContentType :: ContentType -> ContentType
simpleContentType = fst . B.breakByte 59 -- 59 == ;
instance HasReps a => HasReps (DontFullyEvaluate a) where
chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a
instance HasContentType a => HasContentType (DontFullyEvaluate a) where
getContentType = getContentType . liftM unDontFullyEvaluate
instance ToContent a => ToContent (DontFullyEvaluate a) where
toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
@ -226,3 +216,47 @@ instance ToContent J.Value where
. Blaze.fromLazyText
. toLazyText
. fromValue
instance HasContentType J.Value where
getContentType _ = typeJson
instance HasContentType Html where
getContentType _ = typeHtml
instance HasContentType Text where
getContentType _ = typePlain
instance HasContentType T.Text where
getContentType _ = typePlain
-- | Any type which can be converted to 'TypedContent'.
--
-- Since 1.2.0
class ToContent a => ToTypedContent a where
toTypedContent :: a -> TypedContent
instance ToTypedContent TypedContent where
toTypedContent = id
instance ToTypedContent () where
toTypedContent () = TypedContent typePlain (toContent ())
instance ToTypedContent (ContentType, Content) where
toTypedContent (ct, content) = TypedContent ct content
instance ToTypedContent RepHtml where
toTypedContent (RepHtml c) = TypedContent typeHtml c
instance ToTypedContent RepJson where
toTypedContent (RepJson c) = TypedContent typeJson c
instance ToTypedContent RepPlain where
toTypedContent (RepPlain c) = TypedContent typePlain c
instance ToTypedContent RepXml where
toTypedContent (RepXml c) = TypedContent typeXml c
instance ToTypedContent J.Value where
toTypedContent v = TypedContent typeJson (toContent v)
instance ToTypedContent Html where
toTypedContent h = TypedContent typeHtml (toContent h)
instance ToTypedContent T.Text where
toTypedContent t = TypedContent typePlain (toContent t)
instance ToTypedContent Text where
toTypedContent t = TypedContent typePlain (toContent t)
instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
toTypedContent (DontFullyEvaluate a) =
let TypedContent ct c = toTypedContent a
in TypedContent ct (ContentDontEvaluate c)

8
yesod-core/Yesod/Core/Class.hs
View File

@ -75,7 +75,7 @@ class RenderRoute a => Yesod a where
approot = ApprootRelative
-- | Output error response pages.
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
errorHandler :: ErrorResponse -> GHandler sub a TypedContent
errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page.
@ -405,13 +405,13 @@ $newline never
applyLayout' :: Yesod master
=> Html -- ^ title
-> HtmlUrl (Route master) -- ^ body
-> GHandler sub master ChooseRep
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
-> GHandler sub master TypedContent
applyLayout' title body = fmap toTypedContent $ defaultLayout $ do
setTitle title
toWidget body
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent
defaultErrorHandler NotFound = do
r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r

21
yesod-core/Yesod/Core/Json.hs
View File

@ -20,12 +20,9 @@ module Yesod.Core.Json
, acceptsJson
) where
import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect)
import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Trans.Class (lift)
import Yesod.Content
( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
, RepJson (RepJson)
)
import Yesod.Content (TypedContent)
import Yesod.Internal.Core (defaultLayout, Yesod)
import Yesod.Widget (GWidget)
import Yesod.Routes.Class
@ -52,17 +49,17 @@ import Data.Maybe (listToMaybe)
defaultLayoutJson :: (Yesod master, J.ToJSON a)
=> GWidget sub master () -- ^ HTML
-> a -- ^ JSON
-> GHandler sub master RepHtmlJson
defaultLayoutJson w json = do
RepHtml html' <- defaultLayout w
return $ RepHtmlJson html' $ toContent (J.toJSON json)
-> GHandler sub master TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ return $ J.toJSON json
-- | Wraps a data type in a 'RepJson'. The data type must
-- support conversion to JSON via 'J.ToJSON'.
--
-- /Since: 0.3.0/
jsonToRepJson :: J.ToJSON a => a -> GHandler sub master RepJson
jsonToRepJson = return . RepJson . toContent . J.toJSON
jsonToRepJson :: J.ToJSON a => a -> GHandler sub master J.Value
jsonToRepJson = return . J.toJSON
-- | Parse the request body to a data type as a JSON value. The
-- data type must support conversion from JSON via 'J.FromJSON'.
@ -108,7 +105,7 @@ array = J.Array . V.fromList . map J.toJSON
jsonOrRedirect :: (Yesod master, J.ToJSON a)
=> Route master -- ^ Redirect target
-> a -- ^ Data to send via JSON
-> GHandler sub master RepJson
-> GHandler sub master J.Value
jsonOrRedirect r j = do
q <- acceptsJson
if q then jsonToRepJson (J.toJSON j)

14
yesod-core/Yesod/Core/Run.hs
View File

@ -91,7 +91,7 @@ local f (GHandler x) = GHandler $ \r -> x $ f r
-- | Function used internally by Yesod in the process of converting a
-- 'GHandler' into an 'Application'. Should not be needed by users.
runHandler :: HasReps c
runHandler :: ToTypedContent c
=> RunHandlerEnv sub master
-> GHandler sub master c
-> YesodApp
@ -101,7 +101,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
Just (HCError x) -> x
_ -> InternalError $ T.pack $ show e
istate <- liftIO $ I.newIORef GHState
{ ghsSession = initSession
{ ghsSession = reqSession yreq
, ghsRBC = Nothing
, ghsIdent = 1
, ghsCache = mempty
@ -118,7 +118,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
state <- liftIO $ I.readIORef istate
let finalSession = ghsSession state
let headers = ghsHeaders state
let contents = either id (HCContent H.status200 . chooseRep) contents'
let contents = either id (HCContent H.status200 . toTypedContent) contents'
let handleError e = do
yar <- rheOnError e yreq
{ reqSession = finalSession
@ -131,8 +131,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
let sendFile' ct fp p =
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
case contents of
HCContent status a -> do
(ct, c) <- liftIO $ a cts
HCContent status (TypedContent ct c) -> do
ec' <- liftIO $ evaluateContent c
case ec' of
Left e -> handleError e
@ -160,9 +159,6 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
emptyContent
finalSession
HCWai r -> return $ YRWai r
where
cts = reqAccept yreq
initSession = reqSession yreq
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
@ -276,7 +272,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
defaultYesodRunner :: Yesod master
=> YesodRunnerEnv sub master
-> GHandler sub master ChooseRep
-> GHandler sub master TypedContent
-> Application
defaultYesodRunner YesodRunnerEnv {..} handler' req
| KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse

11
yesod-core/Yesod/Core/Types.hs
View File

@ -249,15 +249,10 @@ data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content an
| ContentFile !FilePath !(Maybe FilePart)
| ContentDontEvaluate !Content
-- | A function which gives targetted representations of content based on the
-- content-types the user accepts.
type ChooseRep =
[ContentType] -- ^ list of content-types user accepts, ordered by preference
-> IO (ContentType, Content)
data TypedContent = TypedContent !ContentType !Content
newtype RepHtml = RepHtml Content
newtype RepJson = RepJson Content
data RepHtmlJson = RepHtmlJson Content Content
newtype RepPlain = RepPlain Content
newtype RepXml = RepXml Content
@ -267,7 +262,7 @@ type ContentType = ByteString -- FIXME Text?
-- request.
--
-- Since 1.1.0
newtype DontFullyEvaluate a = DontFullyEvaluate a
newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
-- | Responses to indicate some form of an error occurred. These are different
-- from 'SpecialResponse' in that they allow for custom error pages.
@ -327,7 +322,7 @@ instance Monoid (GWData a) where
(a7 `mappend` b7)
data HandlerContents =
HCContent H.Status ChooseRep
HCContent H.Status !TypedContent
| HCError ErrorResponse
| HCSendFile ContentType FilePath (Maybe FilePart)
| HCRedirect H.Status Text

4
yesod-core/Yesod/Dispatch.hs
View File

@ -52,7 +52,7 @@ import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Content (chooseRep)
import Yesod.Content (toTypedContent)
import Yesod.Routes.Parse
import System.Log.FastLogger (Logger)
import Yesod.Core.Types
@ -151,7 +151,7 @@ mkDispatchInstance context sub master res = do
Clause pat body decs <- mkDispatchClause
[|yesodRunner $loggerE |]
[|yesodDispatch $loggerE |]
[|fmap chooseRep|]
[|fmap toTypedContent|]
res
return $ FunD 'yesodDispatch
[ Clause (loggerP:pat)

46
yesod-core/Yesod/Handler.hs
View File

@ -78,6 +78,7 @@ module Yesod.Handler
-- $representations
, selectRep
, provideRep
, provideRepType
, ProvidedRep
-- * Setting headers
, setCookie
@ -157,8 +158,7 @@ import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..))
import Web.Cookie (SetCookie (..))
import Yesod.Content (HasReps, chooseRep,
toContent, typePlain, simpleContentType)
import Yesod.Content (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..))
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
@ -467,13 +467,13 @@ sendFilePart ct fp off count =
-- | Bypass remaining handler code and output the given content with a 200
-- status code.
sendResponse :: (HandlerError m, HasReps c) => c -> m a
sendResponse = handlerError . HCContent H.status200 . chooseRep
sendResponse :: (HandlerError m, ToTypedContent c) => c -> m a
sendResponse = handlerError . HCContent H.status200 . toTypedContent
-- | Bypass remaining handler code and output the given content with the given
-- status code.
sendResponseStatus :: (HandlerError m, HasReps c) => H.Status -> c -> m a
sendResponseStatus s = handlerError . HCContent s . chooseRep
sendResponseStatus :: (HandlerError m, ToTypedContent c) => H.Status -> c -> m a
sendResponseStatus s = handlerError . HCContent s . toTypedContent
-- | Send a 201 "Created" response with the given route as the Location
-- response header.
@ -831,19 +831,19 @@ lookupCookies pn = do
-- Since 1.2.0
selectRep :: HandlerReader m
=> Writer.Writer (Endo [ProvidedRep m]) ()
-> m (ContentType, Content)
-> m TypedContent
selectRep w = do
cts <- liftM reqAccept askYesodRequest
case mapMaybe tryAccept cts of
[] ->
case reps of
[] -> return (typePlain, "No reps provided to selectRep")
[] -> return $ toTypedContent ("No reps provided to selectRep" :: Text)
rep:_ -> returnRep rep
rep:_ -> returnRep rep
where
returnRep (ProvidedRep ct mcontent) = do
content <- mcontent
return (ct, content)
return $ TypedContent ct content
reps = appEndo (Writer.execWriter w) []
repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList
@ -868,14 +868,22 @@ data ProvidedRep m = ProvidedRep !ContentType !(m Content)
-- client. Should be used together with 'selectRep'.
--
-- Since 1.2.0
provideRep :: (MonadIO m, HasReps a)
=> ContentType
-> m a
provideRep :: (MonadIO m, HasContentType a)
=> m a
-> Writer.Writer (Endo [ProvidedRep m]) ()
provideRep ct handler =
Writer.tell $ Endo $ (ProvidedRep ct (grabContent handler):)
where
grabContent f = do
rep <- f
(_, content) <- liftIO $ chooseRep rep [ct]
return content
provideRep handler = provideRepType (getContentType handler) handler
-- | Same as 'provideRep', but instead of determining the content type from the
-- type of the value itself, you provide the content type separately. This can
-- be a convenience instead of creating newtype wrappers for uncommonly used
-- content types.
--
-- > provideRepType "application/x-special-format" "This is the content"
--
-- Since 1.2.0
provideRepType :: (MonadIO m, ToContent a)
=> ContentType
-> m a
-> Writer.Writer (Endo [ProvidedRep m]) ()
provideRepType ct handler =
Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):)

2
yesod-core/Yesod/Internal/Core.hs
View File

@ -114,7 +114,7 @@ class YesodDispatch sub master where
yesodRunner :: Yesod master
=> Logger
-> GHandler sub master ChooseRep
-> GHandler sub master TypedContent
-> master
-> sub
-> Maybe (Route sub)

2
yesod-core/test/YesodCoreTest/Exceptions.hs
View File

@ -18,7 +18,7 @@ mkYesod "Y" [parseRoutes|
instance Yesod Y where
approot = ApprootStatic "http://test"
errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e
errorHandler (InternalError e) = return $ toTypedContent e
errorHandler x = defaultErrorHandler x
getRootR :: Handler ()

12
yesod-core/test/YesodCoreTest/Reps.hs
View File

@ -8,6 +8,7 @@ import Network.Wai.Test
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.String (IsString)
import Data.Text (Text)
data App = App
@ -20,12 +21,13 @@ instance Yesod App
specialHtml :: IsString a => a
specialHtml = "text/html; charset=special"
getHomeR :: Handler (ContentType, Content)
getHomeR :: Handler TypedContent
getHomeR = selectRep $ do
provideRep typeHtml $ return $ RepPlain "HTML"
provideRep specialHtml $ return $ RepPlain "HTMLSPECIAL"
provideRep typeJson $ return $ RepPlain "JSON"
provideRep typeXml $ return $ RepPlain "XML"
let go ct t = provideRepType ct $ return (t :: Text)
go typeHtml "HTML"
go specialHtml "HTMLSPECIAL"
go typeJson "JSON"
go typeXml "XML"
test :: String -- ^ accept header
-> ByteString -- ^ expected body