MIME.hs

{-# 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'
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'
type MediaType = Media.MediaType
mediaType :: forall t. MediaTypeFor t => MediaType
mediaType = mediaTypeFor (Proxy @t)
{-# INLINE mediaType #-}

-- ** Type 'MediaTypes'
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 = "*/*"

-- ** Type 'JSON'
data JSON deriving (Typeable)
instance MediaTypeFor JSON where
	mediaTypeFor _t = charsetUTF8 $ "application"Media.//"json"
	mediaTypesFor t = mediaTypeFor t :| ["application"Media.//"json"]

-- ** Type 'HTML'
data HTML deriving (Typeable)
instance MediaTypeFor HTML where
	mediaTypeFor _t = charsetUTF8 $ "text"Media.//"html"
	mediaTypesFor t = mediaTypeFor t :| ["text"Media.//"html"]

-- ** Type 'FormUrlEncoded'
data FormUrlEncoded deriving (Typeable)
instance MediaTypeFor FormUrlEncoded where
	mediaTypeFor _t = "application"Media.//"x-www-form-urlencoded"

-- ** Type 'OctetStream'
data OctetStream deriving (Typeable)
instance MediaTypeFor OctetStream where
	mediaTypeFor _t = "application"Media.//"octet-stream"

-- ** Type 'PlainText'
data PlainText deriving (Typeable)
instance MediaTypeFor PlainText where
	mediaTypeFor _t = charsetUTF8 $ "text"Media.//"plain"

-- * Type 'MimeType'
-- | Existentially wraps a type-level type 't'
-- with a proof it respects 'Constraint' 'c'.
-- Usyally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@.
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'
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'
-- | Implicitely generate 'MediaType's and 'MimeType's
-- from given type-level list of types.
class MimeTypes (ts::[*]) (c:: * -> Constraint) where
	mimeTypesMap :: NonEmpty (MediaType, MimeType c)
-- | Single 'MimeType'.
instance
 (MediaTypeFor t, c t) =>
 MimeTypes '[t] c where
	mimeTypesMap =
		(, MimeType @c @t Proxy)
		 <$> mediaTypesFor (Proxy @t)
-- | More than one 'MimeType'.
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)

-- * Type 'MimeEncodable'
class MediaTypeFor t => MimeEncodable a t where
	mimeEncode :: Proxy t -> MimeEncoder a
instance MimeEncodable () PlainText where
	mimeEncode _ () = BLC.pack ""
-- | @BSL.fromStrict . T.encodeUtf8@
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
-- | @Web.urlEncodeAsForm@
-- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
	mimeEncode _ = Web.urlEncodeAsForm
{-
-- | `encode`
instance {-# OVERLAPPABLE #-}
         ToJSON a => MimeEncodable JSON a where
	mimeEncode _ = encode
-}

-- ** Type 'MimeEncoder'
type MimeEncoder a = a -> BSL.ByteString

-- * Type 'MimeDecodable'
class MediaTypeFor mt => MimeDecodable a mt where
	mimeDecode :: Proxy mt -> MimeDecoder a
	-- mimeDecode p = mimeUnserializeWithType p (mimeType p)

-- ** Type 'MimeDecoder'
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
-- | @Web.urlDecodeAsForm@
-- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
	mimeDecode _ = left T.unpack . Web.urlDecodeAsForm
{-
-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
-- objects and arrays.
--
-- Will handle trailing whitespace, but not trailing junk. ie.
--
-- >>> eitherDecodeLenient "1 " :: Either String Int
-- Right 1
--
-- >>> eitherDecodeLenient "1 junk" :: Either String Int
-- Left "trailing junk after valid JSON: endOfInput"
eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
eitherDecodeLenient input =
    parseOnly parser (cs input) >>= parseEither parseJSON
  where
    parser = skipSpace
               *> Data.Aeson.Parser.value
              <*  skipSpace
              <*  (endOfInput <?> "trailing junk after valid JSON")

-- | `eitherDecode`
instance FromJSON a => MimeDecodable JSON a where
	mimeDecode _ = eitherDecodeLenient
-}