{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module TiedoteMD.State where

import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.ByteString (ByteString)
import Data.Function (on)
import Data.List (intersectBy)
import Data.List (partition)
import Data.Maybe (listToMaybe, isNothing, catMaybes)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Time (UTCTime)
import Data.Typeable (Typeable)

import Data.Acid

import qualified Data.List.NonEmpty as NE

import TiedoteMD.Types

data State = State
    { stateMessages :: [Message]
    , stateSendJobs :: [SendJob]
    } deriving (Show, Typeable)

emptyState :: State
emptyState = State
    { stateMessages = []
    , stateSendJobs = []
    }

updateListBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
updateListBy f old new = olds <> news
    where news = differenceBy f new old
          olds = intersectBy f old new

elemBy :: (a -> b -> Bool) -> a -> [b] -> Bool
elemBy = (.) any

differenceBy :: (a -> b -> Bool) -> [a] -> [b] -> [a]
differenceBy f xs ys = filter (\x -> not $ elemBy f x ys) xs

updateState :: [Message] -> Update State ()
updateState new = do
    state@(State {..}) <- get
    let newstate = state { stateMessages = updateListBy ((==) `on` messageHash) stateMessages new }
    put newstate

updateRecipients :: ByteString -> [Email] -> Update State ()
updateRecipients hash emails = do
    state@(State {..}) <- get
    let newstate = state { stateMessages = map updateIfSameHash stateMessages }
    put newstate
        where updateIfSameHash message@(Message {..})
                | messageHash == hash = message { recipients = emails }
                | otherwise = message

moveToSendQueue :: UTCTime -> Update State ()
moveToSendQueue currentTime = do
    state@(State {..}) <- get
    let (messagesToSend, remainingMessages) = partition ((<= currentTime) . sendTime) stateMessages
        toSendJob sendJobMessage = (\mails -> SendJob {toSend = mails, ..}) <$>
            NE.nonEmpty (recipients sendJobMessage)
        newstate = state
            { stateMessages = remainingMessages
            , stateSendJobs = stateSendJobs <> catMaybes (map toSendJob messagesToSend)
            }
    put newstate

getMessageFromQueue :: Query State (Maybe (Email, Message))
getMessageFromQueue = do
    State {..} <- ask
    pure $ do
        SendJob {..} <- listToMaybe stateSendJobs
        pure (NE.head toSend, sendJobMessage)

-- XXX: This function assumes that new SendJobs are always added to the tail and there is only one thread 
markMessageAsSent :: Update State ()
markMessageAsSent = do
    state@(State {..}) <- get
    let newQueue = case stateSendJobs of
                     [] -> undefined
                     -- TODO: This should never happen, how should we deal with it?
                     -- Should we crash as the code is assuming a wrong state
                     -- or should we just keep the queue empty and go on
                     (sendJob@(SendJob {..}) : sendJobs) ->
                         maybe sendJobs (\remaining -> sendJob {toSend = remaining} : sendJobs) $
                             NE.nonEmpty $ NE.tail toSend
        newstate = state { stateSendJobs = newQueue }
    put newstate

addMessageRecipients :: [MailID] -> [Email] -> Update State [Message]
addMessageRecipients ids recipients = do
    state@(State {..}) <- get
    let newMessages = map addRecipients stateMessages
        newstate = state {stateMessages = newMessages}
    put newstate
    pure $ filter isTarget $ newMessages
        where isTarget = maybe False (`elem` ids) . previewMailID
              addRecipients message
                | isTarget message = message {recipients = recipients}
                | otherwise = message

getMessageToPreview :: UTCTime -> Query State (Maybe Message)
getMessageToPreview currentTime = listToMaybe . filter needsPreview . stateMessages <$> ask
        where needsPreview Message{..} = currentTime >= previewTime && isNothing previewMailID

setPreviewID :: ByteString -> MailID -> Update State ()
setPreviewID hash mailID = do
    state@(State {..}) <- get
    let newstate = state {stateMessages = map setMessagePreviewID stateMessages}
    put newstate
        where setMessagePreviewID msg@(Message {..})
                | messageHash == hash = msg {previewMailID = Just mailID}
                | otherwise = msg

getState :: Query State State
getState = ask

deriveSafeCopy 0 'base ''State

makeAcidic ''State
    [ 'updateState
    , 'updateRecipients
    , 'moveToSendQueue
    , 'getMessageFromQueue
    , 'markMessageAsSent
    , 'addMessageRecipients
    , 'getMessageToPreview
    , 'setPreviewID
    , 'getState
    ]