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