{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Core.Json
    ( -- * Convert from a JSON value
      defaultLayoutJson
    , jsonToRepJson
    , returnJson
    , returnJsonEncoding
    , provideJson

      -- * Convert to a JSON value
    , parseCheckJsonBody
    , parseInsecureJsonBody
    , requireCheckJsonBody
    , requireInsecureJsonBody
      -- ** Deprecated JSON conversion
    , parseJsonBody
    , parseJsonBody_
    , requireJsonBody

      -- * Produce JSON values
    , J.Value (..)
    , J.ToJSON (..)
    , J.FromJSON (..)
    , array
    , object
    , (.=)
    , (J..:)

      -- * Convenience functions
    , jsonOrRedirect
    , jsonEncodingOrRedirect
    , acceptsJson

      -- * Checking if data is JSON
    , contentTypeHeaderIsJson
    ) where

import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
import Control.Monad.Trans.Writer (Writer)
import Data.Monoid (Endo)
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 (WidgetFor)
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 Data.Conduit.Lift
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)

-- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output
-- ('defaultLayout').
--
-- @since 0.3.0
defaultLayoutJson :: (Yesod site, J.ToJSON a)
                  => WidgetFor site ()  -- ^ HTML
                  -> HandlerFor site a  -- ^ JSON
                  -> HandlerFor site TypedContent
defaultLayoutJson :: WidgetFor site ()
-> HandlerFor site a -> HandlerFor site TypedContent
defaultLayoutJson WidgetFor site ()
w HandlerFor site a
json = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout WidgetFor site ()
w
    HandlerFor site Encoding
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Encoding
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Encoding
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ (a -> Encoding) -> HandlerFor site a -> HandlerFor site Encoding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Encoding
forall a. ToJSON a => a -> Encoding
J.toEncoding HandlerFor site a
json

-- | Wraps a data type in a 'RepJson'.  The data type must
-- support conversion to JSON via 'J.ToJSON'.
--
-- @since 0.3.0
jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
jsonToRepJson :: a -> m Value
jsonToRepJson = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> (a -> Value) -> a -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
J.toJSON
{-# DEPRECATED jsonToRepJson "Use returnJson instead" #-}

-- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function.
--
-- @since 1.2.1
returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value
returnJson :: a -> m Value
returnJson = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> (a -> Value) -> a -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
J.toJSON

-- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.
--
-- @since 1.4.21
returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding
returnJsonEncoding :: a -> m Encoding
returnJsonEncoding = Encoding -> m Encoding
forall (m :: * -> *) a. Monad m => a -> m a
return (Encoding -> m Encoding) -> (a -> Encoding) -> a -> m Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
forall a. ToJSON a => a -> Encoding
J.toEncoding

-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s
-- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.
--
-- @since 1.2.1
provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
provideJson :: a -> Writer (Endo [ProvidedRep m]) ()
provideJson = m Encoding -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Encoding -> Writer (Endo [ProvidedRep m]) ())
-> (a -> m Encoding) -> a -> Writer (Endo [ProvidedRep m]) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> m Encoding
forall (m :: * -> *) a. Monad m => a -> m a
return (Encoding -> m Encoding) -> (a -> Encoding) -> a -> m Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
forall a. ToJSON a => a -> Encoding
J.toEncoding

-- | Same as 'parseInsecureJsonBody'
--
-- @since 0.3.0
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody :: m (Result a)
parseJsonBody = m (Result a)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseInsecureJsonBody
{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}

-- | Same as 'parseCheckJsonBody', but does not check that the mime type
-- indicates JSON content.
--
-- Note: This function is vulnerable to CSRF attacks.
--
-- @since 1.6.11
parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseInsecureJsonBody :: m (Result a)
parseInsecureJsonBody = do
    Either SomeException Value
eValue <- ConduitT () Void m (Either SomeException Value)
-> m (Either SomeException Value)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m (Either SomeException Value)
 -> m (Either SomeException Value))
-> ConduitT () Void m (Either SomeException Value)
-> m (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString m ()
forall (m :: * -> *) i.
MonadHandler m =>
ConduitT i ByteString m ()
rawRequestBody ConduitT () ByteString m ()
-> ConduitM ByteString Void m (Either SomeException Value)
-> ConduitT () Void m (Either SomeException Value)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Void (CatchT m) Value
-> ConduitM ByteString Void m (Either SomeException Value)
forall (m :: * -> *) i o r.
Monad m =>
ConduitT i o (CatchT m) r
-> ConduitT i o m (Either SomeException r)
runCatchC (Parser ByteString Value
-> ConduitT ByteString Void (CatchT m) Value
forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
sinkParser Parser ByteString Value
JP.value')
    Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> m (Result a)) -> Result a -> m (Result a)
forall a b. (a -> b) -> a -> b
$ case Either SomeException Value
eValue of
        Left SomeException
e -> String -> Result a
forall a. String -> Result a
J.Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        Right Value
value -> Value -> Result a
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
value

-- | Parse the request body to a data type as a JSON value.  The
-- data type must support conversion from JSON via 'J.FromJSON'.
-- If you want the raw JSON value, just ask for a @'J.Result'
-- 'J.Value'@.
--
-- The MIME type must indicate JSON content. Requiring a JSON
-- content-type helps secure your site against CSRF attacks
-- (browsers will perform POST requests for form and text/plain
-- content-types without doing a CORS check, and those content-types
-- can easily contain valid JSON).
--
-- Note that this function will consume the request body. As such, calling it
-- twice will result in a parse error on the second call, since the request
-- body will no longer be available.
--
-- @since 0.3.0
parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseCheckJsonBody :: m (Result a)
parseCheckJsonBody = do
    Maybe ByteString
mct <- CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"content-type"
    case (ByteString -> Bool) -> Maybe ByteString -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Bool
contentTypeHeaderIsJson Maybe ByteString
mct of
        Just Bool
True -> m (Result a)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseInsecureJsonBody
        Maybe Bool
_ -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> m (Result a)) -> Result a -> m (Result a)
forall a b. (a -> b) -> a -> b
$ String -> Result a
forall a. String -> Result a
J.Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"Non-JSON content type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> String
forall a. Show a => a -> String
show Maybe ByteString
mct

