-- 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 TemplateHaskell #-}
module Network.Wai.Routing.Purescheme.Core.Entity
  ( EntityResponse
  , entity
  , NegotiatedResponse
  , mapEntity
  , withCustomNegotiation
  , withCustomNegotiation'
  , negotiated
  , ok
  , created
  , notFound
  , badRequest
  , entityResponse
  , requestEntity
  )
where

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

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as LBC
import qualified Data.ByteString.Lazy as LBS
import Data.List (find)
import Data.Maybe (fromJust, fromMaybe)
import Data.String.Interpolate.IsString (i)
import Network.HTTP.Media (matchAccept, mapAccept)
import Network.HTTP.Types (Status, ResponseHeaders, notAcceptable406, hAccept, hContentType, 
  statusMessage, badRequest400, unsupportedMediaType415, ok200, created201, notFound404)
import Network.Wai (Response, ResponseReceived, responseLBS, requestHeaders, strictRequestBody)

data EntityResponse e = EntityResponse Status ResponseHeaders e

data NegotiatedResponse = NegotiatedResponse Status ResponseHeaders [(ByteString, LBS.ByteString)]

instance HasResponseHeaders (EntityResponse a) where
  mapResponseHeaders :: (ResponseHeaders -> ResponseHeaders)
-> EntityResponse a -> EntityResponse a
mapResponseHeaders ResponseHeaders -> ResponseHeaders
mapf (EntityResponse Status
responseStatus ResponseHeaders
responseHeaders a
entity) = 
    Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
responseStatus (ResponseHeaders -> ResponseHeaders
mapf ResponseHeaders
responseHeaders) a
entity

instance HasResponseHeaders (NegotiatedResponse) where
  mapResponseHeaders :: (ResponseHeaders -> ResponseHeaders)
-> NegotiatedResponse -> NegotiatedResponse
mapResponseHeaders ResponseHeaders -> ResponseHeaders
mapf (NegotiatedResponse Status
negotiatedStatus ResponseHeaders
negotiatedHeaders [(ByteString, ByteString)]
entity) = 
    Status
-> ResponseHeaders
-> [(ByteString, ByteString)]
-> NegotiatedResponse
NegotiatedResponse Status
negotiatedStatus (ResponseHeaders -> ResponseHeaders
mapf ResponseHeaders
negotiatedHeaders) [(ByteString, ByteString)]
entity

-- | Entity Accessor
entity :: EntityResponse e -> e
entity :: EntityResponse e -> e
entity (EntityResponse Status
_ ResponseHeaders
_ e
e) = e
e

-- | Maps a entity response
mapEntity :: (a -> b) -> EntityResponse a -> EntityResponse b
mapEntity :: (a -> b) -> EntityResponse a -> EntityResponse b
mapEntity a -> b
mapf (EntityResponse Status
responseStatus ResponseHeaders
responseHeaders a
entity) = 
  Status -> ResponseHeaders -> b -> EntityResponse b
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
responseStatus ResponseHeaders
responseHeaders (a -> b
mapf a
entity) 

-- | Converts an application of NegotiatedResponse to a normal WAI Application
-- 
-- This will reject the request with not acceptable (406) in case the content negotation
-- fail
-- 
-- Note: This is going to do the content negotiation after the inner application has repond with 
-- a NegotiatedResponse. That means, any IO is performed before the conetent negoatiation happen.
-- TODO: Find another way to do custom negotiation
-- Better to use @'withCustomNegotiation''
withCustomNegotiation :: GenericApplication NegotiatedResponse -> GenericApplication Response
withCustomNegotiation :: GenericApplication NegotiatedResponse
-> GenericApplication Response
withCustomNegotiation GenericApplication NegotiatedResponse
inner Request
req Response -> IO ResponseReceived
respond = GenericApplication NegotiatedResponse
inner Request
req NegotiatedResponse -> IO ResponseReceived
processNegotiated
  where

    processNegotiated :: NegotiatedResponse -> IO ResponseReceived
    processNegotiated :: NegotiatedResponse -> IO ResponseReceived
processNegotiated (NegotiatedResponse Status
responseStatus ResponseHeaders
responseHeaders [(ByteString, ByteString)]
responses) =
      let
        acceptedMediaTypes :: [ByteString]
acceptedMediaTypes = ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, ByteString)]
responses
        respondUsing :: (ByteString, ByteString) -> IO ResponseReceived
respondUsing (ByteString
mediaType, ByteString
payload) = 
          let
            newHeaders :: ResponseHeaders
