{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.HTTP.MIME where
import Control.Arrow (left)
import Data.Either (Either(..))
import Data.Function (($), (.), id)
import Data.Foldable (toList)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Kind (Constraint)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst, snd)
import Data.Typeable (Typeable)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Network.HTTP.Media as Media
import qualified Web.FormUrlEncoded as Web
class MediaTypeFor t where
mediaTypeFor :: Proxy t -> MediaType
mediaTypesFor :: Proxy t -> NonEmpty MediaType
mediaTypesFor t = mediaTypeFor t:|[]
instance MediaTypeFor () where
mediaTypeFor _t = mimeAny
type MediaType = Media.MediaType
mediaType :: forall t. MediaTypeFor t => MediaType
mediaType = mediaTypeFor (Proxy @t)
{-# INLINE mediaType #-}
type MediaTypes = NonEmpty MediaType
mediaTypes :: forall ts c. MimeTypes ts c => MediaTypes
mediaTypes = fst <$> mimeTypesMap @ts @c
{-# INLINE mediaTypes #-}
charsetUTF8 :: MediaType -> MediaType
charsetUTF8 = (Media./: ("charset", "utf-8"))
mimeAny :: MediaType
mimeAny = "*/*"
data JSON deriving (Typeable)
instance MediaTypeFor JSON where
mediaTypeFor _t = charsetUTF8 $ "application"Media.//"json"
mediaTypesFor t = mediaTypeFor t :| ["application"Media.//"json"]
data HTML deriving (Typeable)
instance MediaTypeFor HTML where
mediaTypeFor _t = charsetUTF8 $ "text"Media.//"html"
mediaTypesFor t = mediaTypeFor t :| ["text"Media.//"html"]
data FormUrlEncoded deriving (Typeable)
instance MediaTypeFor FormUrlEncoded where
mediaTypeFor _t = "application"Media.//"x-www-form-urlencoded"
data OctetStream deriving (Typeable)
instance MediaTypeFor OctetStream where
mediaTypeFor _t = "application"Media.//"octet-stream"
data PlainText deriving (Typeable)
instance MediaTypeFor PlainText where
mediaTypeFor _t = charsetUTF8 $ "text"Media.//"plain"
data MimeType c where
MimeType :: (c t, MediaTypeFor t) => Proxy t -> MimeType c
mimeType :: forall t c. MediaTypeFor t => c t => MimeType c
mimeType = MimeType (Proxy @t)
{-# INLINE mimeType #-}
type MimeTypeTs c = NonEmpty (MimeType c)
mimeTypes :: forall ts c. MimeTypes ts c => NonEmpty (MimeType c)
mimeTypes = snd <$> mimeTypesMap @ts @c
{-# INLINE mimeTypes #-}
class MimeTypes (ts::[*]) (c:: * -> Constraint) where
mimeTypesMap :: NonEmpty (MediaType, MimeType c)
instance
(MediaTypeFor t, c t) =>
MimeTypes '[t] c where
mimeTypesMap =
(, MimeType @c @t Proxy)
<$> mediaTypesFor (Proxy @t)
instance
( MediaTypeFor t
, MimeTypes (t1 ':ts) c
, c t
) =>
MimeTypes (t ': t1 ': ts) c where
mimeTypesMap =
((, MimeType @c @t Proxy)
<$> mediaTypesFor (Proxy @t))
<> mimeTypesMap @(t1 ':ts) @c
matchAccept ::
forall ts c. MimeTypes ts c =>
BS.ByteString -> Maybe (MimeType c)
matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
matchContent ::
forall ts c. MimeTypes ts c =>
BS.ByteString -> Maybe (MimeType c)
matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
class MediaTypeFor t => MimeEncodable a t where
mimeEncode :: Proxy t -> MimeEncoder a
instance MimeEncodable () PlainText where
mimeEncode _ () = BLC.pack ""
instance MimeEncodable String PlainText where
mimeEncode _ = BLC.pack
instance MimeEncodable T.Text PlainText where
mimeEncode _ = BSL.fromStrict . T.encodeUtf8
instance MimeEncodable TL.Text PlainText where
mimeEncode _ = TL.encodeUtf8
instance MimeEncodable BS.ByteString OctetStream where
mimeEncode _ = BSL.fromStrict
instance MimeEncodable BSL.ByteString OctetStream where
mimeEncode _ = id
instance MimeEncodable Int PlainText where
mimeEncode _ = TL.encodeUtf8 . TL.pack . show
instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
mimeEncode _ = Web.urlEncodeAsForm
type MimeEncoder a = a -> BSL.ByteString
class MediaTypeFor mt => MimeDecodable a mt where
mimeDecode :: Proxy mt -> MimeDecoder a
type MimeDecoder a = BSL.ByteString -> Either String a
instance MimeDecodable () PlainText where
mimeDecode _ bsl =
if BLC.null bsl
then Right ()
else Left "not empty"
instance MimeDecodable String PlainText where
mimeDecode _ = Right . BLC.unpack
instance MimeDecodable T.Text PlainText where
mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
instance MimeDecodable TL.Text PlainText where
mimeDecode _ = left show . TL.decodeUtf8'
instance MimeDecodable BS.ByteString OctetStream where
mimeDecode _ = Right . BSL.toStrict
instance MimeDecodable BSL.ByteString OctetStream where
mimeDecode _ = Right
instance MimeDecodable Int PlainText where
mimeDecode _mt bsl =
let s = TL.unpack $ TL.decodeUtf8 bsl in
case readMaybe s of
Just n -> Right n
_ -> Left $ "cannot parse as Int: "<>s
instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
mimeDecode _ = left T.unpack . Web.urlDecodeAsForm