1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-}
    2 module Databrary.Model.Notification.Notify
    3   ( lookupNotify
    4   , lookupAccountNotify
    5   , NoticeMap
    6   , changeNotify
    7   , removeNotify
    8   , lookupNoticePartyAuthorization
    9   ) where
   10 
   11 import Control.Monad (when)
   12 import qualified Data.Aeson as JSON
   13 import qualified Data.Vector as V
   14 import qualified Data.Vector.Mutable as VM
   15 import Database.PostgreSQL.Typed.Query (pgSQL)
   16 
   17 import Databrary.Has (peek)
   18 import Databrary.Service.DB
   19 import Databrary.Model.SQL
   20 import Databrary.Model.Id
   21 import Databrary.Model.Permission
   22 import Databrary.Model.Party.Types
   23 import Databrary.Model.Identity.Types
   24 import Databrary.Model.Notification.Notice
   25 import Databrary.Model.Notification.SQL
   26 
   27 useTDB
   28 
   29 lookupNotify :: MonadDB c m => Account -> Notice -> m Delivery
   30 lookupNotify a n = fromMaybeDelivery <$>
   31   dbQuery1 $(selectQuery selectNotifyDelivery "$WHERE target = ${partyId $ partyRow $ accountParty a} AND notice = ${n}")
   32 
   33 lookupAccountNotify :: MonadDB c m => Account -> m (NoticeMap Delivery)
   34 lookupAccountNotify a = NoticeMap <$>
   35   dbQuery [pgSQL|!SELECT notice, delivery FROM notify_view WHERE target = ${partyId $ partyRow $ accountParty a} ORDER BY notice|]
   36 
   37 changeNotify :: MonadDB c m => Account -> Notice -> Delivery -> m ()
   38 changeNotify a n d = do
   39   (r, _) <- updateOrInsert
   40     [pgSQL|UPDATE notify SET delivery = ${d} WHERE target = ${partyId $ partyRow $ accountParty a} AND notice = ${n}|]
   41     [pgSQL|INSERT INTO notify (target, notice, delivery) VALUES (${partyId $ partyRow $ accountParty a}, ${n}, ${d})|]
   42   when (r /= 1) $ fail $ "changeNotify: " ++ show r ++ " rows"
   43 
   44 -- |This resets to the default value (not necessarily DeliveryNone).
   45 removeNotify :: MonadDB c m => Account -> Notice -> m Bool
   46 removeNotify a n =
   47   dbExecute1 [pgSQL|DELETE FROM notify WHERE target = ${partyId $ partyRow $ accountParty a} AND notice = ${n}|]
   48 
   49 lookupNoticePartyAuthorization :: (MonadHasIdentity c m, MonadDB c m) => Notice -> m [(Party, Maybe Permission, Delivery)]
   50 lookupNoticePartyAuthorization n = do
   51   ident <- peek
   52   dbQuery $(selectQuery (selectPartyAuthorizationNotify 'ident) "WHERE notice = ${n} AND account.password IS NOT NULL")
   53 
   54 newtype NoticeMap a = NoticeMap [(Notice, a)]
   55 
   56 noticeInt :: Notice -> Int
   57 noticeInt = fromIntegral . unId . noticeId
   58 
   59 noticeMapToList :: NoticeMap a -> [Maybe a]
   60 noticeMapToList (NoticeMap m) = pop 0 m where
   61   pop _ [] = []
   62   pop i nl@((n,x):l) = case i `compare` noticeInt n of
   63     LT -> Nothing : pop (succ i) nl
   64     EQ -> Just x : pop (succ i) l
   65     GT -> error "NoticeMap: out of order"
   66 
   67 instance JSON.ToJSON a => JSON.ToJSON (NoticeMap a) where
   68   toJSON (NoticeMap m) = JSON.Array $ V.create $ do
   69     v <- VM.replicate (succ (noticeInt maxBound)) JSON.Null
   70     mapM_ (\(n,x) -> VM.write v (noticeInt n) $ JSON.toJSON x) m
   71     return v
   72   toEncoding = JSON.foldable . noticeMapToList