module Yesod.Core.Json
(
defaultLayoutJson
, jsonToRepJson
, parseJsonBody
, parseJsonBody_
, J.Value (..)
, J.ToJSON (..)
, J.FromJSON (..)
, array
, object
, (.=)
, (J..:)
, jsonOrRedirect
, acceptsJson
) where
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
import Data.Aeson ((.=), object)
import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (pack)
import qualified Data.Vector as V
import Data.Conduit
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site IO ()
-> HandlerT site IO a
-> HandlerT site IO TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
jsonToRepJson = return . J.toJSON
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value
parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
parseJsonBody_ = do
ra <- parseJsonBody
case ra of
J.Error s -> invalidArgs [pack s]
J.Success a -> return a
array :: J.ToJSON a => [a] -> J.Value
array = J.Array . V.fromList . map J.toJSON
jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
=> Route (HandlerSite m)
-> a
-> m J.Value
jsonOrRedirect r j = do
q <- acceptsJson
if q then return (J.toJSON j)
else redirect r
acceptsJson :: MonadHandler m => m Bool
acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. listToMaybe
. reqAccept)
`liftM` getRequest