-- Copyright 2020 Fernando Rincon Martin
-- 
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
-- 
--     http://www.apache.org/licenses/LICENSE-2.0
-- 
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Wai.Routing.Purescheme.Core.Entity.Json
  ( withContentNegotiationJson
  , entityJson
  )
where

import Network.Wai.Routing.Purescheme.Core.Basic
import Network.Wai.Routing.Purescheme.Core.Entity
import Network.Wai.Routing.Purescheme.Core.Internal

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.String.Interpolate.IsString (i)
import qualified Data.Text as T
import Network.HTTP.Media (MediaType, matchContent)
import Network.HTTP.Types (unsupportedMediaType415, badRequest400, statusMessage, hContentType)
import Network.Wai (Response, strictRequestBody, requestHeaders)

import Data.Aeson (ToJSON, FromJSON, eitherDecode, encode)

withContentNegotiationJson :: ((forall a. ToJSON a => EntityResponse a -> NegotiatedResponse) -> GenericApplication NegotiatedResponse) -> GenericApplication Response
withContentNegotiationJson :: ((forall a. ToJSON a => EntityResponse a -> NegotiatedResponse)
 -> GenericApplication NegotiatedResponse)
-> GenericApplication Response
withContentNegotiationJson (forall a. ToJSON a => EntityResponse a -> NegotiatedResponse)
-> GenericApplication NegotiatedResponse
f = GenericApplication NegotiatedResponse
-> GenericApplication Response
withCustomNegotiation (GenericApplication NegotiatedResponse
 -> GenericApplication Response)
-> GenericApplication NegotiatedResponse
-> GenericApplication Response
forall a b. (a -> b) -> a -> b
$ (forall a. ToJSON a => EntityResponse a -> NegotiatedResponse)
-> GenericApplication NegotiatedResponse
f ((forall a. ToJSON a => EntityResponse a -> NegotiatedResponse)
 -> GenericApplication NegotiatedResponse)
-> (forall a. ToJSON a => EntityResponse a -> NegotiatedResponse)
-> GenericApplication NegotiatedResponse
forall a b. (a -> b) -> a -> b
$ [(ByteString, a -> ByteString)]
-> EntityResponse a -> NegotiatedResponse
forall a.
[(ByteString, a -> ByteString)]
-> EntityResponse a -> NegotiatedResponse
negotiated [(ByteString, a -> ByteString)]
forall a. ToJSON a => [(ByteString, a -> ByteString)]
negotiationJson

negotiationJson :: ToJSON a => [(ByteString, a -> LBS.ByteString)]
negotiationJson :: [(ByteString, a -> ByteString)]
negotiationJson = 
  [ (ByteString
"application/json", a -> ByteString
forall a. ToJSON a => a -> ByteString
encode)
  ]


-- TODO: We are doing strictRequestBody that means, we are going to read all the body in memory
-- so that we need to have a guard on the bytes of the content (Content-Length)
entityJson :: FromJSON a => (a -> GenericApplication b) -> GenericApplication b
entityJson :: (a -> GenericApplication b) -> GenericApplication b
entityJson a -> GenericApplication b
inner Request
req b -> IO ResponseReceived
respond = 
  if Bool
isValidContentType
    then do
      ByteString
valueString <- Request -> IO ByteString
strictRequestBody Request
req
      case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
valueString of
        Right a
result -> a -> GenericApplication b
inner a
result Request
req b -> IO ResponseReceived
respond
        Left String
decodeError -> Rejection -> IO ResponseReceived
reject' (Rejection -> IO ResponseReceived)
-> Rejection -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Text -> Rejection
decodeErrorRejection (Text -> Rejection) -> Text -> Rejection
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
decodeError
    else Rejection -> IO ResponseReceived
reject' (Rejection -> IO ResponseReceived)
-> Rejection -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Text -> Rejection
unsupportedMediaTypeRejection Text
"Content-Type not supported"
  where
    isValidContentType :: Bool
isValidContentType = 
      case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req of 
        Maybe ByteString
Nothing -> Bool
True
        Just ByteString
contentTypeHeader -> case [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
matchContent [MediaType
"application/json" :: MediaType] ByteString
contentTypeHeader of
          Maybe MediaType
Nothing -> Bool
False
          Just MediaType
_ -> Bool
True

unsupportedMediaTypeRejection :: T.Text -> Rejection
unsupportedMediaTypeRejection :: Text -> Rejection
unsupportedMediaTypeRejection Text
errorMessage =
  Rejection :: Text -> Int -> Status -> [(HeaderName, ByteString)] -> Rejection
Rejection
    { status :: Status
status = Status
unsupportedMediaType415
    , message :: Text
message = [i|#{statusMessage unsupportedMediaType415}: #{errorMessage}|]
    , priority :: Int
priority = Int
200
    , headers :: [(HeaderName, ByteString)]
headers = []
    }

decodeErrorRejection :: T.Text -> Rejection
decodeErrorRejection :: Text -> Rejection
decodeErrorRejection Text
errorMessage =
  Rejection :: Text -> Int -> Status -> [(HeaderName, ByteString)] -> Rejection
Rejection
    { status :: Status
status = Status
badRequest400
    , message :: Text
message = [i|#{statusMessage badRequest400}: Error decoding entity body: #{errorMessage}|]
    , priority :: Int
priority = Int
300
    , headers :: [(HeaderName, ByteString)]
headers = []
    }