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 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
import Language.Symantic.HTTP.Media

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

-- * Type 'MimeSerialize'
class MediaTypeable mt => MimeSerialize mt a where
	mimeSerialize :: Proxy mt -> Serializer a
-- | @BSL.fromStrict . T.encodeUtf8@
instance MimeSerialize PlainText String where
	mimeSerialize _ = BLC.pack
instance MimeSerialize PlainText T.Text where
	mimeSerialize _ = BSL.fromStrict . T.encodeUtf8
instance MimeSerialize PlainText TL.Text where
	mimeSerialize _ = TL.encodeUtf8
instance MimeSerialize OctetStream BS.ByteString where
	mimeSerialize _ = BSL.fromStrict
instance MimeSerialize OctetStream BSL.ByteString 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 FormUrlEncoded a 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 mt a where
	mimeUnserialize :: Proxy mt -> Unserializer a
	-- mimeUnserialize p = mimeUnserializeWithType p (mediaType p)
	
	{-
	-- | 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 PlainText String where
	mimeUnserialize _ = Right . BLC.unpack
instance MimeUnserialize PlainText T.Text where
	mimeUnserialize _ = left show . T.decodeUtf8' . BSL.toStrict
instance MimeUnserialize PlainText TL.Text where
	mimeUnserialize _ = left show . TL.decodeUtf8'
instance MimeUnserialize OctetStream BS.ByteString where
	mimeUnserialize _ = Right . BSL.toStrict
instance MimeUnserialize OctetStream BSL.ByteString 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 FormUrlEncoded a 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
-}
-- ** Type 'Unserializer'
type Unserializer a = BSL.ByteString -> Either String a













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