module Symantic.HTTP.Mime
 ( module Symantic.HTTP.Mime
 , module Symantic.HTTP.Mime.Type
 ) where

import Control.Arrow (left)
import Data.Either (Either(..))
import Data.Function (($), (.), id)
import Data.Proxy (Proxy(..))
import Data.String (String)
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 Web.FormUrlEncoded as Web

import Symantic.HTTP.Mime.Type

{-
-- * Type 'MimeType'
data MimeType mt a where
 MimeType ::
  forall mt.
  MimeEncodable mt a =>
  MimeDecodable mt a =>
  MimeType mt a

mimeType :: MediaType -> MimeType mt
-}

{-
newtype AcceptHeader = AcceptHeader BS.ByteString
	deriving (Eq, Show, Read, Typeable, Generic)
-}

-- * Type 'MimeEncodable'
class MediaTypeable mt => MimeEncodable a mt where
	mimeEncode :: Proxy mt -> Serializer 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
-- | @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 'Serializer'
type Serializer a = a -> BSL.ByteString

{-
class (AllMime list) => AllCTSerialize (list :: [*]) a where
	-- If the Accept header can be matched, returns (Just) a tuple of the
	-- Content-Type and response (serialization of @a@ into the appropriate
	-- mimetype).
	handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)

instance {-# OVERLAPPABLE #-}
         (Accept ct, AllMime cts, AllMimeSerialize (ct ': cts) a) => AllCTSerialize (ct ': cts) a where
	handleAcceptH _ (AcceptHeader accept) val = Media.mapAcceptMedia lkup accept
	where
	pctyps = Proxy :: Proxy (ct ': cts)
	amrs   = allMimeSerialize pctyps val
	lkup   = fmap (\(a,b) -> (a, (BSL.fromStrict $ Media.renderHeader a, b))) amrs

instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTSerialize '[] () where
  handleAcceptH _ _ _ = error "unreachable"
-}

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

-- ** Type 'Unserializer'
type Unserializer a = BSL.ByteString -> Either String a
	
	{-
	-- | Variant which is given the actual 'Media.MediaType' provided by the other party.
	--
	-- In the most cases you don't want to branch based on the 'Media.MediaType'.
	-- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
	mimeUnserializeWithType :: Proxy mt -> Media.MediaType -> Unserializer a
	mimeUnserializeWithType p _ = mimeDecode p
	{-# MINIMAL mimeDecode | mimeUnserializeWithType #-}
	-}
instance MimeDecodable () PlainText where
	mimeDecode _ t =
		if BLC.null t
		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
-- | @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
-}













{-
-- | A type for responses without content-body.
data NoContent = NoContent
  deriving (Show, Eq)



class AllCTUnserialize (list :: [*]) a where
    canHandleCTypeH
        :: Proxy list
        -> ByteString  -- Content-Type header
        -> Maybe (ByteString -> Either String a)

    handleCTypeH :: Proxy list
                 -> ByteString     -- Content-Type header
                 -> ByteString     -- Request body
                 -> Maybe (Either String a)
    handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH

instance ( AllMimeUnserialize ctyps a ) => AllCTUnserialize ctyps a where
    canHandleCTypeH p ctypeH =
        Media.mapContentMedia (allMimeUnserialize p) (cs ctypeH)

--------------------------------------------------------------------------
-- * Utils (Internal)

class AllMime (list :: [*]) where
    allMime :: Proxy list -> [Media.MediaType]

instance AllMime '[] where
    allMime _ = []

instance (MediaType ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
    allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
      where
        pctyp  = Proxy :: Proxy ctyp
        pctyps = Proxy :: Proxy ctyps

canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
canHandleAcceptH p (AcceptHeader h ) = isJust $ Media.matchAccept (allMime p) h

--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeEncodable
--------------------------------------------------------------------------
class (AllMime list) => AllMimeSerialize (list :: [*]) a where
    allMimeSerialize :: Proxy list
                  -> a                              -- value to serialize
                  -> [(Media.MediaType, ByteString)]    -- content-types/response pairs

instance {-# OVERLAPPABLE #-} ( MimeEncodable ctyp a ) => AllMimeSerialize '[ctyp] a where
    allMimeSerialize _ a = map (, bs) $ NE.toList $ contentTypes pctyp
      where
        bs    = mimeEncode pctyp a
        pctyp = Proxy :: Proxy ctyp

instance {-# OVERLAPPABLE #-}
         ( MimeEncodable ctyp a
         , AllMimeSerialize (ctyp' ': ctyps) a
         ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) a where
    allMimeSerialize _ a =
        map (, bs) (NE.toList $ contentTypes pctyp)
        ++ allMimeSerialize pctyps a
      where
        bs     = mimeEncode pctyp a
        pctyp  = Proxy :: Proxy ctyp
        pctyps = Proxy :: Proxy (ctyp' ': ctyps)


-- Ideally we would like to declare a 'MimeEncodable a NoContent' instance, and
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeEncodable JSON a', so we do this instead
instance {-# OVERLAPPING #-} ( MediaType ctyp ) => AllMimeSerialize '[ctyp] NoContent where
    allMimeSerialize _ _ = map (, "") $ NE.toList $ contentTypes pctyp
      where
        pctyp = Proxy :: Proxy ctyp

instance {-# OVERLAPPING #-}
         ( AllMime (ctyp ': ctyp' ': ctyps)
         ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) NoContent where
    allMimeSerialize p _ = zip (allMime p) (repeat "")

--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeDecodable
--------------------------------------------------------------------------
class (AllMime list) => AllMimeUnserialize (list :: [*]) a where
    allMimeUnserialize :: Proxy list
                    -> [(Media.MediaType, ByteString -> Either String a)]
instance AllMimeUnserialize '[] a where
    allMimeUnserialize _ = []
instance ( MimeDecodable ctyp a
         , AllMimeUnserialize ctyps a
         ) => AllMimeUnserialize (ctyp ': ctyps) a where
    allMimeUnserialize _ =
        map mk (NE.toList $ contentTypes pctyp)
        ++ allMimeUnserialize pctyps
      where
        mk ct   = (ct, mimeUnserializeWithType pctyp ct)
        pctyp  = Proxy :: Proxy ctyp
        pctyps = Proxy :: Proxy ctyps
-}