module Yesod.Json
(
defaultLayoutJson
, jsonToRepJson
, parseJsonBody
, parseJsonBody_
, J.Value (..)
, object
, array
, (.=)
, jsonOrRedirect
, acceptsJson
) where
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.Parser as JP
import Data.Aeson ((.=))
import qualified Data.Aeson.Encode as JE
import Data.Aeson.Encode (fromValue)
import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (Text, pack)
import qualified Data.Vector as V
import Text.Julius (ToJavascript (..))
import Data.Text.Lazy.Builder (fromLazyText)
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, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import qualified Data.ByteString.Char8 as B8
import Safe (headMay)
#if !MIN_VERSION_yesod_core(1, 1, 5)
instance ToContent J.Value where
toContent = flip ContentBuilder Nothing
. Blaze.fromLazyText
. toLazyText
. fromValue
#endif
defaultLayoutJson :: (Yesod master, J.ToJSON a)
=> GWidget sub master ()
-> a
-> GHandler sub master RepHtmlJson
defaultLayoutJson w json = do
RepHtml html' <- defaultLayout w
return $ RepHtmlJson html' $ toContent (J.toJSON json)
jsonToRepJson :: J.ToJSON a => a -> GHandler sub master RepJson
jsonToRepJson = return . RepJson . toContent . J.toJSON
parseJsonBody :: J.FromJSON a => GHandler sub master (J.Result a)
parseJsonBody = do
req <- waiRequest
eValue <- lift
$ runExceptionT
$ transPipe lift (requestBody req)
$$ sinkParser JP.value'
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value
parseJsonBody_ :: J.FromJSON a => GHandler sub master a
parseJsonBody_ = do
ra <- parseJsonBody
case ra of
J.Error s -> invalidArgs [pack s]
J.Success a -> return a
#if !MIN_VERSION_shakespeare_js(1, 0, 2)
instance ToJavascript J.Value where
toJavascript = fromLazyText . decodeUtf8 . JE.encode
#endif
object :: J.ToJSON a => [(Text, a)] -> J.Value
object = J.object . map (second J.toJSON)
array :: J.ToJSON a => [a] -> J.Value
array = J.Array . V.fromList . map J.toJSON
jsonOrRedirect :: (Yesod master, J.ToJSON a)
=> Route master
-> a
-> GHandler sub master RepJson
jsonOrRedirect r j = do
q <- acceptsJson
if q then jsonToRepJson (J.toJSON j)
else redirect r
acceptsJson :: Yesod master => GHandler sub master Bool
acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join
. fmap (headMay . parseHttpAccept)
. lookup "Accept" . requestHeaders
<$> waiRequest