1 {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} 2 module Databrary.Controller.Notification 3 ( viewNotify 4 , postNotify 5 , createNotification 6 , createVolumeNotification 7 , broadcastNotification 8 , viewNotifications 9 , deleteNotification 10 , deleteNotifications 11 , forkNotifier 12 , updateStateNotifications 13 , updateAuthorizeNotifications 14 ) where 15 16 import Control.Applicative ((<|>)) 17 import Control.Concurrent (ThreadId, forkFinally, threadDelay) 18 import Control.Concurrent.MVar (takeMVar, tryTakeMVar) 19 import Control.Monad (join, when, void, forM_) 20 import Data.Function (on) 21 import Data.List (groupBy) 22 import Data.Time.Clock (getCurrentTime, addUTCTime) 23 import Database.PostgreSQL.Typed (pgSQL) 24 import Network.HTTP.Types (noContent204) 25 import qualified Text.Regex.Posix as Regex 26 27 import Databrary.Has 28 import Databrary.Ops 29 import qualified Databrary.JSON as JSON 30 import Databrary.Service.Types 31 import Databrary.Service.DB 32 import Databrary.Service.Notification 33 import Databrary.Service.Log 34 import Databrary.Service.Mail 35 import Databrary.Service.Messages 36 import Databrary.Context 37 import Databrary.Model.Id.Types 38 import Databrary.Model.Party 39 import Databrary.Model.Volume.Types 40 import Databrary.Model.Authorize.Types 41 import Databrary.Model.Notification 42 import Databrary.HTTP.Path.Parser 43 import Databrary.HTTP.Form.Deform 44 import Databrary.Controller.Permission 45 import Databrary.Controller.Paths 46 import Databrary.Controller.Form 47 import Databrary.Action 48 import Databrary.View.Notification 49 50 viewNotify :: ActionRoute () 51 viewNotify = action GET (pathJSON </< "notify") $ \() -> withAuth $ do 52 u <- authAccount 53 n <- lookupAccountNotify u 54 return $ okResponse [] $ JSON.toEncoding n 55 56 postNotify :: ActionRoute () 57 postNotify = action POST (pathJSON </< "notify") $ \() -> withAuth $ do 58 u <- authAccount 59 (nl, md) <- runForm Nothing $ do 60 csrfForm 61 (,) 62 <$> ("notice" .:> return <$> deform <|> withSubDeforms (const deform)) 63 <*> ("delivery" .:> deformNonEmpty deform) 64 mapM_ (maybe (void . removeNotify u) (\d n -> changeNotify u n d) md) nl 65 return $ emptyResponse noContent204 [] 66 67 createNotification :: Notification -> Handler () 68 createNotification n' = do 69 d <- lookupNotify (notificationTarget n') (notificationNotice n') 70 when (d > DeliveryNone) $ do 71 n <- addNotification n' 72 if notificationDelivered n' >= DeliveryAsync 73 then sendTargetNotifications [n] 74 else when (d >= DeliveryAsync) $ focusIO $ triggerNotifications Nothing 75 76 broadcastNotification :: Bool -> ((Notice -> Notification) -> Notification) -> Handler () 77 broadcastNotification add f = 78 void $ (if add then addBroadcastNotification else removeMatchingNotifications) $ f $ blankNotification $ siteAccount nobodySiteAuth 79 80 createVolumeNotification :: Volume -> ((Notice -> Notification) -> Notification) -> Handler () 81 createVolumeNotification v f = do 82 u <- peek 83 forM_ (volumeOwners v) $ \(p, _) -> when (u /= p) $ 84 createNotification (f $ blankNotification blankAccount{ accountParty = blankParty{ partyRow = (partyRow blankParty){ partyId = p } } }) 85 { notificationVolume = Just $ volumeRow v } 86 87 viewNotifications :: ActionRoute () 88 viewNotifications = action GET (pathJSON </< "notification") $ \() -> withAuth $ do 89 _ <- authAccount 90 nl <- lookupUserNotifications 91 _ <- changeNotificationsDelivery (filter ((DeliverySite >) . notificationDelivered) nl) DeliverySite -- would be nice if it could be done as part of lookupNotifications 92 msg <- peek 93 return $ okResponse [] $ 94 JSON.mapRecords 95 (\n -> notificationJSON n `JSON.foldObjectIntoRec` ("html" JSON..= htmlNotification msg n)) 96 nl 97 98 deleteNotification :: ActionRoute (Id Notification) 99 deleteNotification = action DELETE (pathJSON >/> pathId) $ \i -> withAuth $ do 100 _ <- authAccount 101 r <- removeNotification i 102 if r 103 then return $ emptyResponse noContent204 [] 104 else peeks notFoundResponse 105 106 deleteNotifications :: ActionRoute () 107 deleteNotifications = action DELETE (pathJSON >/> "notification") $ \() -> withAuth $ do 108 _ <- authAccount 109 _ <- removeNotifications 110 return $ emptyResponse noContent204 [] 111 112 -- |Assumed to be all same target 113 sendTargetNotifications :: (MonadMail c m, MonadHas Notifications c m, MonadHas Messages c m) => [Notification] -> m () 114 sendTargetNotifications l@(Notification{ notificationTarget = u }:_) = do 115 Notifications{ notificationsFilter = filt, notificationsCopy = copy } <- peek 116 msg <- peek 117 sendMail (map Right (filter (Regex.matchTest filt . accountEmail) [u])) (maybe [] (return . Left) copy) 118 "Databrary notifications" 119 $ mailNotifications msg l 120 sendTargetNotifications [] = return () 121 122 emitNotifications :: Delivery -> ActionContextM () 123 emitNotifications d = do 124 unl <- lookupUndeliveredNotifications d 125 mapM_ sendTargetNotifications $ groupBy ((==) `on` partyId . partyRow . accountParty . notificationTarget) unl 126 _ <- changeNotificationsDelivery unl d 127 return () 128 129 runNotifier :: Service -> IO () 130 runNotifier rc = loop where 131 t = notificationsTrigger $ serviceNotification rc 132 loop = do 133 d' <- takeMVar t 134 d <- d' `orElseM` do 135 threadDelay 60000000 -- 60 second throttle on async notifications 136 join <$> tryTakeMVar t 137 runContextM (emitNotifications $ periodicDelivery d) rc 138 loop 139 140 forkNotifier :: Service -> IO ThreadId 141 forkNotifier rc = forkFinally (runNotifier rc) $ \r -> do 142 t <- getCurrentTime 143 logMsg t ("notifier aborted: " ++ show r) (view rc) 144 145 updateStateNotifications :: MonadDB c m => m () 146 updateStateNotifications = 147 dbTransaction $ dbExecute_ [pgSQL|# 148 CREATE TEMPORARY TABLE notification_authorize_expire (id, target, party, permission, time, notice) ON COMMIT DROP 149 AS WITH authorize_expire AS (SELECT * FROM authorize WHERE expires BETWEEN CURRENT_TIMESTAMP - interval '30 days' AND CURRENT_TIMESTAMP + interval '1 week') 150 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 151 FROM notification FULL JOIN authorize_expire JOIN account ON child = id ON child = target AND parent = party 152 WHERE (notice IS NULL OR notice = ${NoticeAuthorizeExpiring} OR notice = ${NoticeAuthorizeExpired}) 153 UNION ALL 154 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 155 FROM notification FULL JOIN authorize_expire JOIN account ON parent = id ON parent = target AND child = party 156 WHERE (notice IS NULL OR notice = ${NoticeAuthorizeChildExpiring} OR notice = ${NoticeAuthorizeChildExpired}); 157 DELETE FROM notification USING notification_authorize_expire nae 158 WHERE notification.id = nae.id AND nae.notice IS NULL; 159 UPDATE notification SET notice = nae.notice, time = nae.time, delivered = CASE WHEN notification.notice = nae.notice THEN delivered ELSE 'none' END, permission = nae.permission 160 FROM notification_authorize_expire nae WHERE notification.id = nae.id; 161 INSERT INTO notification (notice, target, party, permission, time, agent) 162 SELECT notice, target, party, permission, time, ${partyId $ partyRow nobodyParty} 163 FROM notification_authorize_expire WHERE id IS NULL; 164 |] 165 166 updateAuthorizeNotifications :: (MonadHas ActionContext c m, MonadDB c m) => Maybe Authorize -> Authorize -> m () 167 updateAuthorizeNotifications Nothing _ = return () 168 updateAuthorizeNotifications (Just Authorize{ authorizeExpires = o }) Authorize{ authorization = Authorization{ authorizeChild = Party{ partyRow = PartyRow{ partyId = c } }, authorizeParent = Party{ partyRow = PartyRow{ partyId = p } } }, authorizeExpires = e } = do 169 t <- peeks contextTimestamp 170 let t' = addUTCTime 691200 t 171 when (all (t' <) e && any (t' >=) o) $ 172 dbExecute_ [pgSQL|# 173 DELETE FROM notification 174 WHERE agent = ${partyId $ partyRow nobodyParty} 175 AND (((notice = ${NoticeAuthorizeExpiring} OR notice = ${NoticeAuthorizeExpired}) AND target = ${c} AND party = ${p}) 176 OR ((notice = ${NoticeAuthorizeChildExpiring} OR notice = ${NoticeAuthorizeChildExpired}) AND target = ${p} AND party = ${c})) 177 |]