-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
-- error.
parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
parseJsonBody_ :: m a
parseJsonBody_ = m a
forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireInsecureJsonBody
{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}

-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
-- error.
requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
requireJsonBody :: m a
requireJsonBody = m a
forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireInsecureJsonBody
{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}

-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
-- error.
--
-- @since 1.6.11
requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
requireInsecureJsonBody :: m a
requireInsecureJsonBody = do
    Result a
ra <- m (Result a)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseInsecureJsonBody
    case Result a
ra of
        J.Error String
s -> [Text] -> m a
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [String -> Text
pack String
s]
        J.Success a
a -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
-- error.
requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
requireCheckJsonBody :: m a
requireCheckJsonBody = do
    Result a
ra <- m (Result a)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
    case Result a
ra of
        J.Error String
s -> [Text] -> m a
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [String -> Text
pack String
s]
        J.Success a
a -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Convert a list of values to an 'J.Array'.
array :: J.ToJSON a => [a] -> J.Value
array :: [a] -> Value
array = Array -> Value
J.Array (Array -> Value) -> ([a] -> Array) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> ([a] -> [Value]) -> [a] -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. ToJSON a => a -> Value
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@ (e.g. AJAX, see 'acceptsJSON').
--
--     2. 3xx otherwise, following the PRG pattern.
jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
               => Route (HandlerSite m) -- ^ Redirect target
               -> a            -- ^ Data to send via JSON
               -> m J.Value
jsonOrRedirect :: Route (HandlerSite m) -> a -> m Value
jsonOrRedirect = (a -> Value) -> Route (HandlerSite m) -> a -> m Value
forall (m :: * -> *) a b.
MonadHandler m =>
(a -> b) -> Route (HandlerSite m) -> a -> m b
jsonOrRedirect' a -> Value
forall a. ToJSON a => a -> Value
J.toJSON

-- | jsonEncodingOrRedirect 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@ (e.g. AJAX, see 'acceptsJSON').
--
--     2. 3xx otherwise, following the PRG pattern.
-- @since 1.4.21
jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
            => Route (HandlerSite m) -- ^ Redirect target
            -> a            -- ^ Data to send via JSON
            -> m J.Encoding
jsonEncodingOrRedirect :: Route (HandlerSite m) -> a -> m Encoding
jsonEncodingOrRedirect = (a -> Encoding) -> Route (HandlerSite m) -> a -> m Encoding
forall (m :: * -> *) a b.
MonadHandler m =>
(a -> b) -> Route (HandlerSite m) -> a -> m b
jsonOrRedirect' a -> Encoding
forall a. ToJSON a => a -> Encoding
J.toEncoding

jsonOrRedirect' :: MonadHandler m
            => (a -> b)
            -> Route (HandlerSite m) -- ^ Redirect target
            -> a            -- ^ Data to send via JSON
            -> m b
jsonOrRedirect' :: (a -> b) -> Route (HandlerSite m) -> a -> m b
jsonOrRedirect' a -> b
f Route (HandlerSite m)
r a
j = do
    Bool
q <- m Bool
forall (m :: * -> *). MonadHandler m => m Bool
acceptsJson
    if Bool
q then b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
j)
         else Route (HandlerSite m) -> m b
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route (HandlerSite m)
r

-- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header.
acceptsJson :: MonadHandler m => m Bool
acceptsJson :: m Bool
acceptsJson =  (Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"application/json") (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';'))
            (Maybe ByteString -> Bool)
-> (YesodRequest -> Maybe ByteString) -> YesodRequest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe
            ([ByteString] -> Maybe ByteString)
-> (YesodRequest -> [ByteString])
-> YesodRequest
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  YesodRequest -> [ByteString]
reqAccept)
           (YesodRequest -> Bool) -> m YesodRequest -> m Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest

-- | Given the @Content-Type@ header, returns if it is JSON.
--
-- This function is currently a simple check for @application/json@, but in the future may check for
-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.
--
-- @since 1.6.17
contentTypeHeaderIsJson :: B8.ByteString -> Bool
contentTypeHeaderIsJson :: ByteString -> Bool
contentTypeHeaderIsJson ByteString
bs = (Char -> Bool) -> ByteString -> ByteString
B8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"application/json"