{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
module Web.Eved.ContentType
    where

import           Control.Monad
import           Data.Aeson
import           Data.Bifunctor       (first)
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as LBS
import           Data.List.NonEmpty   (NonEmpty)
import qualified Data.List.NonEmpty   as NE
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Network.HTTP.Media
import           Network.HTTP.Types

data ContentType a = ContentType
    { ContentType a -> a -> (RequestHeaders, ByteString)
toContentType   :: a -> (RequestHeaders, LBS.ByteString)
    , ContentType a -> (RequestHeaders, ByteString) -> Either Text a
fromContentType :: (RequestHeaders, LBS.ByteString) -> Either Text a
    , ContentType a -> NonEmpty MediaType
mediaTypes      :: NonEmpty MediaType
    }

json :: (FromJSON a, ToJSON a, Applicative f) => f (ContentType a)
json :: f (ContentType a)
json = ContentType a -> f (ContentType a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContentType a -> f (ContentType a))
-> ContentType a -> f (ContentType a)
forall a b. (a -> b) -> a -> b
$ ContentType :: forall a.
(a -> (RequestHeaders, ByteString))
-> ((RequestHeaders, ByteString) -> Either Text a)
-> NonEmpty MediaType
-> ContentType a
ContentType
    { toContentType :: a -> (RequestHeaders, ByteString)
toContentType = (RequestHeaders
forall a. Monoid a => a
mempty,) (ByteString -> (RequestHeaders, ByteString))
-> (a -> ByteString) -> a -> (RequestHeaders, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode
    , fromContentType :: (RequestHeaders, ByteString) -> Either Text a
fromContentType = (String -> Text) -> Either String a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack (Either String a -> Either Text a)
-> ((RequestHeaders, ByteString) -> Either String a)
-> (RequestHeaders, ByteString)
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> ((RequestHeaders, ByteString) -> ByteString)
-> (RequestHeaders, ByteString)
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RequestHeaders, ByteString) -> ByteString
forall a b. (a, b) -> b
snd
    , mediaTypes :: NonEmpty MediaType
mediaTypes = [MediaType] -> NonEmpty MediaType
forall a. [a] -> NonEmpty a
NE.fromList [ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json"]
    }

data WithHeaders a = WithHeaders RequestHeaders a

addHeaders :: RequestHeaders -> a -> WithHeaders a
addHeaders :: RequestHeaders -> a -> WithHeaders a
addHeaders = RequestHeaders -> a -> WithHeaders a
forall a. RequestHeaders -> a -> WithHeaders a
WithHeaders

withHeaders :: Functor f => f (ContentType a) -> f (ContentType (WithHeaders a))
withHeaders :: f (ContentType a) -> f (ContentType (WithHeaders a))
withHeaders = (ContentType a -> ContentType (WithHeaders a))
-> f (ContentType a) -> f (ContentType (WithHeaders a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ContentType a -> ContentType (WithHeaders a))
 -> f (ContentType a) -> f (ContentType (WithHeaders a)))
-> (ContentType a -> ContentType (WithHeaders a))
-> f (ContentType a)
-> f (ContentType (WithHeaders a))
forall a b. (a -> b) -> a -> b
$ \ContentType a
ctype ->
    ContentType :: forall a.
(a -> (RequestHeaders, ByteString))
-> ((RequestHeaders, ByteString) -> Either Text a)
-> NonEmpty MediaType
-> ContentType a
ContentType
        { toContentType :: WithHeaders a -> (RequestHeaders, ByteString)
toContentType = \(WithHeaders RequestHeaders
rHeaders a
val) -> (RequestHeaders
rHeaders, (RequestHeaders, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((RequestHeaders, ByteString) -> ByteString)
-> (RequestHeaders, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ContentType a -> a -> (RequestHeaders, ByteString)
forall a. ContentType a -> a -> (RequestHeaders, ByteString)
toContentType ContentType a
ctype a
val)
        , fromContentType :: (RequestHeaders, ByteString) -> Either Text (WithHeaders a)
fromContentType = \(RequestHeaders
rHeaders, ByteString
rBody) -> (a -> WithHeaders a)
-> Either Text a -> Either Text (WithHeaders a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RequestHeaders -> a -> WithHeaders a
forall a. RequestHeaders -> a -> WithHeaders a
WithHeaders RequestHeaders
rHeaders) (ContentType a -> (RequestHeaders, ByteString) -> Either Text a
forall a.
ContentType a -> (RequestHeaders, ByteString) -> Either Text a
fromContentType ContentType a
ctype (RequestHeaders
forall a. Monoid a => a
mempty, ByteString
rBody))
        , mediaTypes :: NonEmpty MediaType
mediaTypes = ContentType a -> NonEmpty MediaType
forall a. ContentType a -> NonEmpty MediaType
mediaTypes ContentType a
ctype
        }

acceptHeader :: NonEmpty (ContentType a) -> Header
acceptHeader :: NonEmpty (ContentType a) -> Header
acceptHeader NonEmpty (ContentType a)
ctypes = (HeaderName
hAccept, [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader ([MediaType] -> ByteString) -> [MediaType] -> ByteString
forall a b. (a -> b) -> a -> b
$ NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ ContentType a -> NonEmpty MediaType
forall a. ContentType a -> NonEmpty MediaType
mediaTypes (ContentType a -> NonEmpty MediaType)
-> NonEmpty (ContentType a) -> NonEmpty MediaType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty (ContentType a)
ctypes)

contentTypeHeader :: ContentType a -> Header
contentTypeHeader :: ContentType a -> Header
contentTypeHeader ContentType a
ctype = (HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader (MediaType -> ByteString) -> MediaType -> ByteString
forall a b. (a -> b) -> a -> b
$ NonEmpty MediaType -> MediaType
forall a. NonEmpty a -> a
NE.head (NonEmpty MediaType -> MediaType)
-> NonEmpty MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$ ContentType a -> NonEmpty MediaType
forall a. ContentType a -> NonEmpty MediaType
mediaTypes ContentType a
ctype)

collectMediaTypes :: (ContentType a -> MediaType -> b) -> NonEmpty (ContentType a) -> [b]
collectMediaTypes :: (ContentType a -> MediaType -> b)
-> NonEmpty (ContentType a) -> [b]
collectMediaTypes ContentType a -> MediaType -> b
f NonEmpty (ContentType a)
ctypes =
    NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty b -> [b]) -> NonEmpty b -> [b]
forall a b. (a -> b) -> a -> b
$ NonEmpty (ContentType a)
ctypes NonEmpty (ContentType a)
-> (ContentType a -> NonEmpty b) -> NonEmpty b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ContentType a
ctype ->
      (MediaType -> b) -> NonEmpty MediaType -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ContentType a -> MediaType -> b
f ContentType a
ctype) (ContentType a -> NonEmpty MediaType
forall a. ContentType a -> NonEmpty MediaType
mediaTypes ContentType a
ctype)
    )

chooseAcceptCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (MediaType, a -> (RequestHeaders, LBS.ByteString))
chooseAcceptCType :: NonEmpty (ContentType a)
-> ByteString
-> Maybe (MediaType, a -> (RequestHeaders, ByteString))
chooseAcceptCType NonEmpty (ContentType a)
ctypes =
    [(MediaType, (MediaType, a -> (RequestHeaders, ByteString)))]
-> ByteString
-> Maybe (MediaType, a -> (RequestHeaders, ByteString))
forall b. [(MediaType, b)] -> ByteString -> Maybe b
mapAcceptMedia ([(MediaType, (MediaType, a -> (RequestHeaders, ByteString)))]
 -> ByteString
 -> Maybe (MediaType, a -> (RequestHeaders, ByteString)))
-> [(MediaType, (MediaType, a -> (RequestHeaders, ByteString)))]
-> ByteString
-> Maybe (MediaType, a -> (RequestHeaders, ByteString))
forall a b. (a -> b) -> a -> b
$ (ContentType a
 -> MediaType
 -> (MediaType, (MediaType, a -> (RequestHeaders, ByteString))))
-> NonEmpty (ContentType a)
-> [(MediaType, (MediaType, a -> (RequestHeaders, ByteString)))]
forall a b.
(ContentType a -> MediaType -> b)
-> NonEmpty (ContentType a) -> [b]
collectMediaTypes (\ContentType a
ctype MediaType
x -> (MediaType
x, (MediaType
x, ContentType a -> a -> (RequestHeaders, ByteString)
forall a. ContentType a -> a -> (RequestHeaders, ByteString)
toContentType ContentType a
ctype))) NonEmpty (ContentType a)
ctypes

chooseContentCType :: NonEmpty (ContentType a) -> RequestHeaders -> BS.ByteString -> Maybe (LBS.ByteString -> Either Text a)
chooseContentCType :: NonEmpty (ContentType a)
-> RequestHeaders
-> ByteString
-> Maybe (ByteString -> Either Text a)
chooseContentCType NonEmpty (ContentType a)
ctypes RequestHeaders
rHeaders =
    [(MediaType, ByteString -> Either Text a)]
-> ByteString -> Maybe (ByteString -> Either Text a)
forall b. [(MediaType, b)] -> ByteString -> Maybe b
mapContentMedia ([(MediaType, ByteString -> Either Text a)]
 -> ByteString -> Maybe (ByteString -> Either Text a))
-> [(MediaType, ByteString -> Either Text a)]
-> ByteString
-> Maybe (ByteString -> Either Text a)
forall a b. (a -> b) -> a -> b
$ (ContentType a
 -> MediaType -> (MediaType, ByteString -> Either Text a))
-> NonEmpty (ContentType a)
-> [(MediaType, ByteString -> Either Text a)]
forall a b.
(ContentType a -> MediaType -> b)
-> NonEmpty (ContentType a) -> [b]
collectMediaTypes (\ContentType a
ctype MediaType
x -> (MediaType
x, ContentType a -> (RequestHeaders, ByteString) -> Either Text a
forall a.
ContentType a -> (RequestHeaders, ByteString) -> Either Text a
fromContentType ContentType a
ctype ((RequestHeaders, ByteString) -> Either Text a)
-> (ByteString -> (RequestHeaders, ByteString))
-> ByteString
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RequestHeaders
rHeaders,))) NonEmpty (ContentType a)
ctypes