{-# 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
-}