1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds, RecordWildCards, OverloadedStrings #-} 2 module Databrary.Model.Notification 3 ( module Databrary.Model.Notification.Types 4 , module Databrary.Model.Notification.Notify 5 , addNotification 6 , addBroadcastNotification 7 , changeNotificationsDelivery 8 , lookupUserNotifications 9 , countUserNotifications 10 , lookupUndeliveredNotifications 11 , removeNotification 12 , removeNotifications 13 , cleanNotifications 14 , removeMatchingNotifications 15 , notificationJSON 16 ) where 17 18 import Control.Monad (mfilter) 19 import Data.Int (Int64) 20 import Data.Maybe (fromMaybe) 21 import Data.Monoid ((<>)) 22 import Database.PostgreSQL.Typed (pgSQL) 23 24 import Databrary.Has 25 import qualified Databrary.JSON as JSON 26 import Databrary.Service.DB 27 import Databrary.Model.SQL 28 import Databrary.Model.Id.Types 29 import Databrary.Model.Party 30 import Databrary.Model.Volume.Types 31 import Databrary.Model.Segment 32 import Databrary.Model.Tag.Types 33 import Databrary.Model.Notification.Types 34 import Databrary.Model.Notification.Notify 35 import Databrary.Model.Notification.SQL 36 37 useTDB 38 39 addNotification :: (MonadDB c m, MonadHas Party c m) => Notification -> m Notification 40 addNotification n@Notification{..} = do 41 u <- peeks partyRow 42 (i, t) <- dbQuery1' [pgSQL|INSERT INTO notification (target, notice, delivered, agent, party, volume, container, segment, asset, comment, tag, permission, release) VALUES (${partyId $ partyRow $ accountParty notificationTarget}, ${notificationNotice}, ${notificationDelivered}, ${partyId u}, ${partyId <$> notificationParty}, ${volumeId <$> notificationVolume}, ${notificationContainerId}, ${notificationSegment}, ${notificationAssetId}, ${notificationCommentId}, ${tagId <$> notificationTag}, ${notificationPermission}, ${notificationRelease}) RETURNING id, time|] 43 return n 44 { notificationId = i 45 , notificationTime = t 46 , notificationAgent = u 47 } 48 49 addBroadcastNotification :: (MonadDB c m, MonadHas Party c m) => Notification -> m Int 50 addBroadcastNotification Notification{..} = do 51 u <- peeks (partyId . partyRow) 52 dbExecute [pgSQL|INSERT INTO notification (target, notice, delivered, agent, party, volume, container, segment, asset, comment, tag, permission, release) SELECT target, notice, ${notificationDelivered}, ${u}, ${partyId <$> notificationParty}, ${volumeId <$> notificationVolume}, ${notificationContainerId}, ${notificationSegment}, ${notificationAssetId}, ${notificationCommentId}, ${tagId <$> notificationTag}, ${notificationPermission}, ${notificationRelease} FROM notify_view WHERE notice = ${notificationNotice} AND delivery > 'none' AND target <> ${u}|] 53 54 changeNotificationsDelivery :: MonadDB c m => [Notification] -> Delivery -> m Int 55 changeNotificationsDelivery nl d = 56 dbExecute [pgSQL|UPDATE notification SET delivered = ${d} WHERE id = ANY (${map notificationId nl}) AND delivered < ${d}|] 57 58 lookupUserNotifications :: (MonadDB c m, MonadHas Account c m) => m [Notification] 59 lookupUserNotifications = do 60 u <- peek 61 dbQuery $ ($ u) <$> $(selectQuery selectTargetNotification "$WHERE target = ${view u :: Id Party} ORDER BY notification.id DESC") 62 63 countUserNotifications :: (MonadDB c m, MonadHas (Id Party) c m) => m Int64 64 countUserNotifications = do 65 u <- peek 66 dbQuery1' $ fromMaybe 0 <$> [pgSQL|$SELECT count(id) FROM notification WHERE target = ${u :: Id Party} AND delivered = 'none'|] 67 68 lookupUndeliveredNotifications :: MonadDB c m => Delivery -> m [Notification] 69 lookupUndeliveredNotifications d = 70 dbQuery $(selectQuery selectNotification "JOIN notify_view USING (target, notice) WHERE delivery >= ${d} AND delivered = 'none' ORDER BY notification.target, notification.id") 71 72 removeNotification :: (MonadDB c m, MonadHas (Id Party) c m) => Id Notification -> m Bool 73 removeNotification i = do 74 p <- peek 75 dbExecute1 [pgSQL|DELETE FROM notification WHERE id = ${i} AND target = ${p :: Id Party}|] 76 77 removeNotifications :: (MonadDB c m, MonadHas (Id Party) c m) => m Int 78 removeNotifications = do 79 p <- peek 80 dbExecute [pgSQL|DELETE FROM notification WHERE target = ${p :: Id Party} AND agent <> ${partyId $ partyRow nobodyParty}|] 81 82 cleanNotifications :: MonadDB c m => m Int 83 cleanNotifications = 84 dbExecute [pgSQL|DELETE FROM notification WHERE delivered > 'none' AND time < CURRENT_TIMESTAMP - interval '30 days'|] 85 86 removeMatchingNotifications :: MonadDB c m => Notification -> m Int 87 removeMatchingNotifications Notification{..} = 88 dbExecute [pgSQL|DELETE FROM notification 89 WHERE notice = ${notificationNotice} 90 AND target = COALESCE(${mfilter (no /=) $ Just $ partyId $ partyRow $ accountParty notificationTarget}, target) 91 AND agent = COALESCE(${mfilter (no /=) $ Just $ partyId notificationAgent}, agent) 92 AND COALESCE(party, -1) = COALESCE(${partyId <$> notificationParty}, party, -1) 93 AND COALESCE(volume, -1) = COALESCE(${volumeId <$> notificationVolume}, volume, -1) 94 AND COALESCE(container, -1) = COALESCE(${notificationContainerId}, container, -1) 95 AND COALESCE(segment, 'empty') <@ ${fromMaybe fullSegment notificationSegment} 96 AND COALESCE(asset, -1) = COALESCE(${notificationAssetId}, asset, -1) 97 AND COALESCE(comment, -1) = COALESCE(${notificationCommentId}, comment, -1) 98 AND COALESCE(tag, -1) = COALESCE(${tagId <$> notificationTag}, tag, -1) 99 |] 100 where 101 no :: Num (IdType a) => Id a 102 no = Id $ -1 103 104 notificationJSON :: JSON.ToNestedObject o u => Notification -> JSON.Record (Id Notification) o 105 notificationJSON Notification{..} = JSON.Record notificationId $ 106 "notice" JSON..= notificationNotice 107 <> "time" JSON..= notificationTime 108 <> "delivered" JSON..= notificationDelivered 109 <> "agent" JSON..=. JSON.recordObject ({-on (==) partyId notificationAgent (partyRow (accountParty notificationTarget)) ?!>-} partyRowJSON notificationAgent) 110 <> "party" `JSON.kvObjectOrEmpty` (partyId <$> notificationParty) 111 <> "permission" `JSON.kvObjectOrEmpty` notificationPermission 112 <> "volume" `JSON.kvObjectOrEmpty` (volumeId <$> notificationVolume) 113 <> "container" `JSON.kvObjectOrEmpty` notificationContainerId 114 <> "segment" `JSON.kvObjectOrEmpty` notificationSegment 115 <> "asset" `JSON.kvObjectOrEmpty` notificationAssetId 116 <> "comment" `JSON.kvObjectOrEmpty` notificationCommentId 117 <> "tag" `JSON.kvObjectOrEmpty` (tagName <$> notificationTag)