content: -- |
  -- Module      : PostgREST.ApiRequest.Payload
  -- Description : Parser for PostgREST Request Body
  --
  -- This module is in charge of parsing the request body (payload)
  --
  {-# LANGUAGE LambdaCase     #-}
  {-# LANGUAGE NamedFieldPuns #-}
  module PostgREST.ApiRequest.Payload
    ( getPayload
    ) where
  
  import qualified Data.Aeson            as JSON
  import qualified Data.Aeson.Key        as K
  import qualified Data.Aeson.KeyMap     as KM
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.ByteString.Lazy  as LBS
  import qualified Data.Csv              as CSV
  import qualified Data.HashMap.Strict   as HM
  import qualified Data.Map.Strict       as M
  import qualified Data.Set              as S
  import qualified Data.Text.Encoding    as T
  import qualified Data.Vector           as V
  
  import Control.Arrow           ((***))
  import Data.Aeson.Types        (emptyArray, emptyObject)
  import Data.Either.Combinators (mapBoth)
  import Network.HTTP.Types.URI  (parseSimpleQuery)
  
  import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
  import PostgREST.ApiRequest.Types
  import PostgREST.Error                   (ApiRequestError (..))
  import PostgREST.MediaType               (MediaType (..))
  import PostgREST.SchemaCache.Identifiers (FieldName)
  
  import qualified PostgREST.MediaType as MediaType
  
  import Protolude
  
  getPayload :: RequestBody -> MediaType -> QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
  getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
    checkedPayload <- if shouldParsePayload then payload else Right Nothing
    let cols = case (checkedPayload, columns) of
          (Just ProcessedJSON{payKeys}, _)       -> payKeys
          (Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
          (Just RawJSON{}, Just cls)             -> cls
          _                                      -> S.empty
    return (checkedPayload, cols)
    where
      payload :: Either ApiRequestError (Maybe Payload)
      payload = mapBoth InvalidBody Just $ case (contentMediaType, isProc) of
        (MTApplicationJSON, _) ->
          if isJust columns
            then Right $ RawJSON reqBody
            else note "All object keys must match" . payloadAttributes reqBody
                   =<< if LBS.null reqBody && isProc
                         then Right emptyObject
                         else first BS.pack $
                            -- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
                            maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
        (MTTextCSV, _) -> do
          json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
          note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
        (MTUrlEncoded, True) ->
          Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
        (MTUrlEncoded, False) ->
          let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
          Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
        (MTTextPlain, True) -> Right $ RawPay reqBody
        (MTTextXML, True) -> Right $ RawPay reqBody
        (MTOctetStream, True) -> Right $ RawPay reqBody
        (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
  
      shouldParsePayload = case action of
        ActDb (ActRelationMut _ MutationDelete) -> False
        ActDb (ActRelationMut _ _)              -> True
        ActDb (ActRoutine _  Inv)               -> True
        _                                       -> False
  
      columns = case action of
        ActDb (ActRelationMut _ MutationCreate) -> qsColumns
        ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
        ActDb (ActRoutine     _ Inv)            -> qsColumns
        _                                       -> Nothing
  
      isProc = case action of
        ActDb (ActRoutine _ _) -> True
        _                      -> False
      params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
  
  type CsvData = V.Vector (M.Map Text LBS.ByteString)
  
  {-|
    Converts CSV like
    a,b
    1,hi
    2,bye
  
    into a JSON array like
    [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
  
    The reason for its odd signature is so that it can compose
    directly with CSV.decodeByName
  -}
  csvToJson :: (CSV.Header, CsvData) -> JSON.Value
  csvToJson (_, vals) =
    JSON.Array $ V.map rowToJsonObj vals
   where
    rowToJsonObj = JSON.Object . KM.fromMapText .
      M.map (\str ->
          if str == "NULL"
            then JSON.Null
            else JSON.String . T.decodeUtf8 $ LBS.toStrict str
        )
  
  payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
  payloadAttributes raw json =
    -- Test that Array contains only Objects having the same keys
    case json of
      JSON.Array arr ->
        case arr V.!? 0 of
          Just (JSON.Object o) ->
            let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
                areKeysUniform = all (\case
                  JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
                  _ -> False) arr in
            if areKeysUniform
              then Just $ ProcessedJSON raw canonicalKeys
              else Nothing
          Just _ -> Nothing
          Nothing -> Just emptyPJArray
  
      JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
  
      -- truncate everything else to an empty array.
      _ -> Just emptyPJArray
    where
      emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
  