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.
  MimeSerialize mt a =>
  MimeUnserialize mt a =>
  MimeType mt a

mimeType :: MediaType -> MimeType mt
-}

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

-- * Type 'MimeSerialize'
class MediaTypeable mt => MimeSerialize a mt where
	mimeSerialize :: Proxy mt -> Serializer a
-- | @BSL.fromStrict . T.encodeUtf8@
instance MimeSerialize String PlainText where
	mimeSerialize _ = BLC.pack
instance MimeSerialize T.Text PlainText where
	mimeSerialize _ = BSL.fromStrict . T.encodeUtf8
instance MimeSerialize TL.Text PlainText where
	mimeSerialize _ = TL.encodeUtf8
instance MimeSerialize BS.ByteString OctetStream where
	mimeSerialize _ = BSL.fromStrict
instance MimeSerialize BSL.ByteString OctetStream where
	mimeSerialize _ = id
-- | @Web.urlEncodeAsForm@
-- Note that the @mimeUnserialize p (mimeSerialize p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance Web.ToForm a => MimeSerialize a FormUrlEncoded where
	mimeSerialize _ = Web.urlEncodeAsForm
{-
-- | `encode`
instance {-# OVERLAPPABLE #-}
         ToJSON a => MimeSerialize JSON a where
	mimeSerialize _ = 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 'MimeUnserialize'
class MediaTypeable mt => MimeUnserialize a mt where
	mimeUnserialize :: Proxy mt -> Unserializer a
	-- mimeUnserialize 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 _ = mimeUnserialize p
	{-# MINIMAL mimeUnserialize | mimeUnserializeWithType #-}
	-}
instance MimeUnserialize String PlainText where
	mimeUnserialize _ = Right . BLC.unpack
instance MimeUnserialize T.Text PlainText where
	mimeUnserialize _ = left show . T.decodeUtf8' . BSL.toStrict
instance MimeUnserialize TL.Text PlainText where
	mimeUnserialize _ = left show . TL.decodeUtf8'
instance MimeUnserialize BS.ByteString OctetStream where
	mimeUnserialize _ = Right . BSL.toStrict
instance MimeUnserialize BSL.ByteString OctetStream where
	mimeUnserialize _ = Right
-- | @Web.urlDecodeAsForm@
-- Note that the @mimeUnserialize p (mimeSerialize p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance Web.FromForm a => MimeUnserialize a FormUrlEncoded where
	mimeUnserialize _ = 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 => MimeUnserialize JSON a where
	mimeUnserialize _ = 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 MimeSerialize
--------------------------------------------------------------------------
class (AllMime list) => AllMimeSerialize (list :: [*]) a where
    allMimeSerialize :: Proxy list
                  -> a                              -- value to serialize
                  -> [(Media.MediaType, ByteString)]    -- content-types/response pairs

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

instance {-# OVERLAPPABLE #-}
         ( MimeSerialize 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     = mimeSerialize pctyp a
        pctyp  = Proxy :: Proxy ctyp
        pctyps = Proxy :: Proxy (ctyp' ': ctyps)


-- Ideally we would like to declare a 'MimeSerialize a NoContent' instance, and
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeSerialize 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 MimeUnserialize
--------------------------------------------------------------------------
class (AllMime list) => AllMimeUnserialize (list :: [*]) a where
    allMimeUnserialize :: Proxy list
                    -> [(Media.MediaType, ByteString -> Either String a)]
instance AllMimeUnserialize '[] a where
    allMimeUnserialize _ = []
instance ( MimeUnserialize 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
-}