diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index dcda9da9..383a54c1 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 347d39b4..e4362dc1 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index b4ca9c06..2c751c6c 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index e13356af..7518fed7 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index f85084c0..5e649e66 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -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 diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 6c4a0d6b..b9f8cad3 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -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) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 337ac3ec..04e85740 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -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):) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index a0bc2392..e7e5d753 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -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) diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index d8ba52d2..3e0fcddf 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/yesod-core/test/YesodCoreTest/Exceptions.hs @@ -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 () diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs index 903c66ec..e2496b61 100644 --- a/yesod-core/test/YesodCoreTest/Reps.hs +++ b/yesod-core/test/YesodCoreTest/Reps.hs @@ -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