From 1953c8943ba3cfd6ba033e3f68e613deb6addf63 Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Fri, 13 Jan 2012 11:50:55 -0800 Subject: [PATCH 1/4] Adds jsonOrRedirect --- yesod-json/Yesod/Json.hs | 36 +++++++++++++++++++++++++++++++++--- yesod-json/yesod-json.cabal | 4 ++++ 2 files changed, 37 insertions(+), 3 deletions(-) diff --git a/yesod-json/Yesod/Json.hs b/yesod-json/Yesod/Json.hs index 369e3775..374408f6 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-json/Yesod/Json.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Json @@ -14,16 +14,22 @@ module Yesod.Json , J.Value (..) , object , array + + -- * Convenience functions + , jsonOrRedirect ) where -import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs) +import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) , RepJson (RepJson), Content (ContentBuilder) ) import Yesod.Core (defaultLayout, Yesod) import Yesod.Widget (GWidget) +import Yesod.Routes.Class import Control.Arrow (second) +import Control.Applicative ((<$>)) +import Control.Monad (join) import qualified Data.Aeson as J import qualified Data.Aeson.Encode as JE import Data.Aeson.Encode (fromValue) @@ -36,7 +42,10 @@ import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.Builder (toLazyText) import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Conduit (($$)) -import Network.Wai (requestBody) +import Network.Wai (requestBody, requestHeaders) +import Network.Wai.Parse (parseHttpAccept) +import qualified Data.ByteString as B +import Safe (headMay) instance ToContent J.Value where toContent = flip ContentBuilder Nothing @@ -94,3 +103,24 @@ object = J.object . map (second J.toJSON) -- | Convert a list of values to an 'J.Array'. array :: J.ToJSON a => [a] -> J.Value array = J.Array . V.fromList . map J.toJSON + +-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different +-- response based on Accept headers: +-- +-- 1. 200 with JSON data if the client prefers application/json (i.e. is an +-- AJAX request) +-- +-- 2. 3xx otherwise, following the PRG pattern. +jsonOrRedirect :: (Yesod master, J.ToJSON a) + => Route master -- ^ Redirect target + -> a -- ^ Data to send via JSON + -> GHandler sub master RepJson +jsonOrRedirect r j = do + q <- acceptsJson + if q then jsonToRepJson (J.toJSON j) + else redirect r + where + acceptsJson = maybe False ("application/json" `B.isPrefixOf`) <$> firstAccept + firstAccept = return . join + . fmap (headMay . parseHttpAccept) + =<< lookup "Accept" . requestHeaders <$> waiRequest diff --git a/yesod-json/yesod-json.cabal b/yesod-json/yesod-json.cabal index 4838d872..a5b65405 100644 --- a/yesod-json/yesod-json.cabal +++ b/yesod-json/yesod-json.cabal @@ -15,6 +15,7 @@ description: Generate content for Yesod using the aeson package. library build-depends: base >= 4 && < 5 , yesod-core >= 0.10 && < 0.11 + , yesod-routes < 0.1 , aeson >= 0.5 , text >= 0.8 && < 1.0 , shakespeare-js >= 0.10 && < 0.11 @@ -25,6 +26,9 @@ library , conduit >= 0.0 && < 0.1 , transformers >= 0.2.2 && < 0.3 , wai >= 1.0 && < 1.1 + , wai-extra >= 1.0 && < 1.1 + , bytestring >= 0.9 && < 0.10 + , safe >= 0.2 && < 0.4 exposed-modules: Yesod.Json ghc-options: -Wall From c6a08f0c4ad88467d322298df84e7460dbe861f9 Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Fri, 13 Jan 2012 11:58:10 -0800 Subject: [PATCH 2/4] Pedantic comment revision --- yesod-json/Yesod/Json.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-json/Yesod/Json.hs b/yesod-json/Yesod/Json.hs index 374408f6..509367a1 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-json/Yesod/Json.hs @@ -107,8 +107,7 @@ array = J.Array . V.fromList . map J.toJSON -- | jsonOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: -- --- 1. 200 with JSON data if the client prefers application/json (i.e. is an --- AJAX request) +-- 1. 200 with JSON data if the client prefers application/json (e.g. AJAX). -- -- 2. 3xx otherwise, following the PRG pattern. jsonOrRedirect :: (Yesod master, J.ToJSON a) From b2c715f2231296ce50828eeca122449e4d17fe3d Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Sat, 14 Jan 2012 09:13:47 -0800 Subject: [PATCH 3/4] Small refactor to jsonOrRedirect --- yesod-json/Yesod/Json.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/yesod-json/Yesod/Json.hs b/yesod-json/Yesod/Json.hs index 509367a1..78d394a9 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-json/Yesod/Json.hs @@ -119,7 +119,8 @@ jsonOrRedirect r j = do if q then jsonToRepJson (J.toJSON j) else redirect r where - acceptsJson = maybe False ("application/json" `B.isPrefixOf`) <$> firstAccept - firstAccept = return . join + acceptsJson = maybe False ("application/json" `B.isPrefixOf`) + . join . fmap (headMay . parseHttpAccept) - =<< lookup "Accept" . requestHeaders <$> waiRequest + . lookup "Accept" . requestHeaders + <$> waiRequest From 7bff503ebb906d6bc2c682592beb3158c7a7b84c Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Sat, 14 Jan 2012 11:12:03 -0800 Subject: [PATCH 4/4] More robust parsing of Accept --- yesod-json/Yesod/Json.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-json/Yesod/Json.hs b/yesod-json/Yesod/Json.hs index 78d394a9..e59a11a9 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-json/Yesod/Json.hs @@ -44,7 +44,7 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Conduit (($$)) import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) -import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import Safe (headMay) instance ToContent J.Value where @@ -119,7 +119,7 @@ jsonOrRedirect r j = do if q then jsonToRepJson (J.toJSON j) else redirect r where - acceptsJson = maybe False ("application/json" `B.isPrefixOf`) + acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) . join . fmap (headMay . parseHttpAccept) . lookup "Accept" . requestHeaders