module Email where

import Prelude ()
import BasicPrelude
import Data.Char                                 (isAscii, isAlphaNum)
import Data.Functor                              ((<&>), ($>))
import Control.Error
	(headZ, lastZ, justZ, hush, exceptT)
import Data.Time.Clock                           (UTCTime)
import Data.Time.Format                          (formatTime, defaultTimeLocale)
import Control.Exception                         (ErrorCall(..))
import Control.Lens
	(Lens', Const, Leftmost, filtered, firstOf, view, _Right, set, at)
import qualified Data.ByteString.Char8           as C8
import qualified Data.Text                       as T
import qualified Data.Attoparsec.ByteString.Lazy as Atto
import qualified Data.MIME                       as MIME
import qualified Data.MIME.Charset               as MIME
import qualified Data.MIME.EncodedWord           as MIME
import qualified Data.XML.Types                  as XML
import qualified Network.Protocol.XMPP           as XMPP
import qualified Network.URI                     as URI
import qualified Network.Mail.Mime               as Mail
import qualified UnexceptionalIO.Trans           as UIO

import Util

mboxFrom :: Atto.Parser ()
mboxFrom =
	Atto.string (encodeUtf8 $ s"From ") *>
	Atto.skipWhile (\c -> c /= 0x0D && c /= 0x0A) *>
	MIME.crlf $> ()

messageID :: Atto.Parser Text
messageID =
	Atto.skipWhile (Atto.inClass " \t\n\r") *>
	Atto.satisfy (==0x3C) *>
	(decodeUtf8 <$> Atto.takeTill (==0x3E)) <* -- @ also required by rfc5332
	Atto.satisfy (==0x3E) <*
	Atto.skipWhile (Atto.inClass " \t\n\r")

messageOptionalMboxFrom :: Atto.Parser MIME.MIMEMessage
messageOptionalMboxFrom = Atto.option () mboxFrom *> MIME.message MIME.mime

isTextPlain :: MIME.WireEntity -> Bool
isTextPlain = MIME.matchContentType (s"text") (Just $ s"plain") .
	view MIME.contentType

getEmailBody ::
	   (Text -> Const (Leftmost Text) Text)
	-> MIME.WireEntity
	-> Const (Leftmost Text) MIME.WireEntity
getEmailBody = MIME.transferDecoded' . _Right .
	MIME.charsetPrism MIME.defaultCharsets .
	filtered (not . MIME.isAttachment) .
	MIME.body

plainTextBody ::
	   (Text -> Const (Leftmost Text) Text)
	-> MIME.MIMEMessage
	-> Const (Leftmost Text) MIME.MIMEMessage
plainTextBody = MIME.entities . filtered isTextPlain . getEmailBody

mailboxNode :: MIME.Mailbox -> Text
mailboxNode (MIME.Mailbox _ (MIME.AddrSpec local _)) =
	equalsDecode local

mailboxToJID :: Text -> MIME.Mailbox -> Maybe XMPP.JID
mailboxToJID domain (MIME.Mailbox _ addrspec) =
	XMPP.parseJID $ escapeJid addr ++ s"@" ++ domain
	where
	addr = decodeUtf8 $ MIME.renderAddressSpec addrspec

-- always escapes . for now
unescapedInEmailLocalpart :: Char -> Bool
unescapedInEmailLocalpart c = isAscii c &&
	(isAlphaNum c || c `elem` "#$&'*+-/?^_`{|}~")

jidToLocalpart :: XMPP.JID -> ByteString
jidToLocalpart = encodeUtf8 . fromString . equalsEncode . bareTxt

equalsEncode :: Text -> String
equalsEncode =
	map (\c -> if c == '%' then '=' else c) .
	URI.escapeURIString unescapedInEmailLocalpart .
	textToString

equalsDecode :: ByteString -> Text
equalsDecode =
	fromString . URI.unEscapeString .
	map (\c -> if c == '=' then '%' else c) .
	textToString . decodeUtf8

jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
jidToMailbox jid domain = MIME.Mailbox (XMPP.strNode <$> XMPP.jidNode jid) $
	MIME.AddrSpec (jidToLocalpart jid) domain

emailToMessageType :: MIME.MIMEMessage -> XMPP.MessageType
emailToMessageType email
	| Just _ <- chatVersion email =
		XMPP.MessageChat
	| otherwise = XMPP.MessageNormal
	where
	chatVersion = firstOf (MIME.headers . MIME.header (s"Chat-Version"))

emailToOriginID :: MIME.MIMEMessage -> Maybe XML.Element
emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
	firstOf (MIME.headers . MIME.header (s"message-id")) email
	where
	originID msgid = XML.Element (s"{urn:xmpp:sid:0}origin-id")
		[(s"id", [XML.ContentText msgid])] []

extractThreadFromRef :: Text -> Atto.Parser Text
extractThreadFromRef domain = mfilter (/= s"\0") $ fmap equalsDecode $
	Atto.satisfy (==0x3C) *>
	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
	Atto.satisfy (==0x2E) *>
	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
	Atto.satisfy (==0x2E) *>
	Atto.takeTill (`elem`[0x40,0x3E,0x20]) <*
	Atto.satisfy (==0x40) <*
	Atto.string (encodeUtf8 domain) <*
	Atto.satisfy (==0x3E)

extractThreadFromRefs :: Text -> Atto.Parser Text
extractThreadFromRefs domain =
	justZ =<< lastZ =<<
	Atto.sepBy
		((Just <$> extractThreadFromRef domain) <|> skipWord)
		(Atto.many1 $ Atto.satisfy (==0x20))
	where
	skipWord = Atto.skipWhile (/=0x20) $> Nothing

limitReferencesLength :: ByteString -> ByteString
limitReferencesLength refs = C8.unwords $ limit (C8.words refs)
	where
	limit (x:xs) = x : drop (length xs - 4) xs
	limit [] = []

referencesFromInReplyTo :: Text -> MIME.MIMEMessage -> Maybe ByteString
referencesFromInReplyTo domain email =
	maybe replyto (\refs -> fmap ((refs ++ s" ") ++) replyto) extractedRefs
	where
	extractedRefs = fmap encodeUtf8 $ T.stripPrefix (s"References: ") =<<
		(hush . MIME.parse (extractThreadFromRef domain) =<< replyto)
	replyto = firstOf (MIME.headers . MIME.header (s"in-reply-to")) email

emailToThread :: Text -> MIME.MIMEMessage -> Maybe XML.Element
emailToThread domain email = thread <&> \threadID ->
	XML.Element (s"{jabber:component:accept}thread")
	parent
	[XML.NodeContent $ XML.ContentText $ decodeUtf8 threadID]
	where
	parent =
		maybeToList $
		fmap ((,) (s"parent") . (:[]) . XML.ContentText
		)
		(hush . MIME.parse (extractThreadFromRefs domain) =<< refs)
	thread = fmap (s"References: "++) $
		((\x y -> x ++ s" " ++ y) <$> refs <*> msgid) <|> msgid
	msgid = firstOf (MIME.headers . MIME.header (s"message-id")) email
	refs = firstOf (MIME.headers . MIME.header (s"references")) email <|>
		referencesFromInReplyTo domain email

emailSubject :: MIME.MIMEMessage -> Maybe Text
emailSubject email = MIME.decodeEncodedWords MIME.defaultCharsets <$>
		firstOf (MIME.headers . MIME.header (s"subject")) email

chatEmailSubject :: MIME.MIMEMessage -> Maybe Text
chatEmailSubject =
	mfilter (not . (s"Re: Chat: " `T.isPrefixOf`)) .
	mfilter (not . (s"Chat: " `T.isPrefixOf`)) .
	emailSubject

emailToSubject :: XMPP.MessageType -> MIME.MIMEMessage -> Maybe XML.Element
emailToSubject = fmap (mkElement (s"{jabber:component:accept}subject")) .: go
	where
	go XMPP.MessageChat = chatEmailSubject
	go _ = emailSubject

emailToStanza ::
	   Text
	-> MIME.MIMEMessage
	-> XMPP.Message
emailToStanza domain email =
	(XMPP.emptyMessage typ) {
		XMPP.messageFrom = mailboxToJID domain fromMailbox,
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText textBody]
		] ++ subject ++ nick ++ mid ++
		maybeToList (emailToThread domain email)
	}
	where
	typ = emailToMessageType email
	subject = maybeToList $ emailToSubject typ email
	mid = maybeToList $ emailToOriginID email
	nick = maybeToList $ fmap (\n ->
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
				[] [XML.NodeContent $ XML.ContentText n]
		) fn
	Just textBody = firstOf plainTextBody email
	Just fromMailbox@(MIME.Mailbox fn _) =
		headZ =<< firstOf (MIME.headerFrom MIME.defaultCharsets) email

