module Language.Symantic.HTTP.Mime where

-- import qualified Data.List.NonEmpty as NE
import Control.Arrow (left)
import Data.Either (Either(..))
import Data.Function ((.), id)
import Data.Proxy (Proxy(..))
import Data.String (String)
import Prelude ()
import Text.Show (Show(..))
import Web.FormUrlEncoded (FromForm, urlDecodeAsForm{-, urlEncodeAsForm, ToForm-})
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 M

import Language.Symantic.HTTP.Media

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

-- * Type 'MimeRender'
class MediaTypeable mt => MimeRender mt a where
	mimeRender  :: Proxy mt -> a -> BSL.ByteString
-- | @BSL.fromStrict . T.encodeUtf8@
instance MimeRender PlainText String where
	mimeRender _ = BLC.pack
instance MimeRender PlainText T.Text where
	mimeRender _ = BSL.fromStrict . T.encodeUtf8
instance MimeRender PlainText TL.Text where
	mimeRender _ = TL.encodeUtf8
instance MimeRender OctetStream BS.ByteString where
	mimeRender _ = BSL.fromStrict
instance MimeRender OctetStream BSL.ByteString where
	mimeRender _ = id
{-
-- | `encode`
instance {-# OVERLAPPABLE #-}
         ToJSON a => MimeRender JSON a where
	mimeRender _ = encode

-- | @urlEncodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance {-# OVERLAPPABLE #-}
         ToForm a => MimeRender FormUrlEncoded a where
	mimeRender _ = urlEncodeAsForm
-}

{-
class (AllMime list) => AllCTRender (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, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
	handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
	where
	pctyps = Proxy :: Proxy (ct ': cts)
	amrs   = allMimeRender pctyps val
	lkup   = fmap (\(a,b) -> (a, (BSL.fromStrict $ M.renderHeader a, b))) amrs

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

-- * Type 'MimeUnrender'
class MediaTypeable mt => MimeUnrender mt a where
	mimeUnrender :: Proxy mt -> BSL.ByteString -> Either String a
	mimeUnrender p = mimeUnrenderWithType p (mediaType p)
	
	-- | Variant which is given the actual 'M.MediaType' provided by the other party.
	--
	-- In the most cases you don't want to branch based on the 'M.MediaType'.
	-- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
	mimeUnrenderWithType :: Proxy mt -> M.MediaType -> BSL.ByteString -> Either String a
	mimeUnrenderWithType p _ = mimeUnrender p
	{-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
instance MimeUnrender PlainText String where
	mimeUnrender _ = Right . BLC.unpack
instance MimeUnrender PlainText T.Text where
	mimeUnrender _ = left show . T.decodeUtf8' . BSL.toStrict
instance MimeUnrender PlainText TL.Text where
	mimeUnrender _ = left show . TL.decodeUtf8'
instance MimeUnrender OctetStream BS.ByteString where
	mimeUnrender _ = Right . BSL.toStrict
instance MimeUnrender OctetStream BSL.ByteString where
	mimeUnrender _ = Right
-- | @urlDecodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromForm a => MimeUnrender FormUrlEncoded a where
	mimeUnrender _ = left T.unpack . 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 => MimeUnrender JSON a where
	mimeUnrender _ = eitherDecodeLenient
-}













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



class AllCTUnrender (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 ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
    canHandleCTypeH p ctypeH =
        M.mapContentMedia (allMimeUnrender p) (cs ctypeH)

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

class AllMime (list :: [*]) where
    allMime :: Proxy list -> [M.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 $ M.matchAccept (allMime p) h

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

instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
    allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp
      where
        bs    = mimeRender pctyp a
        pctyp = Proxy :: Proxy ctyp

instance {-# OVERLAPPABLE #-}
         ( MimeRender ctyp a
         , AllMimeRender (ctyp' ': ctyps) a
         ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
    allMimeRender _ a =
        map (, bs) (NE.toList $ contentTypes pctyp)
        ++ allMimeRender pctyps a
      where
        bs     = mimeRender pctyp a
        pctyp  = Proxy :: Proxy ctyp
        pctyps = Proxy :: Proxy (ctyp' ': ctyps)


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

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

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