1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-} 2 module 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 Has (peek) 18 import Service.DB 19 import Model.SQL 20 import Model.Id 21 import Model.Permission 22 import Model.Party.Types 23 import Model.Identity.Types 24 import Model.Notification.Notice 25 import 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