defaultSubject :: XMPP.Message -> Maybe Text
defaultSubject message@XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	(s"Chat: " ++) . T.take 80 <$> getBody message
defaultSubject _ = Nothing

typeHeaders :: XMPP.Message -> MIME.MIMEMessage -> MIME.MIMEMessage
typeHeaders XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	set (MIME.headers . at (s"Chat-Version")) (Just $ s"1.0")
typeHeaders _ = id

mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString
mkMessageID domain now message = ((s"<" ++) . (++ s">")) $
	MIME.renderAddressSpec $ MIME.AddrSpec
	(fromString $ time ++ "." ++ sid ++ "." ++ thread) domain
	where
	sid = maybe "=00" equalsEncode $ XMPP.stanzaID message
	thread =
		maybe "=00" (equalsEncode . mconcat . XML.elementText) $
		child (s"{jabber:component:accept}thread") message
	time = formatTime defaultTimeLocale "%s" now

mkReferences :: XMPP.Message -> Maybe ByteString
mkReferences =
	fmap (limitReferencesLength . encodeUtf8) .
	(T.stripPrefix (s"References: ") =<<) .
	fmap (mconcat . XML.elementText) .
	child (s"{jabber:component:accept}thread")

data EmailWithEnvelope = EmailWithEnvelope {
	emailMessage :: MIME.MIMEMessage,
	emailEnvelopeFrom :: MIME.AddrSpec,
	emailEnvelopeTo :: MIME.AddrSpec
}

