{-# LANGUAGE OverloadedStrings #-}

module Servant.Benchmark.Endpoint where

import Control.Applicative ((<|>))
import qualified Data.ByteString as BS
import Data.CaseInsensitive (mk)
import Data.Maybe (maybeToList)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Media (MediaType, RenderHeader (renderHeader), (//), (/:))
import Network.HTTP.Types (Method, hContentType)
import Network.HTTP.Types.Header (Header)

{- | An API endpoint.
-
-}
data Endpoint = MkEndpoint
    { Endpoint -> Text
name :: T.Text
    , -- All endpoint request paths
      Endpoint -> Text
path :: T.Text
    , -- The endpoint request method
      Endpoint -> Maybe Method
method :: Maybe Method
    , -- | The request value, where applicable.
      -- Only the first encountered request value is taken into consideration
      -- eg. "user" :> ReqBody '[JSON] Text :> ReqBody '[JSON] Int :> Get '[JSON] User
      -- will produce only a `Text` based request value
      Endpoint -> Maybe Method
body :: Maybe BS.ByteString
    , -- | The requests content type.
      -- Only the first encountered content type is taken into consideration.
      -- If you're building an endpoint manually, you should enter the media type here
      -- rather than directly in headers. All implementations automatically include the
      -- content type header during benchmark configuration output.
      Endpoint -> Maybe MediaType
contentType :: Maybe MediaType
    , -- | The request headers
      Endpoint -> [Header]
headers :: [Header]
    }
    deriving (Int -> Endpoint -> ShowS
[Endpoint] -> ShowS
Endpoint -> String
(Int -> Endpoint -> ShowS)
-> (Endpoint -> String) -> ([Endpoint] -> ShowS) -> Show Endpoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Endpoint] -> ShowS
$cshowList :: [Endpoint] -> ShowS
show :: Endpoint -> String
$cshow :: Endpoint -> String
showsPrec :: Int -> Endpoint -> ShowS
$cshowsPrec :: Int -> Endpoint -> ShowS
Show, Endpoint -> Endpoint -> Bool
(Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool) -> Eq Endpoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Endpoint -> Endpoint -> Bool
$c/= :: Endpoint -> Endpoint -> Bool
== :: Endpoint -> Endpoint -> Bool
$c== :: Endpoint -> Endpoint -> Bool
Eq)

instance Semigroup Endpoint where
    Endpoint
a <> :: Endpoint -> Endpoint -> Endpoint
<> Endpoint
b =
        Text
-> Text
-> Maybe Method
-> Maybe Method
-> Maybe MediaType
-> [Header]
-> Endpoint
MkEndpoint
            (Endpoint -> Text
name Endpoint
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Endpoint -> Text
name Endpoint
b)
            (Endpoint -> Text
path Endpoint
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Endpoint -> Text
path Endpoint
b)
            (Endpoint -> Maybe Method
method Endpoint
a Maybe Method -> Maybe Method -> Maybe Method
forall a. Semigroup a => a -> a -> a
<> Endpoint -> Maybe Method
method Endpoint
b)
            (Endpoint -> Maybe Method
body Endpoint
a Maybe Method -> Maybe Method -> Maybe Method
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Endpoint -> Maybe Method
body Endpoint
b)
            (Endpoint -> Maybe MediaType
contentType Endpoint
a Maybe MediaType -> Maybe MediaType -> Maybe MediaType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Endpoint -> Maybe MediaType
contentType Endpoint
b)
            (Endpoint -> [Header]
headers Endpoint
a [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> Endpoint -> [Header]
headers Endpoint
b)

instance Monoid Endpoint where
    mempty :: Endpoint
mempty = Text
-> Text
-> Maybe Method
-> Maybe Method
-> Maybe MediaType
-> [Header]
-> Endpoint
MkEndpoint Text
forall a. Monoid a => a
mempty Text
forall a. Monoid a => a
mempty Maybe Method
forall a. Monoid a => a
mempty Maybe Method
forall a. Maybe a
Nothing Maybe MediaType
forall a. Maybe a
Nothing []

{- | Pack an endpoint created from an API interpretation in a form
 ready to be serialized.
 - This is only useful if your are building your own output.
-}
pack :: Endpoint -> Endpoint
pack :: Endpoint -> Endpoint
pack Endpoint
endpoint =
    Endpoint
endpoint
        { contentType :: Maybe MediaType
contentType = Maybe MediaType
forall a. Maybe a
Nothing
        , headers :: [Header]
headers = [Header]
ct [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Endpoint -> [Header]
headers Endpoint
endpoint
        }
  where
    ct :: [Header]
ct = Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList Maybe Header
ctHeader
    ctHeader :: Maybe Header
ctHeader = (,) HeaderName
hContentType (Method -> Header) -> Maybe Method -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MediaType -> Method) -> Maybe MediaType -> Maybe Method
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MediaType -> Method
forall h. RenderHeader h => h -> Method
renderHeader (Endpoint -> Maybe MediaType
contentType Endpoint
endpoint)

-- | Create a `Header` from two `Text` inputs
mkHeader :: T.Text -> T.Text -> Header
mkHeader :: Text -> Text -> Header
mkHeader Text
ciName Text
value =
    (Method -> HeaderName
forall s. FoldCase s => s -> CI s
mk (Method -> HeaderName) -> Method -> HeaderName
forall a b. (a -> b) -> a -> b
$ Text -> Method
T.encodeUtf8 Text
ciName, Text -> Method
T.encodeUtf8 Text
value)

-- * Content Types

-- | application/json
ctJSON :: MediaType
ctJSON :: MediaType
ctJSON = Method
hApplication Method -> Method -> MediaType
// Method
hJSON

-- | text/plain ; charset=utf-8
ctPlainText :: MediaType
ctPlainText :: MediaType
ctPlainText = Method
hText Method -> Method -> MediaType
// Method
hPlain MediaType -> (Method, Method) -> MediaType
/: (Method
hCharset, Method
hUTF8)

-- | application
hApplication :: BS.ByteString
hApplication :: Method
hApplication = Method
"application"

-- | json
hJSON :: BS.ByteString
hJSON :: Method
hJSON = Method
"json"

-- | text
hText :: BS.ByteString
hText :: Method
hText = Method
"text"

-- | plain
hPlain :: BS.ByteString
hPlain :: Method
hPlain = Method
"plain"

-- | charset
hCharset :: BS.ByteString
hCharset :: Method
hCharset = Method
"charset"

-- | utf-8
hUTF8 :: BS.ByteString
hUTF8 :: Method
hUTF8 = Method
"utf-8"