Payload.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A module defining the Payload type. This is used in specifications to
-- represent request body data. Currently JSON and URLEncoded bodies are
-- supported.
--
-- The module provides a FromJSON instance to parse a Payload from a
-- specification.
--
-- Payload is parsed from an object containing two keys: `bodyType` and
-- `content`.
--
-- The value of the `bodyType` field must be either `json` or
-- `urlencoded` and this indicates how the request data should be encoded.
--
-- When `bodyType` is `urlencoded ` the value of the `content` field must be an
-- object with string, numeric or boolean values.
--
-- When `bodyType` is `json` the value of the `content` field will be used as
-- the JSON payload.
--
-- If `bodyType` is not present then the whole object is used as the JSON
-- payload.
--
-- Examples:
-- 1. A URLEncoded request payload:
--
-- >  requestData:
-- >     bodyType: urlencoded
-- >     content:
-- >       key1: value
-- >       key2: true
-- >       key3: 10.22
--
-- 2: A JSON request payload using `bodyType`:
--
-- >  requestData:
-- >     bodyType: json
-- >     content:
-- >       key1: value
-- >       key2: [1,2,3]
--
-- 3: A JSON request payload without using `bodyType`:
--
-- >  requestData:
-- >     key1: value
-- >     key2: [1,2,3]
--
module Testing.CurlRunnings.Internal.Payload
  ( Payload (..)
  ) where

import           Data.Aeson
import qualified Data.Char                                   as C
import qualified Data.HashMap.Strict                         as H
import qualified Data.Text                                   as T
import           GHC.Generics
import           Testing.CurlRunnings.Internal.KeyValuePairs

data Payload = JSON Value | URLEncoded KeyValuePairs deriving Generic

instance Show Payload where
  show (JSON v) = show v
  show (URLEncoded (KeyValuePairs xs)) = T.unpack $ T.intercalate "&" $ fmap (\(KeyValuePair k v) -> k <> "=" <> v) xs

payloadTagFieldName :: T.Text
payloadTagFieldName = "bodyType"

payloadContentsFieldName :: T.Text
payloadContentsFieldName = "content"

instance FromJSON Payload where
  parseJSON v = withObject "payload" parsePayload v where
    parsePayload o = if not (H.member payloadTagFieldName o) then return (JSON v) else genericParseJSON payloadOptions v
    payloadOptions = defaultOptions { sumEncoding = TaggedObject { tagFieldName = T.unpack payloadTagFieldName
                                                                 , contentsFieldName = T.unpack payloadContentsFieldName
                                                                 }
                                    , constructorTagModifier = fmap C.toLower
                                    }

instance ToJSON Payload where
  toJSON (JSON v) = object [(payloadTagFieldName, "json"), (payloadContentsFieldName, toJSON v)]
  toJSON (URLEncoded xs) = object [(payloadTagFieldName, "urlencoded"), (payloadContentsFieldName, toJSON xs)]