module Network.HTTP.Kinder.MediaType (
HasMediaType (..)
, MimeEncode (..)
, MimeDecode (..)
, AllMimeEncode
, AllMimeDecode
, TextPlain
, JSON
, Ver (..)
, negotiatedMimeEncode
, negotiatedMimeDecode
, NegotiatedDecodeResult (..)
, encodersOf
, decodersOf
, MediaType ()
, mainType, subType, (/?), (/.)
, Quality ()
) where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as Sl
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Proxy
import Data.Singletons
import Data.Singletons.Prelude.List (Sing (SCons, SNil))
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import GHC.Exts
import GHC.TypeLits
import Network.HTTP.Media (MediaType (), Quality (),
mainType, matchQuality, subType,
(/.), (//), (/:), (/?))
class HasMediaType t where
mediaType :: sing t -> MediaType
class HasMediaType t => MimeEncode t a where
mimeEncode :: sing t -> a -> S.ByteString
class HasMediaType t => MimeDecode t a where
mimeDecode :: sing t -> S.ByteString -> Either String a
type family AllMimeEncode (a :: *) (ts :: [*]) :: Constraint where
AllMimeEncode a '[] = ()
AllMimeEncode a (t ': ts) = (MimeEncode t a, AllMimeEncode a ts)
type family AllMimeDecode (a :: *) (ts :: [*]) :: Constraint where
AllMimeDecode a '[] = ()
AllMimeDecode a (t ': ts) = (MimeDecode t a, AllMimeDecode a ts)
encodersOf
:: AllMimeEncode a ts
=> Sing ts -> Map MediaType (a -> S.ByteString)
encodersOf s =
case s of
SNil -> Map.empty
SCons r rs -> Map.insert (mediaType r) (mimeEncode r) (encodersOf rs)
decodersOf
:: AllMimeDecode a ts
=> Sing ts -> Map MediaType (S.ByteString -> Either String a)
decodersOf s =
case s of
SNil -> Map.empty
SCons r rs -> Map.insert (mediaType r) (mimeDecode r) (decodersOf rs)
negotiatedMimeEncode
:: AllMimeEncode a ts
=> Sing ts
-> Maybe ([Quality MediaType] -> a -> (MediaType, S.ByteString))
negotiatedMimeEncode SNil = Nothing
negotiatedMimeEncode valid@(SCons defaultMt _) =
Just (encode defaultEnc (Map.keys encoderMap) encoderMap)
where
encoderMap = encodersOf valid
defaultEnc = (mediaType defaultMt, mimeEncode defaultMt)
encode (theDefaultMt, theDefaultEnc) provided theEncMap acceptable a =
maybe (theDefaultMt, theDefaultEnc a) id $ do
mt <- matchQuality provided acceptable
enc <- Map.lookup mt theEncMap
return (mt, enc a)
data NegotiatedDecodeResult a
= NegotiatedDecode a
| NegotiatedDecodeError String
| DecodeNegotiationFailure MediaType
deriving (Eq, Ord, Show)
resultDecode :: Either String a -> NegotiatedDecodeResult a
resultDecode res =
case res of
Left err -> NegotiatedDecodeError err
Right val -> NegotiatedDecode val
negotiatedMimeDecode
:: AllMimeDecode a ts
=> Sing ts
-> Maybe (Maybe MediaType -> S.ByteString -> NegotiatedDecodeResult a)
negotiatedMimeDecode SNil = Nothing
negotiatedMimeDecode valid@(SCons defaultMt _) =
Just (decode defaultDec decoderMap)
where
decoderMap = decodersOf valid
defaultDec = (mediaType defaultMt, mimeDecode defaultMt)
decode (_theDefaultMt, theDefaultDec) theDecMap maybeCt bytes =
case maybeCt of
Nothing -> resultDecode (theDefaultDec bytes)
Just ct ->
case Map.lookup ct theDecMap of
Nothing -> DecodeNegotiationFailure ct
Just dec -> resultDecode (dec bytes)
newtype Ver (n :: Nat) a = Ver { getVer :: a }
deriving (Eq, Ord, Show, Functor)
instance Applicative (Ver n) where
pure = Ver
Ver f <*> Ver a = Ver (f a)
instance Monad (Ver n) where
return = pure
Ver x >>= f = f x
instance (HasMediaType t, KnownNat n) => HasMediaType (Ver n t) where
mediaType _ = mediaType (Proxy :: Proxy t) /: ("version", fromString (show (natVal (Proxy :: Proxy n))))
data TextPlain
instance HasMediaType TextPlain where
mediaType _ = "text" // "plain"
instance MimeEncode TextPlain Text where
mimeEncode _ = Text.encodeUtf8
data JSON
instance HasMediaType JSON where
mediaType _ = "application" // "json"
instance Aeson.ToJSON a => MimeEncode JSON a where
mimeEncode _ = Sl.toStrict . Aeson.encode
instance Aeson.FromJSON a => MimeDecode JSON a where
mimeDecode _ bs = Aeson.eitherDecodeStrict bs