newHeaders = ResponseHeaders -> Header -> ResponseHeaders
addOrReplaceHeader ResponseHeaders
responseHeaders (HeaderName
hContentType, ByteString
mediaType)
            response :: Response
response = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
responseStatus ResponseHeaders
newHeaders ByteString
payload
          in Response -> IO ResponseReceived
respond Response
response
      in
        case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req of
          Maybe ByteString
Nothing -> (ByteString, ByteString) -> IO ResponseReceived
respondUsing ((ByteString, ByteString) -> IO ResponseReceived)
-> (ByteString, ByteString) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> (ByteString, ByteString)
forall a. [a] -> a
head [(ByteString, ByteString)]
responses
          Just ByteString
"*/*" -> (ByteString, ByteString) -> IO ResponseReceived
respondUsing ((ByteString, ByteString) -> IO ResponseReceived)
-> (ByteString, ByteString) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> (ByteString, ByteString)
forall a. [a] -> a
head [(ByteString, ByteString)]
responses
          Just ByteString
accept -> case [ByteString] -> ByteString -> Maybe ByteString
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept [ByteString]
acceptedMediaTypes ByteString
accept of
            Maybe ByteString
Nothing -> Rejection -> IO ResponseReceived
reject' (Rejection -> IO ResponseReceived)
-> Rejection -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Rejection
notAcceptableRejection [ByteString]
acceptedMediaTypes
            Just ByteString
accepted -> (ByteString, ByteString) -> IO ResponseReceived
respondUsing ((ByteString, ByteString) -> IO ResponseReceived)
-> (ByteString, ByteString) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Maybe (ByteString, ByteString) -> (ByteString, ByteString)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (ByteString, ByteString) -> (ByteString, ByteString))
-> Maybe (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> Maybe (ByteString, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(ByteString
k, ByteString
_) -> ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
accepted) [(ByteString, ByteString)]
responses

-- | The same than @'withCustomNegotiation' but checking the Accept header before doing any IO
withCustomNegotiation' :: [ByteString] -> GenericApplication NegotiatedResponse -> GenericApplication Response
withCustomNegotiation' :: [ByteString]
-> GenericApplication NegotiatedResponse
-> GenericApplication Response
withCustomNegotiation' [ByteString]
accepted GenericApplication NegotiatedResponse
inner Request
req = 
  let
    doit :: (Response -> IO ResponseReceived) -> IO ResponseReceived
doit = GenericApplication NegotiatedResponse
-> GenericApplication Response
withCustomNegotiation GenericApplication NegotiatedResponse
inner Request
req
  in
    case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req of 
      Maybe ByteString
Nothing -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doit
      Just ByteString
"*/*" -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doit
      Just ByteString
accept -> case [ByteString] -> ByteString -> Maybe ByteString
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept [ByteString]
accepted ByteString
accept of
        Maybe ByteString
Nothing -> Rejection
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall r.
Rejection -> (r -> IO ResponseReceived) -> IO ResponseReceived
reject (Rejection
 -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
-> Rejection
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Rejection
notAcceptableRejection [ByteString]
accepted
        Just ByteString
_ -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doit

notAcceptableRejection :: [ByteString] -> Rejection
notAcceptableRejection :: [ByteString] -> Rejection
notAcceptableRejection [ByteString]
acceptedResponses = 
  Rejection :: Text -> Int -> Status -> ResponseHeaders -> Rejection
Rejection
    { status :: Status
status = Status
notAcceptable406
    , message :: Text
message = [i|#{statusMessage notAcceptable406}: Acceptable media types: #{LBC.intercalate ", " acceptedResponses}|]
    , priority :: Int
priority = Int
200
    , headers :: ResponseHeaders
headers = []
    }

-- | Converts a entity response to a negotiated entity
negotiated :: [(ByteString, a -> LBS.ByteString)] -> EntityResponse a ->  NegotiatedResponse
negotiated :: [(ByteString, a -> ByteString)]
-> EntityResponse a -> NegotiatedResponse
negotiated [(ByteString, a -> ByteString)]
accptableResponses (EntityResponse Status
responseStatus ResponseHeaders
responseHeaders a
entity) = 
  Status
-> ResponseHeaders
-> [(ByteString, ByteString)]
-> NegotiatedResponse
NegotiatedResponse Status
responseStatus ResponseHeaders
responseHeaders (((ByteString, a -> ByteString) -> (ByteString, ByteString))
-> [(ByteString, a -> ByteString)] -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
key, a -> ByteString
v) -> (ByteString
key, a -> ByteString
v a
entity)) [(ByteString, a -> ByteString)]
accptableResponses)
  -- TODO: This uses lazyness from haskell so that not all payloads are generated

-- | Reads the entity and pass it to provided function
--
-- The map provides the accepted media types with the functions that decodes it
-- 
-- As specified in https://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- a missing content type header from the request is treated "application/octet-stream"
--
-- Note: This will read all the payload in memory and then decode it
-- so it can blow up the memory. Better to have a guard on the size of the request
requestEntity :: [(ByteString, LBS.ByteString -> Either String a)] -> (a -> GenericApplication b) -> GenericApplication b
requestEntity :: [(ByteString, ByteString -> Either String a)]
-> (a -> GenericApplication b) -> GenericApplication b
requestEntity [(ByteString, ByteString -> Either String a)]
mappings a -> GenericApplication b
fa Request
req b -> IO ResponseReceived
respond = 
  let 
    contentTypeHeader :: ByteString
contentTypeHeader = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
  in
    case [(ByteString, ByteString -> Either String a)]
-> ByteString -> Maybe (ByteString -> Either String a)
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept [(ByteString, ByteString -> Either String a)]
mappings ByteString
contentTypeHeader of
      Just ByteString -> Either String a
decodeFunc -> do
        Either String a
decodedOrError <- ByteString -> Either String a
decodeFunc (ByteString -> Either String a)
-> IO ByteString -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO ByteString
strictRequestBody Request
req
        case Either String a
decodedOrError of
          Left String
decodeError -> Rejection -> IO ResponseReceived
reject' (Rejection -> IO ResponseReceived)
-> Rejection -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> Rejection
decodeErrorRejection String
decodeError
          Right a
decoded -> a -> GenericApplication b
fa a
decoded Request
req b -> IO ResponseReceived
respond
      Maybe (ByteString -> Either String a)
Nothing -> Rejection -> IO ResponseReceived
reject' (Rejection -> IO ResponseReceived)
-> Rejection -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Rejection
unsupportedMediaTypeRejection ([ByteString] -> Rejection) -> [ByteString] -> Rejection
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString -> Either String a) -> ByteString)
-> [(ByteString, ByteString -> Either String a)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, ByteString -> Either String a) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, ByteString -> Either String a)]
mappings

