From d2f5ca449d819f5fe4d1fa1bd630e17f8beb8e31 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 09:08:34 +0200 Subject: [PATCH] selectRep/provideRep API --- yesod-core/Yesod/Handler.hs | 82 ++++++++++++++++++++++++++- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/Reps.hs | 53 +++++++++++++++++ 3 files changed, 135 insertions(+), 2 deletions(-) create mode 100644 yesod-core/test/YesodCoreTest/Reps.hs diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index dbf25d75..337ac3ec 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -74,6 +74,11 @@ module Yesod.Handler , sendResponseStatus , sendResponseCreated , sendWaiResponse + -- * Different representations + -- $representations + , selectRep + , provideRep + , ProvidedRep -- * Setting headers , setCookie , getExpires @@ -123,9 +128,10 @@ import Data.Time (UTCTime, addUTCTime, import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, mkFileInfoLBS, mkFileInfoSource) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<|>)) import Control.Monad (ap, liftM) +import qualified Control.Monad.Trans.Writer as Writer import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, liftResourceT) @@ -152,7 +158,7 @@ import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) import Yesod.Content (HasReps, chooseRep, - toContent) + toContent, typePlain, simpleContentType) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) @@ -801,3 +807,75 @@ lookupCookies :: HandlerReader m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr + +-- $representations +-- +-- HTTP allows content negotation to determine what /representation/ of data +-- you would like to use. The most common example of this is providing both a +-- user-facing HTML page and an API facing JSON response from the same URL. The +-- means of achieving this is the Accept HTTP header, which provides a list of +-- content types the client will accept, sorted by preference. +-- +-- By using 'selectRep' and 'provideRep', you can provide a number of different +-- representations, e.g.: +-- +-- > selectRep $ do +-- > provideRep typeHtml $ produceHtmlOutput +-- > provideRep typeJson $ produceJsonOutput +-- +-- The first provided representation will be used if no matches are found. + +-- | Select a representation to send to the client based on the representations +-- provided inside this do-block. Should be used together with 'provideRep'. +-- +-- Since 1.2.0 +selectRep :: HandlerReader m + => Writer.Writer (Endo [ProvidedRep m]) () + -> m (ContentType, Content) +selectRep w = do + cts <- liftM reqAccept askYesodRequest + case mapMaybe tryAccept cts of + [] -> + case reps of + [] -> return (typePlain, "No reps provided to selectRep") + rep:_ -> returnRep rep + rep:_ -> returnRep rep + where + returnRep (ProvidedRep ct mcontent) = do + content <- mcontent + return (ct, content) + + reps = appEndo (Writer.execWriter w) [] + repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList + [ (k, v) + , (noSpace k, v) + , (simpleContentType k, v) + ]) reps + tryAccept ct = Map.lookup ct repMap <|> + Map.lookup (noSpace ct) repMap <|> + Map.lookup (simpleContentType ct) repMap + + -- Mime types such as "text/html; charset=foo" get converted to + -- "text/html;charset=foo" + noSpace = S8.filter (/= ' ') + +-- | Internal representation of a single provided representation. +-- +-- Since 1.2.0 +data ProvidedRep m = ProvidedRep !ContentType !(m Content) + +-- | Provide a single representation to be used, based on the request of the +-- client. Should be used together with 'selectRep'. +-- +-- Since 1.2.0 +provideRep :: (MonadIO m, HasReps a) + => ContentType + -> 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 diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 58bf0325..dc220d33 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -14,6 +14,7 @@ import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json +import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth import Test.Hspec @@ -34,4 +35,5 @@ specs = do JsLoader.specs RequestBodySize.specs Json.specs + Reps.specs Auth.specs diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs new file mode 100644 index 00000000..903c66ec --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Reps.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +module YesodCoreTest.Reps (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import Network.Wai +import Network.Wai.Test +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.String (IsString) + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +instance Yesod App + +specialHtml :: IsString a => a +specialHtml = "text/html; charset=special" + +getHomeR :: Handler (ContentType, Content) +getHomeR = selectRep $ do + provideRep typeHtml $ return $ RepPlain "HTML" + provideRep specialHtml $ return $ RepPlain "HTMLSPECIAL" + provideRep typeJson $ return $ RepPlain "JSON" + provideRep typeXml $ return $ RepPlain "XML" + +test :: String -- ^ accept header + -> ByteString -- ^ expected body + -> Spec +test accept expected = it accept $ do + app <- toWaiApp App + flip runSession app $ do + sres <- request defaultRequest + { requestHeaders = [("Accept", S8.pack accept)] + } + assertBody expected sres + assertStatus 200 sres + +specs :: Spec +specs = describe "selectRep" $ do + test "application/json" "JSON" + test (S8.unpack typeJson) "JSON" + test "text/xml" "XML" + test (S8.unpack typeXml) "XML" + test "text/xml,application/json" "XML" + test "text/foo" "HTML" + test "text/xml;q=0.9,application/json;q=1.0" "JSON" + test (S8.unpack typeHtml) "HTML" + test "text/html" "HTML" + test specialHtml "HTMLSPECIAL"