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     |]