{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}

module Webc.MIME where

import Control.Arrow (left)
import Data.Bool
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Either (Either (..))
import Data.Foldable (toList)
import Data.Function (id, ($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Kind (Constraint, Type)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (Maybe (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
import Data.String (String)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Data.Tuple (fst, snd)
import Data.Typeable (Typeable)
import Network.HTTP.Media qualified as Media
import Text.Read (readMaybe)
import Text.Show (Show (..))

--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'.
-- Usually '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 #-}
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 a type-level list of types.
class MimeTypes (ts :: [Type]) (c :: Type -> Constraint) where
  mimeTypesMap :: NonEmpty (MediaType, MimeType c)

instance (MediaTypeFor t, c t) => MimeTypes '[t] c where
  mimeTypesMap = (,MimeType @c @t Proxy) <$> mediaTypesFor (Proxy @t)
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

-- ** 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
    | BLC.null bsl = Right ()
    | otherwise = 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 =
    case readMaybe s of
      Just n -> Right n
      _ -> Left $ "cannot parse as Int: " <> s
    where
      s = TL.unpack (TL.decodeUtf8 bsl)

-- | @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