{-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
module Clckwrks.MailingList.Acid where
import Control.Lens ((^.), (.=), (?=), (^?), (&), (.~), view, set, over)
import Control.Lens.At (at)
import Control.Applicative ((<$>))
import Control.Lens.At (at)
import Control.Lens.TH (makeLenses)
import Control.Lens.Prism (_Just)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, modify, put)
import Data.Acid (Query, Update, makeAcidic)
import Data.Data (Data, Typeable)
import Data.IxSet (IxSet, Proxy(..), (@=), (@+), getOne, empty, toAscList, toList, fromList, updateIx)
import qualified Data.IxSet as IxSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Ratio ((%))
import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (UTCTime(..))
import Data.UUID (UUID)
import Clckwrks.MailingList.Types (Email(..), Message(..), msgId, MessageId(..), Subscriber(..), subId, subStatus, SubscriptionStatus(..), SubscriberId(..), incSubscriberId, msgSubject, msgId)
import System.FilePath (FilePath)
data MailingListState_0 = MailingListState_0
{ _subscribers_0 :: IxSet Subscriber
, _nextSubscriberId_0 :: SubscriberId
, _messages_0 :: Map MessageId Message
, _nextMessageId_0 :: MessageId
, _contactAddr_0 :: Maybe Email
, _optInConfirm_0 :: Maybe MessageId
, _sendmailPath_0 :: Maybe FilePath
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
deriveSafeCopy 0 'base ''MailingListState_0
data MailingListState = MailingListState
{ _subscribers :: IxSet Subscriber
, _nextSubscriberId :: SubscriberId
, _messages :: Map MessageId Message
, _mailLog :: Set (MessageId, SubscriberId, UTCTime)
, _nextMessageId :: MessageId
, _contactAddr :: Maybe Email
, _optInConfirm :: Maybe MessageId
, _sendmailPath :: Maybe FilePath
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
deriveSafeCopy 1 'extension ''MailingListState
makeLenses ''MailingListState
instance Migrate MailingListState where
type MigrateFrom MailingListState = MailingListState_0
migrate (MailingListState_0 s ns m nm ca oic sp) = MailingListState s ns m Set.empty nm ca oic sp
optInConfirmMsgId :: MessageId
optInConfirmMsgId = MessageId 1
optInConfirmMsg :: Email -> Message
optInConfirmMsg from =
Message { _msgId = MessageId 1
, _msgSubject = "Please Confirm Your Mailing List Subscription"
, _msgFrom = from
, _msgBody = "Hello,\n\n\
\\
\To complete your subscription to our mailing list you must click on the following link:\n\n" <> "$link$" <>
"\n\nIf you did not issue the request to join this list then you can just ignore this message and you will remain unsubscribed."
}
initialMailingListState :: MailingListState
initialMailingListState = MailingListState
{ _subscribers = IxSet.empty
, _nextSubscriberId = SubscriberId 1
, _messages = Map.empty
, _mailLog = Set.empty
, _nextMessageId = MessageId 2
, _contactAddr = Nothing
, _optInConfirm = Nothing
, _sendmailPath = Nothing
-- , _sendQueue = [(SubscriberId, MessageId)]
-- , _mailLog = Set (SubscriberId, MessageId, UTCTime)
}
-- | FIXME: behavior if email already exists
addSubscriber :: Email -> SubscriptionStatus -> UTCTime -> Update MailingListState Subscriber
addSubscriber email subscriptionStatus now =
do ms@MailingListState{..} <- get
case getOne $ (ms ^. subscribers) @= email of
Nothing -> do
let subscriber = Subscriber { _subId = _nextSubscriberId
, _subEmail = email
, _subStatus = [(now, subscriptionStatus)]
}
put $ ms { _subscribers = IxSet.insert subscriber _subscribers
, _nextSubscriberId = incSubscriberId _nextSubscriberId
}
pure subscriber
(Just subscriber) ->
pure subscriber
askSubscribers :: Query MailingListState (IxSet Subscriber)
askSubscribers =
do ms <- ask
pure $ ms ^. subscribers
{-
askActiveSubscribers :: Query MailingListState (IxSet Subscriber)
askActiveSubscribers =
do ms <- ask
case (ms ^. subscribers) @= Subscribed of
subs -> pure $ filter (\sub -> head (sub ^. subStatus) == Subscribed) IxSet.toList
-}
signupSubscriber :: Email -> SubscriptionStatus -> UTCTime -> Update MailingListState Subscriber
signupSubscriber email subscriptionStatus now =
do ms@MailingListState{..} <- get
case getOne $ (ms ^. subscribers) @= email of
-- email not already in the system
Nothing -> do
let subscriber = Subscriber { _subId = _nextSubscriberId
, _subEmail = email
, _subStatus = [(now, subscriptionStatus)]
}
put $ ms { _subscribers = IxSet.insert subscriber _subscribers
, _nextSubscriberId = incSubscriberId _nextSubscriberId
}
pure subscriber
(Just subscriber) ->
case subscriber ^. subStatus of
-- not sure how this would happen
[] -> do
let subscriber' = set subStatus [(now, subscriptionStatus)] subscriber
put $ ms { _subscribers = IxSet.updateIx (subscriber' ^. subId) subscriber' _subscribers }
pure subscriber'
statuses@(currentStatus:previousStatuses) ->
case currentStatus of
(_, Subscribed) -> pure subscriber
(_, AwaitingConfirmation{}) -> pure subscriber
_ -> do
let subscriber' = set subStatus ((now, subscriptionStatus):statuses) subscriber
put $ ms { _subscribers = IxSet.updateIx (subscriber' ^. subId) subscriber' _subscribers }
pure subscriber'
data VerificationResult
= SubscriptionConfirmed
| AlreadySubscribed
| InvalidConfirmation
deriveSafeCopy 0 'base ''VerificationResult
verifyOptIn :: UTCTime -> SubscriberId -> UUID -> Update MailingListState VerificationResult
verifyOptIn now sid uuid =
do ms@MailingListState{..} <- get
case getOne $ (ms ^. subscribers) @= sid of
Nothing -> pure InvalidConfirmation
(Just subscriber) ->
case subscriber ^. subStatus of
((_,AwaitingConfirmation uuid'):_)
| uuid == uuid' ->
do let subscriber' = subscriber { _subStatus = (now, Subscribed) : (_subStatus subscriber) }
put $ ms { _subscribers = IxSet.updateIx sid subscriber' _subscribers }
pure SubscriptionConfirmed
| otherwise -> pure InvalidConfirmation
((_,Subscribed):_) -> pure AlreadySubscribed
_ -> pure InvalidConfirmation
changeSubscriptionStatus :: SubscriberId -> SubscriptionStatus -> UTCTime -> Update MailingListState (Maybe Subscriber)
changeSubscriptionStatus subscriberId newStatus now =
do ms@MailingListState{..} <- get
case getOne $ _subscribers @= subscriberId of
Nothing -> pure Nothing
(Just subscriber) ->
do let subscriber' = subscriber { _subStatus = (now, newStatus) : (_subStatus subscriber) }
put $ ms { _subscribers = IxSet.updateIx subscriberId subscriber' _subscribers }
pure $ Just subscriber'
getOptInConfirmMessage :: Query MailingListState (Maybe Message)
getOptInConfirmMessage =
do mmessageId <- view optInConfirm
case mmessageId of
Nothing -> pure Nothing
(Just messageId) ->
view (messages . at messageId)
getMailingListSettings :: Query MailingListState (Maybe FilePath, Maybe Email, Maybe Message)
getMailingListSettings =
do mSendmail <- view sendmailPath
mEmail <- view contactAddr
mId <- view optInConfirm
case mId of
Nothing -> pure (mSendmail, mEmail, Nothing)
(Just mid) ->
do mMessage <- view (messages . at mid)
pure (mSendmail, mEmail, mMessage)
getSendmailPath :: Query MailingListState (Maybe FilePath)
getSendmailPath = view sendmailPath
setMailingListSettings :: Maybe FilePath
-> Maybe Email
-> Maybe Message
-> Update MailingListState ()
setMailingListSettings mSendmail mEmail mMessage =
do sendmailPath .= mSendmail
contactAddr .= mEmail
case mMessage of
Nothing -> do
optInConfirm .= Nothing
(Just message) -> do
optInConfirm .= over _Just (^. msgId) mMessage
messages . at (message ^. msgId) ?= message
addMailLogEntry :: (MessageId, SubscriberId, UTCTime) -> Update MailingListState ()
addMailLogEntry entry =
do mls@MailingListState {..} <- get
put $ mls { _mailLog = Set.insert entry _mailLog }
askMessageSubjects :: Query MailingListState [(MessageId, Text)]
askMessageSubjects =
do mls <- ask
pure $ map (\(i, m) -> (i, m ^. msgSubject)) (Map.toList $ mls ^. messages)
messageById :: MessageId -> Query MailingListState (Maybe Message)
messageById msgid =
view (messages . at msgid)
updateMessage :: Message -> Update MailingListState ()
updateMessage msg =
messages . at (msg ^. msgId) .= Just msg
createMessage :: Update MailingListState MessageId
createMessage =
do mls <- get
let msgid = mls ^. nextMessageId
msg = Message msgid (Email mempty) mempty mempty
put $ mls & (messages . at msgid) .~ Just msg
& nextMessageId .~ succ msgid
pure msgid
$(makeAcidic ''MailingListState
[ 'addSubscriber
, 'addMailLogEntry
, 'askSubscribers
-- , 'askActiveSubscriber
, 'changeSubscriptionStatus
, 'getOptInConfirmMessage
, 'signupSubscriber
, 'verifyOptIn
, 'getMailingListSettings
, 'setMailingListSettings
, 'getSendmailPath
, 'askMessageSubjects
, 'messageById
, 'updateMessage
, 'createMessage
])