module Controller.Notification
( viewNotify
, postNotify
, createNotification
, createVolumeNotification
, broadcastNotification
, viewNotifications
, deleteNotification
, deleteNotifications
, forkNotifier
, updateStateNotifications
, updateAuthorizeNotifications
, emitNotifications
) where
import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, forkFinally, threadDelay)
import Control.Concurrent.MVar (takeMVar, tryTakeMVar)
import Control.Monad (join, when, void, forM_)
import qualified Data.Aeson as Aeson
import Data.Function (on)
import Data.List (groupBy)
import Data.Time.Clock (getCurrentTime, addUTCTime)
import Database.PostgreSQL.Typed (pgSQL)
import Network.HTTP.Types (noContent204)
import qualified Text.Regex.Posix as Regex
import Has
import Ops
import qualified JSON
import Service.Types
import Service.DB
import Service.Notification
import Service.Log
import Service.Mail
import Service.Messages
import Context
import Model.Id.Types
import Model.Party
import Model.Volume.Types
import Model.Authorize.Types
import Model.Notification
import HTTP.Path.Parser
import HTTP.Form.Deform
import Controller.Permission
import Controller.Paths
import Controller.Form
import Action
import View.Notification
viewNotify :: ActionRoute ()
viewNotify = action GET (pathJSON </< "notify") $ \() -> withAuth $ do
u <- authAccount
n <- ViewNotifyResult <$> lookupAccountNotify u
return $ okResponse [] $ (Aeson.encode . unwrap) n
newtype ViewNotifyResult = ViewNotifyResult { unwrap :: NoticeMap Delivery }
data UpdateNotifyRequest = UpdateNotifyRequest [Notice] (Maybe Delivery)
postNotify :: ActionRoute ()
postNotify = action POST (pathJSON </< "notify") $ \() -> withAuth $ do
u <- authAccount
UpdateNotifyRequest nl md <- runForm Nothing $ do
csrfForm
UpdateNotifyRequest
<$> ("notice" .:> return <$> deform <|> withSubDeforms (const deform))
<*> ("delivery" .:> deformNonEmpty deform)
mapM_ (maybe (void . removeNotify u) (flip (changeNotify u)) md) nl
return $ emptyResponse noContent204 []
createNotification
:: ( MonadDB c m
, MonadHas Party c m
, MonadMail c m
, MonadHas Notifications c m
, MonadHas Messages c m)
=> Notification
-> m ()
createNotification n' = do
d <- lookupNotify (notificationTarget n') (notificationNotice n')
when (d > DeliveryNone) $ do
n <- addNotification n'
if notificationDelivered n' >= DeliveryAsync
then sendTargetNotifications [n]
else when (d >= DeliveryAsync) $ focusIO $ triggerNotifications Nothing
broadcastNotification :: Bool -> ((Notice -> Notification) -> Notification) -> Handler ()
broadcastNotification add f =
void $ (if add then addBroadcastNotification else removeMatchingNotifications) $ f $ blankNotification $ siteAccount nobodySiteAuth
createVolumeNotification
:: ( MonadDB c m
, MonadHas (Id Party) c m
, MonadHas Party c m
, MonadMail c m
, MonadHas Notifications c m
, MonadHas Messages c m)
=> Volume
-> ((Notice -> Notification) -> Notification)
-> m ()
createVolumeNotification v f = do
u <- peek
forM_ (volumeOwners v) $ \(p, _) -> when (u /= p) $
createNotification (f $ blankNotification blankAccount{ accountParty = blankParty{ partyRow = (partyRow blankParty){ partyId = p } } })
{ notificationVolume = Just $ volumeRow v }
viewNotifications :: ActionRoute ()
viewNotifications = action GET (pathJSON </< "notification") $ \() -> withAuth $ do
_ <- authAccount
nl <- lookupUserNotifications
_ <- changeNotificationsDelivery (filter ((DeliverySite >) . notificationDelivered) nl) DeliverySite
msg <- peek
return $ okResponse [] $
JSON.mapRecords
(\n -> notificationJSON n `JSON.foldObjectIntoRec` ("html" JSON..= htmlNotification msg n))
nl
deleteNotification :: ActionRoute (Id Notification)
deleteNotification = action DELETE (pathJSON >/> pathId) $ \i -> withAuth $ do
_ <- authAccount
r <- removeNotification i
if r
then return $ emptyResponse noContent204 []
else peeks notFoundResponse
deleteNotifications :: ActionRoute ()
deleteNotifications = action DELETE (pathJSON >/> "notification") $ \() -> withAuth $ do
_ <- authAccount
_ <- removeNotifications
return $ emptyResponse noContent204 []
sendTargetNotifications :: (MonadMail c m, MonadHas Notifications c m, MonadHas Messages c m) => [Notification] -> m ()
sendTargetNotifications l@(Notification{ notificationTarget = u }:_) = do
Notifications{ notificationsFilter = filt, notificationsCopy = copy } <- peek
msg <- peek
sendMail (map Right (filter (Regex.matchTest filt . accountEmail) [u])) (maybe [] (return . Left) copy)
"Databrary notifications"
$ mailNotifications msg l
sendTargetNotifications [] = return ()
emitNotifications
:: ( MonadDB c m
, MonadMail c m
, MonadHas Notifications c m
, MonadHas Messages c m)
=> Delivery
-> m ()
emitNotifications d = do
unl <- lookupUndeliveredNotifications d
mapM_ sendTargetNotifications $ groupBy ((==) `on` partyId . partyRow . accountParty . notificationTarget) unl
_ <- changeNotificationsDelivery unl d
return ()
runNotifier :: Service -> IO ()
runNotifier rc = loop where
t = notificationsTrigger $ serviceNotification rc
loop = do
d' <- takeMVar t
d <- d' `orElseM` do
threadDelay 60000000
join <$> tryTakeMVar t
runContextM (emitNotifications $ periodicDelivery d) rc
loop
forkNotifier :: Service -> IO ThreadId
forkNotifier rc = forkFinally (runNotifier rc) $ \r -> do
t <- getCurrentTime
logMsg t ("notifier aborted: " ++ show r) (view rc)
updateStateNotifications :: MonadDB c m => m ()
updateStateNotifications =
dbTransaction $ dbExecute_ [pgSQL|#
CREATE TEMPORARY TABLE notification_authorize_expire (id, target, party, permission, time, notice) ON COMMIT DROP
AS WITH authorize_expire AS (SELECT * FROM authorize WHERE expires BETWEEN CURRENT_TIMESTAMP interval '30 days' AND CURRENT_TIMESTAMP + interval '1 week')
SELECT notification.id, COALESCE(child, target), COALESCE(parent, party), site, expires, CASE WHEN expires <= CURRENT_TIMESTAMP THEN ${NoticeAuthorizeExpired} WHEN expires > CURRENT_TIMESTAMP THEN ${NoticeAuthorizeExpiring} END
FROM notification FULL JOIN authorize_expire JOIN account ON child = id ON child = target AND parent = party
WHERE (notice IS NULL OR notice = ${NoticeAuthorizeExpiring} OR notice = ${NoticeAuthorizeExpired})
UNION ALL
SELECT notification.id, COALESCE(parent, target), COALESCE(child, party), site, expires, CASE WHEN expires <= CURRENT_TIMESTAMP THEN ${NoticeAuthorizeChildExpired} WHEN expires > CURRENT_TIMESTAMP THEN ${NoticeAuthorizeChildExpiring} END
FROM notification FULL JOIN authorize_expire JOIN account ON parent = id ON parent = target AND child = party
WHERE (notice IS NULL OR notice = ${NoticeAuthorizeChildExpiring} OR notice = ${NoticeAuthorizeChildExpired});
DELETE FROM notification USING notification_authorize_expire nae
WHERE notification.id = nae.id AND nae.notice IS NULL;
UPDATE notification SET notice = nae.notice, time = nae.time, delivered = CASE WHEN notification.notice = nae.notice THEN delivered ELSE 'none' END, permission = nae.permission
FROM notification_authorize_expire nae WHERE notification.id = nae.id;
INSERT INTO notification (notice, target, party, permission, time, agent)
SELECT notice, target, party, permission, time, ${partyId $ partyRow nobodyParty}
FROM notification_authorize_expire WHERE id IS NULL;
|]
updateAuthorizeNotifications :: (MonadHas ActionContext c m, MonadDB c m) => Maybe Authorize -> Authorize -> m ()
updateAuthorizeNotifications Nothing _ = return ()
updateAuthorizeNotifications (Just Authorize{ authorizeExpires = o }) Authorize{ authorization = Authorization{ authorizeChild = Party{ partyRow = PartyRow{ partyId = c } }, authorizeParent = Party{ partyRow = PartyRow{ partyId = p } } }, authorizeExpires = e } = do
t <- peeks contextTimestamp
let t' = addUTCTime 691200 t
when (all (t' <) e && any (t' >=) o) $
dbExecute_ [pgSQL|#
DELETE FROM notification
WHERE agent = ${partyId $ partyRow nobodyParty}
AND (((notice = ${NoticeAuthorizeExpiring} OR notice = ${NoticeAuthorizeExpired}) AND target = ${c} AND party = ${p})
OR ((notice = ${NoticeAuthorizeChildExpiring} OR notice = ${NoticeAuthorizeChildExpired}) AND target = ${p} AND party = ${c}))
|]