{-# LANGUAGE OverloadedStrings #-}
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 -> ByteString
toContentType   :: a -> LBS.ByteString
    , ContentType a -> ByteString -> Either Text a
fromContentType :: 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 -> ByteString)
-> (ByteString -> Either Text a)
-> NonEmpty MediaType
-> ContentType a
ContentType
    { toContentType :: a -> ByteString
toContentType = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode
    , fromContentType :: 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)
-> (ByteString -> Either String a) -> 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
    , mediaTypes :: NonEmpty MediaType
mediaTypes = [MediaType] -> NonEmpty MediaType
forall a. [a] -> NonEmpty a
NE.fromList [ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json"]
    }

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 -> LBS.ByteString)
chooseAcceptCType :: NonEmpty (ContentType a)
-> ByteString -> Maybe (MediaType, a -> ByteString)
chooseAcceptCType NonEmpty (ContentType a)
ctypes =
    [(MediaType, (MediaType, a -> ByteString))]
-> ByteString -> Maybe (MediaType, a -> ByteString)
forall b. [(MediaType, b)] -> ByteString -> Maybe b
mapAcceptMedia ([(MediaType, (MediaType, a -> ByteString))]
 -> ByteString -> Maybe (MediaType, a -> ByteString))
-> [(MediaType, (MediaType, a -> ByteString))]
-> ByteString
-> Maybe (MediaType, a -> ByteString)
forall a b. (a -> b) -> a -> b
$ (ContentType a
 -> MediaType -> (MediaType, (MediaType, a -> ByteString)))
-> NonEmpty (ContentType a)
-> [(MediaType, (MediaType, a -> 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 -> ByteString
forall a. ContentType a -> a -> ByteString
toContentType ContentType a
ctype))) NonEmpty (ContentType a)
ctypes

chooseContentCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (LBS.ByteString -> Either Text a)
chooseContentCType :: NonEmpty (ContentType a)
-> ByteString -> Maybe (ByteString -> Either Text a)
chooseContentCType NonEmpty (ContentType a)
ctypes =
    [(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 -> ByteString -> Either Text a
forall a. ContentType a -> ByteString -> Either Text a
fromContentType ContentType a
ctype)) NonEmpty (ContentType a)
ctypes