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

module Literate.Web.Types.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.Eq (Eq (..))
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 (..), isJust)
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, eqT)
import Network.HTTP.Media qualified as Media
import Text.Read (readMaybe)
import Text.Show (Show (..))

--import qualified Web.FormUrlEncoded as Web

-- * Class 'FileExtension'
class FileExtension fmt where
  fileExtension :: T.Text

-- * Class 'MediaTypeFor'
class (Typeable fmt, FileExtension fmt) => MediaTypeFor fmt where
  mediaTypeFor :: Proxy fmt -> MediaType
  mediaTypesFor :: Proxy fmt -> NonEmpty MediaType
  mediaTypesFor fmt = mediaTypeFor fmt :| []
instance MediaTypeFor () where
  mediaTypeFor _t = mimeAny
instance FileExtension () where
  fileExtension = ""

-- ** Type 'MediaType'
type MediaType = Media.MediaType
mediaType :: forall fmt. MediaTypeFor fmt => MediaType
mediaType = mediaTypeFor (Proxy @fmt)
{-# 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 fmt = mediaTypeFor fmt :| ["application" Media.// "json"]
instance FileExtension JSON where
  fileExtension = "json"

-- ** Type 'HTML'
data HTML deriving (Typeable)
instance MediaTypeFor HTML where
  mediaTypeFor _t = charsetUTF8 $ "text" Media.// "html"
  mediaTypesFor fmt = mediaTypeFor fmt :| ["text" Media.// "html"]
instance FileExtension HTML where
  fileExtension = "html"

-- ** Type 'FormUrlEncoded'
data FormUrlEncoded deriving (Typeable)
instance MediaTypeFor FormUrlEncoded where
  mediaTypeFor _t = "application" Media.// "x-www-form-urlencoded"
instance FileExtension FormUrlEncoded where
  fileExtension = "url"

-- ** Type 'OctetStream'
data OctetStream deriving (Typeable)
instance MediaTypeFor OctetStream where
  mediaTypeFor _t = "application" Media.// "octet-stream"
instance FileExtension OctetStream where
  fileExtension = "bin"

-- ** Type 'PlainText'
data PlainText deriving (Typeable)
instance MediaTypeFor PlainText where
  mediaTypeFor _t = charsetUTF8 $ "text" Media.// "plain"
instance FileExtension PlainText where
  fileExtension = "txt"

-- * Type 'MimeType'

-- | Existentially wraps a type-level type 'fmt'
-- with a proof it respects 'Constraint' 'c'.
-- Usually 'c' is 'MimeEncodable' or 'MimeDecodable'.
data MimeType c where
  MimeType :: (c fmt, MediaTypeFor fmt) => Proxy fmt -> MimeType c

instance Eq (MimeType c) where
  MimeType (_ :: Proxy x) == MimeType (_ :: Proxy y) = isJust (eqT @x @y)

mimeType :: forall fmt c. MediaTypeFor fmt => c fmt => MimeType c
mimeType = MimeType (Proxy @fmt)
{-# 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 fmt, c fmt) => MimeTypes '[fmt] c where
  mimeTypesMap = (,MimeType @c @fmt Proxy) <$> mediaTypesFor (Proxy @fmt)
instance (MediaTypeFor fmt, MimeTypes (t1 ': ts) c, c fmt) => MimeTypes (fmt ': t1 ': ts) c where
  mimeTypesMap =
    ( (,MimeType @c @fmt Proxy)
        <$> mediaTypesFor (Proxy @fmt)
    )
      <> 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 fmt => MimeEncodable a fmt where
  mimeEncode :: 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 @_ @fmt (mimeEncode @_ @fmt 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 @_ @fmt (mimeEncode @_ @fmt 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