TypedContent

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
+    , TypedContent (..)
-    , HasReps (..)
+    , ToTypedContent (..)
-    , defChooseRep
+    , 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.
+repHtml :: ToContent a => a -> RepHtml
-class HasReps a where
+repHtml = RepHtml . toContent
-    chooseRep :: a -> ChooseRep
 
--- | A helper method for generating 'HasReps' instances.
+repJson :: ToContent a => a -> RepJson
---
+repJson = RepJson . toContent
--- 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)
 
-instance HasReps ChooseRep where
+repPlain :: ToContent a => a -> RepPlain
-    chooseRep = id
+repPlain = RepPlain . toContent
 
-instance HasReps () where
+repXml :: ToContent a => a -> RepXml
-    chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]
+repXml = RepXml . toContent
 
-instance HasReps (ContentType, Content) where
+class ToTypedContent a => HasContentType a where
-    chooseRep = const . return
+    getContentType :: Monad m => m a -> ContentType
 
-instance HasReps [(ContentType, Content)] where
+instance HasContentType RepHtml where
-    chooseRep a cts = return $
+    getContentType _ = typeHtml
-        case filter (\(ct, _) -> go ct `elem` map go cts) a of
+deriving instance ToContent RepHtml
-            ((ct, c):_) -> (ct, c)
+
-            _ -> case a of
+instance HasContentType RepJson where
-                    (x:_) -> x
+    getContentType _ = typeJson
-                    _ -> error "chooseRep [(ContentType, Content)] of empty"
+deriving instance ToContent RepJson
-      where
+
-        go = simpleContentType
+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
+instance HasContentType a => HasContentType (DontFullyEvaluate a) where
-    chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a
+    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)

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
+             -> GHandler sub master TypedContent
-applyLayout' title body = fmap chooseRep $ defaultLayout $ do
+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

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
+import Yesod.Content (TypedContent)
-    ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
-    , RepJson (RepJson)
-    )
 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
+                  -> GHandler sub master TypedContent
-defaultLayoutJson w json = do
+defaultLayoutJson w json = selectRep $ do
-    RepHtml html' <- defaultLayout w
+    provideRep $ defaultLayout w
-    return $ RepHtmlJson html' $ toContent (J.toJSON json)
+    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 :: J.ToJSON a => a -> GHandler sub master J.Value
-jsonToRepJson = return . RepJson . toContent . J.toJSON
+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)

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
+        HCContent status (TypedContent ct c) -> do
-            (ct, c) <- liftIO $ a cts
             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

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
+data TypedContent = TypedContent !ContentType !Content
--- content-types the user accepts.
-type ChooseRep =
-    [ContentType] -- ^ list of content-types user accepts, ordered by preference
- -> IO (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

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)

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,
+import           Yesod.Content                 (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..))
-                                                toContent, typePlain, simpleContentType)
 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 m, ToTypedContent c) => c -> m a
-sendResponse = handlerError . HCContent H.status200 . chooseRep
+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 :: (HandlerError m, ToTypedContent c) => H.Status -> c -> m a
-sendResponseStatus s = handlerError . HCContent s . chooseRep
+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)
+provideRep :: (MonadIO m, HasContentType a)
-           => ContentType
+           => m a
-           -> m a
            -> Writer.Writer (Endo [ProvidedRep m]) ()
-provideRep ct handler =
+provideRep handler = provideRepType (getContentType handler) handler
-    Writer.tell $ Endo $ (ProvidedRep ct (grabContent handler):)
+
-  where
+-- | Same as 'provideRep', but instead of determining the content type from the
-    grabContent f = do
+-- type of the value itself, you provide the content type separately. This can
-        rep <- f
+-- be a convenience instead of creating newtype wrappers for uncommonly used
-        (_, content) <- liftIO $ chooseRep rep [ct]
+-- content types.
-        return content
+--
+-- > 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):)

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)

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 ()

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"
+    let go ct t = provideRepType ct $ return (t :: Text)
-    provideRep specialHtml $ return $ RepPlain "HTMLSPECIAL"
+    go typeHtml "HTML"
-    provideRep typeJson $ return $ RepPlain "JSON"
+    go specialHtml "HTMLSPECIAL"
-    provideRep typeXml $ return $ RepPlain "XML"
+    go typeJson "JSON"
+    go typeXml "XML"
 
 test :: String -- ^ accept header
      -> ByteString -- ^ expected body