{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.MIME.Extended
    ( module Data.MIME
    ) where

import Control.Lens hiding ((.=))
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Extended ()
import Data.CaseInsensitive (CI)
import Data.Either (fromRight)
import Data.List.NonEmpty (NonEmpty)
import Data.MIME
import Data.MIME.EncodedWord
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Char8 as C8
import qualified Data.CaseInsensitive as CI
import qualified Data.Vector


-- Data.MIME.Boundary.Extra
makeBoundaryUnsafe :: ByteString -> Boundary
makeBoundaryUnsafe = either (error . C8.unpack) id . makeBoundary



instance ToJSON (Message s MIME) where
    toJSON (Message h b) =
      object
          [ "headers" .= toJSON h
          , "body" .=
            case b of
              Part b' -> toJSON b'
              Encapsulated b' -> toJSON b'
              Multipart _ _ b' -> toJSON b'
              FailedParse _ msg -> toJSON msg
          ]

instance FromJSON (Message s MIME) where
    parseJSON =
        withObject "MIMEMessage" $ \v -> do
          h <- v .: "headers"
          b <-
            case h ^. contentType of
              ContentType "message" "rfc822" _ ->
                Encapsulated <$> v .: "body"

              ContentType "multipart" _ _ ->
                makeMultipart h <$> v .: "body"

              _ ->
                Part <$> v .: "body"
          pure $ Message h b


instance ToJSON Headers where
    toJSON (Headers h) =
        Array . Data.Vector.fromList . map toJSON' $ h
      where
        toJSON' (k, v) =
          object
            [ "key" .= toJSON k
            , "value" .= toJSON (decodeEncodedWords defaultCharsets v)
            ]

instance FromJSON Headers where
    parseJSON =
        withArray "Headers" $ \v -> do
          x <- mapM parseJSON' $ Data.Vector.toList v
          pure $ Headers x
      where
        parseJSON' =
            withObject "Header" $ \v ->
              (,) <$> v .: "key"
                  <*> encodeEncodedWords `fmap` (v .: "value")


makeMultipart :: HasHeaders s => s -> NonEmpty MIMEMessage -> MIME
makeMultipart h =
    Multipart sub boundary
  where
    ( sub, boundary ) =
      either dummyPrep id $ prepMultipart (h ^. contentType)

    dummyPrep :: (Show a) => a -> (MultipartSubtype, Boundary)
    dummyPrep err =
      ( Unrecognised $ CI.mk $ C8.pack $ show err
      , fromRight (makeBoundaryUnsafe "bad_boundary") $
          makeBoundary $ fromMaybe "no_boundary_found" $
            firstOf (contentType . mimeBoundary) h
      )

    -- Stuff below this line taken from Data.MIME.mime'

    prepMultipart :: ContentType
                     -> Either MIMEParseError (MultipartSubtype, Boundary)
    prepMultipart ct =
      (,) <$> parseSubtype ct <*> parseBoundary ct

    parseSubtype :: ContentType
                    -> Either MIMEParseError MultipartSubtype
    parseSubtype ct = case view ctSubtype ct of
      "mixed"         -> pure Mixed
      "alternative"   -> pure Alternative
      "digest"        -> pure Digest
      "parallel"      -> pure Parallel
      "multilingual"  -> pure Multilingual
      "report"        -> Report <$> getRequiredParam "report-type" ct
      "signed"        -> Signed
                          <$> getRequiredParam "protocol" ct
                          <*> getRequiredParam "micalg" ct
      "encrypted"     -> Encrypted <$> getRequiredParam "protocol" ct
      "related"       -> Related
                          <$> ( getRequiredParam "type" ct
                              >>= \s ->
                                    maybe
                                      (Left $ InvalidParameterValue "type" s)
                                      Right
                                      (preview (parsed parseContentType) s)
                              )
                          <*> getOptionalParam "start" ct
                          <*> getOptionalParam "start-info" ct
      unrecognised    -> pure $ Unrecognised unrecognised

    parseBoundary :: HasParameters s => s -> Either MIMEParseError Boundary
    parseBoundary ct =
      getRequiredParam "boundary" ct
      >>= over _Left (InvalidParameterValue "boundary") . makeBoundary

    getRequiredParam :: HasParameters s =>
                        CI ByteString -> s -> Either MIMEParseError ByteString
    getRequiredParam k =
      maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k)

    getOptionalParam :: HasParameters s =>
                        CI ByteString -> s -> Either a (Maybe ByteString)
    getOptionalParam k =
      Right . preview (rawParameter k)

data MIMEParseError
  = RequiredParameterMissing (CI ByteString)
  | InvalidParameterValue (CI ByteString) ByteString
  | MultipartParseFail
  | EncapsulatedMessageParseFail
  deriving (Eq, Show)