{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module TiedoteMD.Send where

import Control.Concurrent (threadDelay)
import Control.Exception (throwIO)
import Control.Lens (set, _Just)
import Control.Monad (forever, unless)
import Data.Acid (AcidState, query, update)
import Data.Attoparsec.ByteString (endOfInput, parseOnly)
import Data.Binary.Builder (toLazyByteString)
import Data.MIME (Address(..), Mailbox, Boundary, MIMEMessage, MIME(..), Headers(..), MultipartSubtype(..), ContentTypeWith(..), DispositionType(..), buildMessage, headerTo, headerSubject, headerFrom, headerMessageID, headerContentID, header, createTextPlainMessage, contentType, contentDisposition, dispositionType, createAttachment, parseContentType, makeContentID)
import Data.MIME.Charset (defaultCharsets)
import Data.Set (Set)
import Data.Time (getCurrentTime)
import System.Exit (ExitCode(..))
import System.Exit.Codes (codeTempFail)
import System.IO (hClose, stdout)
import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc)
import System.Random (getStdRandom, uniform)

import qualified Data.ByteString.Lazy as LBS
import qualified Data.IMF as IMF
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Text as T

import TiedoteMD.State
import TiedoteMD.Types

sendmail :: FilePath -> LBS.ByteString -> IO ()
sendmail path bs = do
    (Just stdin, _, _, processHandle) <- createProcess (proc path ["-t"]) {std_in = CreatePipe}
    LBS.hPut stdin bs
    hClose stdin
    exitCode <- waitForProcess processHandle 
    unless (exitCode `elem` [ExitSuccess, codeTempFail]) $
        throwIO $ ProcessError (T.pack path) exitCode

manageQueue :: AcidState State -> Mailbox -> FilePath -> IO ()
manageQueue acid sender sendmailPath = forever $ do
    maybeNextJob <- query acid GetMessageFromQueue
    case maybeNextJob of
      Nothing -> pure ()
      Just (address, message) -> do
          boundary <- getStdRandom uniform
          boundary' <- getStdRandom uniform
          let mail = renderMessage message sender boundary boundary'
          sendmail sendmailPath $ toLazyByteString $ buildMessage $
              set (headerTo defaultCharsets) [Single $ emailToMailbox address] mail
          update acid MarkMessageAsSent
    -- Delay for 3s to reduce spamminess
    threadDelay $ 3 * 1000 * 1000

manageQueueingMessages :: AcidState State -> IO ()
manageQueueingMessages acid = forever $ do
     -- TODO: sleep until next move or updateMessages to save CPU and acid storage size
    threadDelay $ 10 * 1000 * 1000
    queueMessages acid

queueMessages :: AcidState State -> IO ()
queueMessages acid = getCurrentTime >>= update acid . MoveToSendQueue

renderMessage :: Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
renderMessage = renderMessage' "" Nothing

renderMessage' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary boundary' =
    maybe id (set headerMessageID . Just . mailIDToMessageID) maybeMailID $
    set (headerSubject defaultCharsets) (Just $ subjectPrefix <> subject) $
    set (header "Precedence") "Bulk" $
    -- Apparently some big mail providers want mass email to include "Precedence: Bulk"
    set (headerFrom defaultCharsets) [Single sender] $
    IMF.Message (Headers []) $ Multipart Alternative boundary $ NE.fromList
        [ createTextPlainMessage plainTextMessage
        , createTextMarkdownMessage markdownMessage
        , createTextHtmlMessage boundary' mediaParts htmlMessage
        ]

createTextMarkdownMessage :: T.Text -> MIMEMessage
createTextMarkdownMessage = set contentType "text/markdown; charset=utf-8; variant=pandoc" . createTextPlainMessage

createTextHtmlMessage :: Boundary -> Set MediaPart -> T.Text -> MIMEMessage
createTextHtmlMessage boundary mediaParts html = IMF.Message (Headers []) $ multipartRelated $
    (set contentType "text/html; charset=utf-8" $ createTextPlainMessage html) NE.:| mediaAttachments
        where multipartRelated = Multipart
                  (Related (Just $ ContentType "text" "html" ()) Nothing Nothing) boundary
              mediaAttachments = mediaPartToAttachment <$> Set.toList mediaParts

mediaPartToAttachment :: MediaPart -> MIMEMessage
mediaPartToAttachment MediaPart {..} =
    set (contentDisposition . _Just . dispositionType) Inline $
    set headerContentID (Just contentID) $
    createAttachment mimeType Nothing mediaPartContents
        where mimeType = either (error "purebred-email couldn't parse pandoc's mime type!") id $
                  parseOnly (parseContentType <* endOfInput) mediaPartMimeType
              contentID = either (error "purebred-email couldn't parse it's own contentID!") id $
                  makeContentID mediaPartContentID