{-# OPTIONS_GHC -fno-warn-orphans #-}

module Network.Mail.Mime.Instances
  ( MailHeaders(..)
  ) where

import ClassyPrelude
import Network.Mail.Mime

import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson as Aeson
import Data.Aeson.TH

import Control.Monad.Fail (MonadFail(..))

import Utils.PathPiece

import Utils (assertM)

import qualified Data.Csv as Csv
import Data.Binary (Binary)

import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString as BS

import Data.Text.Encoding (decodeUtf8')

import Control.Lens


deriving instance Read Address
deriving instance Ord Address
deriving anyclass instance Hashable Address

deriveToJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''Address

instance FromJSON Address where
  parseJSON = Aeson.withObject "Address" $ \obj -> do
    addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
    addressEmail <- obj Aeson..: "email"
    return Address{..}


instance Csv.ToNamedRecord Address where
  toNamedRecord Address{..} = Csv.namedRecord
    [ "name" Csv..= addressName
    , "email" Csv..= addressEmail
    ]

instance Csv.DefaultOrdered Address where
  headerOrder _ = Csv.header [ "name", "email" ]

  
newtype MailHeaders = MailHeaders Headers
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (NFData)

instance ToJSON MailHeaders where
  toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
instance FromJSON MailHeaders where
  parseJSON = fmap (MailHeaders . over (traverse . _1) encodeUtf8) . parseJSON

instance Binary Encoding
instance Binary Disposition
instance Binary PartContent
instance Binary Part
instance Binary Address
instance Binary Mail

deriving anyclass instance NFData Encoding
deriving anyclass instance NFData Disposition
deriving anyclass instance NFData PartContent
deriving anyclass instance NFData Part
deriving anyclass instance NFData Address
deriving anyclass instance NFData Mail
  
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  } ''Encoding

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece . dropSuffix "Disposition"
  } ''Disposition

instance ToJSON PartContent where
  toJSON (PartContent (toStrict -> content))
    | BS.all (< 0x80) content
    , Right content' <- decodeUtf8' content = Aeson.String content'
  toJSON (PartContent content) = Aeson.object
    [ "encoding" Aeson..= ("base64" :: String)
    , "content" Aeson..= decodeUtf8 (Base64.encode $ toStrict content)
    ]
  toJSON (NestedParts ps) = toJSON ps
instance FromJSON PartContent where
  parseJSON (Aeson.String t) = return . PartContent . fromStrict $ encodeUtf8 t
  parseJSON (Aeson.Object o) = do
    encoding <- o Aeson..: "encoding"
    content <- o Aeson..: "content"
    if | encoding == "base64" -> either fail (return . PartContent . fromStrict) . Base64.decode $ encodeUtf8 content
       | otherwise -> fail $ "Unknown encoding: “" <> encoding <> "”"
  parseJSON v = NestedParts <$> parseJSON v

instance ToJSON Part where
  toJSON Part{..} = Aeson.object
    [ "type" Aeson..= partType
    , "encoding" Aeson..= partEncoding
    , "disposition" Aeson..= partDisposition
    , "headers" Aeson..= MailHeaders partHeaders
    , "content" Aeson..= partContent
    ]
instance FromJSON Part where
  parseJSON = Aeson.withObject "Part" $ \o -> do
    partType <- o Aeson..: "type"
    partEncoding <- o Aeson..: "encoding"
    partDisposition <- o Aeson..: "disposition"
    MailHeaders partHeaders <- o Aeson..: "headers"
    partContent <- o Aeson..: "content"
    return Part{..}