emailMessage' :: Lens' EmailWithEnvelope MIME.MIMEMessage
emailMessage' f (EmailWithEnvelope msg from to) =
	fmap (\msg' -> EmailWithEnvelope msg' from to) (f msg)

sendEmail :: (UIO.Unexceptional m) => String -> EmailWithEnvelope -> m Bool
sendEmail sendmail (EmailWithEnvelope mail from to) =
	exceptT (\(ErrorCall _) -> return False) (const $ return True) $
	UIO.fromIO' (error . show) $ Mail.sendmailCustom sendmail [
		"-i",
		"-f", textToString $ decodeUtf8 $ MIME.renderAddressSpec from,
		"--", textToString $ decodeUtf8 $ MIME.renderAddressSpec to
	] (MIME.renderMessage mail)

messageToEmail ::
	   MIME.Domain
	-> UTCTime
	-> XMPP.Message
	-> Either XMPP.Message EmailWithEnvelope
messageToEmail fromDomain now message@XMPP.Message {
		XMPP.messageFrom = Just from,
		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
	} | Just bodyTxt <- getBody message,
	    Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =
		Right $ EmailWithEnvelope {
			emailEnvelopeFrom = fromAddrSpec,
			emailEnvelopeTo = toAddrSpec,
			emailMessage =
			set (MIME.headers . at (s"Message-ID")) (Just mid) $
			set (MIME.headers . at (s"References")) refs $
			typeHeaders message $
			set (MIME.headerTo MIME.defaultCharsets)
				[MIME.Single toMailbox] $
			setFrom $
			set (MIME.headers . at (s"Jabber-ID")) jidHeader $
			set (MIME.headers . at (s"Subject")) subjectHeader $
			set MIME.headerDate (Just dateHeader) $
			MIME.createTextPlainMessage bodyTxt
		}
	| Left err <- parsedToNode = Left $
		messageError (
			errorPayload "cancel" "item-not-found"
			(fromString $ "Not a valid email address: " ++ err) []
		)
		message
	where
	mid = mkMessageID fromDomain now message
	refs = mkReferences message
	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
	dateHeader = fromMaybe now $ parseXMPPTime =<<
		XML.attributeText (s"stamp") =<<
		child (s"{urn:xmpp:delay}delay") message
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)
	setFrom = set (MIME.headerFrom MIME.defaultCharsets) [fromMailbox]
	fromMailbox@(MIME.Mailbox _ fromAddrSpec) = jidToMailbox from fromDomain
	parsedToNode =
		MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode
	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
messageToEmail _ _ message = Left $
	messageError
	(errorPayload "modify" "bad-request" (s"Could not process message") [])
	message