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