136 lines
4.6 KiB
Haskell
136 lines
4.6 KiB
Haskell
{-# 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
|
|
]
|