decodeErrorRejection :: String -> Rejection
decodeErrorRejection :: String -> Rejection
decodeErrorRejection String
reason = 
  Rejection :: Text -> Int -> Status -> ResponseHeaders -> Rejection
Rejection
    { status :: Status
status = Status
badRequest400
    , message :: Text
message = [i|#{statusMessage badRequest400}: Error reading entity: #{reason}|]
    , priority :: Int
priority = Int
200
    , headers :: ResponseHeaders
headers = []
    }

unsupportedMediaTypeRejection :: [ByteString] -> Rejection
unsupportedMediaTypeRejection :: [ByteString] -> Rejection
unsupportedMediaTypeRejection [ByteString]
supportedMediaTypes = 
  Rejection :: Text -> Int -> Status -> ResponseHeaders -> Rejection
Rejection
    { status :: Status
status = Status
unsupportedMediaType415
    , message :: Text
message = [i|#{statusMessage unsupportedMediaType415}: Supported Media Types: #{LBC.intercalate ", " supportedMediaTypes}|]
    , priority :: Int
priority = Int
200
    , headers :: ResponseHeaders
headers = []
    }

-- | Creates an entity response with status 200
ok :: a -> EntityResponse a
ok :: a -> EntityResponse a
ok = Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
ok200 []

-- | Creates a entity response with status 201
created :: a -> EntityResponse a
created :: a -> EntityResponse a
created = Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
created201 []

-- | Creates an entity response with status 404
notFound :: a -> EntityResponse a
notFound :: a -> EntityResponse a
notFound = Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
notFound404 []

-- | Creates an entity response with status 400
badRequest :: a -> EntityResponse a
badRequest :: a -> EntityResponse a
badRequest = Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse Status
badRequest400 []

-- | Creates a entity response with the provided status and response headers
entityResponse :: Status -> ResponseHeaders -> a -> EntityResponse a
entityResponse :: Status -> ResponseHeaders -> a -> EntityResponse a
entityResponse = Status -> ResponseHeaders -> a -> EntityResponse a
forall e. Status -> ResponseHeaders -> e -> EntityResponse e
EntityResponse