From 850d2fa42313c389b18adbf406131829966ff3cd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 25 Apr 2025 16:47:39 +0100 Subject: [PATCH 1/9] ntf server: PostgreSQL database storage (#1519) * ntf server: PostgreSQL database storage * ntf server: import/export stubs * ntf server postgres db functions * some notifications tests pass * notifications tests pass * import/export notification store logs * fix ntf server CLI * log in parralel * update subscription statuses using executeMany * fix import/export * refactor * fix queries * prohibit token_id and subscription_id updates, dont update tokens and subscriptions on conflict, improve server insertion, remove duplicate tokens for import, remove subscriptions without tokens for import * comment * remame * increase test delay --- simplexmq.cabal | 37 +- src/Simplex/Messaging/Client/Agent.hs | 10 +- src/Simplex/Messaging/Encoding.hs | 2 +- src/Simplex/Messaging/Encoding/String.hs | 2 +- .../Messaging/Notifications/Protocol.hs | 14 + src/Simplex/Messaging/Notifications/Server.hs | 480 +++++------ .../Messaging/Notifications/Server/Env.hs | 49 +- .../Messaging/Notifications/Server/Main.hs | 171 +++- .../Notifications/Server/Push/APNS.hs | 10 +- .../Messaging/Notifications/Server/Store.hs | 104 +-- .../Notifications/Server/Store/Migrations.hs | 81 ++ .../Notifications/Server/Store/Postgres.hs | 809 ++++++++++++++++++ .../Notifications/Server/Store/Types.hs | 109 +++ .../Notifications/Server/StoreLog.hs | 201 ++--- src/Simplex/Messaging/Server/CLI.hs | 94 +- src/Simplex/Messaging/Server/Env/STM.hs | 2 + src/Simplex/Messaging/Server/Main.hs | 74 +- src/Simplex/Messaging/Server/Main/Init.hs | 31 +- src/Simplex/Messaging/Server/NtfStore.hs | 2 +- .../Messaging/Server/QueueStore/Postgres.hs | 19 +- tests/AgentTests.hs | 13 +- tests/AgentTests/NotificationTests.hs | 70 +- tests/CLITests.hs | 21 +- tests/NtfClient.hs | 70 +- tests/NtfServerTests.hs | 18 +- tests/SMPAgentClient.hs | 3 +- tests/SMPClient.hs | 21 +- tests/Test.hs | 20 +- tests/XFTPAgent.hs | 2 +- 29 files changed, 1805 insertions(+), 734 deletions(-) create mode 100644 src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs create mode 100644 src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs create mode 100644 src/Simplex/Messaging/Notifications/Server/Store/Types.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 2590afc96..43eb6b31c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -216,15 +216,6 @@ library Simplex.FileTransfer.Server.Stats Simplex.FileTransfer.Server.Store Simplex.FileTransfer.Server.StoreLog - Simplex.Messaging.Notifications.Server - Simplex.Messaging.Notifications.Server.Control - Simplex.Messaging.Notifications.Server.Env - Simplex.Messaging.Notifications.Server.Main - Simplex.Messaging.Notifications.Server.Push.APNS - Simplex.Messaging.Notifications.Server.Push.APNS.Internal - Simplex.Messaging.Notifications.Server.Stats - Simplex.Messaging.Notifications.Server.Store - Simplex.Messaging.Notifications.Server.StoreLog Simplex.Messaging.Server Simplex.Messaging.Server.CLI Simplex.Messaging.Server.Control @@ -257,6 +248,18 @@ library if flag(server_postgres) exposed-modules: + Simplex.Messaging.Notifications.Server + Simplex.Messaging.Notifications.Server.Control + Simplex.Messaging.Notifications.Server.Env + Simplex.Messaging.Notifications.Server.Main + Simplex.Messaging.Notifications.Server.Push.APNS + Simplex.Messaging.Notifications.Server.Push.APNS.Internal + Simplex.Messaging.Notifications.Server.Stats + Simplex.Messaging.Notifications.Server.Store + Simplex.Messaging.Notifications.Server.Store.Migrations + Simplex.Messaging.Notifications.Server.Store.Postgres + Simplex.Messaging.Notifications.Server.Store.Types + Simplex.Messaging.Notifications.Server.StoreLog Simplex.Messaging.Server.QueueStore.Postgres Simplex.Messaging.Server.QueueStore.Postgres.Migrations other-modules: @@ -340,6 +343,8 @@ library , sqlcipher-simple ==0.4.* if flag(server_postgres) cpp-options: -DdbServerPostgres + build-depends: + hex-text ==0.1.* if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* @@ -352,6 +357,10 @@ library executable ntf-server if flag(client_library) buildable: False + if flag(server_postgres) + cpp-options: -DdbServerPostgres + else + buildable: False main-is: Main.hs other-modules: Paths_simplexmq @@ -444,7 +453,6 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests - AgentTests.NotificationTests AgentTests.ServerChoice AgentTests.ShortLinkTests CLITests @@ -460,8 +468,6 @@ test-suite simplexmq-test CoreTests.UtilTests CoreTests.VersionRangeTests FileDescriptionTests - NtfClient - NtfServerTests RemoteControl ServerTests SMPAgentClient @@ -484,6 +490,9 @@ test-suite simplexmq-test AgentTests.SQLiteTests if flag(server_postgres) other-modules: + AgentTests.NotificationTests + NtfClient + NtfServerTests ServerTests.SchemaDump hs-source-dirs: tests @@ -537,6 +546,8 @@ test-suite simplexmq-test , warp-tls , yaml default-language: Haskell2010 + if flag(server_postgres) + cpp-options: -DdbServerPostgres if flag(client_postgres) cpp-options: -DdbPostgres else @@ -550,5 +561,3 @@ test-suite simplexmq-test if flag(client_postgres) || flag(server_postgres) build-depends: postgresql-simple ==0.7.* - if flag(server_postgres) - cpp-options: -DdbServerPostgres diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 1a7a67806..dab0a4040 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -412,14 +412,22 @@ removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () removeSubscription = removeSub_ . srvSubs {-# INLINE removeSubscription #-} +removePendingSub :: SMPClientAgent -> SMPServer -> SMPSub -> STM () +removePendingSub = removeSub_ . pendingSrvSubs +{-# INLINE removePendingSub #-} + removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM () removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s) +removeSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removeSubscriptions = removeSubs_ . srvSubs +{-# INLINE removeSubscriptions #-} + removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM () removePendingSubs = removeSubs_ . pendingSrvSubs {-# INLINE removePendingSubs #-} -removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removeSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [QueueId] -> STM () removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss)) where ss = S.fromList $ map (party,) qs diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index 15718e297..ef0033dfb 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -143,7 +143,7 @@ instance Encoding Large where instance Encoding SystemTime where smpEncode = smpEncode . systemSeconds {-# INLINE smpEncode #-} - smpP = MkSystemTime <$> smpP <*> pure 0 + smpP = (`MkSystemTime` 0) <$> smpP {-# INLINE smpP #-} _smpP :: Encoding a => Parser a diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 97e7d087b..c963ec99a 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -140,7 +140,7 @@ instance StrEncoding Int64 where instance StrEncoding SystemTime where strEncode = strEncode . systemSeconds - strP = MkSystemTime <$> strP <*> pure 0 + strP = (`MkSystemTime` 0) <$> strP instance StrEncoding UTCTime where strEncode = B.pack . iso8601Show diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 2167814c1..b23bd4e91 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -517,8 +517,11 @@ instance Encoding NtfSubStatus where instance StrEncoding NtfSubStatus where strEncode = smpEncode + {-# INLINE strEncode #-} strP = smpP + {-# INLINE strP #-} +-- TODO [ntfdb] check what happens in agent when token in not yet registered data NtfTknStatus = -- | Token created in DB NTNew @@ -534,6 +537,17 @@ data NtfTknStatus NTExpired deriving (Eq, Show) +allowNtfSubCommands :: NtfTknStatus -> Bool +allowNtfSubCommands = \case + NTNew -> False + NTRegistered -> False + -- TODO [ntfdb] we could have separate statuses to show whether it became invalid + -- after verification (allow commands) or before (do not allow) + NTInvalid _ -> True + NTConfirmed -> False + NTActive -> True + NTExpired -> True + instance Encoding NtfTknStatus where smpEncode = \case NTNew -> "NEW" diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 84aebf9db..c1f1aa9ab 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -20,10 +20,8 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Data.Bifunctor (first) -import qualified Data.ByteString.Builder as BLD import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.IORef @@ -33,7 +31,8 @@ import Data.List (intercalate, partition, sort) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) +import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) @@ -51,14 +50,16 @@ import Simplex.Messaging.Notifications.Server.Control import Simplex.Messaging.Notifications.Server.Env import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..)) import Simplex.Messaging.Notifications.Server.Stats -import Simplex.Messaging.Notifications.Server.Store -import Simplex.Messaging.Notifications.Server.StoreLog +import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf) +import Simplex.Messaging.Notifications.Server.Store.Postgres +import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGet, tPut) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Control (CPClientRole (..)) -import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate) +import Simplex.Messaging.Server.Env.STM (StartOptions (..)) +import Simplex.Messaging.Server.QueueStore (getSystemDate) import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -66,7 +67,7 @@ import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth ( import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer) import Simplex.Messaging.Util -import System.Exit (exitFailure) +import System.Exit (exitFailure, exitSuccess) import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, async, uninterruptibleCancel, unliftIO, withFile) @@ -78,6 +79,8 @@ import UnliftIO.STM import GHC.Conc (listThreads) #endif +import qualified Data.ByteString.Base64 as B64 + runNtfServer :: NtfServerConfig -> IO () runNtfServer cfg = do started <- newEmptyTMVarIO @@ -89,11 +92,14 @@ runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtf type M a = ReaderT NtfEnv IO a ntfServer :: NtfServerConfig -> TMVar Bool -> M () -ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do - restoreServerLastNtfs +ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} started = do restoreServerStats s <- asks subscriber ps <- asks pushServer + when (maintenance startOptions) $ do + liftIO $ putStrLn "Server started in 'maintenance' mode, exiting" + stopServer + liftIO $ exitSuccess resubscribe s raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer where @@ -124,7 +130,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do logInfo "Server stopped" saveServer :: M () - saveServer = withNtfLog closeStoreLog >> saveServerLastNtfs >> saveServerStats + saveServer = asks store >>= liftIO . closeNtfDbStore >> saveServerStats serverStatsThread_ :: NtfServerConfig -> [M ()] serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -330,10 +336,23 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do resubscribe :: NtfSubscriber -> M () resubscribe NtfSubscriber {newSubQ} = do logInfo "Preparing SMP resubscriptions..." - subs <- readTVarIO =<< asks (subscriptions . store) - subs' <- filterM (fmap ntfShouldSubscribe . readTVarIO . subStatus) $ M.elems subs - atomically . writeTBQueue newSubQ $ map NtfSub subs' - logInfo $ "SMP resubscriptions queued (" <> tshow (length subs') <> " subscriptions)" + st <- asks store + batchSize <- asks $ subsBatchSize . config + liftIO $ do + srvs <- getUsedSMPServers st + count <- foldM (subscribeSrvSubs st batchSize) (0 :: Int) srvs + logInfo $ "SMP resubscriptions queued (" <> tshow count <> " subscriptions)" + where + subscribeSrvSubs st batchSize !count srv = do + (n, subs_) <- + foldNtfSubscriptions st srv batchSize (0, []) $ \(!i, subs) sub -> + if length subs == batchSize + then write (L.fromList subs) $> (i + 1, []) + else pure (i + 1, sub : subs) + mapM_ write $ L.nonEmpty subs_ + pure $ count + n + where + write subs = atomically $ writeTBQueue newSubQ (srv, subs) ntfSubscriber :: NtfSubscriber -> M () ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do @@ -341,44 +360,44 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge where subscribe :: M () subscribe = forever $ do - subs <- atomically (readTBQueue newSubQ) - let ss = L.groupAllWith server subs - batchSize <- asks $ subsBatchSize . config - forM_ ss $ \serverSubs -> do - let srv = server $ L.head serverSubs - batches = toChunks batchSize $ L.toList serverSubs - SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber srv - mapM_ (atomically . writeTQueue subscriberSubQ) batches - - server :: NtfEntityRec 'Subscription -> SMPServer - server (NtfSub sub) = ntfSubServer sub + (srv, subs) <- atomically $ readTBQueue newSubQ + -- TODO [ntfdb] as we now group by server before putting subs to queue, + -- maybe this "subscribe" thread can be removed completely, + -- and the caller would directly write to SMPSubscriber queues + SMPSubscriber {subscriberSubQ} <- getSMPSubscriber srv + atomically $ writeTQueue subscriberSubQ subs + -- TODO [ntfdb] this does not guarantee that only one subscriber per server is created + -- there should be TMVar in the map + -- This does not need changing if single newSubQ remains, but if it is removed, it need to change getSMPSubscriber :: SMPServer -> M SMPSubscriber getSMPSubscriber smpServer = liftIO (TM.lookupIO smpServer smpSubscribers) >>= maybe createSMPSubscriber pure where createSMPSubscriber = do - sub@SMPSubscriber {subThreadId} <- liftIO newSMPSubscriber + sub@SMPSubscriber {subThreadId} <- liftIO $ newSMPSubscriber smpServer atomically $ TM.insert smpServer sub smpSubscribers tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub) atomically . writeTVar subThreadId $ Just tId pure sub runSMPSubscriber :: SMPSubscriber -> M () - runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} = + runSMPSubscriber SMPSubscriber {smpServer, subscriberSubQ} = do + st <- asks store forever $ do + -- TODO [ntfdb] possibly, the subscriptions can be batched here and sent every say 5 seconds + -- this should be analysed once we have prometheus stats subs <- atomically $ readTQueue subscriberSubQ - let subs' = L.map (\(NtfSub sub) -> sub) subs - srv = server $ L.head subs - logSubStatus srv "subscribing" $ length subs - mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs' - liftIO $ subscribeQueues srv subs' + -- TODO [ntfdb] validate/partition that SMP server matches and log internal error if not + updated <- liftIO $ batchUpdateSubStatus st subs NSPending + logSubStatus smpServer "subscribing" (L.length subs) updated + liftIO $ subscribeQueues smpServer subs -- \| Subscribe to queues. The list of results can have a different order. - subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO () + subscribeQueues :: SMPServer -> NonEmpty NtfSubRec -> IO () subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map sub subs) where - sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey) + sub NtfSubRec {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey) receiveSMP :: M () receiveSMP = forever $ do @@ -395,91 +414,83 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge NtfPushServer {pushQ} <- asks pushServer stats <- asks serverStats liftIO $ updatePeriodStats (activeSubs stats) ntfId - tkn_ <- atomically (findNtfSubscriptionToken st smpQueue) - forM_ tkn_ $ \tkn -> do - let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} - lastNtfs <- liftIO $ addTokenLastNtf st (ntfTknId tkn) newNtf - atomically (writeTBQueue pushQ (tkn, PNMessage lastNtfs)) + let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} + ntfs_ <- liftIO $ addTokenLastNtf st newNtf + forM_ ntfs_ $ \(tkn, lastNtfs) -> atomically $ writeTBQueue pushQ (tkn, PNMessage lastNtfs) + -- TODO [ntfdb] track queued notifications separately? incNtfStat ntfReceived - Right SMP.END -> - whenM (atomically $ activeClientSession' ca sessionId srv) $ - updateSubStatus smpQueue NSEnd - Right SMP.DELD -> updateSubStatus smpQueue NSDeleted + Right SMP.END -> do + whenM (atomically $ activeClientSession' ca sessionId srv) $ do + st <- asks store + void $ liftIO $ updateSrvSubStatus st smpQueue NSEnd + Right SMP.DELD -> do + st <- asks store + void $ liftIO $ updateSrvSubStatus st smpQueue NSDeleted Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e Right _ -> logError "SMP server unexpected response" Left e -> logError $ "SMP client error: " <> tshow e - receiveAgent = + receiveAgent = do + st <- asks store forever $ atomically (readTBQueue agentQ) >>= \case CAConnected srv -> logInfo $ "SMP server reconnected " <> showServer' srv CADisconnected srv subs -> do - logSubStatus srv "disconnected" $ length subs - forM_ subs $ \(_, ntfId) -> do - let smpQueue = SMPQueueNtf srv ntfId - updateSubStatus smpQueue NSInactive - CASubscribed srv _ subs -> do - forM_ subs $ \ntfId -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive - logSubStatus srv "subscribed" $ length subs - CASubError srv _ errs -> - forM errs (\(ntfId, err) -> handleSubError (SMPQueueNtf srv ntfId) err) - >>= logSubErrors srv . catMaybes . L.toList + forM_ (L.nonEmpty $ map snd $ S.toList subs) $ \nIds -> do + updated <- liftIO $ batchUpdateSrvSubStatus st srv nIds NSInactive + logSubStatus srv "disconnected" (L.length nIds) updated + CASubscribed srv _ nIds -> do + updated <- liftIO $ batchUpdateSrvSubStatus st srv nIds NSActive + logSubStatus srv "subscribed" (L.length nIds) updated + CASubError srv _ errs -> do + forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> subErrorStatus err) $ L.toList errs) $ \subStatuses -> do + updated <- liftIO $ batchUpdateSrvSubStatuses st srv subStatuses + logSubErrors srv subStatuses updated - logSubStatus srv event n = - when (n > 0) . logInfo $ - "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subscriptions)" + logSubStatus :: SMPServer -> T.Text -> Int -> Int64 -> M () + logSubStatus srv event n updated = + logInfo $ "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subs, " <> tshow updated <> " subs updated)" - logSubErrors :: SMPServer -> [NtfSubStatus] -> M () - logSubErrors srv errs = forM_ (L.group $ sort errs) $ \errs' -> do - logError $ "SMP subscription errors on server " <> showServer' srv <> ": " <> tshow (L.head errs') <> " (" <> tshow (length errs') <> " errors)" + logSubErrors :: SMPServer -> NonEmpty (SMP.NotifierId, NtfSubStatus) -> Int64 -> M () + logSubErrors srv subs updated = forM_ (L.group $ L.sort $ L.map snd subs) $ \ss -> do + logError $ "SMP server subscription errors " <> showServer' srv <> ": " <> tshow (L.head ss) <> " (" <> tshow (length ss) <> " errors, " <> tshow updated <> " subs updated)" showServer' = decodeLatin1 . strEncode . host - handleSubError :: SMPQueueNtf -> SMPClientError -> M (Maybe NtfSubStatus) - handleSubError smpQueue = \case - PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth $> Just NSAuth + subErrorStatus :: SMPClientError -> Maybe NtfSubStatus + subErrorStatus = \case + PCEProtocolError AUTH -> Just NSAuth PCEProtocolError e -> updateErr "SMP error " e PCEResponseError e -> updateErr "ResponseError " e PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r PCETransportError e -> updateErr "TransportError " e PCECryptoError e -> updateErr "CryptoError " e - PCEIncompatibleHost -> let e = NSErr "IncompatibleHost" in updateSubStatus smpQueue e $> Just e - PCEResponseTimeout -> pure Nothing - PCENetworkError -> pure Nothing - PCEIOError _ -> pure Nothing + PCEIncompatibleHost -> Just $ NSErr "IncompatibleHost" + PCEResponseTimeout -> Nothing + PCENetworkError -> Nothing + PCEIOError _ -> Nothing where - updateErr :: Show e => ByteString -> e -> M (Maybe NtfSubStatus) - updateErr errType e = updateSubStatus smpQueue (NSErr $ errType <> bshow e) $> Just (NSErr errType) - - updateSubStatus smpQueue status = do - st <- asks store - atomically (findNtfSubscription st smpQueue) >>= mapM_ update - where - update NtfSubData {ntfSubId, subStatus} = do - old <- atomically $ stateTVar subStatus (,status) - when (old /= status) $ withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status + -- Note on moving to PostgreSQL: the idea of logging errors without e is removed here + updateErr :: Show e => ByteString -> e -> Maybe NtfSubStatus + updateErr errType e = Just $ NSErr $ errType <> bshow e ntfPush :: NtfPushServer -> M () ntfPush s@NtfPushServer {pushQ} = forever $ do - (tkn@NtfTknData {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) + (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) - status <- readTVarIO tknStatus case ntf of PNVerification _ -> deliverNotification pp tkn ntf >>= \case Right _ -> do - status_ <- atomically $ stateTVar tknStatus $ \case - NTActive -> (Nothing, NTActive) - NTConfirmed -> (Nothing, NTConfirmed) - _ -> (Just NTConfirmed, NTConfirmed) - forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' + st <- asks store + void $ liftIO $ setTknStatusConfirmed st tkn incNtfStatT t ntfVrfDelivered Left _ -> incNtfStatT t ntfVrfFailed - PNCheckMessages -> checkActiveTkn status $ do + PNCheckMessages -> checkActiveTkn tknStatus $ do deliverNotification pp tkn ntf >>= incNtfStatT t . (\case Left _ -> ntfCronFailed; Right () -> ntfCronDelivered) - PNMessage {} -> checkActiveTkn status $ do + PNMessage {} -> checkActiveTkn tknStatus $ do stats <- asks serverStats liftIO $ updatePeriodStats (activeTokens stats) ntfTknId deliverNotification pp tkn ntf @@ -489,8 +500,8 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do checkActiveTkn status action | status == NTActive = action | otherwise = liftIO $ logError "bad notification token status" - deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ()) - deliverNotification pp tkn@NtfTknData {ntfTknId} ntf = do + deliverNotification :: PushProvider -> NtfTknRec -> PushNotification -> M (Either PushProviderError ()) + deliverNotification pp tkn@NtfTknRec {ntfTknId} ntf = do deliver <- liftIO $ getPushClient s pp liftIO (runExceptT $ deliver tkn ntf) >>= \case Right _ -> pure $ Right () @@ -499,7 +510,10 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do PPRetryLater -> retryDeliver PPCryptoError _ -> err e PPResponseError {} -> err e - PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e + PPTokenInvalid r -> do + st <- asks store + void $ liftIO $ updateTknStatus st tkn $ NTInvalid $ Just r + err e PPPermanentError -> err e where retryDeliver :: M (Either PushProviderError ()) @@ -508,15 +522,13 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do liftIO (runExceptT $ deliver tkn ntf) >>= \case Right _ -> pure $ Right () Left e -> case e of - PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e + PPTokenInvalid r -> do + st <- asks store + void $ liftIO $ updateTknStatus st tkn $ NTInvalid $ Just r + err e _ -> err e err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e -updateTknStatus :: NtfTknData -> NtfTknStatus -> M () -updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do - old <- atomically $ stateTVar tknStatus (,status) - when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status - runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M () runNtfClientTransport th@THandle {params} = do qSize <- asks $ clientQSize . config @@ -563,160 +575,144 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime -data VerificationResult = VRVerified (Maybe NtfTknData, NtfRequest) | VRFailed +data VerificationResult = VRVerified NtfRequest | VRFailed verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do st <- asks store case cmd of + -- TODO [ntfdb] this looks suspicious, as if it can prevent repeated registrations NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do - r_ <- atomically $ getNtfTokenRegistration st tkn + r_ <- liftIO $ getNtfTokenRegistration st tkn pure $ if verifyCmdAuthorization auth_ tAuth authorized k then case r_ of - Just t@NtfTknData {tknVerifyKey} - | k == tknVerifyKey -> verifiedTknCmd t c + Right t@NtfTknRec {tknVerifyKey} + -- keys will be the same because of condition in `getNtfTokenRegistration` + | k == tknVerifyKey -> VRVerified $ tknCmd t c | otherwise -> VRFailed - Nothing -> VRVerified (Nothing, NtfReqNew corrId (ANE SToken tkn)) + Left _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) else VRFailed NtfCmd SToken c -> do - t_ <- liftIO $ getNtfTokenIO st entId - verifyToken t_ (`verifiedTknCmd` c) - NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> do - s_ <- atomically $ findNtfSubscription st smpQueue - case s_ of - Nothing -> do - t_ <- atomically $ getActiveNtfToken st tknId - verifyToken' t_ $ VRVerified (t_, NtfReqNew corrId (ANE SSubscription sub)) - Just s@NtfSubData {tokenId = subTknId} -> - if subTknId == tknId - then do - t_ <- atomically $ getActiveNtfToken st subTknId - verifyToken' t_ $ verifiedSubCmd t_ s c - else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - NtfCmd SSubscription PING -> pure $ VRVerified (Nothing, NtfReqPing corrId entId) - NtfCmd SSubscription c -> do - s_ <- liftIO $ getNtfSubscriptionIO st entId - case s_ of - Just s@NtfSubData {tokenId = subTknId} -> do - t_ <- atomically $ getActiveNtfToken st subTknId - verifyToken' t_ $ verifiedSubCmd t_ s c - _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed + t_ <- liftIO $ getNtfToken st entId + verifyToken_' t_ (`tknCmd` c) + NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> + liftIO $ verify <$> findNtfSubscription st tknId smpQueue + where + verify = \case + Right (t, s_) -> verifyToken t $ case s_ of + Nothing -> NtfReqNew corrId (ANE SSubscription sub) + Just s -> subCmd s c + -- TODO [ntfdb] it should simply return error if it is not AUTH + Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed + NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId + NtfCmd SSubscription c -> liftIO $ verify <$> getNtfSubscription st entId + where + verify = \case + Right (t, s) -> verifyToken t $ subCmd s c + -- TODO [ntfdb] it should simply return error if it is not AUTH + Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed where - verifiedTknCmd t c = VRVerified (Just t, NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) - verifiedSubCmd t_ s c = VRVerified (t_, NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) - verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult - verifyToken t_ positiveVerificationResult = - pure $ case t_ of - Just t@NtfTknData {tknVerifyKey} -> - if verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey - then positiveVerificationResult t - else VRFailed - _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult - verifyToken' t_ = verifyToken t_ . const + tknCmd t c = NtfReqCmd SToken (NtfTkn t) (corrId, entId, c) + subCmd s c = NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c) + verifyToken_' :: Either ErrorType NtfTknRec -> (NtfTknRec -> NtfRequest) -> M VerificationResult + verifyToken_' t_ result = pure $ case t_ of + Right t -> verifyToken t $ result t + -- TODO [ntfdb] it should simply return error if it is not AUTH + Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed + verifyToken :: NtfTknRec -> NtfRequest -> VerificationResult + verifyToken NtfTknRec {tknVerifyKey} r + | verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey = VRVerified r + | otherwise = VRFailed client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} = - forever $ do - ts <- liftIO getSystemDate + forever $ atomically (readTBQueue rcvQ) - >>= mapM (\(tkn_, req) -> updateTokenDate ts tkn_ >> processCommand req) + >>= mapM processCommand >>= atomically . writeTBQueue sndQ where - updateTokenDate :: RoundedSystemTime -> Maybe NtfTknData -> M () - updateTokenDate ts' = mapM_ $ \NtfTknData {ntfTknId, tknUpdatedAt} -> do - let t' = Just ts' - t <- atomically $ swapTVar tknUpdatedAt t' - unless (t' == t) $ withNtfLog $ \s -> logUpdateTokenTime s ntfTknId ts' processCommand :: NtfRequest -> M (Transmission NtfResponse) processCommand = \case - NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do + NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> (corrId,NoEntity,) <$> do logDebug "TNEW - new token" - st <- asks store - ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random + (srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random let dhSecret = C.dh' dhPubKey srvDhPrivKey tknId <- getId regCode <- getRegCode ts <- liftIO $ getSystemDate - tkn <- liftIO $ mkNtfTknData tknId newTkn ks dhSecret regCode ts - atomically $ addNtfToken st tknId tkn - atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) - incNtfStatT token ntfVrfQueued - withNtfLog (`logCreateToken` tkn) - incNtfStatT token tknCreated - pure (corrId, NoEntity, NRTknId tknId srvDhPubKey) - NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do - status <- readTVarIO tknStatus + let tkn = mkNtfTknRec tknId newTkn srvDhPrivKey dhSecret regCode ts + withNtfStore (`addNtfToken` tkn) $ \_ -> do + atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) + incNtfStatT token ntfVrfQueued + incNtfStatT token tknCreated + pure $ NRTknId tknId srvDhPubKey + NtfReqCmd SToken (NtfTkn tkn@NtfTknRec {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhPrivKey}) (corrId, tknId, cmd) -> do (corrId,tknId,) <$> case cmd of TNEW (NewNtfTkn _ _ dhPubKey) -> do logDebug "TNEW - registered token" - let dhSecret = C.dh' dhPubKey srvDhPrivKey + let dhSecret = C.dh' dhPubKey tknDhPrivKey -- it is required that DH secret is the same, to avoid failed verifications if notification is delaying if tknDhSecret == dhSecret then do atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode) incNtfStatT token ntfVrfQueued - pure $ NRTknId ntfTknId srvDhPubKey + pure $ NRTknId ntfTknId $ C.publicKey tknDhPrivKey else pure $ NRErr AUTH TVFY code -- this allows repeated verification for cases when client connection dropped before server response - | (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do + | (tknStatus == NTRegistered || tknStatus == NTConfirmed || tknStatus == NTActive) && tknRegCode == code -> do logDebug "TVFY - token verified" - st <- asks store - updateTknStatus tkn NTActive - tIds <- atomically $ removeInactiveTokenRegistrations st tkn - forM_ tIds cancelInvervalNotifications - incNtfStatT token tknVerified - pure NROk + withNtfStore (`setTokenActive` tkn) $ \tIds -> do + -- TODO [ntfdb] this will be unnecessary if all cron notifications move to one thread + forM_ tIds cancelInvervalNotifications + incNtfStatT token tknVerified + pure NROk | otherwise -> do logDebug "TVFY - incorrect code or token status" + liftIO $ print tkn + let NtfRegCode c = code + liftIO $ print $ B64.encode c pure $ NRErr AUTH TCHK -> do logDebug "TCHK" - pure $ NRTkn status + pure $ NRTkn tknStatus TRPL token' -> do logDebug "TRPL - replace token" - st <- asks store regCode <- getRegCode - atomically $ do - removeTokenRegistration st tkn - writeTVar tknStatus NTRegistered - let tkn' = tkn {token = token', tknRegCode = regCode} - addNtfToken st tknId tkn' - writeTBQueue pushQ (tkn', PNVerification regCode) - incNtfStatT token ntfVrfQueued - withNtfLog $ \s -> logUpdateToken s tknId token' regCode - incNtfStatT token tknReplaced - pure NROk + let tkn' = tkn {token = token', tknStatus = NTRegistered, tknRegCode = regCode} + withNtfStore (`replaceNtfToken` tkn') $ \_ -> do + atomically $ writeTBQueue pushQ (tkn', PNVerification regCode) + incNtfStatT token ntfVrfQueued + incNtfStatT token tknReplaced + pure NROk TDEL -> do logDebug "TDEL" - st <- asks store - qs <- atomically $ deleteNtfToken st tknId - forM_ qs $ \SMPQueueNtf {smpServer, notifierId} -> - atomically $ removeSubscription ca smpServer (SPNotifier, notifierId) - cancelInvervalNotifications tknId - withNtfLog (`logDeleteToken` tknId) - incNtfStatT token tknDeleted - pure NROk + withNtfStore (`deleteNtfToken` tknId) $ \ss -> do + forM_ ss $ \(smpServer, nIds) -> do + atomically $ removeSubscriptions ca smpServer SPNotifier nIds + atomically $ removePendingSubs ca smpServer SPNotifier nIds + cancelInvervalNotifications tknId + incNtfStatT token tknDeleted + pure NROk TCRN 0 -> do logDebug "TCRN 0" - atomically $ writeTVar tknCronInterval 0 - cancelInvervalNotifications tknId - withNtfLog $ \s -> logTokenCron s tknId 0 - pure NROk + withNtfStore (\st -> updateTknCronInterval st ntfTknId 0) $ \_ -> do + -- TODO [ntfdb] move cron intervals to one thread + cancelInvervalNotifications tknId + pure NROk TCRN int | int < 20 -> pure $ NRErr QUOTA | otherwise -> do logDebug "TCRN" - atomically $ writeTVar tknCronInterval int - liftIO (TM.lookupIO tknId intervalNotifiers) >>= \case - Nothing -> runIntervalNotifier int - Just IntervalNotifier {interval, action} -> - unless (interval == int) $ do - uninterruptibleCancel action - runIntervalNotifier int - withNtfLog $ \s -> logTokenCron s tknId int - pure NROk + withNtfStore (\st -> updateTknCronInterval st ntfTknId int) $ \_ -> do + -- TODO [ntfdb] move cron intervals to one thread + liftIO (TM.lookupIO tknId intervalNotifiers) >>= \case + Nothing -> runIntervalNotifier int + Just IntervalNotifier {interval, action} -> + unless (interval == int) $ do + uninterruptibleCancel action + runIntervalNotifier int + pure NROk where runIntervalNotifier interval = do action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60 @@ -726,20 +722,20 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu intervalNotifier delay = forever $ do liftIO $ threadDelay' delay atomically $ writeTBQueue pushQ (tkn, PNCheckMessages) - NtfReqNew corrId (ANE SSubscription newSub) -> do + NtfReqNew corrId (ANE SSubscription newSub@(NewNtfSub _ (SMPQueueNtf srv _) _)) -> do logDebug "SNEW - new subscription" - st <- asks store subId <- getId - sub <- atomically $ mkNtfSubData subId newSub + let sub = mkNtfSubRec subId newSub resp <- - atomically (addNtfSubscription st subId sub) >>= \case - Just _ -> atomically (writeTBQueue newSubQ [NtfSub sub]) $> NRSubId subId - _ -> pure $ NRErr AUTH - withNtfLog (`logCreateSubscription` sub) - incNtfStat subCreated + withNtfStore (`addNtfSubscription` sub) $ \case + True -> do + atomically $ writeTBQueue newSubQ (srv, [sub]) + incNtfStat subCreated + pure $ NRSubId subId + -- TODO [ntfdb] we must allow repeated inserts that don't change credentials + False -> pure $ NRErr AUTH pure (corrId, NoEntity, resp) - NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do - status <- readTVarIO subStatus + NtfReqCmd SSubscription (NtfSub NtfSubRec {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do (corrId,subId,) <$> case cmd of SNEW (NewNtfSub _ _ notifierKey) -> do logDebug "SNEW - existing subscription" @@ -750,15 +746,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu else NRErr AUTH SCHK -> do logDebug "SCHK" - pure $ NRSub status + pure $ NRSub subStatus SDEL -> do logDebug "SDEL" - st <- asks store - atomically $ deleteNtfSubscription st subId - atomically $ removeSubscription ca smpServer (SPNotifier, notifierId) - withNtfLog (`logDeleteSubscription` subId) - incNtfStat subDeleted - pure NROk + withNtfStore (`deleteNtfSubscription` subId) $ \_ -> do + atomically $ removeSubscription ca smpServer (SPNotifier, notifierId) + atomically $ removePendingSub ca smpServer (SPNotifier, notifierId) + incNtfStat subDeleted + pure NROk PING -> pure NRPong NtfReqPing corrId entId -> pure (corrId, entId, NRPong) getId :: M NtfEntityId @@ -772,8 +767,12 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically (TM.lookupDelete tknId intervalNotifiers) >>= mapM_ (uninterruptibleCancel . action) -withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M () -withNtfLog action = liftIO . mapM_ action =<< asks storeLog +withNtfStore :: (NtfPostgresStore -> IO (Either ErrorType a)) -> (a -> M NtfResponse) -> M NtfResponse +withNtfStore stAction continue = do + st <- asks store + liftIO (stAction st) >>= \case + Left e -> pure $ NRErr e + Right a -> continue a incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M () incNtfStatT (DeviceToken PPApnsNull _) _ = pure () @@ -784,43 +783,24 @@ incNtfStat statSel = do stats <- asks serverStats liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1) -saveServerLastNtfs :: M () -saveServerLastNtfs = asks (storeLastNtfsFile . config) >>= mapM_ saveLastNtfs +restoreServerLastNtfs :: NtfSTMStore -> FilePath -> IO () +restoreServerLastNtfs st f = + whenM (doesFileExist f) $ do + logInfo $ "restoring last notifications from file " <> T.pack f + runExceptT (liftIO (B.readFile f) >>= mapM restoreNtf . B.lines) >>= \case + Left e -> do + logError . T.pack $ "error restoring last notifications: " <> e + exitFailure + Right _ -> do + renameFile f $ f <> ".bak" + logInfo "last notifications restored" where - saveLastNtfs f = do - logInfo $ "saving last notifications to file " <> T.pack f - NtfStore {tokenLastNtfs} <- asks store - liftIO . withFile f WriteMode $ \h -> - readTVarIO tokenLastNtfs >>= mapM_ (saveTokenLastNtfs h) . M.assocs - logInfo "notifications saved" + restoreNtf s = do + TNMRv1 tknId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s + liftIO $ stmStoreTokenLastNtf st tknId ntf where - -- reverse on save, to save notifications in order, will become reversed again when restoring. - saveTokenLastNtfs h (tknId, v) = BLD.hPutBuilder h . encodeLastNtfs tknId . L.reverse =<< readTVarIO v - encodeLastNtfs tknId = mconcat . L.toList . L.map (\ntf -> BLD.byteString (strEncode $ TNMRv1 tknId ntf) <> BLD.char8 '\n') - -restoreServerLastNtfs :: M () -restoreServerLastNtfs = - asks (storeLastNtfsFile . config) >>= mapM_ restoreLastNtfs - where - restoreLastNtfs f = - whenM (doesFileExist f) $ do - logInfo $ "restoring last notifications from file " <> T.pack f - st <- asks store - runExceptT (liftIO (LB.readFile f) >>= mapM (restoreNtf st) . LB.lines) >>= \case - Left e -> do - logError . T.pack $ "error restoring last notifications: " <> e - liftIO exitFailure - Right _ -> do - renameFile f $ f <> ".bak" - logInfo "last notifications restored" - where - restoreNtf st s' = do - TNMRv1 tknId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s - liftIO $ storeTokenLastNtf st tknId ntf - where - s = LB.toStrict s' - ntfErr :: Show e => String -> e -> String - ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) + ntfErr :: Show e => String -> e -> String + ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) saveServerStats :: M () saveServerStats = diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 3859a3df1..46f3e9f2d 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -9,7 +9,6 @@ module Simplex.Messaging.Notifications.Server.Env where import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) -import Control.Logger.Simple import Crypto.Random import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) @@ -25,16 +24,17 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Stats -import Simplex.Messaging.Notifications.Server.Store -import Simplex.Messaging.Notifications.Server.StoreLog +import Simplex.Messaging.Notifications.Server.Store.Postgres +import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF) import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission) +import Simplex.Messaging.Server.Env.STM (StartOptions) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..)) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential) -import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -52,8 +52,7 @@ data NtfServerConfig = NtfServerConfig apnsConfig :: APNSPushClientConfig, subsBatchSize :: Int, inactiveClientExpiration :: Maybe ExpirationConfig, - storeLogFile :: Maybe FilePath, - storeLastNtfsFile :: Maybe FilePath, + dbStoreConfig :: PostgresStoreCfg, ntfCredentials :: ServerCredentials, -- stats config - see SMP server config logStatsInterval :: Maybe Int64, @@ -61,7 +60,8 @@ data NtfServerConfig = NtfServerConfig serverStatsLogFile :: FilePath, serverStatsBackupFile :: Maybe FilePath, ntfServerVRange :: VersionRangeNTF, - transportConfig :: TransportServerConfig + transportConfig :: TransportServerConfig, + startOptions :: StartOptions } defaultInactiveClientExpiration :: ExpirationConfig @@ -75,8 +75,7 @@ data NtfEnv = NtfEnv { config :: NtfServerConfig, subscriber :: NtfSubscriber, pushServer :: NtfPushServer, - store :: NtfStore, - storeLog :: Maybe (StoreLog 'WriteMode), + store :: NtfPostgresStore, random :: TVar ChaChaDRG, tlsServerCreds :: T.Credential, serverIdentity :: C.KeyHash, @@ -84,22 +83,23 @@ data NtfEnv = NtfEnv } newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials} = do random <- C.newRandom - store <- newNtfStore - logInfo "restoring subscriptions..." - storeLog <- mapM (`readWriteNtfStore` store) storeLogFile - logInfo "restored subscriptions" + store <- newNtfDbStore dbStoreConfig + -- TODO [ntfdb] this should happen with compacting on start + -- logInfo "restoring subscriptions..." + -- storeLog <- mapM (`readWriteNtfStore` store) storeLogFile + -- logInfo "restored subscriptions" subscriber <- newNtfSubscriber subQSize smpAgentCfg random pushServer <- newNtfPushServer pushQSize apnsConfig tlsServerCreds <- loadServerCredential ntfCredentials Fingerprint fp <- loadFingerprint ntfCredentials serverStats <- newNtfServerStats =<< getCurrentTime - pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} + pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} data NtfSubscriber = NtfSubscriber { smpSubscribers :: TMap SMPServer SMPSubscriber, - newSubQ :: TBQueue [NtfEntityRec 'Subscription], + newSubQ :: TBQueue (SMPServer, NonEmpty NtfSubRec), -- should match SMPServer smpAgent :: SMPClientAgent } @@ -111,18 +111,19 @@ newNtfSubscriber qSize smpAgentCfg random = do pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent} data SMPSubscriber = SMPSubscriber - { newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)), + { smpServer :: SMPServer, + subscriberSubQ :: TQueue (NonEmpty NtfSubRec), subThreadId :: TVar (Maybe (Weak ThreadId)) } -newSMPSubscriber :: IO SMPSubscriber -newSMPSubscriber = do - newSubQ <- newTQueueIO +newSMPSubscriber :: SMPServer -> IO SMPSubscriber +newSMPSubscriber smpServer = do + subscriberSubQ <- newTQueueIO subThreadId <- newTVarIO Nothing - pure SMPSubscriber {newSubQ, subThreadId} + pure SMPSubscriber {smpServer, subscriberSubQ, subThreadId} data NtfPushServer = NtfPushServer - { pushQ :: TBQueue (NtfTknData, PushNotification), + { pushQ :: TBQueue (NtfTknRec, PushNotification), pushClients :: TMap PushProvider PushProviderClient, intervalNotifiers :: TMap NtfTokenId IntervalNotifier, apnsConfig :: APNSPushClientConfig @@ -130,7 +131,7 @@ data NtfPushServer = NtfPushServer data IntervalNotifier = IntervalNotifier { action :: Async (), - token :: NtfTknData, + token :: NtfTknRec, interval :: Word16 } @@ -159,7 +160,7 @@ data NtfRequest | NtfReqPing CorrId NtfEntityId data NtfServerClient = NtfServerClient - { rcvQ :: TBQueue (NonEmpty (Maybe NtfTknData, NtfRequest)), + { rcvQ :: TBQueue (NonEmpty NtfRequest), sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)), ntfThParams :: THandleParams NTFVersion 'TServer, connected :: TVar Bool, diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 5418ec4e9..aa0e036ba 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -11,29 +11,42 @@ module Simplex.Messaging.Notifications.Server.Main where import Control.Monad ((<$!>)) +import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Ini (lookupValue, readIniFile) +import Data.Int (Int64) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as T -import Network.Socket (HostName) +import Network.Socket (HostName, ServiceName) import Options.Applicative +import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Notifications.Server (runNtfServer) +import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) +import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore) +import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore) +import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore) import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI +import Simplex.Messaging.Server.Env.STM (StartOptions) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (simplexMQVersion) +import Simplex.Messaging.Server.Main.Init (iniDbOpts) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.StoreLog (closeStoreLog) +import Simplex.Messaging.Transport (ATransport, simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) -import Simplex.Messaging.Util (tshow) -import System.Directory (createDirectoryIfMissing, doesFileExist) +import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Util (ifM, tshow) +import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) +import System.Exit (exitFailure) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) @@ -45,14 +58,8 @@ ntfServerCLI cfgPath logPath = doesFileExist iniFile >>= \case True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." _ -> initializeServer opts - OnlineCert certOpts -> - doesFileExist iniFile >>= \case - True -> genOnline cfgPath certOpts - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - Start -> - doesFileExist iniFile >>= \case - True -> readIniFile iniFile >>= either exitError runServer - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts + Start opts -> withIniFile $ runServer opts Delete -> do confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" @@ -60,13 +67,75 @@ ntfServerCLI cfgPath logPath = deleteDirIfExists cfgPath deleteDirIfExists logPath putStrLn "Deleted configuration and log files" + Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do + schemaExists <- checkSchemaExists connstr schema + storeLogExists <- doesFileExist storeLogFilePath + lastNtfsExists <- doesFileExist defaultLastNtfsFile + case cmd of + SCImport + | schemaExists && (storeLogExists || lastNtfsExists) -> exitConfigureNtfStore connstr schema + | schemaExists -> do + putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr + exitFailure + | not storeLogExists -> do + putStrLn $ storeLogFilePath <> " file does not exist." + exitFailure + | not lastNtfsExists -> do + putStrLn $ defaultLastNtfsFile <> " file does not exist." + exitFailure + | otherwise -> do + storeLogFile <- getRequiredStoreLogFile ini + confirmOrExit + ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema) + "Notification server store not imported" + stmStore <- newNtfSTMStore + sl <- readWriteNtfSTMStore True storeLogFile stmStore + closeStoreLog sl + restoreServerLastNtfs stmStore defaultLastNtfsFile + let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + ps <- newNtfDbStore storeCfg + (tCnt, sCnt, nCnt) <- importNtfSTMStore ps stmStore + renameFile storeLogFile $ storeLogFile <> ".bak" + putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications." + putStrLn "Configure database options in INI file." + SCExport + | schemaExists && storeLogExists -> exitConfigureNtfStore connstr schema + | not schemaExists -> do + putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr + exitFailure + | storeLogExists -> do + putStrLn $ storeLogFilePath <> " file already exists." + exitFailure + | lastNtfsExists -> do + putStrLn $ defaultLastNtfsFile <> " file already exists." + exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath) + "Notification server store not imported" + let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Just storeLogFilePath, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + st <- newNtfDbStore storeCfg + (tCnt, sCnt, nCnt) <- exportNtfDbStore st defaultLastNtfsFile + putStrLn $ "Export completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications." where + withIniFile a = + doesFileExist iniFile >>= \case + True -> readIniFile iniFile >>= either exitError a + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + getRequiredStoreLogFile ini = do + case enableStoreLog' ini $> storeLogFilePath of + Just storeLogFile -> do + ifM + (doesFileExist storeLogFile) + (pure storeLogFile) + (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) + Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure iniFile = combine cfgPath "ntf-server.ini" serverVersion = "SMP notifications server v" <> simplexMQVersion defaultServerPort = "443" executableName = "ntf-server" storeLogFilePath = combine logPath "ntf-server-store.log" - initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do + initializeServer InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn} = do clearDirIfExists cfgPath clearDirIfExists logPath createDirectoryIfMissing True cfgPath @@ -88,6 +157,10 @@ ntfServerCLI cfgPath logPath = \# and restoring it when the server is started.\n\ \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> "# Database connection settings for PostgreSQL database.\n" + <> iniDbOpts dbOptions defaultNtfDBOpts + <> "Time to retain deleted entities in the database, days.\n" + <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n") <> "# Last notifications are optionally saved and restored when the server restarts,\n\ \# they are preserved in the .bak file until the next restart.\n" <> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n") @@ -125,26 +198,29 @@ ntfServerCLI cfgPath logPath = \disconnect: off\n" <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n") - runServer ini = do + enableStoreLog' = settingIsOn "STORE_LOG" "enable" + runServer startOptions ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config let host = either (const "") T.unpack $ lookupValue "TRANSPORT" "host" ini port = T.unpack $ strictIni "TRANSPORT" "port" ini - cfg@NtfServerConfig {transports, storeLogFile} = serverConfig + cfg@NtfServerConfig {transports} = serverConfig srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing printServiceInfo serverVersion srv - printServerConfig transports storeLogFile + printNtfServerConfig transports dbStoreConfig runNtfServer cfg where - enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) - restoreLastNtfsFile path = case iniOnOff "STORE_LOG" "restore_last_notifications" ini of - Just True -> Just path - Just False -> Nothing - -- if the setting is not set, it is enabled when store log is enabled - _ -> enableStoreLog $> path + dbStoreLogPath = enableStoreLog' ini $> storeLogFilePath + dbStoreConfig = + PostgresStoreCfg + { dbOpts = iniDBOptions ini defaultNtfDBOpts, + dbStoreLogPath, + confirmMigrations = MCYesUp, + deletedTTL = iniDeletedTTL ini + } serverConfig = NtfServerConfig { transports = iniTransports ini, @@ -180,8 +256,7 @@ ntfServerCLI cfgPath logPath = { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini, checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini }, - storeLogFile = enableStoreLog $> storeLogFilePath, - storeLastNtfsFile = restoreLastNtfsFile $ combine logPath "ntf-server-last-notifications.log", + dbStoreConfig, ntfCredentials = ServerCredentials { caCertificateFile = Just $ c caCrtFile, @@ -196,32 +271,67 @@ ntfServerCLI cfgPath logPath = transportConfig = defaultTransportServerConfig { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini - } + }, + startOptions } + iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini + defaultLastNtfsFile = combine logPath "ntf-server-last-notifications.log" + exitConfigureNtfStore connstr schema = do + putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")." + putStrLn "Configure notification server storage." + exitFailure + +printNtfServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> PostgresStoreCfg -> IO () +printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do + B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema + printServerConfig "NTF" transports dbStoreLogPath data CliCommand = Init InitOptions | OnlineCert CertOptions - | Start + | Start StartOptions | Delete + | Database StoreCmd DBOpts + +data StoreCmd = SCImport | SCExport data InitOptions = InitOptions { enableStoreLog :: Bool, + dbOptions :: DBOpts, signAlgorithm :: SignAlgorithm, ip :: HostName, fqdn :: Maybe HostName } deriving (Show) +defaultNtfDBOpts :: DBOpts +defaultNtfDBOpts = + DBOpts + { connstr = "postgresql://ntf@/ntf_server_store", + schema = "ntf_server", + poolSize = 10, + createSchema = False + } + +-- time to retain deleted tokens and subscriptions in the database (days), for debugging +defaultDeletedTTL :: Int64 +defaultDeletedTTL = 21 + cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand cliCommandP cfgPath logPath iniFile = hsubparser ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")")) - <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) + <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultNtfDBOpts) (progDesc "Import/export notifications server store to/from PostgreSQL database")) ) where + databaseCmdP = + hsubparser + ( command "import" (info (pure SCImport) (progDesc $ "Import store logs into a new PostgreSQL database schema")) + <> command "export" (info (pure SCExport) (progDesc $ "Export PostgreSQL database schema to store logs")) + ) initP :: Parser InitOptions initP = do enableStoreLog <- @@ -234,6 +344,7 @@ cliCommandP cfgPath logPath iniFile = <> short 'l' <> help "Enable store log for persistence (DEPRECATED, enabled by default)" ) + dbOptions <- dbOptsP defaultNtfDBOpts signAlgorithm <- option (maybeReader readMaybe) @@ -261,4 +372,4 @@ cliCommandP cfgPath logPath iniFile = <> showDefault <> metavar "FQDN" ) - pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} + pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn} diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index ec9cd272c..7439e4fea 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -50,7 +50,7 @@ import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS.Internal -import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..)) +import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..)) import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2.Client @@ -263,8 +263,8 @@ disconnectApnsHTTP2Client APNSPushClient {https2Client} = ntfCategoryCheckMessage :: Text ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE" -apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification -apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case +apnsNotification :: NtfTknRec -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification +apnsNotification NtfTknRec {tknDhSecret} nonce paddedLen = \case PNVerification (NtfRegCode code) -> encrypt code $ \code' -> apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code'] @@ -313,7 +313,7 @@ data PushProviderError | PPPermanentError deriving (Show, Exception) -type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO () +type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO () -- this is not a newtype on purpose to have a correct JSON encoding as a record data APNSErrorResponse = APNSErrorResponse {reason :: Text} @@ -321,7 +321,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text} $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse) apnsPushProviderClient :: APNSPushClient -> PushProviderClient -apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do +apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do http2 <- liftHTTPS2 $ getApnsHTTP2Client c nonce <- atomically $ C.randomCbNonce nonceDrg apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index 259a933b6..4b8a4e230 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -30,7 +30,7 @@ import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (whenM, ($>>=)) -data NtfStore = NtfStore +data NtfSTMStore = NtfSTMStore { tokens :: TMap NtfTokenId NtfTknData, -- multiple registrations exist to protect from malicious registrations if token is compromised tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId), @@ -40,15 +40,15 @@ data NtfStore = NtfStore tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)) } -newNtfStore :: IO NtfStore -newNtfStore = do +newNtfSTMStore :: IO NtfSTMStore +newNtfSTMStore = do tokens <- TM.emptyIO tokenRegistrations <- TM.emptyIO subscriptions <- TM.emptyIO tokenSubscriptions <- TM.emptyIO subscriptionLookup <- TM.emptyIO tokenLastNtfs <- TM.emptyIO - pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs} + pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs} data NtfTknData = NtfTknData { ntfTknId :: NtfTokenId, @@ -80,18 +80,11 @@ data NtfSubData = NtfSubData ntfSubServer :: NtfSubData -> SMPServer ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer -data NtfEntityRec (e :: NtfEntity) where - NtfTkn :: NtfTknData -> NtfEntityRec 'Token - NtfSub :: NtfSubData -> NtfEntityRec 'Subscription +stmGetNtfTokenIO :: NtfSTMStore -> NtfTokenId -> IO (Maybe NtfTknData) +stmGetNtfTokenIO st tknId = TM.lookupIO tknId (tokens st) -getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData) -getNtfToken st tknId = TM.lookup tknId (tokens st) - -getNtfTokenIO :: NtfStore -> NtfTokenId -> IO (Maybe NtfTknData) -getNtfTokenIO st tknId = TM.lookupIO tknId (tokens st) - -addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM () -addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do +stmAddNtfToken :: NtfSTMStore -> NtfTokenId -> NtfTknData -> STM () +stmAddNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do TM.insert tknId tkn $ tokens st TM.lookup token regs >>= \case Just tIds -> TM.insert regKey tknId tIds @@ -102,16 +95,8 @@ addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do regs = tokenRegistrations st regKey = C.toPubKey C.pubKeyBytes tknVerifyKey -getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData) -getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) = - TM.lookup token (tokenRegistrations st) - $>>= TM.lookup regKey - $>>= (`TM.lookup` tokens st) - where - regKey = C.toPubKey C.pubKeyBytes tknVerifyKey - -removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId] -removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} = +stmRemoveInactiveTokenRegistrations :: NtfSTMStore -> NtfTknData -> STM [NtfTokenId] +stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} = TM.lookup token (tokenRegistrations st) >>= maybe (pure []) removeRegs where @@ -125,8 +110,8 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} = void $ deleteTokenSubs st tId' pure $ map snd tIds -removeTokenRegistration :: NtfStore -> NtfTknData -> STM () -removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} = +stmRemoveTokenRegistration :: NtfSTMStore -> NtfTknData -> STM () +stmRemoveTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} = TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg where removeReg regs = @@ -134,8 +119,8 @@ removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} = >>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs) k = C.toPubKey C.pubKeyBytes tknVerifyKey -deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf] -deleteNtfToken st tknId = do +stmDeleteNtfToken :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf] +stmDeleteNtfToken st tknId = do void $ TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} -> TM.lookup token regs $>>= \tIds -> @@ -147,7 +132,7 @@ deleteNtfToken st tknId = do regs = tokenRegistrations st regKey = C.toPubKey C.pubKeyBytes -deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf] +deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf] deleteTokenSubs st tknId = do qs <- TM.lookupDelete tknId (tokenSubscriptions st) @@ -159,32 +144,11 @@ deleteTokenSubs st tknId = do $>>= \NtfSubData {smpQueue} -> TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue -getNtfSubscriptionIO :: NtfStore -> NtfSubscriptionId -> IO (Maybe NtfSubData) -getNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st) +stmGetNtfSubscriptionIO :: NtfSTMStore -> NtfSubscriptionId -> IO (Maybe NtfSubData) +stmGetNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st) -findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData) -findNtfSubscription st smpQueue = do - TM.lookup smpQueue (subscriptionLookup st) - $>>= \subId -> TM.lookup subId (subscriptions st) - -findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData) -findNtfSubscriptionToken st smpQueue = do - findNtfSubscription st smpQueue - $>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId - -getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData) -getActiveNtfToken st tknId = - getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do - tStatus <- readTVar tknStatus - pure $ if tStatus == NTActive then Just tkn else Nothing - -mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData -mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do - subStatus <- newTVar NSNew - pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey} - -addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ()) -addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} = +stmAddNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ()) +stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} = TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub where newTokenSub = do @@ -198,8 +162,8 @@ addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} = -- return Nothing if subscription existed before pure $ Just () -deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM () -deleteNtfSubscription st subId = do +stmDeleteNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> STM () +stmDeleteNtfSubscription st subId = do TM.lookupDelete subId (subscriptions st) >>= mapM_ ( \NtfSubData {smpQueue, tokenId} -> do @@ -208,32 +172,10 @@ deleteNtfSubscription st subId = do forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId ) -addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData) -addTokenLastNtf st tknId newNtf = - TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf) - where - maybeNewTokenLastNtfs = - TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf - newTokenLastNtfs = do - v <- newTVar [newNtf] - TM.insert tknId v $ tokenLastNtfs st - pure [newNtf] - addNtf v = - stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs') - where - rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData - rebuildList = foldr keepPrevNtf [newNtf] - where - PNMessageData {smpQueue = newNtfQ} = newNtf - keepPrevNtf ntf@PNMessageData {smpQueue} ntfs - | smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs - | otherwise = ntfs - maxNtfs = 6 - -- This function is expected to be called after store log is read, -- as it checks for token existence when adding last notification. -storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO () -storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do +stmStoreTokenLastNtf :: NtfSTMStore -> NtfTokenId -> PNMessageData -> IO () +stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|)) where newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|)) diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs new file mode 100644 index 000000000..a9de42668 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Notifications.Server.Store.Migrations where + +import Data.List (sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import Simplex.Messaging.Agent.Store.Shared +import Text.RawString.QQ (r) + +ntfServerSchemaMigrations :: [(String, Text, Maybe Text)] +ntfServerSchemaMigrations = + [ ("20250417_initial", m20250417_initial, Nothing) + ] + +-- | The list of migrations in ascending order by date +ntfServerMigrations :: [Migration] +ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations + where + migration (name, up, down) = Migration {name, up, down = down} + +m20250417_initial :: Text +m20250417_initial = + T.pack + [r| +CREATE TABLE tokens( + token_id BYTEA NOT NULL, + push_provider TEXT NOT NULL, + push_provider_token BYTEA NOT NULL, + status TEXT NOT NULL, + verify_key BYTEA NOT NULL, + dh_priv_key BYTEA NOT NULL, + dh_secret BYTEA NOT NULL, + reg_code BYTEA NOT NULL, + cron_interval BIGINT NOT NULL, + cron_sent_at BIGINT, + updated_at BIGINT, + PRIMARY KEY (token_id) +); + +CREATE UNIQUE INDEX idx_tokens_push_provider_token ON tokens(push_provider, push_provider_token, verify_key); +CREATE INDEX idx_tokens_cron_sent_at ON tokens((cron_sent_at + cron_interval)); + +CREATE TABLE smp_servers( + smp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + smp_host TEXT NOT NULL, + smp_port TEXT NOT NULL, + smp_keyhash BYTEA NOT NULL +); + +CREATE UNIQUE INDEX idx_smp_servers ON smp_servers(smp_host, smp_port, smp_keyhash); + +CREATE TABLE subscriptions( + subscription_id BYTEA NOT NULL, + token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT, + smp_server_id BIGINT REFERENCES smp_servers ON DELETE RESTRICT ON UPDATE RESTRICT, + smp_notifier_id BYTEA NOT NULL, + smp_notifier_key BYTEA NOT NULL, + status TEXT NOT NULL, + PRIMARY KEY (subscription_id) +); + +CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON subscriptions(smp_server_id, smp_notifier_id); +CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status); +CREATE INDEX idx_subscriptions_token_id ON subscriptions(token_id); + +CREATE TABLE last_notifications( + token_ntf_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT, + subscription_id BYTEA NOT NULL REFERENCES subscriptions ON DELETE CASCADE ON UPDATE RESTRICT, + sent_at BIGINT NOT NULL, + nmsg_nonce BYTEA NOT NULL, + nmsg_data BYTEA NOT NULL +); + +CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token_id, sent_at); +CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id); + +CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id); + |] diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs new file mode 100644 index 000000000..afe60e5b5 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -0,0 +1,809 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Simplex.Messaging.Notifications.Server.Store.Postgres where + +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Bitraversable (bimapM) +import qualified Data.ByteString.Base64.URL as B64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Containers.ListUtils (nubOrd) +import Data.Either (fromRight) +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.List (foldl', intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock.System (SystemTime (..)) +import Data.Word (Word16) +import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, ToRow, (:.) (..)) +import qualified Database.PostgreSQL.Simple as DB +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Network.Socket (ServiceName) +import Simplex.Messaging.Agent.Store.AgentStore () +import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) +import Simplex.Messaging.Encoding +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer) +import Simplex.Messaging.Notifications.Server.Store.Migrations +import Simplex.Messaging.Notifications.Server.Store.Types +import Simplex.Messaging.Notifications.Server.StoreLog +import Simplex.Messaging.Parsers (parseAll) +import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, pattern SMPServer) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate) +import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) +import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Util (anyM, firstRow, maybeFirstRow, toChunks, tshow) +import System.Exit (exitFailure) +import System.IO (IOMode (..), hFlush, stdout, withFile) +import Text.Hex (decodeHex) + +#if !defined(dbPostgres) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Util (eitherToMaybe) +#endif + +data NtfPostgresStore = NtfPostgresStore + { dbStore :: DBStore, + dbStoreLog :: Maybe (StoreLog 'WriteMode), + deletedTTL :: Int64 + } + +mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> NtfTknRec +mkNtfTknRec ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhPrivKey tknDhSecret tknRegCode ts = + NtfTknRec {ntfTknId, token, tknStatus = NTRegistered, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval = 0, tknUpdatedAt = Just ts} + +ntfSubServer' :: NtfSubRec -> SMPServer +ntfSubServer' NtfSubRec {smpQueue = SMPQueueNtf {smpServer}} = smpServer + +data NtfEntityRec (e :: NtfEntity) where + NtfTkn :: NtfTknRec -> NtfEntityRec 'Token + NtfSub :: NtfSubRec -> NtfEntityRec 'Subscription + +newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore +newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do + dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations + dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath + pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL} + where + err e = do + logError $ "STORE: newNtfStore, error opening PostgreSQL database, " <> tshow e + exitFailure + +closeNtfDbStore :: NtfPostgresStore -> IO () +closeNtfDbStore NtfPostgresStore {dbStore, dbStoreLog} = do + closeDBStore dbStore + mapM_ closeStoreLog dbStoreLog + +addNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) +addNtfToken st tkn = + withDB "addNtfToken" st $ \db -> + E.try (DB.execute db insertNtfTknQuery $ ntfTknToRow tkn) + >>= bimapM handleDuplicate (\_ -> withLog "addNtfToken" st (`logCreateToken` tkn)) + +insertNtfTknQuery :: Query +insertNtfTknQuery = + [sql| + INSERT INTO tokens + (token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?) + |] + +replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) +replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} = + withDB "replaceNtfToken" st $ \db -> runExceptT $ do + ExceptT $ assertUpdated <$> + DB.execute + db + [sql| + UPDATE tokens + SET push_provider = ?, push_provider_token = ?, status = ?, reg_code = ? + WHERE token_id = ? + |] + (pp, Binary ppToken, tknStatus, Binary regCode, ntfTknId) + withLog "replaceNtfToken" st $ \sl -> logUpdateToken sl ntfTknId token code + +ntfTknToRow :: NtfTknRec -> NtfTknRow +ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} = + let DeviceToken pp ppToken = token + NtfRegCode regCode = tknRegCode + in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) + +getNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType NtfTknRec) +getNtfToken st tknId = getNtfToken_ st " WHERE token_id = ?" (Only tknId) + +getNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType NtfTknRec) +getNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = + getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey) + +getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType NtfTknRec) +getNtfToken_ st cond params = + withDB "getNtfToken" st $ \db -> runExceptT $ do + tkn <- ExceptT $ firstRow rowToNtfTkn AUTH $ DB.query db (ntfTknQuery <> cond) params + liftIO $ updateTokenDate st db tkn + pure tkn + +updateTokenDate :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> IO () +updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do + ts <- getSystemDate + when (maybe True (ts /=) tknUpdatedAt) $ do + void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId) + withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts + +type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe RoundedSystemTime) + +ntfTknQuery :: Query +ntfTknQuery = + [sql| + SELECT token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at + FROM tokens + |] + +rowToNtfTkn :: NtfTknRow -> NtfTknRec +rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) = + let token = DeviceToken pp ppToken + tknRegCode = NtfRegCode regCode + in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} + +deleteNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType [(SMPServer, [NotifierId])]) +deleteNtfToken st tknId = + withDB "deleteNtfToken" st $ \db -> runExceptT $ do + -- This SELECT obtains exclusive lock on token row and prevents any inserts + -- into other tables for this token ID until the deletion completes. + _ <- ExceptT $ firstRow (fromOnly @Int) AUTH $ + DB.query db "SELECT 1 FROM tokens WHERE token_id = ? FOR UPDATE" (Only tknId) + subs <- + liftIO $ map toServerSubs <$> + DB.query + db + [sql| + SELECT p.smp_host, p.smp_port, p.smp_keyhash, + string_agg(s.smp_notifier_id :: TEXT, ',') AS notifier_ids + FROM smp_servers p + JOIN subscriptions s ON s.smp_server_id = p.smp_server_id + WHERE s.token_id = ? + GROUP BY p.smp_host, p.smp_port, p.smp_keyhash; + |] + (Only tknId) + liftIO $ void $ DB.execute db "DELETE FROM tokens WHERE token_id = ?" (Only tknId) + withLog "deleteNtfToken" st (`logDeleteToken` tknId) + pure subs + where + toServerSubs :: SMPServerRow :. Only Text -> (SMPServer, [NotifierId]) + toServerSubs (srv :. Only nIdsStr) = (rowToSrv srv, parseByteaString nIdsStr) + parseByteaString :: Text -> [NotifierId] + parseByteaString s = mapMaybe (fmap EntityId . decodeHex . T.drop 2) $ T.splitOn "," s -- drop 2 to remove "\\x" + +type SMPServerRow = (NonEmpty TransportHost, ServiceName, C.KeyHash) + +type SMPQueueNtfRow = (NonEmpty TransportHost, ServiceName, C.KeyHash, NotifierId) + +rowToSrv :: SMPServerRow -> SMPServer +rowToSrv (host, port, kh) = SMPServer host port kh + +srvToRow :: SMPServer -> SMPServerRow +srvToRow (SMPServer host port kh) = (host, port, kh) + +smpQueueToRow :: SMPQueueNtf -> SMPQueueNtfRow +smpQueueToRow (SMPQueueNtf (SMPServer host port kh) nId) = (host, port, kh, nId) + +rowToSMPQueue :: SMPQueueNtfRow -> SMPQueueNtf +rowToSMPQueue (host, port, kh, nId) = SMPQueueNtf (SMPServer host port kh) nId + +updateTknCronInterval :: NtfPostgresStore -> NtfTokenId -> Word16 -> IO (Either ErrorType ()) +updateTknCronInterval st tknId cronInt = + withDB "updateTknCronInterval" st $ \db -> runExceptT $ do + ExceptT $ assertUpdated <$> + DB.execute db "UPDATE tokens SET cron_interval = ? WHERE token_id = ?" (cronInt, tknId) + withLog "updateTknCronInterval" st $ \sl -> logTokenCron sl tknId 0 + +-- Reads servers that have subscriptions that need subscribing. +-- It is executed on server start, and it is supposed to crash on database error +getUsedSMPServers :: NtfPostgresStore -> IO [SMPServer] +getUsedSMPServers st = + withTransaction (dbStore st) $ \db -> + map rowToSrv <$> + DB.query + db + [sql| + SELECT p.smp_host, p.smp_port, p.smp_keyhash + FROM smp_servers p + WHERE EXISTS ( + SELECT 1 FROM subscriptions s + WHERE s.smp_server_id = p.smp_server_id + AND s.status IN ? + ) + |] + (Only (In [NSNew, NSPending, NSActive, NSInactive])) + +foldNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Int -> s -> (s -> NtfSubRec -> IO s) -> IO s +foldNtfSubscriptions st srv fetchCount state action = + withConnection (dbStore st) $ \db -> + DB.foldWithOptions opts db query params state $ \s -> action s . toNtfSub + where + query = + [sql| + SELECT s.subscription_id, s.token_id, s.smp_notifier_id, s.status, s.smp_notifier_key + FROM subscriptions s + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? + AND s.status IN ? + |] + params = srvToRow srv :. Only (In [NSNew, NSPending, NSActive, NSInactive]) + opts = DB.defaultFoldOptions {DB.fetchQuantity = DB.Fixed fetchCount} + toNtfSub (ntfSubId, tokenId, nId, subStatus, notifierKey) = + NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf srv nId, subStatus, notifierKey} + +findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec)) +findNtfSubscription st tknId q@(SMPQueueNtf srv nId) = + withDB "findNtfSubscription" st $ \db -> runExceptT $ do + r@(tkn@NtfTknRec {tknStatus}, _) <- + ExceptT $ firstRow (rowToNtfTknMaybeSub q) AUTH $ + DB.query + db + [sql| + SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at, + s.subscription_id, s.smp_notifier_key, s.status + FROM tokens t + LEFT JOIN subscriptions s ON s.token_id = t.token_id AND s.smp_notifier_id = ? + LEFT JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? + WHERE t.token_id = ? + |] + (Only nId :. srvToRow srv :. Only tknId) + liftIO $ updateTokenDate st db tkn + unless (allowNtfSubCommands tknStatus) $ throwE AUTH + pure r + +getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec)) +getNtfSubscription st subId = + withDB "getNtfSubscription" st $ \db -> runExceptT $ do + r@(tkn@NtfTknRec {tknStatus}, _) <- + ExceptT $ firstRow rowToNtfTknSub AUTH $ + DB.query + db + [sql| + SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at, + s.subscription_id, s.smp_notifier_key, s.status, + p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id + FROM subscriptions s + JOIN tokens t ON t.token_id = s.token_id + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + WHERE s.subscription_id = ? + |] + (Only subId) + liftIO $ updateTokenDate st db tkn + unless (allowNtfSubCommands tknStatus) $ throwE AUTH + pure r + +type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus) + +type MaybeNtfSubRow = (Maybe NtfSubscriptionId, Maybe NtfPrivateAuthKey, Maybe NtfSubStatus) + +rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec) +rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus) :. qRow) = + let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow + smpQueue = rowToSMPQueue qRow + in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}) + +rowToNtfTknMaybeSub :: SMPQueueNtf -> NtfTknRow :. MaybeNtfSubRow -> (NtfTknRec, Maybe NtfSubRec) +rowToNtfTknMaybeSub smpQueue (tknRow :. subRow) = + let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow + sub_ = case subRow of + (Just ntfSubId, Just notifierKey, Just subStatus) -> + Just NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} + _ -> Nothing + in (tkn, sub_) + +mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec +mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = + NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey} + +updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ()) +updateTknStatus st tkn status = + withDB' "updateTknStatus" st $ \db -> updateTknStatus_ st db tkn status + +updateTknStatus_ :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> NtfTknStatus -> IO () +updateTknStatus_ st db NtfTknRec {ntfTknId} status = do + updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ?" (status, ntfTknId, status) + when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId status + +-- unless it was already active +setTknStatusConfirmed :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) +setTknStatusConfirmed st NtfTknRec {ntfTknId} = + withDB' "updateTknStatus" st $ \db -> do + updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ? AND status != ?" (NTConfirmed, ntfTknId, NTConfirmed, NTActive) + when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed + +setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType [NtfTokenId]) +setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} = + withDB' "setTokenActive" st $ \db -> do + updateTknStatus_ st db tkn NTActive + -- this removes other instances of the same token, e.g. because of repeated token registration attempts + tknIds <- + liftIO $ map fromOnly <$> + DB.query + db + [sql| + DELETE FROM tokens + WHERE push_provider = ? AND push_provider_token = ? AND token_id != ? + RETURNING token_id + |] + (pp, Binary ppToken, ntfTknId) + withLog "deleteNtfToken" st $ \sl -> mapM_ (logDeleteToken sl) tknIds + pure tknIds + +addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool) +addNtfSubscription st sub = + withDB "addNtfSubscription" st $ \db -> runExceptT $ do + srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub + n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub + withLog "addNtfSubscription" st (`logCreateSubscription` sub) + pure $ n > 0 + where + -- It is possible to combine these two statements into one with CTEs, + -- to reduce roundtrips in case of `insert`, but it would be making 2 queries in all cases. + -- With 2 statements it will succeed on the first `select` in most cases. + upsertServer db srv = getServer >>= maybe insertServer (pure . Right) + where + getServer = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT smp_server_id + FROM smp_servers + WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ? + |] + (srvToRow srv) + insertServer = + firstRow fromOnly (STORE "error inserting SMP server when adding subscription") $ + DB.query + db + [sql| + INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?) + ON CONFLICT (smp_host, smp_port, smp_keyhash) + DO UPDATE SET smp_host = EXCLUDED.smp_host + RETURNING smp_server_id + |] + (srvToRow srv) + +insertNtfSubQuery :: Query +insertNtfSubQuery = + [sql| + INSERT INTO subscriptions (token_id, smp_server_id, smp_notifier_id, subscription_id, smp_notifier_key, status) + VALUES (?,?,?,?,?,?) + |] + +ntfSubToRow :: Int64 -> NtfSubRec -> (NtfTokenId, Int64, NotifierId) :. NtfSubRow +ntfSubToRow srvId NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf _ nId, notifierKey, subStatus} = + (tokenId, srvId, nId) :. (ntfSubId, notifierKey, subStatus) + +deleteNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType ()) +deleteNtfSubscription st subId = + withDB "deleteNtfSubscription" st $ \db -> runExceptT $ do + ExceptT $ assertUpdated <$> + DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId) + withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId) + +updateSrvSubStatus :: NtfPostgresStore -> SMPQueueNtf -> NtfSubStatus -> IO (Either ErrorType ()) +updateSrvSubStatus st q status = + withDB' "updateSrvSubStatus" st $ \db -> do + subId_ :: Maybe NtfSubscriptionId <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + UPDATE subscriptions s + SET status = ? + FROM smp_servers p + WHERE p.smp_server_id = s.smp_server_id + AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ? + AND s.status != ? + RETURNING s.subscription_id + |] + (Only status :. smpQueueToRow q :. Only status) + forM_ subId_ $ \subId -> + withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl subId status + +batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> NonEmpty NotifierId -> NtfSubStatus -> IO Int64 +batchUpdateSrvSubStatus st srv nIds status = + batchUpdateStatus_ st srv $ \srvId -> + -- without executeMany + -- L.toList $ L.map (status,srvId,,status) nIds + L.toList $ L.map (status,srvId,) nIds + +batchUpdateSrvSubStatuses :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int64 +batchUpdateSrvSubStatuses st srv subs = + batchUpdateStatus_ st srv $ \srvId -> + -- without executeMany + -- L.toList $ L.map (\(nId, status) -> (status, srvId, nId, status)) subs + L.toList $ L.map (\(nId, status) -> (status, srvId, nId)) subs + +-- without executeMany +-- batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId, NtfSubStatus)]) -> IO Int64 +batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId)]) -> IO Int64 +batchUpdateStatus_ st srv mkParams = + fmap (fromRight (-1)) $ withDB "batchUpdateStatus_" st $ \db -> runExceptT $ do + srvId <- ExceptT $ getSMPServerId db + let params = mkParams srvId + subs <- + liftIO $ + DB.returning + db + [sql| + UPDATE subscriptions s + SET status = upd.status + FROM (VALUES(?, ?, ?)) AS upd(status, smp_server_id, smp_notifier_id) + WHERE s.smp_server_id = upd.smp_server_id + AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA) + AND s.status != upd.status + RETURNING s.subscription_id, s.status + |] + params + -- TODO [ntfdb] below is equivalent without using executeMany. + -- executeMany "works", and logs updates. + -- We do not have tests that validate correct subscription status, + -- and the potential problem is BYTEA conversation - VALUES are inserted as TEXT in this case for some reason. + -- subs <- + -- liftIO $ fmap catMaybes $ forM params $ + -- maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ? RETURNING subscription_id, status" + -- logWarn $ "batchUpdateStatus_: " <> tshow (length subs) + withLog "batchUpdateStatus_" st $ forM_ subs . uncurry . logSubscriptionStatus + pure $ fromIntegral $ length subs + where + getSMPServerId db = + firstRow fromOnly AUTH $ + DB.query + db + [sql| + SELECT smp_server_id + FROM smp_servers + WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ? + |] + (srvToRow srv) + +batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty NtfSubRec -> NtfSubStatus -> IO Int64 +batchUpdateSubStatus st subs status = + fmap (fromRight (-1)) $ withDB' "batchUpdateSubStatus" st $ \db -> do + let params = L.toList $ L.map (\NtfSubRec {ntfSubId} -> (status, ntfSubId)) subs + subIds <- + DB.returning + db + [sql| + UPDATE subscriptions s + SET status = upd.status + FROM (VALUES(?, ?)) AS upd(status, subscription_id) + WHERE s.subscription_id = (upd.subscription_id :: BYTEA) + AND s.status != upd.status + RETURNING s.subscription_id + |] + params + -- TODO [ntfdb] below is equivalent without using executeMany - see comment above. + -- let params = L.toList $ L.map (\NtfSubRec {ntfSubId} -> (status, ntfSubId, status)) subs + -- subIds <- + -- fmap catMaybes $ forM params $ + -- maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE subscription_id = ? AND status != ? RETURNING subscription_id" + -- logWarn $ "batchUpdateSubStatus: " <> tshow (length subIds) + withLog "batchUpdateSubStatus" st $ \sl -> + forM_ subIds $ \(Only subId) -> logSubscriptionStatus sl subId status + pure $ fromIntegral $ length subIds + +addTokenLastNtf :: NtfPostgresStore -> PNMessageData -> IO (Either ErrorType (NtfTknRec, NonEmpty PNMessageData)) +addTokenLastNtf st newNtf = + withDB "addTokenLastNtf" st $ \db -> runExceptT $ do + (tkn@NtfTknRec {ntfTknId = tId, tknStatus}, sId) <- + ExceptT $ firstRow toTokenSubId AUTH $ + DB.query + db + [sql| + SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at, + s.subscription_id + FROM tokens t + JOIN subscriptions s ON s.token_id = t.token_id + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ? + FOR UPDATE OF t, s + |] + (smpQueueToRow q) + unless (tknStatus == NTActive) $ throwE AUTH + lastNtfs_ <- + liftIO $ map toLastNtf <$> + DB.query + db + [sql| + WITH new AS ( + INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data) + VALUES (?,?,?,?,?) + ON CONFLICT (token_id, subscription_id) + DO UPDATE SET + sent_at = EXCLUDED.sent_at, + nmsg_nonce = EXCLUDED.nmsg_nonce, + nmsg_data = EXCLUDED.nmsg_data + ), + last AS ( + SELECT token_ntf_id, subscription_id, sent_at, nmsg_nonce, nmsg_data + FROM last_notifications + WHERE token_id = ? + ORDER BY sent_at DESC + LIMIT ? + ), + delete AS ( + DELETE FROM last_notifications + WHERE token_id = ? + AND sent_at < (SELECT min(sent_at) FROM last) + ) + SELECT p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id, + l.sent_at, l.nmsg_nonce, l.nmsg_data + FROM last l + JOIN subscriptions s ON s.subscription_id = l.subscription_id + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + ORDER BY token_ntf_id DESC + |] + (tId, sId, ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId) + let lastNtfs = fromMaybe (newNtf :| []) (L.nonEmpty lastNtfs_) + pure (tkn, lastNtfs) + where + maxNtfs = 6 :: Int + PNMessageData {smpQueue = q, ntfTs, nmsgNonce, encNMsgMeta} = newNtf + toTokenSubId :: NtfTknRow :. Only NtfSubscriptionId -> (NtfTknRec, NtfSubscriptionId) + toTokenSubId (tknRow :. Only sId) = (rowToNtfTkn tknRow, sId) + +toLastNtf :: SMPQueueNtfRow :. (SystemTime, C.CbNonce, Binary EncNMsgMeta) -> PNMessageData +toLastNtf (qRow :. (ts, nonce, Binary encMeta)) = + PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs = ts, nmsgNonce = nonce, encNMsgMeta = encMeta} + +importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> IO (Int64, Int64, Int64) +importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do + (tCnt, tIds) <- importTokens + sCnt <- importSubscriptions tIds + nCnt <- importLastNtfs + pure (tCnt, sCnt, nCnt) + where + importTokens = do + allTokens <- M.elems <$> readTVarIO (tokens stmStore) + tokens <- filterTokens allTokens + let skipped = length allTokens - length tokens + when (skipped /= 0) $ putStrLn $ "Total skipped tokens " <> show skipped + tCnt <- withConnection s $ \db -> foldM (insertToken db) 0 tokens + void $ checkCount "token" (length tokens) tCnt + let tokenIds = S.fromList $ map (\NtfTknData {ntfTknId} -> ntfTknId) tokens + pure (tCnt, tokenIds) + where + filterTokens tokens = do + let deviceTokens = foldl' (\m t -> M.alter (Just . (t :) . fromMaybe []) (tokenKey t) m) M.empty tokens + tokenSubs <- readTVarIO (tokenSubscriptions stmStore) + filterM (keepTokenRegistration deviceTokens tokenSubs) tokens + tokenKey NtfTknData {token, tknVerifyKey} = strEncode token <> ":" <> C.toPubKey C.pubKeyBytes tknVerifyKey + keepTokenRegistration deviceTokens tokenSubs tkn@NtfTknData {ntfTknId, token, tknStatus} = + case M.lookup (tokenKey tkn) deviceTokens of + Just ts + | length ts >= 2 -> + readTVarIO tknStatus >>= \case + NTConfirmed -> do + anyActive <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> (NTActive ==) <$> readTVarIO tknStatus') ts + noSubs <- S.null <$> maybe (pure S.empty) readTVarIO (M.lookup ntfTknId tokenSubs) + if anyActive + then ( + if noSubs + then False <$ putStrLn ("Skipped inactive token " <> enc ntfTknId <> " (no subscriptions)") + else pure True + ) + else do + let noSubsStr = if noSubs then " no subscriptions" else " has subscriptions" + putStrLn $ "Error: more than one registration for token " <> enc ntfTknId <> " " <> show token <> noSubsStr + pure True + _ -> pure True + | otherwise -> pure True + Nothing -> True <$ putStrLn "Error: no device token in lookup map" + insertToken db !n tkn@NtfTknData {ntfTknId} = do + tknRow <- ntfTknToRow <$> mkTknRec tkn + (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) -> + putStrLn ("Error inserting token " <> enc ntfTknId <> " " <> show e) $> n + importSubscriptions tIds = do + allSubs <- M.elems <$> readTVarIO (subscriptions stmStore) + let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs + skipped = length allSubs - length subs + when (skipped /= 0) $ putStrLn $ "Skipped subscriptions (no tokens) " <> show skipped + srvIds <- importServers subs + putStrLn $ "Importing " <> show (length subs) <> " subscriptions..." + -- uncomment this line instead of the next 2 lines to import subs one by one. + (sCnt, missingTkns) <- withConnection s $ \db -> foldM (importSub db srvIds) (0, M.empty) subs + -- sCnt <- foldM (importSubs srvIds) 0 $ toChunks 100000 subs + -- let missingTkns = M.empty + putStrLn $ "Imported " <> show sCnt <> " subscriptions" + unless (M.null missingTkns) $ do + putStrLn $ show (M.size missingTkns) <> " missing tokens:" + forM_ (M.assocs missingTkns) $ \(tId, sIds) -> + putStrLn $ "Token " <> enc tId <> " " <> show (length sIds) <> " subscriptions: " <> intercalate ", " (map enc sIds) + checkCount "subscription" (length subs) sCnt + where + importSubs srvIds !n subs = do + rows <- mapM (ntfSubRow srvIds) subs + cnt <- withConnection s $ \db -> DB.executeMany db insertNtfSubQuery $ L.toList rows + let n' = n + cnt + putStr $ "Imported " <> show n' <> " subscriptions" <> "\r" + hFlush stdout + pure n' + importSub db srvIds (!n, !missingTkns) sub@NtfSubData {ntfSubId = sId, tokenId} = do + subRow <- ntfSubRow srvIds sub + E.try (DB.execute db insertNtfSubQuery subRow) >>= \case + Right i -> do + let n' = n + i + when (n' `mod` 100000 == 0) $ do + putStr $ "Imported " <> show n' <> " subscriptions" <> "\r" + hFlush stdout + pure (n', missingTkns) + Left (e :: E.SomeException) -> do + when (n `mod` 100000 == 0) $ putStrLn "" + putStrLn $ "Error inserting subscription " <> enc sId <> " for token " <> enc tokenId <> " " <> show e + pure (n, M.alter (Just . (sId :) . fromMaybe []) tokenId missingTkns) + ntfSubRow srvIds sub = case M.lookup srv srvIds of + Just sId -> ntfSubToRow sId <$> mkSubRec sub + Nothing -> E.throwIO $ userError $ "no matching server ID for server " <> show srv + where + srv = ntfSubServer sub + importServers subs = do + sIds <- withConnection s $ \db -> map fromOnly <$> DB.returning db srvQuery (map srvToRow srvs) + void $ checkCount "server" (length srvs) (length sIds) + pure $ M.fromList $ zip srvs sIds + where + srvQuery = "INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?) RETURNING smp_server_id" + srvs = nubOrd $ map ntfSubServer subs + importLastNtfs = do + subLookup <- readTVarIO $ subscriptionLookup stmStore + ntfRows <- fmap concat . mapM (lastNtfRows subLookup) . M.assocs =<< readTVarIO (tokenLastNtfs stmStore) + nCnt <- withConnection s $ \db -> DB.executeMany db lastNtfQuery ntfRows + checkCount "last notification" (length ntfRows) nCnt + where + lastNtfQuery = "INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data) VALUES (?,?,?,?,?)" + lastNtfRows :: M.Map SMPQueueNtf NtfSubscriptionId -> (NtfTokenId, TVar (NonEmpty PNMessageData)) -> IO [(NtfTokenId, NtfSubscriptionId, SystemTime, C.CbNonce, Binary ByteString)] + lastNtfRows subLookup (tId, ntfs) = fmap catMaybes . mapM ntfRow . L.toList =<< readTVarIO ntfs + where + ntfRow PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of + Just ntfSubId -> pure $ Just (tId, ntfSubId, ntfTs, nmsgNonce, Binary encNMsgMeta) + Nothing -> Nothing <$ putStrLn ("Error: no subscription " <> show smpQueue <> " for notification of token " <> enc tId) + checkCount name expected inserted + | fromIntegral expected == inserted = do + putStrLn $ "Imported " <> show inserted <> " " <> name <> "s." + pure inserted + | otherwise = do + putStrLn $ "Incorrect " <> name <> " count: expected " <> show expected <> ", imported " <> show inserted + putStrLn "Import aborted, fix data and repeat" + exitFailure + enc = B.unpack . B64.encode . unEntityId + +exportNtfDbStore :: NtfPostgresStore -> FilePath -> IO (Int, Int, Int) +exportNtfDbStore NtfPostgresStore {dbStoreLog = Nothing} _ = + putStrLn "Internal error: export requires store log" >> exitFailure +exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFile = + (,,) <$> exportTokens <*> exportSubscriptions <*> exportLastNtfs + where + exportTokens = + withConnection s $ \db -> DB.fold_ db ntfTknQuery 0 $ \ !i tkn -> + logCreateToken sl (rowToNtfTkn tkn) $> (i + 1) + exportSubscriptions = + withConnection s $ \db -> DB.fold_ db ntfSubQuery 0 $ \ !i sub -> + logCreateSubscription sl (toNtfSub sub) $> (i + 1) + where + ntfSubQuery = + [sql| + SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, + p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id + FROM subscriptions s + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + |] + toNtfSub :: Only NtfTokenId :. NtfSubRow :. SMPQueueNtfRow -> NtfSubRec + toNtfSub (Only tokenId :. (ntfSubId, notifierKey, subStatus) :. qRow) = + let smpQueue = rowToSMPQueue qRow + in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} + exportLastNtfs = + withFile lastNtfsFile WriteMode $ \h -> + withConnection s $ \db -> DB.fold_ db lastNtfsQuery 0 $ \ !i (Only tknId :. ntfRow) -> + B.hPutStr h (encodeLastNtf tknId $ toLastNtf ntfRow) $> (i + 1) + where + -- Note that the order here is ascending, to be compatible with how it is imported + lastNtfsQuery = + [sql| + SELECT s.token_id, p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id, + n.sent_at, n.nmsg_nonce, n.nmsg_data + FROM last_notifications n + JOIN subscriptions s ON s.subscription_id = n.subscription_id + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + ORDER BY token_ntf_id ASC + |] + encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n' + +withDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a) +withDB' op st action = withDB op st $ fmap Right . action + +withDB :: forall a. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) +withDB op st action = + E.uninterruptibleMask_ $ E.try (withTransaction (dbStore st) action) >>= either logErr pure + where + logErr :: E.SomeException -> IO (Either ErrorType a) + logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) + where + err = op <> ", withDB, " <> show e + +withLog :: MonadIO m => String -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m () +withLog op NtfPostgresStore {dbStoreLog} = withLog_ op dbStoreLog +{-# INLINE withLog #-} + +assertUpdated :: Int64 -> Either ErrorType () +assertUpdated 0 = Left AUTH +assertUpdated _ = Right () + +-- TODO [ntfdb] change instance and maybe field type to not round to a second, for more reliable sorting of the most recent notifications +instance FromField SystemTime where fromField f = fmap (`MkSystemTime` 0) . fromField f + +instance ToField SystemTime where toField = toField . systemSeconds + +instance FromField NtfSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8 + +instance ToField NtfSubStatus where toField = toField . decodeLatin1 . smpEncode + +#if !defined(dbPostgres) +instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode + +instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8 + +instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode + +instance FromField (C.PrivateKey 'C.X25519) where fromField = blobFieldDecoder C.decodePrivKey + +instance ToField (C.PrivateKey 'C.X25519) where toField = toField . Binary . C.encodePrivKey + +instance FromField C.APrivateAuthKey where fromField = blobFieldDecoder C.decodePrivKey + +instance ToField C.APrivateAuthKey where toField = toField . Binary . C.encodePrivKey + +instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode + +instance FromField C.KeyHash where fromField = blobFieldDecoder $ parseAll strP + +instance ToField C.KeyHash where toField = toField . Binary . strEncode + +instance FromField C.CbNonce where fromField = blobFieldDecoder $ parseAll smpP + +instance ToField C.CbNonce where toField = toField . Binary . smpEncode +#endif diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Types.hs b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs new file mode 100644 index 000000000..802906386 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Notifications.Server.Store.Types where + +import Control.Applicative (optional) +import Control.Concurrent.STM +import qualified Data.ByteString.Char8 as B +import Data.Word (Word16) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf) +import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..)) +import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) + +data NtfTknRec = NtfTknRec + { ntfTknId :: NtfTokenId, + token :: DeviceToken, + tknStatus :: NtfTknStatus, + tknVerifyKey :: NtfPublicAuthKey, + tknDhPrivKey :: C.PrivateKeyX25519, + tknDhSecret :: C.DhSecretX25519, + tknRegCode :: NtfRegCode, + tknCronInterval :: Word16, + tknUpdatedAt :: Maybe RoundedSystemTime + } + deriving (Show) + +mkTknData :: NtfTknRec -> IO NtfTknData +mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do + tknStatus <- newTVarIO status + tknCronInterval <- newTVarIO cronInt + tknUpdatedAt <- newTVarIO updatedAt + let tknDhKeys = (C.publicKey pk, pk) + pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} + +mkTknRec :: NtfTknData -> IO NtfTknRec +mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys = (_, tknDhPrivKey), tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do + tknStatus <- readTVarIO status + tknCronInterval <- readTVarIO cronInt + tknUpdatedAt <- readTVarIO updatedAt + pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} + +instance StrEncoding NtfTknRec where + strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} = + B.unwords + [ "tknId=" <> strEncode ntfTknId, + "token=" <> strEncode token, + "tokenStatus=" <> strEncode tknStatus, + "verifyKey=" <> strEncode tknVerifyKey, + "dhKeys=" <> strEncode (C.publicKey pk, pk), + "dhSecret=" <> strEncode tknDhSecret, + "regCode=" <> strEncode tknRegCode, + "cron=" <> strEncode tknCronInterval + ] + <> maybe "" updatedAtStr tknUpdatedAt + where + updatedAtStr t = " updatedAt=" <> strEncode t + strP = do + ntfTknId <- "tknId=" *> strP_ + token <- "token=" *> strP_ + tknStatus <- "tokenStatus=" *> strP_ + tknVerifyKey <- "verifyKey=" *> strP_ + (_ :: C.PublicKeyX25519, tknDhPrivKey) <- "dhKeys=" *> strP_ + tknDhSecret <- "dhSecret=" *> strP_ + tknRegCode <- "regCode=" *> strP_ + tknCronInterval <- "cron=" *> strP + tknUpdatedAt <- optional $ " updatedAt=" *> strP + pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} + +data NtfSubRec = NtfSubRec + { ntfSubId :: NtfSubscriptionId, + smpQueue :: SMPQueueNtf, + notifierKey :: NtfPrivateAuthKey, + tokenId :: NtfTokenId, + subStatus :: NtfSubStatus + } + deriving (Show) + +mkSubData :: NtfSubRec -> IO NtfSubData +mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do + subStatus <- newTVarIO status + pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} + +mkSubRec :: NtfSubData -> IO NtfSubRec +mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do + subStatus <- readTVarIO status + pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} + +instance StrEncoding NtfSubRec where + strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} = + B.unwords + [ "subId=" <> strEncode ntfSubId, + "smpQueue=" <> strEncode smpQueue, + "notifierKey=" <> strEncode notifierKey, + "tknId=" <> strEncode tokenId, + "subStatus=" <> strEncode subStatus + ] + strP = do + ntfSubId <- "subId=" *> strP_ + smpQueue <- "smpQueue=" *> strP_ + notifierKey <- "notifierKey=" *> strP_ + tokenId <- "tknId=" *> strP_ + subStatus <- "subStatus=" *> strP + pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index fa0ae373c..87c09826e 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -10,7 +10,7 @@ module Simplex.Messaging.Notifications.Server.StoreLog ( StoreLog, NtfStoreLogRecord (..), - readWriteNtfStore, + readWriteNtfSTMStore, logCreateToken, logTokenStatus, logUpdateToken, @@ -24,23 +24,19 @@ module Simplex.Messaging.Notifications.Server.StoreLog ) where -import Control.Applicative (optional) import Control.Concurrent.STM -import Control.Logger.Simple import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Base64.URL as B64 import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB -import qualified Data.Text as T import Data.Word (Word16) -import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store -import Simplex.Messaging.Protocol (NtfPrivateAuthKey) +import Simplex.Messaging.Notifications.Server.Store.Types +import Simplex.Messaging.Protocol (EntityId (..)) import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (safeDecodeUtf8) import System.IO data NtfStoreLogRecord @@ -55,52 +51,6 @@ data NtfStoreLogRecord | DeleteSubscription NtfSubscriptionId deriving (Show) -data NtfTknRec = NtfTknRec - { ntfTknId :: NtfTokenId, - token :: DeviceToken, - tknStatus :: NtfTknStatus, - tknVerifyKey :: C.APublicAuthKey, - tknDhKeys :: C.KeyPair 'C.X25519, - tknDhSecret :: C.DhSecretX25519, - tknRegCode :: NtfRegCode, - tknCronInterval :: Word16, - tknUpdatedAt :: Maybe RoundedSystemTime - } - deriving (Show) - -mkTknData :: NtfTknRec -> IO NtfTknData -mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do - tknStatus <- newTVarIO status - tknCronInterval <- newTVarIO cronInt - tknUpdatedAt <- newTVarIO updatedAt - pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} - -mkTknRec :: NtfTknData -> IO NtfTknRec -mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do - tknStatus <- readTVarIO status - tknCronInterval <- readTVarIO cronInt - tknUpdatedAt <- readTVarIO updatedAt - pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} - -data NtfSubRec = NtfSubRec - { ntfSubId :: NtfSubscriptionId, - smpQueue :: SMPQueueNtf, - notifierKey :: NtfPrivateAuthKey, - tokenId :: NtfTokenId, - subStatus :: NtfSubStatus - } - deriving (Show) - -mkSubData :: NtfSubRec -> IO NtfSubData -mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do - subStatus <- newTVarIO status - pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} - -mkSubRec :: NtfSubData -> STM NtfSubRec -mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do - subStatus <- readTVar status - pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} - instance StrEncoding NtfStoreLogRecord where strEncode = \case CreateToken tknRec -> strEncode (Str "TCREATE", tknRec) @@ -125,56 +75,12 @@ instance StrEncoding NtfStoreLogRecord where "SDELETE " *> (DeleteSubscription <$> strP) ] -instance StrEncoding NtfTknRec where - strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} = - B.unwords - [ "tknId=" <> strEncode ntfTknId, - "token=" <> strEncode token, - "tokenStatus=" <> strEncode tknStatus, - "verifyKey=" <> strEncode tknVerifyKey, - "dhKeys=" <> strEncode tknDhKeys, - "dhSecret=" <> strEncode tknDhSecret, - "regCode=" <> strEncode tknRegCode, - "cron=" <> strEncode tknCronInterval - ] - <> maybe "" updatedAtStr tknUpdatedAt - where - updatedAtStr t = " updatedAt=" <> strEncode t - strP = do - ntfTknId <- "tknId=" *> strP_ - token <- "token=" *> strP_ - tknStatus <- "tokenStatus=" *> strP_ - tknVerifyKey <- "verifyKey=" *> strP_ - tknDhKeys <- "dhKeys=" *> strP_ - tknDhSecret <- "dhSecret=" *> strP_ - tknRegCode <- "regCode=" *> strP_ - tknCronInterval <- "cron=" *> strP - tknUpdatedAt <- optional $ " updatedAt=" *> strP - pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} - -instance StrEncoding NtfSubRec where - strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} = - B.unwords - [ "subId=" <> strEncode ntfSubId, - "smpQueue=" <> strEncode smpQueue, - "notifierKey=" <> strEncode notifierKey, - "tknId=" <> strEncode tokenId, - "subStatus=" <> strEncode subStatus - ] - strP = do - ntfSubId <- "subId=" *> strP_ - smpQueue <- "smpQueue=" *> strP_ - notifierKey <- "notifierKey=" *> strP_ - tokenId <- "tknId=" *> strP_ - subStatus <- "subStatus=" *> strP - pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} - logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO () logNtfStoreRecord = writeStoreLogRecord {-# INLINE logNtfStoreRecord #-} -logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO () -logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< mkTknRec tkn +logCreateToken :: StoreLog 'WriteMode -> NtfTknRec -> IO () +logCreateToken s = logNtfStoreRecord s . CreateToken logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO () logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus @@ -191,8 +97,8 @@ logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO () logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t -logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO () -logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub) +logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO () +logCreateSubscription s = logNtfStoreRecord s . CreateSubscription logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO () logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus @@ -200,49 +106,54 @@ logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStat logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO () logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId -readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode) -readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore +readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode) +readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore -readNtfStore :: FilePath -> NtfStore -> IO () -readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f +readNtfStore :: Bool -> FilePath -> NtfSTMStore -> IO () +readNtfStore tty f st = readLogLines tty f $ \_ -> processLine where - addNtfLogRecord s = case strDecode s of - Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s) - Right lr -> case lr of - CreateToken r@NtfTknRec {ntfTknId} -> do - tkn <- mkTknData r - atomically $ addNtfToken st ntfTknId tkn - TokenStatus tknId status -> do - tkn_ <- getNtfTokenIO st tknId - forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do - atomically $ writeTVar tknStatus status - when (status == NTActive) $ void $ atomically $ removeInactiveTokenRegistrations st tkn - UpdateToken tknId token' tknRegCode -> do - getNtfTokenIO st tknId - >>= mapM_ - ( \tkn@NtfTknData {tknStatus} -> do - atomically $ removeTokenRegistration st tkn - atomically $ writeTVar tknStatus NTRegistered - atomically $ addNtfToken st tknId tkn {token = token', tknRegCode} - ) - TokenCron tknId cronInt -> - getNtfTokenIO st tknId - >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt) - DeleteToken tknId -> - atomically $ void $ deleteNtfToken st tknId - UpdateTokenTime tknId t -> - getNtfTokenIO st tknId - >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t) - CreateSubscription r@NtfSubRec {ntfSubId} -> do - sub <- mkSubData r - void $ atomically $ addNtfSubscription st ntfSubId sub - SubscriptionStatus subId status -> do - getNtfSubscriptionIO st subId - >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status) - DeleteSubscription subId -> - atomically $ deleteNtfSubscription st subId + processLine s = either printError procNtfLogRecord (strDecode s) + where + printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> B.take 100 s + procNtfLogRecord = \case + CreateToken r@NtfTknRec {ntfTknId} -> do + tkn <- mkTknData r + atomically $ stmAddNtfToken st ntfTknId tkn + TokenStatus tknId status -> do + tkn_ <- stmGetNtfTokenIO st tknId + forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do + atomically $ writeTVar tknStatus status + when (status == NTActive) $ void $ atomically $ stmRemoveInactiveTokenRegistrations st tkn + UpdateToken tknId token' tknRegCode -> do + stmGetNtfTokenIO st tknId + >>= mapM_ + ( \tkn@NtfTknData {tknStatus} -> do + atomically $ stmRemoveTokenRegistration st tkn + atomically $ writeTVar tknStatus NTRegistered + atomically $ stmAddNtfToken st tknId tkn {token = token', tknRegCode} + ) + TokenCron tknId cronInt -> + stmGetNtfTokenIO st tknId + >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt) + DeleteToken tknId -> + atomically $ void $ stmDeleteNtfToken st tknId + UpdateTokenTime tknId t -> + stmGetNtfTokenIO st tknId + >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t) + CreateSubscription r@NtfSubRec {tokenId, ntfSubId} -> do + sub <- mkSubData r + atomically (stmAddNtfSubscription st ntfSubId sub) >>= \case + Just () -> pure () + Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId + where + enc = B64.encode . unEntityId + SubscriptionStatus subId status -> do + stmGetNtfSubscriptionIO st subId + >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status) + DeleteSubscription subId -> + atomically $ stmDeleteNtfSubscription st subId -writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO () -writeNtfStore s NtfStore {tokens, subscriptions} = do - mapM_ (logCreateToken s) =<< readTVarIO tokens - mapM_ (logCreateSubscription s) =<< readTVarIO subscriptions +writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO () +writeNtfStore s NtfSTMStore {tokens, subscriptions} = do + mapM_ (logCreateToken s <=< mkTknRec) =<< readTVarIO tokens + mapM_ (logCreateSubscription s <=< mkSubRec) =<< readTVarIO subscriptions diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 8592aa228..a678825af 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -28,9 +28,10 @@ import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) -import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) @@ -174,6 +175,70 @@ certOptionsP = do ) pure CertOptions {signAlgorithm_, commonName_} +dbOptsP :: DBOpts -> Parser DBOpts +dbOptsP DBOpts {connstr = defDBConnStr, schema = defDBSchema, poolSize = defDBPoolSize} = do + connstr <- + strOption + ( long "database" + <> short 'd' + <> metavar "DB_CONN" + <> help "Database connection string" + <> value defDBConnStr + <> showDefault + ) + schema <- + strOption + ( long "schema" + <> metavar "DB_SCHEMA" + <> help "Database schema" + <> value defDBSchema + <> showDefault + ) + poolSize <- + option + auto + ( long "pool-size" + <> metavar "POOL_SIZE" + <> help "Database pool size" + <> value defDBPoolSize + <> showDefault + ) + pure DBOpts {connstr, schema, poolSize, createSchema = False} + +startOptionsP :: Parser StartOptions +startOptionsP = do + maintenance <- + switch + ( long "maintenance" + <> short 'm' + <> help "Do not start the server, only perform start and stop tasks" + ) + compactLog <- + switch + ( long "compact-log" + <> help "Compact store log (always enabled with `memory` storage for queues)" + ) + skipWarnings <- + switch + ( long "skip-warnings" + <> help "Start the server with non-critical start warnings" + ) + confirmMigrations <- + option + parseConfirmMigrations + ( long "confirm-migrations" + <> metavar "CONFIRM_MIGRATIONS" + <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" + <> value MCConsole + ) + pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations} + where + parseConfirmMigrations :: ReadM MigrationConfirmation + parseConfirmMigrations = eitherReader $ \case + "up" -> Right MCYesUp + "down" -> Right MCYesUpDown + _ -> Left "invalid migration confirmation, pass 'up' or 'down'" + genOnline :: FilePath -> CertOptions -> IO () genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do (signAlgorithm, commonName) <- @@ -294,18 +359,27 @@ iniTransports ini = webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini) ports = map T.unpack . T.splitOn "," -printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO () -printServerConfig transports logFile = do +iniDBOptions :: Ini -> DBOpts -> DBOpts +iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} = + DBOpts + { connstr = either (const connstr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, + schema = either (const schema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, + poolSize = readIniDefault poolSize "STORE_LOG" "db_pool_size" ini, + createSchema = False + } + +printServerConfig :: String -> [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO () +printServerConfig protocol transports logFile = do putStrLn $ case logFile of Just f -> "Store log: " <> f _ -> "Store log disabled." - printServerTransports transports + printServerTransports protocol transports -printServerTransports :: [(ServiceName, ATransport, AddHTTP)] -> IO () -printServerTransports ts = do +printServerTransports :: String -> [(ServiceName, ATransport, AddHTTP)] -> IO () +printServerTransports protocol ts = do forM_ ts $ \(p, ATransport t, addHTTP) -> do let descr = p <> " (" <> transportName t <> ")..." - putStrLn $ "Serving SMP protocol on port " <> descr + putStrLn $ "Serving " <> protocol <> " protocol on port " <> descr when addHTTP $ putStrLn $ "Serving static site on port " <> descr unless (any (\(p, _, _) -> p == "443") ts) $ putStrLn @@ -314,11 +388,11 @@ printServerTransports ts = do printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO () printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of - SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ - SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile + SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ + SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema - printServerTransports transports + printServerTransports "SMP" transports deleteDirIfExists :: FilePath -> IO () deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 5c3e9b6bf..5f3be4a98 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -370,6 +370,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp logInfo $ "restoring queues from file " <> T.pack f sl <- readWriteQueueStore False mkQ f st setStoreLog st sl +#if defined(dbServerPostgres) compactDbStoreLog = \case Just f -> do logInfo $ "compacting queues in file " <> T.pack f @@ -381,6 +382,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp Nothing -> do logError "Error: `--compact-log` used without `db_store_log` INI option" exitFailure +#endif getCredentials protocol creds = do files <- missingCreds unless (null files) $ do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 19e80bada..844d8d86d 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -247,13 +247,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = where iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini - iniDBOptions ini = - DBOpts - { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, - schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, - poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini, - createSchema = False - } iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini defaultStaticPath = combine logPath "www" enableStoreLog' = settingIsOn "STORE_LOG" "enable" @@ -411,7 +404,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir} ASType SQSPostgres SMSJournal -> let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath - storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini} + storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini} in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}, storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default @@ -512,7 +505,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created." #if defined(dbServerPostgres) SQSPostgres -> do - let DBOpts {connstr, schema} = iniDBOptions ini + let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts schemaExists <- checkSchemaExists connstr schema case enableDbStoreLog' ini of Just () @@ -669,7 +662,7 @@ cliCommandP cfgPath logPath iniFile = <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage")) - <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage")) + <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage")) ) where initP :: Parser InitOptions @@ -684,7 +677,7 @@ cliCommandP cfgPath logPath iniFile = <> short 'l' <> help "Enable store log for persistence (DEPRECATED, enabled by default)" ) - dbOptions <- dbOptsP + dbOptions <- dbOptsP defaultDBOpts logStats <- switch ( long "daily-stats" @@ -815,32 +808,6 @@ cliCommandP cfgPath logPath iniFile = disableWeb, scripted } - startOptionsP = do - maintenance <- - switch - ( long "maintenance" - <> short 'm' - <> help "Do not start the server, only perform start and stop tasks" - ) - compactLog <- - switch - ( long "compact-log" - <> help "Compact store log (always enabled with `memory` storage for queues)" - ) - skipWarnings <- - switch - ( long "skip-warnings" - <> help "Start the server with non-critical start warnings" - ) - confirmMigrations <- - option - parseConfirmMigrations - ( long "confirm-migrations" - <> metavar "CONFIRM_MIGRATIONS" - <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" - <> value MCConsole - ) - pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations} journalCmdP = storeCmdP "message log file" "journal storage" databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema" storeCmdP src dest = @@ -849,39 +816,6 @@ cliCommandP cfgPath logPath iniFile = <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src)) <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest)) ) - dbOptsP = do - connstr <- - strOption - ( long "database" - <> short 'd' - <> metavar "DB_CONN" - <> help "Database connection string" - <> value defaultDBConnStr - <> showDefault - ) - schema <- - strOption - ( long "schema" - <> metavar "DB_SCHEMA" - <> help "Database schema" - <> value defaultDBSchema - <> showDefault - ) - poolSize <- - option - auto - ( long "pool-size" - <> metavar "POOL_SIZE" - <> help "Database pool size" - <> value defaultDBPoolSize - <> showDefault - ) - pure DBOpts {connstr, schema, poolSize, createSchema = False} - parseConfirmMigrations :: ReadM MigrationConfirmation - parseConfirmMigrations = eitherReader $ \case - "up" -> Right MCYesUp - "down" -> Right MCYesUpDown - _ -> Left "invalid migration confirmation, pass 'up' or 'down'" parseBasicAuth :: ReadM ServerPassword parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text) diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index 4c218c5cc..7b1b320be 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -4,11 +4,9 @@ module Simplex.Messaging.Server.Main.Init where -import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isNothing) -import Numeric.Natural (Natural) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) @@ -27,14 +25,14 @@ import System.FilePath (()) defaultControlPort :: Int defaultControlPort = 5224 -defaultDBConnStr :: ByteString -defaultDBConnStr = "postgresql://smp@/smp_server_store" - -defaultDBSchema :: ByteString -defaultDBSchema = "smp_server" - -defaultDBPoolSize :: Natural -defaultDBPoolSize = 10 +defaultDBOpts :: DBOpts +defaultDBOpts = + DBOpts + { connstr = "postgresql://smp@/smp_server_store", + schema = "smp_server", + poolSize = 10, + createSchema = False + } -- time to retain deleted queues in the database (days), for debugging defaultDeletedTTL :: Int64 @@ -77,13 +75,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\ \store_queues: memory\n\n\ \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" - <> (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") - <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") - <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") + <> iniDbOpts dbOptions defaultDBOpts <> "# Write database changes to store log file\n\ \# db_store_log: off\n\n\ \# Time to retain deleted queues in the database, days.\n" - <> ("db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n") + <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n") <> "# Message storage mode: `memory` or `journal`.\n\ \store_messages: memory\n\n\ \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ @@ -164,7 +160,6 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n") where InitOptions {enableStoreLog, dbOptions, socksProxy, ownDomains, controlPort, webStaticPath, disableWeb, logStats} = opts - DBOpts {connstr, schema, poolSize} = dbOptions defaultServerPorts = "5223,443" defaultStaticPath = logPath "www" httpsCertFile = cfgPath "web.crt" @@ -221,6 +216,12 @@ informationIniContent InitOptions {sourceCode, serverInfo} = <> "\n" <> countryStr optName (country =<< entity) +iniDbOpts :: DBOpts -> DBOpts -> Text +iniDbOpts DBOpts {connstr, schema, poolSize} DBOpts {connstr = defConnstr, schema = defSchema, poolSize = defPoolSize} = + (optDisabled' (connstr == defConnstr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") + <> (optDisabled' (schema == defSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") + <> (optDisabled' (poolSize == defPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") + optDisabled :: Maybe a -> Text optDisabled = optDisabled' . isNothing {-# INLINE optDisabled #-} diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs index 7895f64e9..383fe014e 100644 --- a/src/Simplex/Messaging/Server/NtfStore.hs +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -28,7 +28,7 @@ data MsgNtf = MsgNtf storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO () storeNtf (NtfStore ns) nId ntf = do TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :)) - -- TODO coalesce messages here once the client is updated to process multiple messages + -- TODO [ntfdb] coalesce messages here once the client is updated to process multiple messages -- for single notification. -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats where diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index a4625b2f7..38158313d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -23,6 +23,8 @@ module Simplex.Messaging.Server.QueueStore.Postgres PostgresStoreCfg (..), batchInsertQueues, foldQueueRecs, + handleDuplicate, + withLog_, ) where @@ -56,6 +58,7 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import GHC.IO (catchAny) import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) +import Simplex.Messaging.Agent.Store.AgentStore () import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) @@ -530,8 +533,12 @@ withDB op st action = err = op <> ", withDB, " <> show e withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m () -withLog op PostgresQueueStore {dbStoreLog} action = - forM_ dbStoreLog $ \sl -> liftIO $ action sl `catchAny` \e -> +withLog op PostgresQueueStore {dbStoreLog} = withLog_ op dbStoreLog +{-# INLINE withLog #-} + +withLog_ :: MonadIO m => String -> Maybe (StoreLog 'WriteMode) -> (StoreLog 'WriteMode -> IO ()) -> m () +withLog_ op sl_ action = + forM_ sl_ $ \sl -> liftIO $ action sl `catchAny` \e -> logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e) handleDuplicate :: SqlError -> IO ErrorType @@ -541,15 +548,15 @@ handleDuplicate e = case constraintViolation e of -- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL -instance ToField EntityId where toField (EntityId s) = toField $ Binary s - -deriving newtype instance FromField EntityId - instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary . smpEncode instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode #if !defined(dbPostgres) +instance ToField EntityId where toField (EntityId s) = toField $ Binary s + +deriving newtype instance FromField EntityId + instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 0b261672a..07f806b56 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -12,12 +12,12 @@ import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) -import AgentTests.NotificationTests (notificationTests) import AgentTests.ServerChoice (serverChoiceTests) import AgentTests.ShortLinkTests (shortLinkTests) import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec + #if defined(dbPostgres) import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) @@ -25,6 +25,12 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) import AgentTests.SQLiteTests (storeTests) #endif +#if defined(dbServerPostgres) +import AgentTests.NotificationTests (notificationTests) +import SMPClient (postgressBracket) +import NtfClient (ntfTestServerDBConnectInfo) +#endif + agentCoreTests :: Spec agentCoreTests = do describe "Migration tests" migrationTests @@ -41,7 +47,10 @@ agentTests ps = do #endif describe "Functional API" $ functionalAPITests ps describe "Chosen servers" serverChoiceTests - describe "Notification tests" $ notificationTests ps +#if defined(dbServerPostgres) + around_ (postgressBracket ntfTestServerDBConnectInfo) $ + describe "Notification tests" $ notificationTests ps +#endif #if !defined(dbPostgres) describe "SQLite store" storeTests #endif diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index ea0ebd29b..64196cf3f 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') +import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, ntfTestPort, ntfTestPort2, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -120,10 +120,12 @@ notificationTests ps@(t, _) = do it "should keep working with active token until replaced" $ withAPNSMockServer $ \apns -> testNtfTokenChangeServers t apns - xit'' "should re-register token in NTInvalid status after register attempt" $ + -- TODO [ntfdb] modify database in the test + xit "should re-register token in NTInvalid status after register attempt" $ withAPNSMockServer $ \apns -> testNtfTokenReRegisterInvalid t apns - xit'' "should re-register token in NTInvalid status after checking token" $ + -- TODO [ntfdb] modify database in the test + xit "should re-register token in NTInvalid status after checking token" $ withAPNSMockServer $ \apns -> testNtfTokenReRegisterInvalidOnCheck t apns describe "notification server tests" $ do @@ -163,12 +165,12 @@ notificationTests ps@(t, _) = do it "should keep sending notifications for old token" $ withSmpServer ps $ withAPNSMockServer $ \apns -> - withNtfServerOn t ntfTestPort $ + withNtfServer t $ testNotificationsOldToken apns it "should update server from new token" $ withSmpServer ps $ withAPNSMockServer $ \apns -> - withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> + withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 . withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> testNotificationsNewToken apns ntf testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec @@ -278,7 +280,7 @@ testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestart t apns = do let tkn = DeviceToken PPApnsTest "abcd" ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> - withNtfServerStoreLog t $ \_ -> runRight $ do + withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -288,7 +290,7 @@ testNtfTokenServerRestart t apns = do withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" verifyNtfToken a' tkn nonce verification @@ -299,7 +301,7 @@ testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverify t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> do - ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do + ntfData <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -309,11 +311,11 @@ testNtfTokenServerRestartReverify t apns = do nonce <- C.cbNonce <$> ntfData .-> "nonce" Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification pure () - threadDelay 1000000 + threadDelay 1500000 withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do NTActive <- registerNtfToken a' tkn NMPeriodic NTActive <- checkNtfToken a' tkn pure () @@ -322,7 +324,7 @@ testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ( testNtfTokenServerRestartReverifyTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do - (nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do + (nonce, verification) <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -344,11 +346,11 @@ testNtfTokenServerRestartReverifyTimeout t apns = do (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString) Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken pure () - threadDelay 1000000 + threadDelay 1500000 withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do NTActive <- registerNtfToken a' tkn NMPeriodic NTActive <- checkNtfToken a' tkn pure () @@ -357,7 +359,7 @@ testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregister t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> - withNtfServerStoreLog t $ \_ -> runRight $ do + withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- getMockNotification apns tkn @@ -367,7 +369,7 @@ testNtfTokenServerRestartReregister t apns = do withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, and client might have lost verification notification. -- so that repeat registration happens when client is restarted. - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do NTRegistered <- registerNtfToken a' tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -381,7 +383,7 @@ testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO testNtfTokenServerRestartReregisterTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do - withNtfServerStoreLog t $ \_ -> runRight $ do + withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- getMockNotification apns tkn @@ -402,7 +404,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, and client might have lost verification notification. -- so that repeat registration happens when client is restarted. - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do NTRegistered <- registerNtfToken a' tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -422,8 +424,8 @@ testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers2 testDB $ \a -> - withNtfServerThreadOn t ntfTestPort $ \ntf -> - withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do + withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> + withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do -- register a new token, the agent picks a server and stores its choice NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- @@ -444,7 +446,7 @@ testNtfTokenMultipleServers t apns = do testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO () testNtfTokenChangeServers t apns = - withNtfServerThreadOn t ntfTestPort $ \ntf -> do + withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do tkn <- registerTestToken a "abcd" NMInstant apns NTActive <- checkNtfToken a tkn @@ -467,14 +469,14 @@ testNtfTokenChangeServers t apns = Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apns -- ok, it's down for now getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated killThread ntf - withNtfServerOn t ntfTestPort2 $ runRight_ $ do + withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 $ runRight_ $ do liftIO $ threadDelay 1000000 -- for notification server to reconnect tkn <- registerTestToken a "qwer" NMInstant apns checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive testNtfTokenReRegisterInvalid :: ATransport -> APNSMockServer -> IO () testNtfTokenReRegisterInvalid t apns = do - tkn <- withNtfServerStoreLog t $ \_ -> do + tkn <- withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do tkn <- registerTestToken a "abcd" NMInstant apns NTActive <- checkNtfToken a tkn @@ -482,13 +484,13 @@ testNtfTokenReRegisterInvalid t apns = do threadDelay 250000 -- start server to compact - withNtfServerStoreLog t $ \_ -> pure () + withNtfServer t $ pure () threadDelay 250000 replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" threadDelay 250000 - withNtfServerStoreLog t $ \_ -> do + withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do NTInvalid Nothing <- registerNtfToken a tkn NMInstant tkn1 <- registerTestToken a "abcd" NMInstant apns @@ -503,7 +505,7 @@ replaceSubstringInFile filePath oldText newText = do testNtfTokenReRegisterInvalidOnCheck :: ATransport -> APNSMockServer -> IO () testNtfTokenReRegisterInvalidOnCheck t apns = do - tkn <- withNtfServerStoreLog t $ \_ -> do + tkn <- withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do tkn <- registerTestToken a "abcd" NMInstant apns NTActive <- checkNtfToken a tkn @@ -511,13 +513,13 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do threadDelay 250000 -- start server to compact - withNtfServerStoreLog t $ \_ -> pure () + withNtfServer t $ pure () threadDelay 250000 replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" threadDelay 250000 - withNtfServerStoreLog t $ \_ -> do + withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do NTInvalid Nothing <- checkNtfToken a tkn tkn1 <- registerTestToken a "abcd" NMInstant apns @@ -526,7 +528,7 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) testRunNTFServerTests t srv = - withNtfServerOn t ntfTestPort $ + withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing @@ -567,7 +569,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 closeDBStore store - threadDelay 1000000 + threadDelay 1500000 putStrLn "before opening the database from another agent" -- aliceNtf client doesn't have subscription and is allowed to get notification message @@ -575,7 +577,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId] pure () - threadDelay 1000000 + threadDelay 1500000 putStrLn "after closing the database in another agent" reopenDBStore store foregroundAgent alice @@ -753,7 +755,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d testNotificationsStoreLog :: (ATransport, AStoreType) -> APNSMockServer -> IO () testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do withSmpServerStoreMsgLogOn ps testPort $ \_ -> do - (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do + (aliceId, bobId) <- withNtfServer t $ runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apns liftIO $ threadDelay 250000 @@ -762,19 +764,17 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId 2 Nothing - liftIO $ killThread threadId pure (aliceId, bobId) liftIO $ threadDelay 250000 - withNtfServerStoreLog t $ \threadId -> runRight_ $ do + withNtfServer t $ runRight_ $ do liftIO $ threadDelay 250000 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT 3) void $ messageNotificationData alice apns get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False ackMessage alice bobId 3 Nothing - liftIO $ killThread threadId runRight_ $ do 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "message 4" @@ -784,7 +784,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do noNotifications apns withSmpServerStoreMsgLogOn ps testPort $ \_ -> - withNtfServerStoreLog t $ \_ -> runRight_ $ do + withNtfServer t $ runRight_ $ do void $ messageNotificationData alice apns testNotificationsSMPRestart :: (ATransport, AStoreType) -> APNSMockServer -> IO () diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 7ba2316ca..e5fb784ee 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,7 +20,6 @@ import qualified Network.HTTP.Client as H1 import qualified Network.HTTP2.Client as H2 import Simplex.FileTransfer.Server.Main (xftpServerCLI) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Notifications.Server.Main import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_) import Simplex.Messaging.Transport (TLS (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake) @@ -40,6 +40,12 @@ import UnliftIO.Async (async, cancel) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (bracket) +#if defined(dbServerPostgres) +import NtfClient (ntfTestServerDBConnectInfo) +import SMPClient (postgressBracket) +import Simplex.Messaging.Notifications.Server.Main +#endif + cfgPath :: FilePath cfgPath = "tests/tmp/cli/etc/opt/simplex" @@ -70,9 +76,12 @@ cliTests = do it "no store log, no password" $ smpServerTest False False it "with store log, no password" $ smpServerTest True False it "static files" smpServerTestStatic - describe "Ntf server CLI" $ do - it "should initialize, start and delete the server (no store log)" $ ntfServerTest False - it "should initialize, start and delete the server (with store log)" $ ntfServerTest True +#if defined(dbServerPostgres) + aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ + describe "Ntf server CLI" $ do + it "should initialize, start and delete the server (no store log)" $ ntfServerTest False + it "should initialize, start and delete the server (with store log)" $ ntfServerTest True +#endif describe "XFTP server CLI" $ do it "should initialize, start and delete the server (no store log)" $ xftpServerTest False it "should initialize, start and delete the server (with store log)" $ xftpServerTest True @@ -182,6 +191,7 @@ smpServerTestStatic = do let X.CertificateChain cc = tlsServerCerts tls in map (X.signedObject . X.getSigned) cc +#if defined(dbServerPostgres) ntfServerTest :: Bool -> IO () ntfServerTest storeLog = do capture_ (withArgs (["init"] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) @@ -195,10 +205,11 @@ ntfServerTest storeLog = do r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ())) r `shouldContain` ["SMP notifications server v" <> simplexMQVersion] r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."]) - r `shouldContain` ["Serving SMP protocol on port 443 (TLS)..."] + r `shouldContain` ["Serving NTF protocol on port 443 (TLS)..."] capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`)) doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False +#endif xftpServerTest :: Bool -> IO () xftpServerTest storeLog = do diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 190815832..e7a7c2ba5 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -28,12 +28,15 @@ import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import Data.Text (Text) +import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) import GHC.Generics (Generic) import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket -import SMPClient (prevRange, serverBracket) +import SMPClient (ntfTestPort, prevRange, serverBracket) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -45,6 +48,8 @@ import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.Env.STM (StartOptions (..)) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client @@ -60,12 +65,6 @@ import UnliftIO.STM testHost :: NonEmpty TransportHost testHost = "localhost" -ntfTestPort :: ServiceName -ntfTestPort = "6001" - -ntfTestPort2 :: ServiceName -ntfTestPort2 = "6002" - apnsTestPort :: ServiceName apnsTestPort = "6010" @@ -75,9 +74,46 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" ntfTestStoreLogFile :: FilePath ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" +ntfTestStoreLogFile2 :: FilePath +ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2" + ntfTestStoreLastNtfsFile :: FilePath ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log" +ntfTestStoreDBOpts :: DBOpts +ntfTestStoreDBOpts = + DBOpts + { connstr = ntfTestServerDBConnstr, + schema = "ntf_server", + poolSize = 3, + createSchema = True + } + +ntfTestStoreDBOpts2 :: DBOpts +ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = "smp_server2"} + +ntfTestServerDBConnstr :: ByteString +ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db" + +ntfTestServerDBConnectInfo :: ConnectInfo +ntfTestServerDBConnectInfo = + defaultConnectInfo { + connectUser = "ntf_test_server_user", + connectDatabase = "ntf_test_server_db" + } + +ntfTestDBCfg :: PostgresStoreCfg +ntfTestDBCfg = + PostgresStoreCfg + { dbOpts = ntfTestStoreDBOpts, + dbStoreLogPath = Just ntfTestStoreLogFile, + confirmMigrations = MCYesUp, + deletedTTL = 86400 + } + +ntfTestDBCfg2 :: PostgresStoreCfg +ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2} + testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost @@ -106,8 +142,7 @@ ntfServerCfg = }, subsBatchSize = 900, inactiveClientExpiration = Just defaultInactiveClientExpiration, - storeLogFile = Nothing, - storeLastNtfsFile = Nothing, + dbStoreConfig = ntfTestDBCfg, ntfCredentials = ServerCredentials { caCertificateFile = Just "tests/fixtures/ca.crt", @@ -120,7 +155,8 @@ ntfServerCfg = serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig + transportConfig = defaultTransportServerConfig, + startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} } ntfServerCfgVPrev :: NtfServerConfig @@ -134,11 +170,9 @@ ntfServerCfgVPrev = smpCfg' = smpCfg smpAgentCfg' serverVRange' = serverVRange smpCfg' -withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a -withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, storeLastNtfsFile = Just ntfTestStoreLastNtfsFile, transports = [(ntfTestPort, t, False)]} - -withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]} +withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a +withNtfServerThreadOn t port' dbStoreConfig = + withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig} withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a withNtfServerCfg cfg@NtfServerConfig {transports} = @@ -149,11 +183,11 @@ withNtfServerCfg cfg@NtfServerConfig {transports} = (\started -> runNtfServerBlocking started cfg) (pure ()) -withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => IO a) -> IO a -withNtfServerOn t port' = withNtfServerThreadOn t port' . const +withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a +withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const withNtfServer :: HasCallStack => ATransport -> (HasCallStack => IO a) -> IO a -withNtfServer t = withNtfServerOn t ntfTestPort +withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a runNtfTest test = withNtfServer (transport @c) $ testNtfClient test diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index b2e868cc2..8af15aa59 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -13,6 +13,7 @@ module NtfServerTests where import Control.Concurrent (threadDelay) +import Control.Monad (void) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) @@ -113,9 +114,20 @@ testNotificationSubscription (ATransport t) createQueue = APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn let dhSecret = C.dh' ntfDh dhPriv - Right verification = ntfData .-> "verification" - Right nonce = C.cbNonce <$> ntfData .-> "nonce" - Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification + decryptCode nd = + let Right verification = nd .-> "verification" + Right nonce = C.cbNonce <$> nd .-> "nonce" + Right pt = C.cbDecrypt dhSecret nonce verification + in NtfRegCode pt + let code = decryptCode ntfData + -- test repeated request - should return the same token ID + RespNtf "1a" NoEntity (NRTknId tId1 ntfDh1) <- signSendRecvNtf nh tknKey ("1a", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) + tId1 `shouldBe` tId + ntfDh1 `shouldBe` ntfDh + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData1}} <- + getMockNotification apns tkn + let code1 = decryptCode ntfData1 + code `shouldBe` code1 RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code) RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK) -- ntf server subscribes to queue notifications diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 2903de05c..9fce42669 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -15,8 +15,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import NtfClient (ntfTestPort) -import SMPClient (proxyVRangeV8, testPort) +import SMPClient (proxyVRangeV8, ntfTestPort, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 07dc60723..97470703b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -45,7 +45,12 @@ import UnliftIO.Timeout (timeout) import Util #if defined(dbServerPostgres) -import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +import Database.PostgreSQL.Simple (defaultConnectInfo) +#endif + +#if defined(dbPostgres) || defined(dbServerPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..)) +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #endif testHost :: NonEmpty TransportHost @@ -60,6 +65,12 @@ testPort = "5001" testPort2 :: ServiceName testPort2 = "5002" +ntfTestPort :: ServiceName +ntfTestPort = "6001" + +ntfTestPort2 :: ServiceName +ntfTestPort2 = "6002" + testKeyHash :: C.KeyHash testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" @@ -381,3 +392,11 @@ smpTest4 _ msType test' = smpTestN msType 4 _test unexpected :: (HasCallStack, Show a) => a -> Expectation unexpected r = expectationFailure $ "unexpected response " <> show r + +#if defined(dbPostgres) || defined(dbServerPostgres) +postgressBracket :: ConnectInfo -> IO a -> IO a +postgressBracket connInfo = + E.bracket_ + (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) + (dropDatabaseAndUser connInfo) +#endif diff --git a/tests/Test.hs b/tests/Test.hs index 9ebdec8f7..653538faf 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -21,7 +21,6 @@ import CoreTests.VersionRangeTests import FileDescriptionTests (fileDescriptionTests) import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException -import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) import SMPProxyTests (smpProxyTests) import ServerTests @@ -43,13 +42,14 @@ import AgentTests.SchemaDump (schemaDumpTest) #endif #if defined(dbServerPostgres) +import NtfServerTests (ntfServerTests) +import NtfClient (ntfTestServerDBConnectInfo) import SMPClient (testServerDBConnectInfo) import ServerTests.SchemaDump #endif #if defined(dbPostgres) || defined(dbServerPostgres) -import Database.PostgreSQL.Simple (ConnectInfo (..)) -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) +import SMPClient (postgressBracket) #endif logCfg :: LogConfig @@ -57,6 +57,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do + -- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs" setLogLevel LogError -- LogInfo withGlobalLogging logCfg $ do setEnv "APNS_KEY_ID" "H82WD9K9AQ" @@ -95,7 +96,7 @@ main = do describe "Server schema dump" serverSchemaDumpTest aroundAll_ (postgressBracket testServerDBConnectInfo) $ describe "SMP server via TLS, postgres+jornal message store" $ - before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests + before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests #endif describe "SMP server via TLS, jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) @@ -105,8 +106,9 @@ main = do -- xdescribe "SMP server via WebSockets" $ do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests - describe "Notifications server" $ ntfServerTests (transport @TLS) #if defined(dbServerPostgres) + aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ do + describe "Notifications server" $ ntfServerTests (transport @TLS) aroundAll_ (postgressBracket testServerDBConnectInfo) $ do describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) describe "SMP proxy, postgres+jornal message store" $ @@ -132,11 +134,3 @@ eventuallyRemove path retries = case retries of _ -> E.throwIO ioe where action = removeDirectoryRecursive path - -#if defined(dbPostgres) || defined(dbServerPostgres) -postgressBracket :: ConnectInfo -> IO a -> IO a -postgressBracket connInfo = - E.bracket_ - (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) - (dropDatabaseAndUser connInfo) -#endif diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index f7e880083..bfb601465 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -454,7 +454,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do pure rfd1 -- prefix path should be removed after sending file - threadDelay 200000 + threadDelay 500000 doesDirectoryExist prefixPath `shouldReturn` False doesFileExist encPath `shouldReturn` False From 42dbb887f79776fd51b351f594e17d346389e3c2 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 25 Apr 2025 19:41:18 +0100 Subject: [PATCH 2/9] ntf server: allow retries when creating subscriptions, prohibit subscriptions with the same queue but another notifier key or token (#1525) * ntf server: allow retries when creating subscriptions, prohibit subscriptions with the same queue but another notifier key or token * sync files in the test * refactor --- src/Simplex/Messaging/Notifications/Server.hs | 104 ++++++++---------- .../Notifications/Server/Store/Postgres.hs | 63 +++++------ tests/AgentTests/NotificationTests.hs | 5 +- tests/NtfServerTests.hs | 52 ++++++++- tests/SMPClient.hs | 3 + 5 files changed, 132 insertions(+), 95 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index c1f1aa9ab..dae98d301 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -537,7 +537,8 @@ runNtfClientTransport th@THandle {params} = do s <- asks subscriber ps <- asks pushServer expCfg <- asks $ inactiveClientExpiration . config - raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg) + st <- asks store + raceAny_ ([liftIO $ send th c, client c s ps, liftIO $ receive st th c] <> disconnectThread_ c expCfg) `finally` liftIO (clientDisconnected c) where disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (pure True)] @@ -546,10 +547,10 @@ runNtfClientTransport th@THandle {params} = do clientDisconnected :: NtfServerClient -> IO () clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False -receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M () -receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do - ts <- L.toList <$> liftIO (tGet th) - atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime +receive :: Transport c => NtfPostgresStore -> THandleNTF c 'TServer -> NtfServerClient -> IO () +receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do + ts <- L.toList <$> tGet th + atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime (errs, cmds) <- partitionEithers <$> mapM cmdAction ts write sndQ errs write rcvQ cmds @@ -560,70 +561,60 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ logError $ "invalid client request: " <> tshow e pure $ Left (corrId, entId, NRErr e) Right cmd -> - verified =<< verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd + verified =<< verifyNtfTransmission st ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd where verified = \case VRVerified req -> pure $ Right req - VRFailed -> do + VRFailed e -> do logError "unauthorized client request" - pure $ Left (corrId, entId, NRErr AUTH) + pure $ Left (corrId, entId, NRErr e) write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO () send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do ts <- atomically $ readTBQueue sndQ - void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts - atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime + void $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts + atomically . (writeTVar sndActiveAt $!) =<< getSystemTime -data VerificationResult = VRVerified NtfRequest | VRFailed +data VerificationResult = VRVerified NtfRequest | VRFailed ErrorType -verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult -verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do - st <- asks store - case cmd of - -- TODO [ntfdb] this looks suspicious, as if it can prevent repeated registrations - NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do - r_ <- liftIO $ getNtfTokenRegistration st tkn - pure $ - if verifyCmdAuthorization auth_ tAuth authorized k - then case r_ of - Right t@NtfTknRec {tknVerifyKey} - -- keys will be the same because of condition in `getNtfTokenRegistration` - | k == tknVerifyKey -> VRVerified $ tknCmd t c - | otherwise -> VRFailed - Left _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) - else VRFailed - NtfCmd SToken c -> do - t_ <- liftIO $ getNtfToken st entId - verifyToken_' t_ (`tknCmd` c) - NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> - liftIO $ verify <$> findNtfSubscription st tknId smpQueue - where - verify = \case - Right (t, s_) -> verifyToken t $ case s_ of - Nothing -> NtfReqNew corrId (ANE SSubscription sub) - Just s -> subCmd s c - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId - NtfCmd SSubscription c -> liftIO $ verify <$> getNtfSubscription st entId - where - verify = \case - Right (t, s) -> verifyToken t $ subCmd s c - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed +verifyNtfTransmission :: NtfPostgresStore -> Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> IO VerificationResult +verifyNtfTransmission st auth_ (tAuth, authorized, (corrId, entId, _)) = \case + NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) + | verifyCmdAuthorization auth_ tAuth authorized k -> + result <$> findNtfTokenRegistration st tkn + | otherwise -> pure $ VRFailed AUTH + where + result = \case + Right (Just t@NtfTknRec {tknVerifyKey}) + -- keys will be the same because of condition in `findNtfTokenRegistration` + | k == tknVerifyKey -> VRVerified $ tknCmd t c + | otherwise -> VRFailed AUTH + Right Nothing -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) + Left e -> VRFailed e + NtfCmd SToken c -> either err verify <$> getNtfToken st entId + where + verify t = verifyToken t $ tknCmd t c + NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> + either err verify <$> findNtfSubscription st tknId smpQueue + where + verify (t, s_) = verifyToken t $ case s_ of + Nothing -> NtfReqNew corrId (ANE SSubscription sub) + Just s -> subCmd s c + NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId + NtfCmd SSubscription c -> either err verify <$> getNtfSubscription st entId + where + verify (t, s) = verifyToken t $ subCmd s c where tknCmd t c = NtfReqCmd SToken (NtfTkn t) (corrId, entId, c) subCmd s c = NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c) - verifyToken_' :: Either ErrorType NtfTknRec -> (NtfTknRec -> NtfRequest) -> M VerificationResult - verifyToken_' t_ result = pure $ case t_ of - Right t -> verifyToken t $ result t - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed verifyToken :: NtfTknRec -> NtfRequest -> VerificationResult verifyToken NtfTknRec {tknVerifyKey} r | verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey = VRVerified r - | otherwise = VRFailed + | otherwise = VRFailed AUTH + err = \case -- signature verification for AUTH errors mitigates timing attacks for existence checks + AUTH -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed AUTH + e -> VRFailed e client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} = @@ -669,9 +660,6 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu pure NROk | otherwise -> do logDebug "TVFY - incorrect code or token status" - liftIO $ print tkn - let NtfRegCode c = code - liftIO $ print $ B64.encode c pure $ NRErr AUTH TCHK -> do logDebug "TCHK" @@ -732,17 +720,15 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ writeTBQueue newSubQ (srv, [sub]) incNtfStat subCreated pure $ NRSubId subId - -- TODO [ntfdb] we must allow repeated inserts that don't change credentials False -> pure $ NRErr AUTH pure (corrId, NoEntity, resp) - NtfReqCmd SSubscription (NtfSub NtfSubRec {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do + NtfReqCmd SSubscription (NtfSub NtfSubRec {ntfSubId, smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do (corrId,subId,) <$> case cmd of SNEW (NewNtfSub _ _ notifierKey) -> do logDebug "SNEW - existing subscription" - -- possible improvement: retry if subscription failed, if pending or AUTH do nothing pure $ if notifierKey == registeredNKey - then NRSubId subId + then NRSubId ntfSubId else NRErr AUTH SCHK -> do logDebug "SCHK" diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index afe60e5b5..224aeaec7 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -145,18 +145,20 @@ ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, t in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) getNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType NtfTknRec) -getNtfToken st tknId = getNtfToken_ st " WHERE token_id = ?" (Only tknId) +getNtfToken st tknId = + (maybe (Left AUTH) Right =<<) <$> + getNtfToken_ st " WHERE token_id = ?" (Only tknId) -getNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType NtfTknRec) -getNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = +findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec)) +findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey) -getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType NtfTknRec) +getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec)) getNtfToken_ st cond params = - withDB "getNtfToken" st $ \db -> runExceptT $ do - tkn <- ExceptT $ firstRow rowToNtfTkn AUTH $ DB.query db (ntfTknQuery <> cond) params - liftIO $ updateTokenDate st db tkn - pure tkn + withDB' "getNtfToken" st $ \db -> do + tkn_ <- maybeFirstRow rowToNtfTkn $ DB.query db (ntfTknQuery <> cond) params + mapM_ (updateTokenDate st db) tkn_ + pure tkn_ updateTokenDate :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> IO () updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do @@ -269,26 +271,28 @@ foldNtfSubscriptions st srv fetchCount state action = toNtfSub (ntfSubId, tokenId, nId, subStatus, notifierKey) = NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf srv nId, subStatus, notifierKey} +-- Returns token and subscription. +-- If subscription exists but belongs to another token, returns Left AUTH findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec)) -findNtfSubscription st tknId q@(SMPQueueNtf srv nId) = +findNtfSubscription st tknId q = withDB "findNtfSubscription" st $ \db -> runExceptT $ do - r@(tkn@NtfTknRec {tknStatus}, _) <- - ExceptT $ firstRow (rowToNtfTknMaybeSub q) AUTH $ + tkn@NtfTknRec {ntfTknId, tknStatus} <- ExceptT $ getNtfToken st tknId + unless (allowNtfSubCommands tknStatus) $ throwE AUTH + liftIO $ updateTokenDate st db tkn + sub_ <- + liftIO $ maybeFirstRow (rowToNtfSub q) $ DB.query db [sql| - SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at, - s.subscription_id, s.smp_notifier_key, s.status - FROM tokens t - LEFT JOIN subscriptions s ON s.token_id = t.token_id AND s.smp_notifier_id = ? - LEFT JOIN smp_servers p ON p.smp_server_id = s.smp_server_id - AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? - WHERE t.token_id = ? - |] - (Only nId :. srvToRow srv :. Only tknId) - liftIO $ updateTokenDate st db tkn - unless (allowNtfSubCommands tknStatus) $ throwE AUTH - pure r + SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status + FROM subscriptions s + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? + AND s.smp_notifier_id = ? + |] + (smpQueueToRow q) + forM_ sub_ $ \NtfSubRec {tokenId} -> unless (ntfTknId == tokenId) $ throwE AUTH + pure (tkn, sub_) getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec)) getNtfSubscription st subId = @@ -313,22 +317,15 @@ getNtfSubscription st subId = type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus) -type MaybeNtfSubRow = (Maybe NtfSubscriptionId, Maybe NtfPrivateAuthKey, Maybe NtfSubStatus) - rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec) rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus) :. qRow) = let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow smpQueue = rowToSMPQueue qRow in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}) -rowToNtfTknMaybeSub :: SMPQueueNtf -> NtfTknRow :. MaybeNtfSubRow -> (NtfTknRec, Maybe NtfSubRec) -rowToNtfTknMaybeSub smpQueue (tknRow :. subRow) = - let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow - sub_ = case subRow of - (Just ntfSubId, Just notifierKey, Just subStatus) -> - Just NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} - _ -> Nothing - in (tkn, sub_) +rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec +rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus)) = + NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 64196cf3f..cefe1720b 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -79,6 +79,7 @@ import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfSer import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) +import System.Process (callCommand) import Test.Hspec import UnliftIO #if defined(dbPostgres) @@ -569,7 +570,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 closeDBStore store - threadDelay 1500000 + callCommand "sync" putStrLn "before opening the database from another agent" -- aliceNtf client doesn't have subscription and is allowed to get notification message @@ -577,7 +578,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId] pure () - threadDelay 1500000 + callCommand "sync" putStrLn "after closing the database in another agent" reopenDBStore store foregroundAgent alice diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 8af15aa59..3803e08fa 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -13,7 +13,6 @@ module NtfServerTests where import Control.Concurrent (threadDelay) -import Control.Monad (void) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) @@ -52,6 +51,7 @@ ntfServerTests t = do describe "Notifications server protocol syntax" $ ntfSyntaxTests t describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW + describe "Retried notification subscription" $ testRetriedNtfSubscription t ntfSyntaxTests :: ATransport -> Spec ntfSyntaxTests (ATransport t) = do @@ -179,6 +179,38 @@ testNotificationSubscription (ATransport t) createQueue = smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId +testRetriedNtfSubscription :: ATransport -> Spec +testRetriedNtfSubscription (ATransport t) = + it "should allow retrying to create notification subscription with the same token and key" $ do + g <- C.newRandom + (sPub, _sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + withAPNSMockServer $ \apns -> + smpTest' t $ \h -> + ntfTest t $ \nh -> do + ((_sId, _rId, _rKey, _rcvDhSecret), nId, _rcvNtfDhSecret) <- createNtfQueueNKEY h sPub nPub + (tknKey, _dhSecret, tId, regCode) <- registerToken nh apns "abcd" + let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash + q = SMPQueueNtf srv nId + -- fails creating subscription until token is verified + RespNtf "2" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("2", NoEntity, SNEW $ NewNtfSub tId q nKey) + -- verify token + RespNtf "3" tId1 NROk <- signSendRecvNtf nh tknKey ("3", tId, TVFY regCode) + tId1 `shouldBe` tId + -- create subscription + RespNtf "4" NoEntity (NRSubId subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey) + -- allow retry + RespNtf "4a" NoEntity (NRSubId subId') <- signSendRecvNtf nh tknKey ("4a", NoEntity, SNEW $ NewNtfSub tId q nKey) + subId' `shouldBe` subId + -- fail with another key + (_nPub, nKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g + RespNtf "5" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("5", NoEntity, SNEW $ NewNtfSub tId q nKey') + -- fail with another token + (tknKey', _dhSecret, tId', regCode') <- registerToken nh apns "efgh" + RespNtf "6" _ NROk <- signSendRecvNtf nh tknKey' ("6", tId', TVFY regCode') + RespNtf "7" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey' ("7", NoEntity, SNEW $ NewNtfSub tId' q nKey) + pure () + type CreateQueueFunc = forall c. Transport c => @@ -197,6 +229,24 @@ createNtfQueueNKEY h sPub nPub = do let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) +registerToken :: Transport c => THandleNTF c 'TClient -> APNSMockServer -> ByteString -> IO (C.APrivateAuthKey, C.DhSecretX25519, NtfEntityId, NtfRegCode) +registerToken nh apns token = do + g <- C.newRandom + (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let tkn = DeviceToken PPApnsTest token + RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn + let dhSecret = C.dh' ntfDh dhPriv + decryptCode nd = + let Right verification = nd .-> "verification" + Right nonce = C.cbNonce <$> nd .-> "nonce" + Right pt = C.cbDecrypt dhSecret nonce verification + in NtfRegCode pt + let code = decryptCode ntfData + pure (tknKey, dhSecret, tId, code) + -- TODO [notifications] -- createNtfQueueNEW :: CreateQueueFunc -- createNtfQueueNEW h sPub nPub = do diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 97470703b..801b7f42e 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -360,6 +360,9 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t > smpTest :: (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () +smpTest' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest' = (`smpTest` ASType SQSMemory SMSJournal) + smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` () From f4bc1f092684961fa21f425748024416009d06ba Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 26 Apr 2025 23:37:55 +0100 Subject: [PATCH 3/9] ntf server: skip duplicates when importing tokens and subscriptions (#1526) * ntf server: skip duplicates when importing tokens and subscriptions * skip imported last notifications when no token or subscription present * fix skipped imported notifications count * all tests * fix test --- src/Simplex/Messaging/Notifications/Server.hs | 2 - .../Notifications/Server/Store/Postgres.hs | 161 +++++++++++------- tests/AgentTests/NotificationTests.hs | 4 +- tests/CLITests.hs | 17 +- 4 files changed, 111 insertions(+), 73 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index dae98d301..a67d03b9d 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -79,8 +79,6 @@ import UnliftIO.STM import GHC.Conc (listThreads) #endif -import qualified Data.ByteString.Base64 as B64 - runNtfServer :: NtfServerConfig -> IO () runNtfServer cfg = do started <- newEmptyTMVarIO diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 224aeaec7..8a8c475ac 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -33,11 +33,11 @@ import Data.Containers.ListUtils (nubOrd) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (foldl', intercalate) +import Data.List (findIndex, foldl') import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -587,9 +587,10 @@ toLastNtf (qRow :. (ts, nonce, Binary encMeta)) = importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> IO (Int64, Int64, Int64) importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do - (tCnt, tIds) <- importTokens - sCnt <- importSubscriptions tIds - nCnt <- importLastNtfs + (tIds, tCnt) <- importTokens + subLookup <- readTVarIO $ subscriptionLookup stmStore + sCnt <- importSubscriptions tIds subLookup + nCnt <- importLastNtfs tIds subLookup pure (tCnt, sCnt, nCnt) where importTokens = do @@ -597,59 +598,65 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do tokens <- filterTokens allTokens let skipped = length allTokens - length tokens when (skipped /= 0) $ putStrLn $ "Total skipped tokens " <> show skipped - tCnt <- withConnection s $ \db -> foldM (insertToken db) 0 tokens - void $ checkCount "token" (length tokens) tCnt + -- uncomment this line instead of the next to import tokens one by one. + -- tCnt <- withConnection s $ \db -> foldM (importTkn db) 0 tokens + tRows <- mapM (fmap ntfTknToRow . mkTknRec) tokens + tCnt <- withConnection s $ \db -> DB.executeMany db insertNtfTknQuery tRows let tokenIds = S.fromList $ map (\NtfTknData {ntfTknId} -> ntfTknId) tokens - pure (tCnt, tokenIds) + (tokenIds,) <$> checkCount "token" (length tokens) tCnt where filterTokens tokens = do let deviceTokens = foldl' (\m t -> M.alter (Just . (t :) . fromMaybe []) (tokenKey t) m) M.empty tokens tokenSubs <- readTVarIO (tokenSubscriptions stmStore) filterM (keepTokenRegistration deviceTokens tokenSubs) tokens tokenKey NtfTknData {token, tknVerifyKey} = strEncode token <> ":" <> C.toPubKey C.pubKeyBytes tknVerifyKey - keepTokenRegistration deviceTokens tokenSubs tkn@NtfTknData {ntfTknId, token, tknStatus} = + keepTokenRegistration deviceTokens tokenSubs tkn@NtfTknData {ntfTknId, tknStatus} = case M.lookup (tokenKey tkn) deviceTokens of Just ts - | length ts >= 2 -> + | length ts < 2 -> pure True + | otherwise -> readTVarIO tknStatus >>= \case NTConfirmed -> do - anyActive <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> (NTActive ==) <$> readTVarIO tknStatus') ts - noSubs <- S.null <$> maybe (pure S.empty) readTVarIO (M.lookup ntfTknId tokenSubs) - if anyActive - then ( - if noSubs - then False <$ putStrLn ("Skipped inactive token " <> enc ntfTknId <> " (no subscriptions)") - else pure True - ) + hasSubs <- maybe (pure False) (\v -> not . S.null <$> readTVarIO v) $ M.lookup ntfTknId tokenSubs + if hasSubs + then pure True else do - let noSubsStr = if noSubs then " no subscriptions" else " has subscriptions" - putStrLn $ "Error: more than one registration for token " <> enc ntfTknId <> " " <> show token <> noSubsStr - pure True + anyActive <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> (NTActive ==) <$> readTVarIO tknStatus') ts + if anyActive + then False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId) + else case findIndex (\NtfTknData {ntfTknId = tId} -> tId == ntfTknId) ts of + Just 0 -> pure True -- keeping the first token + Just _ -> False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId <> " (no active token)") + Nothing -> True <$ putStrLn "Error: no device token in the list" _ -> pure True - | otherwise -> pure True Nothing -> True <$ putStrLn "Error: no device token in lookup map" - insertToken db !n tkn@NtfTknData {ntfTknId} = do - tknRow <- ntfTknToRow <$> mkTknRec tkn - (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) -> - putStrLn ("Error inserting token " <> enc ntfTknId <> " " <> show e) $> n - importSubscriptions tIds = do - allSubs <- M.elems <$> readTVarIO (subscriptions stmStore) - let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs - skipped = length allSubs - length subs - when (skipped /= 0) $ putStrLn $ "Skipped subscriptions (no tokens) " <> show skipped + -- importTkn db !n tkn@NtfTknData {ntfTknId} = do + -- tknRow <- ntfTknToRow <$> mkTknRec tkn + -- (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) -> + -- putStrLn ("Error inserting token " <> enc ntfTknId <> " " <> show e) $> n + importSubscriptions :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64 + importSubscriptions tIds subLookup = do + subs <- filterSubs . M.elems =<< readTVarIO (subscriptions stmStore) srvIds <- importServers subs putStrLn $ "Importing " <> show (length subs) <> " subscriptions..." - -- uncomment this line instead of the next 2 lines to import subs one by one. - (sCnt, missingTkns) <- withConnection s $ \db -> foldM (importSub db srvIds) (0, M.empty) subs - -- sCnt <- foldM (importSubs srvIds) 0 $ toChunks 100000 subs - -- let missingTkns = M.empty - putStrLn $ "Imported " <> show sCnt <> " subscriptions" - unless (M.null missingTkns) $ do - putStrLn $ show (M.size missingTkns) <> " missing tokens:" - forM_ (M.assocs missingTkns) $ \(tId, sIds) -> - putStrLn $ "Token " <> enc tId <> " " <> show (length sIds) <> " subscriptions: " <> intercalate ", " (map enc sIds) + -- uncomment this line instead of the next to import subs one by one. + -- (sCnt, errTkns) <- withConnection s $ \db -> foldM (importSub db srvIds) (0, M.empty) subs + sCnt <- foldM (importSubs srvIds) 0 $ toChunks 500000 subs checkCount "subscription" (length subs) sCnt where + filterSubs allSubs = do + let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs + skipped = length allSubs - length subs + when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens" + let (removedSubTokens, removeSubs, dupQueues) = foldl' addSubToken (S.empty, S.empty, S.empty) subs + unless (null removeSubs) $ putStrLn $ "Skipped " <> show (S.size removeSubs) <> " duplicate subscriptions of " <> show (S.size removedSubTokens) <> " tokens for " <> show (S.size dupQueues) <> " queues" + pure $ filter (\NtfSubData {ntfSubId} -> S.notMember ntfSubId removeSubs) subs + where + addSubToken acc@(!stIds, !sIds, !qs) NtfSubData {ntfSubId, smpQueue, tokenId} = + case M.lookup smpQueue subLookup of + Just sId | sId /= ntfSubId -> + (S.insert tokenId stIds, S.insert ntfSubId sIds, S.insert smpQueue qs) + _ -> acc importSubs srvIds !n subs = do rows <- mapM (ntfSubRow srvIds) subs cnt <- withConnection s $ \db -> DB.executeMany db insertNtfSubQuery $ L.toList rows @@ -657,19 +664,19 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do putStr $ "Imported " <> show n' <> " subscriptions" <> "\r" hFlush stdout pure n' - importSub db srvIds (!n, !missingTkns) sub@NtfSubData {ntfSubId = sId, tokenId} = do - subRow <- ntfSubRow srvIds sub - E.try (DB.execute db insertNtfSubQuery subRow) >>= \case - Right i -> do - let n' = n + i - when (n' `mod` 100000 == 0) $ do - putStr $ "Imported " <> show n' <> " subscriptions" <> "\r" - hFlush stdout - pure (n', missingTkns) - Left (e :: E.SomeException) -> do - when (n `mod` 100000 == 0) $ putStrLn "" - putStrLn $ "Error inserting subscription " <> enc sId <> " for token " <> enc tokenId <> " " <> show e - pure (n, M.alter (Just . (sId :) . fromMaybe []) tokenId missingTkns) + -- importSub db srvIds (!n, !errTkns) sub@NtfSubData {ntfSubId = sId, tokenId} = do + -- subRow <- ntfSubRow srvIds sub + -- E.try (DB.execute db insertNtfSubQuery subRow) >>= \case + -- Right i -> do + -- let n' = n + i + -- when (n' `mod` 100000 == 0) $ do + -- putStr $ "Imported " <> show n' <> " subscriptions" <> "\r" + -- hFlush stdout + -- pure (n', errTkns) + -- Left (e :: E.SomeException) -> do + -- when (n `mod` 100000 == 0) $ putStrLn "" + -- putStrLn $ "Error inserting subscription " <> enc sId <> " for token " <> enc tokenId <> " " <> show e + -- pure (n, M.alter (Just . maybe [sId] (sId :)) tokenId errTkns) ntfSubRow srvIds sub = case M.lookup srv srvIds of Just sId -> ntfSubToRow sId <$> mkSubRec sub Nothing -> E.throwIO $ userError $ "no matching server ID for server " <> show srv @@ -682,19 +689,32 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do where srvQuery = "INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?) RETURNING smp_server_id" srvs = nubOrd $ map ntfSubServer subs - importLastNtfs = do - subLookup <- readTVarIO $ subscriptionLookup stmStore - ntfRows <- fmap concat . mapM (lastNtfRows subLookup) . M.assocs =<< readTVarIO (tokenLastNtfs stmStore) + importLastNtfs :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64 + importLastNtfs tIds subLookup = do + ntfs <- readTVarIO (tokenLastNtfs stmStore) + ntfRows <- filterLastNtfRows ntfs nCnt <- withConnection s $ \db -> DB.executeMany db lastNtfQuery ntfRows checkCount "last notification" (length ntfRows) nCnt where lastNtfQuery = "INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data) VALUES (?,?,?,?,?)" - lastNtfRows :: M.Map SMPQueueNtf NtfSubscriptionId -> (NtfTokenId, TVar (NonEmpty PNMessageData)) -> IO [(NtfTokenId, NtfSubscriptionId, SystemTime, C.CbNonce, Binary ByteString)] - lastNtfRows subLookup (tId, ntfs) = fmap catMaybes . mapM ntfRow . L.toList =<< readTVarIO ntfs + filterLastNtfRows ntfs = do + (skippedTkns, ntfCnt, (skippedQueues, ntfRows)) <- foldM lastNtfRows (S.empty, 0, (S.empty, [])) $ M.assocs ntfs + let skipped = ntfCnt - length ntfRows + when (skipped /= 0) $ putStrLn $ "Skipped last notifications " <> show skipped <> " for " <> show (S.size skippedTkns) <> " missing tokens and " <> show (S.size skippedQueues) <> " missing subscriptions with token present" + pure ntfRows + lastNtfRows (!stIds, !cnt, !acc) (tId, ntfVar) = do + ntfs <- L.toList <$> readTVarIO ntfVar + let cnt' = cnt + length ntfs + pure $ + if S.member tId tIds + then (stIds, cnt', foldl' ntfRow acc ntfs) + else (S.insert tId stIds, cnt', acc) where - ntfRow PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of - Just ntfSubId -> pure $ Just (tId, ntfSubId, ntfTs, nmsgNonce, Binary encNMsgMeta) - Nothing -> Nothing <$ putStrLn ("Error: no subscription " <> show smpQueue <> " for notification of token " <> enc tId) + ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of + Just ntfSubId -> + let row = (tId, ntfSubId, ntfTs, nmsgNonce, Binary encNMsgMeta) + in (qs, row : rows) + Nothing -> (S.insert smpQueue qs, rows) checkCount name expected inserted | fromIntegral expected == inserted = do putStrLn $ "Imported " <> show inserted <> " " <> name <> "s." @@ -711,12 +731,21 @@ exportNtfDbStore NtfPostgresStore {dbStoreLog = Nothing} _ = exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFile = (,,) <$> exportTokens <*> exportSubscriptions <*> exportLastNtfs where - exportTokens = - withConnection s $ \db -> DB.fold_ db ntfTknQuery 0 $ \ !i tkn -> + exportTokens = do + tCnt <- withConnection s $ \db -> DB.fold_ db ntfTknQuery 0 $ \ !i tkn -> logCreateToken sl (rowToNtfTkn tkn) $> (i + 1) - exportSubscriptions = - withConnection s $ \db -> DB.fold_ db ntfSubQuery 0 $ \ !i sub -> - logCreateSubscription sl (toNtfSub sub) $> (i + 1) + putStrLn $ "Exported " <> show tCnt <> " tokens" + pure tCnt + exportSubscriptions = do + sCnt <- withConnection s $ \db -> DB.fold_ db ntfSubQuery 0 $ \ !i sub -> do + let i' = i + 1 + logCreateSubscription sl (toNtfSub sub) + when (i' `mod` 500000 == 0) $ do + putStr $ "Exported " <> show i' <> " subscriptions" <> "\r" + hFlush stdout + pure i' + putStrLn $ "Exported " <> show sCnt <> " subscriptions" + pure sCnt where ntfSubQuery = [sql| diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index cefe1720b..ce69e5c11 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -570,7 +570,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 closeDBStore store - callCommand "sync" + threadDelay 500000 >> callCommand "sync" >> threadDelay 500000 putStrLn "before opening the database from another agent" -- aliceNtf client doesn't have subscription and is allowed to get notification message @@ -578,7 +578,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId] pure () - callCommand "sync" + threadDelay 500000 >> callCommand "sync" >> threadDelay 500000 putStrLn "after closing the database in another agent" reopenDBStore store foregroundAgent alice diff --git a/tests/CLITests.hs b/tests/CLITests.hs index e5fb784ee..51d5d6c68 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module CLITests where @@ -8,6 +9,7 @@ import AgentTests.FunctionalAPITests (runRight_) import Control.Logger.Simple import Control.Monad import qualified Crypto.PubKey.RSA as RSA +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HM import Data.Ini (Ini (..), lookupValue, readIniFile, writeIniFile) @@ -41,8 +43,11 @@ import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (bracket) #if defined(dbServerPostgres) -import NtfClient (ntfTestServerDBConnectInfo) +import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.Types (Query (..)) +import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts) import SMPClient (postgressBracket) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Notifications.Server.Main #endif @@ -77,7 +82,7 @@ cliTests = do it "with store log, no password" $ smpServerTest True False it "static files" smpServerTestStatic #if defined(dbServerPostgres) - aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ + around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestStoreDBOpts) $ describe "Ntf server CLI" $ do it "should initialize, start and delete the server (no store log)" $ ntfServerTest False it "should initialize, start and delete the server (with store log)" $ ntfServerTest True @@ -192,9 +197,15 @@ smpServerTestStatic = do in map (X.signedObject . X.getSigned) cc #if defined(dbServerPostgres) +createNtfSchema :: PSQL.ConnectInfo -> DBOpts -> IO () +createNtfSchema connInfo DBOpts {schema} = do + db <- PSQL.connect connInfo + void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema + PSQL.close db + ntfServerTest :: Bool -> IO () ntfServerTest storeLog = do - capture_ (withArgs (["init"] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) + capture_ (withArgs (["init", "--database=" <> B.unpack ntfTestServerDBConnstr] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`)) Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini" lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") From f024ab1c3f2e749bf86c253bd6dc92c1238e414a Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 27 Apr 2025 13:25:44 +0100 Subject: [PATCH 4/9] ntf server: prometheus metrics (#1527) * ntf server: save prometheus stats * info metrics * fix test --- simplexmq.cabal | 1 + src/Simplex/Messaging/Notifications/Server.hs | 179 +++++++++---- .../Messaging/Notifications/Server/Env.hs | 3 + .../Messaging/Notifications/Server/Main.hs | 4 +- .../Notifications/Server/Prometheus.hs | 251 ++++++++++++++++++ .../Notifications/Server/Store/Postgres.hs | 11 + src/Simplex/Messaging/Server.hs | 10 +- src/Simplex/Messaging/Server/Prometheus.hs | 15 +- tests/AgentTests/NotificationTests.hs | 4 +- tests/NtfClient.hs | 5 + 10 files changed, 421 insertions(+), 62 deletions(-) create mode 100644 src/Simplex/Messaging/Notifications/Server/Prometheus.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 43eb6b31c..e3e1e61e7 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -252,6 +252,7 @@ library Simplex.Messaging.Notifications.Server.Control Simplex.Messaging.Notifications.Server.Env Simplex.Messaging.Notifications.Server.Main + Simplex.Messaging.Notifications.Server.Prometheus Simplex.Messaging.Notifications.Server.Push.APNS Simplex.Messaging.Notifications.Server.Push.APNS.Internal Simplex.Messaging.Notifications.Server.Stats diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index a67d03b9d..55ab37885 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -12,9 +12,11 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Notifications.Server where +import Control.Concurrent (threadDelay) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -27,13 +29,15 @@ import Data.Functor (($>)) import Data.IORef import Data.Int (Int64) import qualified Data.IntSet as IS -import Data.List (intercalate, partition, sort) +import Data.List (foldl', intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) import qualified Data.Set as S +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (getSystemTime) @@ -48,6 +52,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Control import Simplex.Messaging.Notifications.Server.Env +import Simplex.Messaging.Notifications.Server.Prometheus import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..)) import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf) @@ -60,13 +65,14 @@ import Simplex.Messaging.Server import Simplex.Messaging.Server.Control (CPClientRole (..)) import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.QueueStore (getSystemDate) -import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats) +import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer) import Simplex.Messaging.Util +import System.Environment (lookupEnv) import System.Exit (exitFailure, exitSuccess) import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) @@ -99,7 +105,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} stopServer liftIO $ exitSuccess resubscribe s - raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer + raceAny_ + ( ntfSubscriber s + : ntfPush ps + : map runServer transports + <> serverStatsThread_ cfg + <> prometheusMetricsThread_ cfg + <> controlPortThread_ cfg + ) + `finally` stopServer where runServer :: (ServiceName, ATransport, AddHTTP) -> M () runServer (tcpPort, ATransport t, _addHTTP) = do @@ -193,6 +207,90 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} ] liftIO $ threadDelay' interval + prometheusMetricsThread_ :: NtfServerConfig -> [M ()] + prometheusMetricsThread_ NtfServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} = + [savePrometheusMetrics interval prometheusMetricsFile] + prometheusMetricsThread_ _ = [] + + savePrometheusMetrics :: Int -> FilePath -> M () + savePrometheusMetrics saveInterval metricsFile = do + labelMyThread "savePrometheusMetrics" + liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile + st <- asks store + ss <- asks serverStats + env <- ask + rtsOpts <- liftIO $ maybe ("set " <> rtsOptionsEnv) T.pack <$> lookupEnv (T.unpack rtsOptionsEnv) + let interval = 1000000 * saveInterval + liftIO $ forever $ do + threadDelay interval + ts <- getCurrentTime + sm <- getNtfServerMetrics st ss rtsOpts + rtm <- getNtfRealTimeMetrics env + T.writeFile metricsFile $ ntfPrometheusMetrics sm rtm ts + + getNtfServerMetrics :: NtfPostgresStore -> NtfServerStats -> Text -> IO NtfServerMetrics + getNtfServerMetrics st ss rtsOptions = do + d <- getNtfServerStatsData ss + let psTkns = periodStatDataCounts $ _activeTokens d + psSubs = periodStatDataCounts $ _activeSubs d + (tokenCount, approxSubCount, lastNtfCount) <- getEntityCounts st + pure NtfServerMetrics {statsData = d, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} + + getNtfRealTimeMetrics :: NtfEnv -> IO NtfRealTimeMetrics + getNtfRealTimeMetrics NtfEnv {subscriber, pushServer} = do +#if MIN_VERSION_base(4,18,0) + threadsCount <- length <$> listThreads +#else + let threadsCount = 0 +#endif + let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber + NtfPushServer {pushQ} = pushServer + SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a + srvSubscribers <- getSMPWorkerMetrics a smpSubscribers + srvClients <- getSMPWorkerMetrics a smpClients + srvSubWorkers <- getSMPWorkerMetrics a smpSubWorkers + ntfActiveSubs <- getSMPSubMetrics a srvSubs + ntfPendingSubs <- getSMPSubMetrics a pendingSrvSubs + smpSessionCount <- M.size <$> readTVarIO smpSessions + apnsPushQLength <- fromIntegral <$> atomically (lengthTBQueue pushQ) + pure NtfRealTimeMetrics {threadsCount, srvSubscribers, srvClients, srvSubWorkers, ntfActiveSubs, ntfPendingSubs, smpSessionCount, apnsPushQLength} + where + getSMPSubMetrics :: SMPClientAgent -> TMap SMPServer (TMap SMPSub a) -> IO NtfSMPSubMetrics + getSMPSubMetrics a v = do + subs <- readTVarIO v + let metrics = NtfSMPSubMetrics {ownSrvSubs = M.empty, otherServers = 0, otherSrvSubCount = 0} + (metrics', otherSrvs) <- foldM countSubs (metrics, S.empty) $ M.assocs subs + pure (metrics' :: NtfSMPSubMetrics) {otherServers = S.size otherSrvs} + where + countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TMap SMPSub a) -> IO (NtfSMPSubMetrics, S.Set Text) + countSubs acc@(metrics, !otherSrvs) (srv@(SMPServer (h :| _) _ _), srvSubs) = + result . M.size <$> readTVarIO srvSubs + where + result 0 = acc + result cnt + | isOwnServer a srv = + let !ownSrvSubs' = M.alter (Just . maybe cnt (+ cnt)) host ownSrvSubs + metrics' = metrics {ownSrvSubs = ownSrvSubs'} :: NtfSMPSubMetrics + in (metrics', otherSrvs) + | otherwise = + let metrics' = metrics {otherSrvSubCount = otherSrvSubCount + cnt} :: NtfSMPSubMetrics + in (metrics', S.insert host otherSrvs) + NtfSMPSubMetrics {ownSrvSubs, otherSrvSubCount} = metrics + host = safeDecodeUtf8 $ strEncode h + + getSMPWorkerMetrics :: SMPClientAgent -> TMap SMPServer a -> IO NtfSMPWorkerMetrics + getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> readTVarIO v + workerMetrics :: SMPClientAgent -> [SMPServer] -> NtfSMPWorkerMetrics + workerMetrics a srvs = NtfSMPWorkerMetrics {ownServers = reverse ownSrvs, otherServers} + where + (ownSrvs, otherServers) = foldl' countSrv ([], 0) srvs + countSrv (!own, !other) srv@(SMPServer (h :| _) _ _) + | isOwnServer a srv = (host : own, other) + | otherwise = (own, other + 1) + where + host = safeDecodeUtf8 $ strEncode h + + controlPortThread_ :: NtfServerConfig -> [M ()] controlPortThread_ NtfServerConfig {controlPort = Just port} = [runCPServer port] controlPortThread_ _ = [] @@ -266,59 +364,38 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} logError "Unauthorized control port command" hPutStrLn h "AUTH" r -> do + NtfRealTimeMetrics {threadsCount, srvSubscribers, srvClients, srvSubWorkers, ntfActiveSubs, ntfPendingSubs, smpSessionCount, apnsPushQLength} <- + getNtfRealTimeMetrics =<< unliftIO u ask #if MIN_VERSION_base(4,18,0) - threads <- liftIO listThreads - hPutStrLn h $ "Threads: " <> show (length threads) + hPutStrLn h $ "Threads: " <> show threadsCount #else hPutStrLn h "Threads: not available on GHC 8.10" #endif - NtfEnv {subscriber, pushServer} <- unliftIO u ask - let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber - NtfPushServer {pushQ} = pushServer - SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a - putSMPWorkers a "SMP subcscribers" smpSubscribers - putSMPWorkers a "SMP clients" smpClients - putSMPWorkers a "SMP subscription workers" smpSubWorkers - sessions <- readTVarIO smpSessions - hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions) - putSMPSubs a "SMP subscriptions" srvSubs - putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs - sz <- atomically $ lengthTBQueue pushQ - hPutStrLn h $ "Push notifications queue length: " <> show sz + putSMPWorkers "SMP subcscribers" srvSubscribers + putSMPWorkers "SMP clients" srvClients + putSMPWorkers "SMP subscription workers" srvSubWorkers + hPutStrLn h $ "SMP sessions count: " <> show smpSessionCount + putSMPSubs "SMP subscriptions" ntfActiveSubs + putSMPSubs "Pending SMP subscriptions" ntfPendingSubs + hPutStrLn h $ "Push notifications queue length: " <> show apnsPushQLength where - putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO () - putSMPSubs a name v = do - subs <- readTVarIO v - (totalCnt, ownCount, otherCnt, servers, ownByServer) <- foldM countSubs (0, 0, 0, [], M.empty) $ M.assocs subs - showServers a name servers - hPutStrLn h $ name <> " total: " <> show totalCnt - hPutStrLn h $ name <> " on own servers: " <> show ownCount - when (r == CPRAdmin && not (null ownByServer)) $ - forM_ (M.assocs ownByServer) $ \(SMPServer (host :| _) _ _, cnt) -> - hPutStrLn h $ name <> " on " <> B.unpack (strEncode host) <> ": " <> show cnt - hPutStrLn h $ name <> " on other servers: " <> show otherCnt - where - countSubs :: (Int, Int, Int, [SMPServer], M.Map SMPServer Int) -> (SMPServer, TMap SMPSub a) -> IO (Int, Int, Int, [SMPServer], M.Map SMPServer Int) - countSubs (!totalCnt, !ownCount, !otherCnt, !servers, !ownByServer) (srv, srvSubs) = do - cnt <- M.size <$> readTVarIO srvSubs - let totalCnt' = totalCnt + cnt - ownServer = isOwnServer a srv - (ownCount', otherCnt') - | ownServer = (ownCount + cnt, otherCnt) - | otherwise = (ownCount, otherCnt + cnt) - servers' = if cnt > 0 then srv : servers else servers - ownByServer' - | r == CPRAdmin && ownServer && cnt > 0 = M.alter (Just . maybe cnt (+ cnt)) srv ownByServer - | otherwise = ownByServer - pure (totalCnt', ownCount', otherCnt', servers', ownByServer') - putSMPWorkers :: SMPClientAgent -> String -> TMap SMPServer a -> IO () - putSMPWorkers a name v = readTVarIO v >>= showServers a name . M.keys - showServers :: SMPClientAgent -> String -> [SMPServer] -> IO () - showServers a name srvs = do - let (ownSrvs, otherSrvs) = partition (isOwnServer a) srvs - hPutStrLn h $ name <> " own servers count: " <> show (length ownSrvs) - when (r == CPRAdmin) $ hPutStrLn h $ name <> " own servers: " <> intercalate "," (sort $ map (\(SMPServer (host :| _) _ _) -> B.unpack $ strEncode host) ownSrvs) - hPutStrLn h $ name <> " other servers count: " <> show (length otherSrvs) + putSMPSubs :: Text -> NtfSMPSubMetrics -> IO () + putSMPSubs name NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} = do + showServers name (M.keys ownSrvSubs) otherServers + let ownSrvSubCount = M.foldl' (+) 0 ownSrvSubs + T.hPutStrLn h $ name <> " total: " <> tshow (ownSrvSubCount + otherSrvSubCount) + T.hPutStrLn h $ name <> " on own servers: " <> tshow ownSrvSubCount + when (r == CPRAdmin && not (M.null ownSrvSubs)) $ + forM_ (M.assocs ownSrvSubs) $ \(host, cnt) -> + T.hPutStrLn h $ name <> " on " <> host <> ": " <> tshow cnt + T.hPutStrLn h $ name <> " on other servers: " <> tshow otherSrvSubCount + putSMPWorkers :: Text -> NtfSMPWorkerMetrics -> IO () + putSMPWorkers name NtfSMPWorkerMetrics {ownServers, otherServers} = showServers name ownServers otherServers + showServers :: Text -> [Text] -> Int -> IO () + showServers name ownServers otherServers = do + T.hPutStrLn h $ name <> " own servers count: " <> tshow (length ownServers) + when (r == CPRAdmin) $ T.hPutStrLn h $ name <> " own servers: " <> T.intercalate "," ownServers + T.hPutStrLn h $ name <> " other servers count: " <> tshow otherServers CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit" CPQuit -> pure () CPSkip -> pure () diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 46f3e9f2d..6488cbb11 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -59,6 +59,9 @@ data NtfServerConfig = NtfServerConfig logStatsStartTime :: Int64, serverStatsLogFile :: FilePath, serverStatsBackupFile :: Maybe FilePath, + -- | interval and file to save prometheus metrics + prometheusInterval :: Maybe Int, + prometheusMetricsFile :: FilePath, ntfServerVRange :: VersionRangeNTF, transportConfig :: TransportServerConfig, startOptions :: StartOptions diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index aa0e036ba..be3210be1 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -44,7 +44,7 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog) import Simplex.Messaging.Transport (ATransport, simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) -import Simplex.Messaging.Util (ifM, tshow) +import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) import System.Exit (exitFailure) import System.FilePath (combine) @@ -267,6 +267,8 @@ ntfServerCLI cfgPath logPath = logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log", + prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini, + prometheusMetricsFile = combine logPath "ntf-server-metrics.txt", ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig diff --git a/src/Simplex/Messaging/Notifications/Server/Prometheus.hs b/src/Simplex/Messaging/Notifications/Server/Prometheus.hs new file mode 100644 index 000000000..a3399c27f --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Prometheus.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} + +module Simplex.Messaging.Notifications.Server.Prometheus where + +import Data.Int (Int64) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..), diffUTCTime) +import Data.Time.Clock.System (systemEpochDay) +import Data.Time.Format.ISO8601 (iso8601Show) +import Simplex.Messaging.Notifications.Server.Stats +import Simplex.Messaging.Server.Stats (PeriodStatCounts (..)) +import Simplex.Messaging.Transport (simplexMQVersion) + +data NtfServerMetrics = NtfServerMetrics + { statsData :: NtfServerStatsData, + activeTokensCounts :: PeriodStatCounts, + activeSubsCounts :: PeriodStatCounts, + tokenCount :: Int64, + approxSubCount :: Int64, + lastNtfCount :: Int64, + rtsOptions :: Text + } + +rtsOptionsEnv :: Text +rtsOptionsEnv = "NTF_RTS_OPTIONS" + +data NtfRealTimeMetrics = NtfRealTimeMetrics + { threadsCount :: Int, + srvSubscribers :: NtfSMPWorkerMetrics, -- smpSubscribers + srvClients :: NtfSMPWorkerMetrics, -- smpClients + srvSubWorkers :: NtfSMPWorkerMetrics, -- smpSubWorkers + ntfActiveSubs :: NtfSMPSubMetrics, -- srvSubs + ntfPendingSubs :: NtfSMPSubMetrics, -- pendingSrvSubs + smpSessionCount :: Int, -- smpSessions + apnsPushQLength :: Int -- lengthTBQueue pushQ + } + +data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int} + +data NtfSMPSubMetrics = NtfSMPSubMetrics {ownSrvSubs :: M.Map Text Int, otherServers :: Int, otherSrvSubCount :: Int} + +{-# FOURMOLU_DISABLE\n#-} +ntfPrometheusMetrics :: NtfServerMetrics -> NtfRealTimeMetrics -> UTCTime -> Text +ntfPrometheusMetrics sm rtm ts = + time <> tokens <> subscriptions <> notifications <> info + where + NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm + NtfRealTimeMetrics + { threadsCount, + srvSubscribers, + srvClients, + srvSubWorkers, + ntfActiveSubs, + ntfPendingSubs, + smpSessionCount, + apnsPushQLength + } = rtm + NtfServerStatsData + { _fromTime, + _tknCreated, + _tknVerified, + _tknDeleted, + _tknReplaced, + _subCreated, + _subDeleted, + _ntfReceived, + _ntfDelivered, + _ntfFailed, + _ntfCronDelivered, + _ntfCronFailed, + _ntfVrfQueued, + _ntfVrfDelivered, + _ntfVrfFailed, + _ntfVrfInvalidTkn + } = statsData + time = + "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\ + \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\ + \\n" + tokens = + "# Tokens\n\ + \# ------\n\ + \\n\ + \# HELP simplex_ntf_tokens_created Created tokens\n\ + \# TYPE simplex_ntf_tokens_created counter\n\ + \simplex_ntf_tokens_created " <> mshow _tknCreated <> "\n# tknCreated\n\ + \\n\ + \# HELP simplex_ntf_tokens_verified Verified tokens\n\ + \# TYPE simplex_ntf_tokens_verified counter\n\ + \simplex_ntf_tokens_verified " <> mshow _tknVerified <> "\n# tknVerified\n\ + \\n\ + \# HELP simplex_ntf_tokens_deleted Deleted tokens\n\ + \# TYPE simplex_ntf_tokens_deleted counter\n\ + \simplex_ntf_tokens_deleted " <> mshow _tknDeleted <> "\n# tknDeleted\n\ + \\n\ + \# HELP simplex_ntf_tokens_replaced Deleted tokens\n\ + \# TYPE simplex_ntf_tokens_replaced counter\n\ + \simplex_ntf_tokens_replaced " <> mshow _tknReplaced <> "\n# tknReplaced\n\ + \\n\ + \# HELP simplex_ntf_tokens_count_daily Daily active tokens\n\ + \# TYPE simplex_ntf_tokens_count_daily gauge\n\ + \simplex_ntf_tokens_count_daily " <> mstr (dayCount psTkns) <> "\n# dayCountTkn\n\ + \\n\ + \# HELP simplex_ntf_tokens_count_weekly Weekly active tokens\n\ + \# TYPE simplex_ntf_tokens_count_weekly gauge\n\ + \simplex_ntf_tokens_count_weekly " <> mstr (weekCount psTkns) <> "\n# weekCountTkn\n\ + \\n\ + \# HELP simplex_ntf_tokens_count_monthly Monthly active tokens\n\ + \# TYPE simplex_ntf_tokens_count_monthly gauge\n\ + \simplex_ntf_tokens_count_monthly " <> mstr (monthCount psTkns) <> "\n# monthCountTkn\n\ + \\n\ + \# HELP simplex_ntf_tokens_total Total number of tokens stored.\n\ + \# TYPE simplex_ntf_tokens_total gauge\n\ + \simplex_ntf_tokens_total " <> mshow tokenCount <> "\n# tokenCount\n\ + \\n" + subscriptions = + "# Subscriptions\n\ + \# -------------\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_created Created subscriptions\n\ + \# TYPE simplex_ntf_subscriptions_created counter\n\ + \simplex_ntf_subscriptions_created " <> mshow _subCreated <> "\n# subCreated\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_deleted Deleted subscriptions\n\ + \# TYPE simplex_ntf_subscriptions_deleted counter\n\ + \simplex_ntf_subscriptions_deleted " <> mshow _subDeleted <> "\n# subDeleted\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_count_daily Daily subscriptions count\n\ + \# TYPE simplex_ntf_subscriptions_count_daily gauge\n\ + \simplex_ntf_subscriptions_count_daily " <> mstr (dayCount psSubs) <> "\n# dayCountSub\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_count_weekly Weekly subscriptions count\n\ + \# TYPE simplex_ntf_subscriptions_count_weekly gauge\n\ + \simplex_ntf_subscriptions_count_weekly " <> mstr (weekCount psSubs) <> "\n# weekCountSub\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_count_monthly Monthly subscriptions count\n\ + \# TYPE simplex_ntf_subscriptions_count_monthly gauge\n\ + \simplex_ntf_subscriptions_count_monthly " <> mstr (monthCount psSubs) <> "\n# monthCountSub\n\ + \\n\ + \# HELP simplex_ntf_subscriptions_approx_total Approximate total number of subscriptions stored.\n\ + \# TYPE simplex_ntf_subscriptions_approx_total gauge\n\ + \simplex_ntf_subscriptions_approx_total " <> mshow approxSubCount <> "\n# approxSubCount\n\ + \\n" + <> showSubMetric ntfActiveSubs "simplex_ntf_smp_subscription_active_" "Active" + <> showSubMetric ntfPendingSubs "simplex_ntf_smp_subscription_pending_" "Pending" + notifications = + "# Notifications\n\ + \# -------------\n\ + \\n\ + \# HELP simplex_ntf_notifications_received Received notifications\n\ + \# TYPE simplex_ntf_notifications_received counter\n\ + \simplex_ntf_notifications_received " <> mshow _ntfReceived <> "\n# ntfReceived\n\ + \\n\ + \# HELP simplex_ntf_notifications_delivered Delivered notifications\n\ + \# TYPE simplex_ntf_notifications_delivered counter\n\ + \simplex_ntf_notifications_delivered " <> mshow _ntfDelivered <> "\n# ntfDelivered\n\ + \\n\ + \# HELP simplex_ntf_notifications_failed Failed notifications\n\ + \# TYPE simplex_ntf_notifications_failed counter\n\ + \simplex_ntf_notifications_failed " <> mshow _ntfFailed <> "\n# ntfFailed\n\ + \\n\ + \# HELP simplex_ntf_notifications_periodic_delivered Delivered periodic notifications\n\ + \# TYPE simplex_ntf_notifications_periodic_delivered counter\n\ + \simplex_ntf_notifications_periodic_delivered " <> mshow _ntfCronDelivered <> "\n# ntfCronDelivered\n\ + \\n\ + \# HELP simplex_ntf_notifications_periodic_failed Failed periodic notifications\n\ + \# TYPE simplex_ntf_notifications_periodic_failed counter\n\ + \simplex_ntf_notifications_periodic_failed " <> mshow _ntfCronFailed <> "\n# ntfCronFailed\n\ + \\n\ + \# HELP simplex_ntf_notifications_verification_queued Token verifications queued\n\ + \# TYPE simplex_ntf_notifications_verification_queued counter\n\ + \simplex_ntf_notifications_verification_queued " <> mshow _ntfVrfQueued <> "\n# ntfVrfQueued\n\ + \\n\ + \# HELP simplex_ntf_notifications_verification_delivered Delivered token verifications\n\ + \# TYPE simplex_ntf_notifications_verification_delivered counter\n\ + \simplex_ntf_notifications_verification_delivered " <> mshow _ntfVrfDelivered <> "\n# ntfVrfDelivered\n\ + \\n\ + \# HELP simplex_ntf_notifications_verification_failed Failed token verification deliveries\n\ + \# TYPE simplex_ntf_notifications_verification_failed counter\n\ + \simplex_ntf_notifications_verification_failed " <> mshow _ntfVrfFailed <> "\n# ntfVrfFailed\n\ + \\n\ + \# HELP simplex_ntf_notifications_verification_invalid_tkn Invalid token errors while delivering verifications\n\ + \# TYPE simplex_ntf_notifications_verification_invalid_tkn counter\n\ + \simplex_ntf_notifications_verification_invalid_tkn " <> mshow _ntfVrfInvalidTkn <> "\n# ntfVrfInvalidTkn\n\ + \\n\ + \# HELP simplex_ntf_notifications_total Total number of last notifications stored.\n\ + \# TYPE simplex_ntf_notifications_total gauge\n\ + \simplex_ntf_notifications_total " <> mshow lastNtfCount <> "\n# lastNtfCount\n\ + \\n" + info = + "# Info\n\ + \# ----\n\ + \\n\ + \# HELP simplex_ntf_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\ + \# TYPE simplex_ntf_info gauge\n\ + \simplex_ntf_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\ + \\n\ + \# HELP simplex_ntf_threads_total Thread count\n\ + \# TYPE simplex_ntf_threads_total gauge\n\ + \simplex_ntf_threads_total " <> mshow threadsCount <> "\n# threadsCount\n\ + \\n" + <> showWorkerMetric srvSubscribers "simplex_ntf_smp_subscribers_" "SMP subcscribers" + <> showWorkerMetric srvClients "simplex_ntf_smp_agent_clients_" "SMP agent clients" + <> showWorkerMetric srvSubWorkers "simplex_ntf_smp_agent_sub_workers_" "SMP agent subscription workers" + <> "# HELP simplex_ntf_smp_sessions_count SMP sessions count\n\ + \# TYPE simplex_ntf_smp_sessions_count gauge\n\ + \simplex_ntf_smp_sessions_count " <> mshow smpSessionCount <> "\n# smpSessionCount\n\ + \\n\ + \# HELP simplex_ntf_apns_queue_length Count of notifications in push queue\n\ + \# TYPE simplex_ntf_apns_queue_length gauge\n\ + \simplex_ntf_apns_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\ + \\n" + showSubMetric NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} mPfx descrPfx = + showOwnSrvSubs <> showOtherSrvSubs + where + showOwnSrvSubs + | M.null ownSrvSubs = showOwn_ "" 0 0 + | otherwise = T.concat $ map (\(host, cnt) -> showOwn_ (metricHost host) 1 cnt) $ M.assocs ownSrvSubs + showOwn_ param srvCnt subCnt = + gaugeMetric (mPfx <> "server_count_own") param srvCnt (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server" + <> gaugeMetric (mPfx <> "sub_count_own") param subCnt (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count" + showOtherSrvSubs = + gaugeMetric (mPfx <> "server_count_other") "" otherServers (descrPfx <> " SMP subscriptions, other server count") "otherServers" + <> gaugeMetric (mPfx <> "sub_count_other") "" otherSrvSubCount (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount" + showWorkerMetric NtfSMPWorkerMetrics {ownServers, otherServers} mPfx descrPfx = + showOwnServers <> showOtherServers + where + showOwnServers + | null ownServers = showOwn_ "" 0 + | otherwise = T.concat $ map (\host -> showOwn_ (metricHost host) 1) ownServers + showOwn_ param cnt = gaugeMetric (mPfx <> "count_own") param cnt (descrPfx <> " count for own servers") "ownServers" + showOtherServers = gaugeMetric (mPfx <> "count_other") "" otherServers (descrPfx <> " count for other servers") "otherServers" + gaugeMetric :: Text -> Text -> Int -> Text -> Text -> Text + gaugeMetric name param value descr codeRef = + "# HELP " <> name <> " " <> descr <> "\n\ + \# TYPE " <> name <> " gauge\n\ + \" <> name <> param <> " " <> mshow value <> "\n# " <> codeRef <> "\n\ + \\n" + metricHost host = "{server=\"" <> host <> "\"}" + mstr a = T.pack a <> " " <> tsEpoch + mshow :: Show a => a -> Text + mshow = mstr . show + tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000 + epoch = UTCTime systemEpochDay 0 +{-# FOURMOLU_ENABLE\n#-} diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 8a8c475ac..3aa1e7e31 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -585,6 +585,17 @@ toLastNtf :: SMPQueueNtfRow :. (SystemTime, C.CbNonce, Binary EncNMsgMeta) -> PN toLastNtf (qRow :. (ts, nonce, Binary encMeta)) = PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs = ts, nmsgNonce = nonce, encNMsgMeta = encMeta} +getEntityCounts :: NtfPostgresStore -> IO (Int64, Int64, Int64) +getEntityCounts st = + fmap (fromRight (0, 0, 0)) $ withDB' "getEntityCounts" st $ \db -> do + tCnt <- count <$> DB.query_ db "SELECT count(1) FROM tokens" + sCnt <- count <$> DB.query_ db "SELECT reltuples::BIGINT FROM pg_class WHERE relname = 'subscriptions' AND relkind = 'r'" + nCnt <- count <$> DB.query_ db "SELECT count(1) FROM last_notifications" + pure (tCnt, sCnt, nCnt) + where + count (Only n : _) = n + count [] = 0 + importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> IO (Int64, Int64, Int64) importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do (tIds, tCnt) <- importTokens diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 32534ccf9..2f3dea57f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -114,6 +114,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util import Simplex.Messaging.Version +import System.Environment (lookupEnv) import System.Exit (exitFailure, exitSuccess) import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) @@ -562,21 +563,22 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt AMS _ _ st <- asks msgStore ss <- asks serverStats env <- ask + rtsOpts <- liftIO $ maybe ("set " <> rtsOptionsEnv) T.pack <$> lookupEnv (T.unpack rtsOptionsEnv) let interval = 1000000 * saveInterval liftIO $ forever $ do threadDelay interval ts <- getCurrentTime - sm <- getServerMetrics st ss + sm <- getServerMetrics st ss rtsOpts rtm <- getRealTimeMetrics env T.writeFile metricsFile $ prometheusMetrics sm rtm ts - getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> IO ServerMetrics - getServerMetrics st ss = do + getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> Text -> IO ServerMetrics + getServerMetrics st ss rtsOptions = do d <- getServerStatsData ss let ps = periodStatDataCounts $ _activeQueues d psNtf = periodStatDataCounts $ _activeQueuesNtf d QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st - pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} + pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount, rtsOptions} getRealTimeMetrics :: Env -> IO RealTimeMetrics getRealTimeMetrics Env {clients, sockets, msgStore = AMS _ _ ms, server = Server {subscribers, notifiers, subClients, ntfSubClients}} = do diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index a542a87f1..39dbc854f 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -14,6 +14,7 @@ import Data.Time.Format.ISO8601 (iso8601Show) import Network.Socket (ServiceName) import Simplex.Messaging.Server.MsgStore.Types (LoadedQueueCounts (..)) import Simplex.Messaging.Server.Stats +import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Server (SocketStats (..)) data ServerMetrics = ServerMetrics @@ -21,9 +22,13 @@ data ServerMetrics = ServerMetrics activeQueueCounts :: PeriodStatCounts, activeNtfCounts :: PeriodStatCounts, queueCount :: Int, - notifierCount :: Int + notifierCount :: Int, + rtsOptions :: Text } +rtsOptionsEnv :: Text +rtsOptionsEnv = "SMP_RTS_OPTIONS" + data RealTimeMetrics = RealTimeMetrics { socketStats :: [(ServiceName, SocketStats)], threadsCount :: Int, @@ -40,7 +45,7 @@ prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text prometheusMetrics sm rtm ts = time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info where - ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} = sm + ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount, rtsOptions} = sm RealTimeMetrics { socketStats, threadsCount, @@ -87,10 +92,8 @@ prometheusMetrics sm rtm ts = _msgGetDuplicate, _msgGetProhibited, _msgExpired, - _activeQueues, _msgSentNtf, _msgRecvNtf, - _activeQueuesNtf, _msgNtfs, _msgNtfsB, _msgNtfNoSub, @@ -347,6 +350,10 @@ prometheusMetrics sm rtm ts = info = "# Info\n\ \# ----\n\ + \\n\ + \# HELP simplex_smp_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\ + \# TYPE simplex_smp_info gauge\n\ + \simplex_smp_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\ \\n" <> socketsMetric socketsAccepted "simplex_smp_sockets_accepted" "Accepted sockets" <> socketsMetric socketsClosed "simplex_smp_sockets_closed" "Closed sockets" diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index ce69e5c11..a5a3e4069 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -570,7 +570,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 closeDBStore store - threadDelay 500000 >> callCommand "sync" >> threadDelay 500000 + threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000 putStrLn "before opening the database from another agent" -- aliceNtf client doesn't have subscription and is allowed to get notification message @@ -578,7 +578,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId] pure () - threadDelay 500000 >> callCommand "sync" >> threadDelay 500000 + threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000 putStrLn "after closing the database in another agent" reopenDBStore store foregroundAgent alice diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index e7a7c2ba5..22bb3abaa 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -80,6 +80,9 @@ ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2" ntfTestStoreLastNtfsFile :: FilePath ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log" +ntfTestPrometheusMetricsFile :: FilePath +ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt" + ntfTestStoreDBOpts :: DBOpts ntfTestStoreDBOpts = DBOpts @@ -154,6 +157,8 @@ ntfServerCfg = logStatsStartTime = 0, serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, + prometheusInterval = Nothing, + prometheusMetricsFile = ntfTestPrometheusMetricsFile, ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig, startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} From 7d0115daec2842e82b23bb1a9b85baddad08e8b3 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 28 Apr 2025 12:18:55 +0100 Subject: [PATCH 5/9] ntf server, agent: send all periodic notifications from one thread, only to old active clients or new clients with periodic notification mode (#1528) * ntf server, agent: send all periodic notifications from one thread, only to old active clients or new clients with periodic notification mode * send different type via subscription queues * option to compact store log on start --- src/Simplex/Messaging/Agent.hs | 13 ++- src/Simplex/Messaging/Agent/Client.hs | 9 +- src/Simplex/Messaging/Notifications/Client.hs | 5 +- src/Simplex/Messaging/Notifications/Server.hs | 106 ++++++++---------- .../Messaging/Notifications/Server/Env.hs | 48 ++++---- .../Messaging/Notifications/Server/Main.hs | 1 + .../Notifications/Server/Prometheus.hs | 21 ++-- .../Notifications/Server/Store/Migrations.hs | 8 +- .../Notifications/Server/Store/Postgres.hs | 52 +++++---- .../Notifications/Server/Store/Types.hs | 4 +- tests/NtfClient.hs | 1 + 11 files changed, 137 insertions(+), 131 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 34d6bbc97..89e379023 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -2197,10 +2197,9 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = atomically $ nsUpdateToken ns tkn' agentNtfCheckToken c tknId tkn' >>= \case NTActive -> do - cron <- asks $ ntfCron . config - agentNtfEnableCron c tknId tkn cron when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete + lift $ setCronInterval c tknId tkn t tkn' (NTActive, Just NTACheck) $ pure () status -> t tkn' (status, Nothing) $ pure () | otherwise -> replaceToken tknId @@ -2261,11 +2260,17 @@ verifyNtfToken' c deviceToken nonce code = withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code' when (toStatus == NTActive) $ do - cron <- asks $ ntfCron . config - agentNtfEnableCron c tknId tkn cron + lift $ setCronInterval c tknId tkn when (ntfMode == NMInstant) $ initializeNtfSubs c _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token" +setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' () +setCronInterval c tknId tkn@NtfToken {ntfMode} = do + cron <- case ntfMode of + NMPeriodic -> asks $ ntfCron . config + _ -> pure 0 + void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c tknId tkn cron + checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus checkNtfToken' c deviceToken = withStore' c getSavedNtfToken >>= \case diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 240b25f7e..455c5eb48 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -77,7 +77,7 @@ module Simplex.Messaging.Agent.Client agentNtfCheckToken, agentNtfReplaceToken, agentNtfDeleteToken, - agentNtfEnableCron, + agentNtfSetCronInterval, agentNtfCreateSubscription, agentNtfCreateSubscriptions, agentNtfCheckSubscription, @@ -1812,9 +1812,10 @@ agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfToken agentNtfDeleteToken c ntfServer ntfPrivKey tknId = withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId -agentNtfEnableCron :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM () -agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval = - withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval +-- set to 0 to disable +agentNtfSetCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM () +agentNtfSetCronInterval c tknId NtfToken {ntfServer, ntfPrivKey} interval = + withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf ntfPrivKey tknId interval agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey = diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index 273010c2c..a2a4f2ec9 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -49,8 +49,9 @@ ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () ntfDeleteToken = okNtfCommand TDEL -ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () -ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId +-- set to 0 to disable +ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () +ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId ntfCreateSubscription c pKey newSub = diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 55ab37885..5407a3bc9 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -40,7 +40,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) -import Data.Time.Clock.System (getSystemTime) +import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import GHC.IORef (atomicSwapIORef) import GHC.Stats (getRTSStats) @@ -76,7 +76,7 @@ import System.Environment (lookupEnv) import System.Exit (exitFailure, exitSuccess) import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) -import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, async, uninterruptibleCancel, unliftIO, withFile) +import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, unliftIO, withFile) import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId) import UnliftIO.Directory (doesFileExist, renameFile) import UnliftIO.Exception @@ -108,6 +108,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} raceAny_ ( ntfSubscriber s : ntfPush ps + : periodicNtfsThread ps : map runServer transports <> serverStatsThread_ cfg <> prometheusMetricsThread_ cfg @@ -252,7 +253,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} ntfActiveSubs <- getSMPSubMetrics a srvSubs ntfPendingSubs <- getSMPSubMetrics a pendingSrvSubs smpSessionCount <- M.size <$> readTVarIO smpSessions - apnsPushQLength <- fromIntegral <$> atomically (lengthTBQueue pushQ) + apnsPushQLength <- atomically $ lengthTBQueue pushQ pure NtfRealTimeMetrics {threadsCount, srvSubscribers, srvClients, srvSubWorkers, ntfActiveSubs, ntfPendingSubs, smpSessionCount, apnsPushQLength} where getSMPSubMetrics :: SMPClientAgent -> TMap SMPServer (TMap SMPSub a) -> IO NtfSMPSubMetrics @@ -463,16 +464,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge -- TODO [ntfdb] possibly, the subscriptions can be batched here and sent every say 5 seconds -- this should be analysed once we have prometheus stats subs <- atomically $ readTQueue subscriberSubQ - -- TODO [ntfdb] validate/partition that SMP server matches and log internal error if not updated <- liftIO $ batchUpdateSubStatus st subs NSPending logSubStatus smpServer "subscribing" (L.length subs) updated liftIO $ subscribeQueues smpServer subs - -- \| Subscribe to queues. The list of results can have a different order. - subscribeQueues :: SMPServer -> NonEmpty NtfSubRec -> IO () - subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map sub subs) - where - sub NtfSubRec {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey) + subscribeQueues :: SMPServer -> NonEmpty ServerNtfSub -> IO () + subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map snd subs) receiveSMP :: M () receiveSMP = forever $ do @@ -492,7 +489,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} ntfs_ <- liftIO $ addTokenLastNtf st newNtf forM_ ntfs_ $ \(tkn, lastNtfs) -> atomically $ writeTBQueue pushQ (tkn, PNMessage lastNtfs) - -- TODO [ntfdb] track queued notifications separately? + -- TODO [ntfdb] count queued notifications separately? incNtfStat ntfReceived Right SMP.END -> do whenM (atomically $ activeClientSession' ca sessionId srv) $ do @@ -554,31 +551,34 @@ ntfPush :: NtfPushServer -> M () ntfPush s@NtfPushServer {pushQ} = forever $ do (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) + st <- asks store case ntf of PNVerification _ -> - deliverNotification pp tkn ntf >>= \case + liftIO (deliverNotification st pp tkn ntf) >>= \case Right _ -> do - st <- asks store void $ liftIO $ setTknStatusConfirmed st tkn incNtfStatT t ntfVrfDelivered Left _ -> incNtfStatT t ntfVrfFailed - PNCheckMessages -> checkActiveTkn tknStatus $ do - deliverNotification pp tkn ntf - >>= incNtfStatT t . (\case Left _ -> ntfCronFailed; Right () -> ntfCronDelivered) + PNCheckMessages -> do + liftIO (deliverNotification st pp tkn ntf) >>= \case + Right _ -> do + void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime + incNtfStatT t ntfCronDelivered + Left _ -> incNtfStatT t ntfCronFailed PNMessage {} -> checkActiveTkn tknStatus $ do stats <- asks serverStats liftIO $ updatePeriodStats (activeTokens stats) ntfTknId - deliverNotification pp tkn ntf + liftIO (deliverNotification st pp tkn ntf) >>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered) where checkActiveTkn :: NtfTknStatus -> M () -> M () checkActiveTkn status action | status == NTActive = action | otherwise = liftIO $ logError "bad notification token status" - deliverNotification :: PushProvider -> NtfTknRec -> PushNotification -> M (Either PushProviderError ()) - deliverNotification pp tkn@NtfTknRec {ntfTknId} ntf = do - deliver <- liftIO $ getPushClient s pp - liftIO (runExceptT $ deliver tkn ntf) >>= \case + deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ()) + deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf = do + deliver <- getPushClient s pp + runExceptT (deliver tkn ntf) >>= \case Right _ -> pure $ Right () Left e -> case e of PPConnection _ -> retryDeliver @@ -586,24 +586,35 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do PPCryptoError _ -> err e PPResponseError {} -> err e PPTokenInvalid r -> do - st <- asks store - void $ liftIO $ updateTknStatus st tkn $ NTInvalid $ Just r + void $ updateTknStatus st tkn $ NTInvalid $ Just r err e PPPermanentError -> err e where - retryDeliver :: M (Either PushProviderError ()) + retryDeliver :: IO (Either PushProviderError ()) retryDeliver = do - deliver <- liftIO $ newPushClient s pp - liftIO (runExceptT $ deliver tkn ntf) >>= \case + deliver <- newPushClient s pp + runExceptT (deliver tkn ntf) >>= \case Right _ -> pure $ Right () Left e -> case e of PPTokenInvalid r -> do - st <- asks store - void $ liftIO $ updateTknStatus st tkn $ NTInvalid $ Just r + void $ updateTknStatus st tkn $ NTInvalid $ Just r err e _ -> err e err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e +-- TODO [ntfdb] this could be further improved by sending periodic notifications directly from this thread, +-- without any queue +periodicNtfsThread :: NtfPushServer -> M () +periodicNtfsThread NtfPushServer {pushQ} = do + st <- asks store + ntfsInterval <- asks $ periodicNtfsInterval . config + let interval = 1000000 * ntfsInterval + liftIO $ forever $ do + threadDelay interval + now <- systemSeconds <$> getSystemTime + cnt <- withPeriodicNtfTokens st now $ \tkn -> atomically $ writeTBQueue pushQ (tkn, PNCheckMessages) + logInfo $ "Scheduled periodic notifications: " <> tshow cnt + runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M () runNtfClientTransport th@THandle {params} = do qSize <- asks $ clientQSize . config @@ -692,7 +703,7 @@ verifyNtfTransmission st auth_ (tAuth, authorized, (corrId, entId, _)) = \case e -> VRFailed e client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () -client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} = +client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ} = forever $ atomically (readTBQueue rcvQ) >>= mapM processCommand @@ -728,11 +739,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu TVFY code -- this allows repeated verification for cases when client connection dropped before server response | (tknStatus == NTRegistered || tknStatus == NTConfirmed || tknStatus == NTActive) && tknRegCode == code -> do logDebug "TVFY - token verified" - withNtfStore (`setTokenActive` tkn) $ \tIds -> do - -- TODO [ntfdb] this will be unnecessary if all cron notifications move to one thread - forM_ tIds cancelInvervalNotifications - incNtfStatT token tknVerified - pure NROk + withNtfStore (`setTokenActive` tkn) $ \_ -> NROk <$ incNtfStatT token tknVerified | otherwise -> do logDebug "TVFY - incorrect code or token status" pure $ NRErr AUTH @@ -754,45 +761,24 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu forM_ ss $ \(smpServer, nIds) -> do atomically $ removeSubscriptions ca smpServer SPNotifier nIds atomically $ removePendingSubs ca smpServer SPNotifier nIds - cancelInvervalNotifications tknId incNtfStatT token tknDeleted pure NROk TCRN 0 -> do logDebug "TCRN 0" - withNtfStore (\st -> updateTknCronInterval st ntfTknId 0) $ \_ -> do - -- TODO [ntfdb] move cron intervals to one thread - cancelInvervalNotifications tknId - pure NROk + withNtfStore (\st -> updateTknCronInterval st ntfTknId 0) $ \_ -> pure NROk TCRN int | int < 20 -> pure $ NRErr QUOTA | otherwise -> do logDebug "TCRN" - withNtfStore (\st -> updateTknCronInterval st ntfTknId int) $ \_ -> do - -- TODO [ntfdb] move cron intervals to one thread - liftIO (TM.lookupIO tknId intervalNotifiers) >>= \case - Nothing -> runIntervalNotifier int - Just IntervalNotifier {interval, action} -> - unless (interval == int) $ do - uninterruptibleCancel action - runIntervalNotifier int - pure NROk - where - runIntervalNotifier interval = do - action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60 - let notifier = IntervalNotifier {action, token = tkn, interval} - atomically $ TM.insert tknId notifier intervalNotifiers - where - intervalNotifier delay = forever $ do - liftIO $ threadDelay' delay - atomically $ writeTBQueue pushQ (tkn, PNCheckMessages) - NtfReqNew corrId (ANE SSubscription newSub@(NewNtfSub _ (SMPQueueNtf srv _) _)) -> do + withNtfStore (\st -> updateTknCronInterval st ntfTknId int) $ \_ -> pure NROk + NtfReqNew corrId (ANE SSubscription newSub@(NewNtfSub _ (SMPQueueNtf srv nId) nKey)) -> do logDebug "SNEW - new subscription" subId <- getId let sub = mkNtfSubRec subId newSub resp <- withNtfStore (`addNtfSubscription` sub) $ \case True -> do - atomically $ writeTBQueue newSubQ (srv, [sub]) + atomically $ writeTBQueue newSubQ (srv, [(subId, (nId, nKey))]) incNtfStat subCreated pure $ NRSubId subId False -> pure $ NRErr AUTH @@ -823,10 +809,6 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config)) randomBytes :: Int -> M ByteString randomBytes n = atomically . C.randomBytes n =<< asks random - cancelInvervalNotifications :: NtfTokenId -> M () - cancelInvervalNotifications tknId = - atomically (TM.lookupDelete tknId intervalNotifiers) - >>= mapM_ (uninterruptibleCancel . action) withNtfStore :: (NtfPostgresStore -> IO (Either ErrorType a)) -> (a -> M NtfResponse) -> M NtfResponse withNtfStore stAction continue = do diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 6488cbb11..415f341cb 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,33 +9,38 @@ module Simplex.Messaging.Notifications.Server.Env where import Control.Concurrent (ThreadId) -import Control.Concurrent.Async (Async) +import Control.Logger.Simple +import Control.Monad import Crypto.Random import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.System (SystemTime) -import Data.Word (Word16) import Data.X509.Validation (Fingerprint (..)) import Network.Socket -import qualified Network.TLS as T +import qualified Network.TLS as TLS import Numeric.Natural import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Stats +import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore) import Simplex.Messaging.Notifications.Server.Store.Postgres import Simplex.Messaging.Notifications.Server.Store.Types +import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore) import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF) import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission) -import Simplex.Messaging.Server.Env.STM (StartOptions) +import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.StoreLog (closeStoreLog) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..)) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential) +import System.Exit (exitFailure) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -54,6 +60,7 @@ data NtfServerConfig = NtfServerConfig inactiveClientExpiration :: Maybe ExpirationConfig, dbStoreConfig :: PostgresStoreCfg, ntfCredentials :: ServerCredentials, + periodicNtfsInterval :: Int, -- seconds -- stats config - see SMP server config logStatsInterval :: Maybe Int64, logStatsStartTime :: Int64, @@ -80,29 +87,34 @@ data NtfEnv = NtfEnv pushServer :: NtfPushServer, store :: NtfPostgresStore, random :: TVar ChaChaDRG, - tlsServerCreds :: T.Credential, + tlsServerCreds :: TLS.Credential, serverIdentity :: C.KeyHash, serverStats :: NtfServerStats } newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, startOptions} = do + when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig random <- C.newRandom store <- newNtfDbStore dbStoreConfig - -- TODO [ntfdb] this should happen with compacting on start - -- logInfo "restoring subscriptions..." - -- storeLog <- mapM (`readWriteNtfStore` store) storeLogFile - -- logInfo "restored subscriptions" subscriber <- newNtfSubscriber subQSize smpAgentCfg random pushServer <- newNtfPushServer pushQSize apnsConfig tlsServerCreds <- loadServerCredential ntfCredentials Fingerprint fp <- loadFingerprint ntfCredentials serverStats <- newNtfServerStats =<< getCurrentTime pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} + where + compactDbStoreLog = \case + Just f -> do + logInfo $ "compacting store log " <> T.pack f + newNtfSTMStore >>= readWriteNtfSTMStore False f >>= closeStoreLog + Nothing -> do + logError "Error: `--compact-log` used without `enable: on` option in STORE_LOG section of INI file" + exitFailure data NtfSubscriber = NtfSubscriber { smpSubscribers :: TMap SMPServer SMPSubscriber, - newSubQ :: TBQueue (SMPServer, NonEmpty NtfSubRec), -- should match SMPServer + newSubQ :: TBQueue (SMPServer, NonEmpty ServerNtfSub), smpAgent :: SMPClientAgent } @@ -115,7 +127,7 @@ newNtfSubscriber qSize smpAgentCfg random = do data SMPSubscriber = SMPSubscriber { smpServer :: SMPServer, - subscriberSubQ :: TQueue (NonEmpty NtfSubRec), + subscriberSubQ :: TQueue (NonEmpty ServerNtfSub), subThreadId :: TVar (Maybe (Weak ThreadId)) } @@ -128,22 +140,14 @@ newSMPSubscriber smpServer = do data NtfPushServer = NtfPushServer { pushQ :: TBQueue (NtfTknRec, PushNotification), pushClients :: TMap PushProvider PushProviderClient, - intervalNotifiers :: TMap NtfTokenId IntervalNotifier, apnsConfig :: APNSPushClientConfig } -data IntervalNotifier = IntervalNotifier - { action :: Async (), - token :: NtfTknRec, - interval :: Word16 - } - newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer newNtfPushServer qSize apnsConfig = do pushQ <- newTBQueueIO qSize pushClients <- TM.emptyIO - intervalNotifiers <- TM.emptyIO - pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig} + pure NtfPushServer {pushQ, pushClients, apnsConfig} newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient newPushClient NtfPushServer {apnsConfig, pushClients} pp = do diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index be3210be1..f59c565bc 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -263,6 +263,7 @@ ntfServerCLI cfgPath logPath = privateKeyFile = c serverKeyFile, certificateFile = c serverCrtFile }, + periodicNtfsInterval = 5 * 60, -- 5 minutes logStatsInterval = logStats $> 86400, -- seconds logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", diff --git a/src/Simplex/Messaging/Notifications/Server/Prometheus.hs b/src/Simplex/Messaging/Notifications/Server/Prometheus.hs index a3399c27f..78d5b4d38 100644 --- a/src/Simplex/Messaging/Notifications/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Notifications/Server/Prometheus.hs @@ -13,6 +13,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffUTCTime) import Data.Time.Clock.System (systemEpochDay) import Data.Time.Format.ISO8601 (iso8601Show) +import Numeric.Natural (Natural) import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Server.Stats (PeriodStatCounts (..)) import Simplex.Messaging.Transport (simplexMQVersion) @@ -32,13 +33,13 @@ rtsOptionsEnv = "NTF_RTS_OPTIONS" data NtfRealTimeMetrics = NtfRealTimeMetrics { threadsCount :: Int, - srvSubscribers :: NtfSMPWorkerMetrics, -- smpSubscribers - srvClients :: NtfSMPWorkerMetrics, -- smpClients - srvSubWorkers :: NtfSMPWorkerMetrics, -- smpSubWorkers - ntfActiveSubs :: NtfSMPSubMetrics, -- srvSubs - ntfPendingSubs :: NtfSMPSubMetrics, -- pendingSrvSubs - smpSessionCount :: Int, -- smpSessions - apnsPushQLength :: Int -- lengthTBQueue pushQ + srvSubscribers :: NtfSMPWorkerMetrics, + srvClients :: NtfSMPWorkerMetrics, + srvSubWorkers :: NtfSMPWorkerMetrics, + ntfActiveSubs :: NtfSMPSubMetrics, + ntfPendingSubs :: NtfSMPSubMetrics, + smpSessionCount :: Int, + apnsPushQLength :: Natural } data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int} @@ -212,9 +213,9 @@ ntfPrometheusMetrics sm rtm ts = \# TYPE simplex_ntf_smp_sessions_count gauge\n\ \simplex_ntf_smp_sessions_count " <> mshow smpSessionCount <> "\n# smpSessionCount\n\ \\n\ - \# HELP simplex_ntf_apns_queue_length Count of notifications in push queue\n\ - \# TYPE simplex_ntf_apns_queue_length gauge\n\ - \simplex_ntf_apns_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\ + \# HELP simplex_ntf_apns_push_queue_length Count of notifications in push queue\n\ + \# TYPE simplex_ntf_apns_push_queue_length gauge\n\ + \simplex_ntf_apns_push_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\ \\n" showSubMetric NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} mPfx descrPfx = showOwnSrvSubs <> showOtherSrvSubs diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs index a9de42668..700be059f 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs @@ -33,14 +33,14 @@ CREATE TABLE tokens( dh_priv_key BYTEA NOT NULL, dh_secret BYTEA NOT NULL, reg_code BYTEA NOT NULL, - cron_interval BIGINT NOT NULL, - cron_sent_at BIGINT, + cron_interval BIGINT NOT NULL, -- minutes + cron_sent_at BIGINT, -- seconds updated_at BIGINT, PRIMARY KEY (token_id) ); CREATE UNIQUE INDEX idx_tokens_push_provider_token ON tokens(push_provider, push_provider_token, verify_key); -CREATE INDEX idx_tokens_cron_sent_at ON tokens((cron_sent_at + cron_interval)); +CREATE INDEX idx_tokens_status_cron_interval_sent_at ON tokens(status, cron_interval, (cron_sent_at + cron_interval * 60)); CREATE TABLE smp_servers( smp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, @@ -69,7 +69,7 @@ CREATE TABLE last_notifications( token_ntf_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT, subscription_id BYTEA NOT NULL REFERENCES subscriptions ON DELETE CASCADE ON UPDATE RESTRICT, - sent_at BIGINT NOT NULL, + sent_at TIMESTAMPTZ NOT NULL, nmsg_nonce BYTEA NOT NULL, nmsg_data BYTEA NOT NULL ); diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 3aa1e7e31..031eda711 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Notifications.Server.Store.Postgres where @@ -42,7 +42,8 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time.Clock.System (SystemTime (..)) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.System (SystemTime (..), systemToUTCTime, utcToSystemTime) import Data.Word (Word16) import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, ToRow, (:.) (..)) import qualified Database.PostgreSQL.Simple as DB @@ -253,14 +254,14 @@ getUsedSMPServers st = |] (Only (In [NSNew, NSPending, NSActive, NSInactive])) -foldNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Int -> s -> (s -> NtfSubRec -> IO s) -> IO s +foldNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Int -> s -> (s -> ServerNtfSub -> IO s) -> IO s foldNtfSubscriptions st srv fetchCount state action = withConnection (dbStore st) $ \db -> - DB.foldWithOptions opts db query params state $ \s -> action s . toNtfSub + DB.foldWithOptions opts db query params state $ \s -> action s . toServerNtfSub where query = [sql| - SELECT s.subscription_id, s.token_id, s.smp_notifier_id, s.status, s.smp_notifier_key + SELECT s.subscription_id, s.smp_notifier_id, s.smp_notifier_key FROM subscriptions s JOIN smp_servers p ON p.smp_server_id = s.smp_server_id WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? @@ -268,8 +269,7 @@ foldNtfSubscriptions st srv fetchCount state action = |] params = srvToRow srv :. Only (In [NSNew, NSPending, NSActive, NSInactive]) opts = DB.defaultFoldOptions {DB.fetchQuantity = DB.Fixed fetchCount} - toNtfSub (ntfSubId, tokenId, nId, subStatus, notifierKey) = - NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf srv nId, subStatus, notifierKey} + toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey)) -- Returns token and subscription. -- If subscription exists but belongs to another token, returns Left AUTH @@ -347,7 +347,7 @@ setTknStatusConfirmed st NtfTknRec {ntfTknId} = updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ? AND status != ?" (NTConfirmed, ntfTknId, NTConfirmed, NTActive) when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed -setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType [NtfTokenId]) +setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} = withDB' "setTokenActive" st $ \db -> do updateTknStatus_ st db tkn NTActive @@ -363,7 +363,17 @@ setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} = |] (pp, Binary ppToken, ntfTknId) withLog "deleteNtfToken" st $ \sl -> mapM_ (logDeleteToken sl) tknIds - pure tknIds + +withPeriodicNtfTokens :: NtfPostgresStore -> Int64 -> (NtfTknRec -> IO ()) -> IO Int +withPeriodicNtfTokens st now notify = + fmap (fromRight 0) $ withDB' "withPeriodicNtfTokens" st $ \db -> + DB.fold db (ntfTknQuery <> " WHERE status = ? AND cron_interval != 0 AND (cron_sent_at + cron_interval * 60) < ?") (NTActive, now) 0 $ \ !n row -> do + notify (rowToNtfTkn row) $> (n + 1) + +updateTokenCronSentAt :: NtfPostgresStore -> NtfTokenId -> Int64 -> IO (Either ErrorType ()) +updateTokenCronSentAt st tknId now = + withDB' "updateTokenCronSentAt" st $ \db -> + void $ DB.execute db "UPDATE tokens t SET cron_sent_at = ? WHERE token_id = ?" (now, tknId) addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool) addNtfSubscription st sub = @@ -495,10 +505,10 @@ batchUpdateStatus_ st srv mkParams = |] (srvToRow srv) -batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty NtfSubRec -> NtfSubStatus -> IO Int64 +batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty ServerNtfSub -> NtfSubStatus -> IO Int64 batchUpdateSubStatus st subs status = fmap (fromRight (-1)) $ withDB' "batchUpdateSubStatus" st $ \db -> do - let params = L.toList $ L.map (\NtfSubRec {ntfSubId} -> (status, ntfSubId)) subs + let params = L.toList $ L.map (\(subId, _) -> (status, subId)) subs subIds <- DB.returning db @@ -572,7 +582,7 @@ addTokenLastNtf st newNtf = JOIN smp_servers p ON p.smp_server_id = s.smp_server_id ORDER BY token_ntf_id DESC |] - (tId, sId, ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId) + (tId, sId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId) let lastNtfs = fromMaybe (newNtf :| []) (L.nonEmpty lastNtfs_) pure (tkn, lastNtfs) where @@ -581,9 +591,10 @@ addTokenLastNtf st newNtf = toTokenSubId :: NtfTknRow :. Only NtfSubscriptionId -> (NtfTknRec, NtfSubscriptionId) toTokenSubId (tknRow :. Only sId) = (rowToNtfTkn tknRow, sId) -toLastNtf :: SMPQueueNtfRow :. (SystemTime, C.CbNonce, Binary EncNMsgMeta) -> PNMessageData +toLastNtf :: SMPQueueNtfRow :. (UTCTime, C.CbNonce, Binary EncNMsgMeta) -> PNMessageData toLastNtf (qRow :. (ts, nonce, Binary encMeta)) = - PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs = ts, nmsgNonce = nonce, encNMsgMeta = encMeta} + let ntfTs = MkSystemTime (systemSeconds $ utcToSystemTime ts) 0 + in PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs, nmsgNonce = nonce, encNMsgMeta = encMeta} getEntityCounts :: NtfPostgresStore -> IO (Int64, Int64, Int64) getEntityCounts st = @@ -609,9 +620,11 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do tokens <- filterTokens allTokens let skipped = length allTokens - length tokens when (skipped /= 0) $ putStrLn $ "Total skipped tokens " <> show skipped - -- uncomment this line instead of the next to import tokens one by one. + -- uncomment this line instead of the next two to import tokens one by one. -- tCnt <- withConnection s $ \db -> foldM (importTkn db) 0 tokens - tRows <- mapM (fmap ntfTknToRow . mkTknRec) tokens + -- token interval is reset to 0 to only send notifications to devices with periodic mode, + -- and before clients are upgraded - to all active devices. + tRows <- mapM (fmap (ntfTknToRow . (\t -> t {tknCronInterval = 0} :: NtfTknRec)) . mkTknRec) tokens tCnt <- withConnection s $ \db -> DB.executeMany db insertNtfTknQuery tRows let tokenIds = S.fromList $ map (\NtfTknData {ntfTknId} -> ntfTknId) tokens (tokenIds,) <$> checkCount "token" (length tokens) tCnt @@ -723,7 +736,7 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do where ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of Just ntfSubId -> - let row = (tId, ntfSubId, ntfTs, nmsgNonce, Binary encNMsgMeta) + let row = (tId, ntfSubId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta) in (qs, row : rows) Nothing -> (S.insert smpQueue qs, rows) checkCount name expected inserted @@ -806,11 +819,6 @@ assertUpdated :: Int64 -> Either ErrorType () assertUpdated 0 = Left AUTH assertUpdated _ = Right () --- TODO [ntfdb] change instance and maybe field type to not round to a second, for more reliable sorting of the most recent notifications -instance FromField SystemTime where fromField f = fmap (`MkSystemTime` 0) . fromField f - -instance ToField SystemTime where toField = toField . systemSeconds - instance FromField NtfSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8 instance ToField NtfSubStatus where toField = toField . decodeLatin1 . smpEncode diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Types.hs b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs index 802906386..76233290b 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Types.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs @@ -14,7 +14,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf) import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..)) -import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey) +import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey) import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) data NtfTknRec = NtfTknRec @@ -81,6 +81,8 @@ data NtfSubRec = NtfSubRec } deriving (Show) +type ServerNtfSub = (NtfSubscriptionId, (NotifierId, NtfPrivateAuthKey)) + mkSubData :: NtfSubRec -> IO NtfSubData mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do subStatus <- newTVarIO status diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 22bb3abaa..11d0400d6 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -152,6 +152,7 @@ ntfServerCfg = privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt" }, + periodicNtfsInterval = 1, -- stats config logStatsInterval = Nothing, logStatsStartTime = 0, From 0a3d014f5d861e0c61314e328de52f704e102f81 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 30 Apr 2025 11:40:32 +0100 Subject: [PATCH 6/9] ntf server: priority db pool for notifications and client commands, concurrent resubscriptions, CLI options (#1529) * ntf server: option to skip specific tokens when importing store log * logs * batch later * subscribe in parallel, bigger queues * ntf server: test schema and migrations * optimize subscriptions * log level * resubscribe before starting * better subscribing * pooled concurrent resubscriptions * 5 * async resubscribe * typo * priority pool * db batch size --- apps/ntf-server/Main.hs | 1 - simplexmq.cabal | 2 +- src/Simplex/FileTransfer/Client/Main.hs | 14 +- src/Simplex/FileTransfer/Server.hs | 18 +- src/Simplex/FileTransfer/Server/Env.hs | 4 +- src/Simplex/Messaging/Agent/Store/Postgres.hs | 29 +-- .../Messaging/Agent/Store/Postgres/Common.hs | 38 +++- src/Simplex/Messaging/Client/Agent.hs | 4 +- src/Simplex/Messaging/Notifications/Server.hs | 72 +++---- .../Messaging/Notifications/Server/Env.hs | 2 +- .../Messaging/Notifications/Server/Main.hs | 31 ++- .../Notifications/Server/Push/APNS.hs | 13 +- .../Notifications/Server/Store/Postgres.hs | 89 ++++++--- .../Server/Store/ntf_server_schema.sql | 178 ++++++++++++++++++ src/Simplex/Messaging/Server.hs | 44 ++--- src/Simplex/Messaging/Server/CLI.hs | 21 ++- src/Simplex/Messaging/Server/Env/STM.hs | 5 +- src/Simplex/Messaging/Server/Main.hs | 8 +- src/Simplex/Messaging/Server/StoreLog.hs | 6 +- src/Simplex/Messaging/Transport/Server.hs | 2 +- src/Simplex/Messaging/Util.hs | 1 + tests/NtfClient.hs | 5 +- tests/PostgresSchemaDump.hs | 70 +++++++ tests/SMPClient.hs | 6 +- tests/ServerTests/SchemaDump.hs | 98 ---------- tests/Test.hs | 25 ++- 26 files changed, 532 insertions(+), 254 deletions(-) create mode 100644 src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql create mode 100644 tests/PostgresSchemaDump.hs delete mode 100644 tests/ServerTests/SchemaDump.hs diff --git a/apps/ntf-server/Main.hs b/apps/ntf-server/Main.hs index ac93580b9..82da000a8 100644 --- a/apps/ntf-server/Main.hs +++ b/apps/ntf-server/Main.hs @@ -15,7 +15,6 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do - setLogLevel LogInfo cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath diff --git a/simplexmq.cabal b/simplexmq.cabal index e3e1e61e7..3c8c0ae24 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -494,7 +494,7 @@ test-suite simplexmq-test AgentTests.NotificationTests NtfClient NtfServerTests - ServerTests.SchemaDump + PostgresSchemaDump hs-source-dirs: tests apps/smp-server/web diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index a330e21a7..c73cac637 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -280,7 +280,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re let chunkSpecs = prepareChunkSpecs encPath chunkSizes fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing} fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing} - logInfo $ "encrypted file to " <> tshow encPath + logDebug $ "encrypted file to " <> tshow encPath pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize) uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] uploadFile g chunks uploadedChunks encSize = do @@ -293,14 +293,14 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re -- TODO shuffle/unshuffle chunks -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though -- upload doesn't allow other requests within the same client until complete (but download does allow). - logInfo $ "uploading " <> tshow (length chunks) <> " chunks..." + logDebug $ "uploading " <> tshow (length chunks) <> " chunks..." (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a) mapM_ throwE errs pure $ map snd (sortOn fst rs) where uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk) uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do - logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..." + logDebug $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..." (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec @@ -308,7 +308,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re c <- withRetry retryCount $ getXFTPServerClient a xftpServer (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec - logInfo $ "uploaded chunk " <> tshow chunkNo + logDebug $ "uploaded chunk " <> tshow chunkNo uploaded <- atomically . stateTVar uploadedChunks $ \cs -> let cs' = fromIntegral chunkSize : cs in (sum cs', cs') liftIO $ do @@ -418,11 +418,11 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath) downloadFileChunk g a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica - logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..." + logDebug $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..." chunkPath <- uniqueCombine encPath $ show chunkNo let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec - logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath + logDebug $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath downloaded <- atomically . stateTVar downloadedChunks $ \cs -> let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs') liftIO $ do @@ -467,7 +467,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId) - logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server + logDebug $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server deleteFileChunk _ _ = throwE $ CLIError "chunk has no replicas" cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO () diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 9bdb9b28e..945c74ac8 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -181,7 +181,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira stopServer = do withFileLog closeStoreLog saveServerStats - logInfo "Server stopped" + logNote "Server stopped" expireFilesThread_ :: XFTPServerConfig -> [M ()] expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp] @@ -560,13 +560,13 @@ expireServerFiles itemDelay expCfg = do usedStart <- readTVarIO $ usedStorage st old <- liftIO $ expireBeforeEpoch expCfg files' <- readTVarIO (files st) - logInfo $ "Expiration check: " <> tshow (M.size files') <> " files" + logNote $ "Expiration check: " <> tshow (M.size files') <> " files" forM_ (M.keys files') $ \sId -> do mapM_ threadDelay itemDelay atomically (expiredFilePath st sId old) >>= mapM_ (maybeRemove $ delete st sId) usedEnd <- readTVarIO $ usedStorage st - logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." + logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." where mbs bs = tshow (bs `div` 1048576) <> "mb" maybeRemove del = maybe del (remove del) @@ -600,15 +600,15 @@ saveServerStats = >>= mapM_ (\f -> asks serverStats >>= liftIO . getFileServerStatsData >>= liftIO . saveStats f) where saveStats f stats = do - logInfo $ "saving server stats to file " <> T.pack f + logNote $ "saving server stats to file " <> T.pack f B.writeFile f $ strEncode stats - logInfo "server stats saved" + logNote "server stats saved" restoreServerStats :: M () restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats where restoreStats f = whenM (doesFileExist f) $ do - logInfo $ "restoring server stats from file " <> T.pack f + logNote $ "restoring server stats from file " <> T.pack f liftIO (strDecode <$> B.readFile f) >>= \case Right d@FileServerStatsData {_filesCount = statsFilesCount, _filesSize = statsFilesSize} -> do s <- asks serverStats @@ -617,10 +617,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat _filesSize <- readTVarIO usedStorage liftIO $ setFileServerStats s d {_filesCount, _filesSize} renameFile f $ f <> ".bak" - logInfo "server stats restored" + logNote "server stats restored" when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount when (statsFilesSize /= _filesSize) $ logWarn $ "Files size differs: stats: " <> tshow statsFilesSize <> ", store: " <> tshow _filesSize - logInfo $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files" + logNote $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files" Left e -> do - logInfo $ "error restoring server stats: " <> T.pack e + logNote $ "error restoring server stats: " <> T.pack e liftIO exitFailure diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 4bccda0ff..21e6d06dd 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -103,8 +103,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede used <- countUsedStorage <$> readTVarIO (files store) atomically $ writeTVar (usedStorage store) used forM_ fileSizeQuota $ \quota -> do - logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used) - when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!" + logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used) + when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!" tlsServerCreds <- loadServerCredential xftpCredentials Fingerprint fp <- loadFingerprint xftpCredentials serverStats <- newFileServerStats =<< getCurrentTime diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 50494e781..075e4be48 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -33,7 +33,6 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Util (ifM, safeDecodeUtf8) import System.Exit (exitFailure) -import UnliftIO.MVar -- | Create a new Postgres DBStore with the given connection string, schema name and migrations. -- If passed schema does not exist in connectInfo database, it will be created. @@ -54,23 +53,26 @@ createDBStore opts migrations confirmMigrations = do connectPostgresStore :: DBOpts -> IO DBStore connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do - dbSem <- newMVar () - dbPool <- newTBQueueIO poolSize + dbPriorityPool <- newDBStorePool poolSize + dbPool <- newDBStorePool poolSize dbClosed <- newTVarIO True - let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPool, dbSem, dbNew = False, dbClosed} - dbNew <- connectPool st createSchema + let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbNew = False, dbClosed} + dbNew <- connectStore st createSchema pure st {dbNew} -- uninterruptibleMask_ here and below is used here so that it is not interrupted half-way, -- it relies on the assumption that when dbClosed = True, the queue is empty, -- and when it is False, the queue is full (or will have connections returned to it by the threads that use them). -connectPool :: DBStore -> Bool -> IO Bool -connectPool DBStore {dbConnstr, dbSchema, dbPoolSize, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do +connectStore :: DBStore -> Bool -> IO Bool +connectStore DBStore {dbConnstr, dbSchema, dbPoolSize, dbPriorityPool, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do (conn, dbNew) <- connectDB dbConnstr dbSchema createSchema -- TODO [postgres] analogue for dbBusyLoop? - conns <- replicateM (dbPoolSize - 1) $ fst <$> connectDB dbConnstr dbSchema False - mapM_ (atomically . writeTBQueue dbPool) (conn : conns) + writeConns dbPriorityPool . (conn :) =<< mkConns (dbPoolSize - 1) + writeConns dbPool =<< mkConns dbPoolSize atomically $ writeTVar dbClosed False pure dbNew + where + writeConns pool conns = mapM_ (atomically . writeTBQueue (dbPoolConns pool)) conns + mkConns n = replicateM n $ fst <$> connectDB dbConnstr dbSchema False connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool) connectDB connstr schema createSchema = do @@ -111,16 +113,19 @@ doesSchemaExist db schema = do pure schemaExists closeDBStore :: DBStore -> IO () -closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} = +closeDBStore DBStore {dbPoolSize, dbPriorityPool, dbPool, dbClosed} = ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do - replicateM_ dbPoolSize $ atomically (readTBQueue dbPool) >>= DB.close + closePool dbPriorityPool + closePool dbPool atomically $ writeTVar dbClosed True + where + closePool pool = replicateM_ dbPoolSize $ atomically (readTBQueue $ dbPoolConns pool) >>= DB.close reopenDBStore :: DBStore -> IO () reopenDBStore st = ifM (readTVarIO $ dbClosed st) - (void $ connectPool st False) + (void $ connectStore st False) (putStrLn "reopenDBStore: already opened") -- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index a71376a20..3ca0a755e 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -6,7 +6,9 @@ module Simplex.Messaging.Agent.Store.Postgres.Common ( DBStore (..), + DBStorePool (..), DBOpts (..), + newDBStorePool, withConnection, withConnection', withTransaction, @@ -20,6 +22,7 @@ import Control.Concurrent.STM import Control.Exception (bracket) import Data.ByteString (ByteString) import qualified Database.PostgreSQL.Simple as PSQL +import Numeric.Natural (Natural) import Simplex.Messaging.Agent.Store.Postgres.Options -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) @@ -27,19 +30,40 @@ data DBStore = DBStore { dbConnstr :: ByteString, dbSchema :: ByteString, dbPoolSize :: Int, - dbPool :: TBQueue PSQL.Connection, - -- MVar is needed for fair pool distribution, without STM retry contention. - -- Only one thread can be blocked on STM read. - dbSem :: MVar (), + dbPriorityPool :: DBStorePool, + dbPool :: DBStorePool, + -- dbPoolSize :: Int, + -- dbPool :: TBQueue PSQL.Connection, + -- -- MVar is needed for fair pool distribution, without STM retry contention. + -- -- Only one thread can be blocked on STM read. + -- dbSem :: MVar (), dbClosed :: TVar Bool, dbNew :: Bool } +newDBStorePool :: Natural -> IO DBStorePool +newDBStorePool poolSize = do + dbSem <- newMVar () + dbPoolConns <- newTBQueueIO poolSize + pure DBStorePool {dbSem, dbPoolConns} + +data DBStorePool = DBStorePool + { dbPoolConns :: TBQueue PSQL.Connection, + -- MVar is needed for fair pool distribution, without STM retry contention. + -- Only one thread can be blocked on STM read. + dbSem :: MVar () + } + withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a -withConnectionPriority DBStore {dbPool, dbSem} _priority = +withConnectionPriority DBStore {dbPriorityPool, dbPool} priority = + withConnectionPool $ if priority then dbPriorityPool else dbPool +{-# INLINE withConnectionPriority #-} + +withConnectionPool :: DBStorePool -> (PSQL.Connection -> IO a) -> IO a +withConnectionPool DBStorePool {dbPoolConns, dbSem} = bracket - (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPool) - (atomically . writeTBQueue dbPool) + (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPoolConns) + (atomically . writeTBQueue dbPoolConns) withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a withConnection st = withConnectionPriority st False diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index dab0a4040..1e3d71b66 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -42,7 +42,7 @@ import Simplex.Messaging.Session import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport -import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=), (<$$>)) +import Simplex.Messaging.Util (catchAll_, ifM, safeDecodeUtf8, toChunks, tshow, whenM, ($>>=), (<$$>)) import System.Timeout (timeout) import UnliftIO (async) import qualified UnliftIO.Exception as E @@ -321,7 +321,7 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE where logSMPError :: SMPClientError -> ExceptT SMPClientError IO a logSMPError e = do - liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e + logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host srv) <> "): " <> tshow e throwE e subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO () diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 5407a3bc9..677f14758 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Notifications.Server where import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (mapConcurrently) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -104,7 +105,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} liftIO $ putStrLn "Server started in 'maintenance' mode, exiting" stopServer liftIO $ exitSuccess - resubscribe s + void $ forkIO $ resubscribe s raceAny_ ( ntfSubscriber s : ntfPush ps @@ -135,12 +136,12 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} stopServer :: M () stopServer = do - logInfo "Saving server state..." + logNote "Saving server state..." saveServer NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread)) liftIO $ closeSMPClientAgent smpAgent - logInfo "Server stopped" + logNote "Server stopped" saveServer :: M () saveServer = asks store >>= liftIO . closeNtfDbStore >> saveServerStats @@ -153,7 +154,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} logServerStats :: Int64 -> Int64 -> FilePath -> M () logServerStats startAt logInterval statsFilePath = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime - logInfo $ "server stats log enabled: " <> T.pack statsFilePath + logNote $ "server stats log enabled: " <> T.pack statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, tknReplaced, subCreated, subDeleted, ntfReceived, ntfDelivered, ntfFailed, ntfCronDelivered, ntfCronFailed, ntfVrfQueued, ntfVrfDelivered, ntfVrfFailed, ntfVrfInvalidTkn, activeTokens, activeSubs} <- asks serverStats @@ -267,12 +268,12 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} countSubs acc@(metrics, !otherSrvs) (srv@(SMPServer (h :| _) _ _), srvSubs) = result . M.size <$> readTVarIO srvSubs where - result 0 = acc result cnt | isOwnServer a srv = let !ownSrvSubs' = M.alter (Just . maybe cnt (+ cnt)) host ownSrvSubs metrics' = metrics {ownSrvSubs = ownSrvSubs'} :: NtfSMPSubMetrics in (metrics', otherSrvs) + | cnt == 0 = acc | otherwise = let metrics' = metrics {otherSrvSubCount = otherSrvSubCount + cnt} :: NtfSMPSubMetrics in (metrics', S.insert host otherSrvs) @@ -410,25 +411,33 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} hPutStrLn h "AUTH" resubscribe :: NtfSubscriber -> M () -resubscribe NtfSubscriber {newSubQ} = do - logInfo "Preparing SMP resubscriptions..." +resubscribe NtfSubscriber {smpAgent = ca} = do st <- asks store batchSize <- asks $ subsBatchSize . config liftIO $ do srvs <- getUsedSMPServers st - count <- foldM (subscribeSrvSubs st batchSize) (0 :: Int) srvs - logInfo $ "SMP resubscriptions queued (" <> tshow count <> " subscriptions)" + logNote $ "Starting SMP resubscriptions for " <> tshow (length srvs) <> " servers..." + counts <- mapConcurrently (subscribeSrvSubs st batchSize) srvs + logNote $ "Completed all SMP resubscriptions for " <> tshow (length srvs) <> " servers (" <> tshow (sum counts) <> " subscriptions)" where - subscribeSrvSubs st batchSize !count srv = do - (n, subs_) <- - foldNtfSubscriptions st srv batchSize (0, []) $ \(!i, subs) sub -> - if length subs == batchSize - then write (L.fromList subs) $> (i + 1, []) - else pure (i + 1, sub : subs) - mapM_ write $ L.nonEmpty subs_ - pure $ count + n + subscribeSrvSubs st batchSize srv = do + let srvStr = safeDecodeUtf8 (strEncode $ L.head $ host srv) + logNote $ "Starting SMP resubscriptions for " <> srvStr + n <- loop 0 Nothing + logNote $ "Completed SMP resubscriptions for " <> srvStr <> " (" <> tshow n <> " subscriptions)" + pure n where - write subs = atomically $ writeTBQueue newSubQ (srv, subs) + dbBatchSize = batchSize * 100 + loop n afterSubId_ = + getServerNtfSubscriptions st srv afterSubId_ dbBatchSize >>= \case + Left _ -> exitFailure + Right [] -> pure n + Right subs -> do + mapM_ (subscribeQueuesNtfs ca srv . L.map snd) $ toChunks batchSize subs + let len = length subs + n' = n + len + afterSubId_' = Just $ fst $ last subs + if len < dbBatchSize then pure n' else loop n' afterSubId_' ntfSubscriber :: NtfSubscriber -> M () ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do @@ -437,14 +446,10 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge subscribe :: M () subscribe = forever $ do (srv, subs) <- atomically $ readTBQueue newSubQ - -- TODO [ntfdb] as we now group by server before putting subs to queue, - -- maybe this "subscribe" thread can be removed completely, - -- and the caller would directly write to SMPSubscriber queues SMPSubscriber {subscriberSubQ} <- getSMPSubscriber srv atomically $ writeTQueue subscriberSubQ subs - -- TODO [ntfdb] this does not guarantee that only one subscriber per server is created - -- there should be TMVar in the map + -- TODO [ntfdb] this does not guarantee that only one subscriber per server is created (there should be TMVar in the map) -- This does not need changing if single newSubQ remains, but if it is removed, it need to change getSMPSubscriber :: SMPServer -> M SMPSubscriber getSMPSubscriber smpServer = @@ -466,10 +471,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge subs <- atomically $ readTQueue subscriberSubQ updated <- liftIO $ batchUpdateSubStatus st subs NSPending logSubStatus smpServer "subscribing" (L.length subs) updated - liftIO $ subscribeQueues smpServer subs - - subscribeQueues :: SMPServer -> NonEmpty ServerNtfSub -> IO () - subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map snd subs) + liftIO $ subscribeQueuesNtfs ca smpServer $ L.map snd subs receiveSMP :: M () receiveSMP = forever $ do @@ -613,7 +615,7 @@ periodicNtfsThread NtfPushServer {pushQ} = do threadDelay interval now <- systemSeconds <$> getSystemTime cnt <- withPeriodicNtfTokens st now $ \tkn -> atomically $ writeTBQueue pushQ (tkn, PNCheckMessages) - logInfo $ "Scheduled periodic notifications: " <> tshow cnt + logNote $ "Scheduled periodic notifications: " <> tshow cnt runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M () runNtfClientTransport th@THandle {params} = do @@ -829,14 +831,14 @@ incNtfStat statSel = do restoreServerLastNtfs :: NtfSTMStore -> FilePath -> IO () restoreServerLastNtfs st f = whenM (doesFileExist f) $ do - logInfo $ "restoring last notifications from file " <> T.pack f + logNote $ "restoring last notifications from file " <> T.pack f runExceptT (liftIO (B.readFile f) >>= mapM restoreNtf . B.lines) >>= \case Left e -> do logError . T.pack $ "error restoring last notifications: " <> e exitFailure Right _ -> do renameFile f $ f <> ".bak" - logInfo "last notifications restored" + logNote "last notifications restored" where restoreNtf s = do TNMRv1 tknId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s @@ -851,21 +853,21 @@ saveServerStats = >>= mapM_ (\f -> asks serverStats >>= liftIO . getNtfServerStatsData >>= liftIO . saveStats f) where saveStats f stats = do - logInfo $ "saving server stats to file " <> T.pack f + logNote $ "saving server stats to file " <> T.pack f B.writeFile f $ strEncode stats - logInfo "server stats saved" + logNote "server stats saved" restoreServerStats :: M () restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats where restoreStats f = whenM (doesFileExist f) $ do - logInfo $ "restoring server stats from file " <> T.pack f + logNote $ "restoring server stats from file " <> T.pack f liftIO (strDecode <$> B.readFile f) >>= \case Right d -> do s <- asks serverStats liftIO $ setNtfServerStats s d renameFile f $ f <> ".bak" - logInfo "server stats restored" + logNote "server stats restored" Left e -> do - logInfo $ "error restoring server stats: " <> T.pack e + logNote $ "error restoring server stats: " <> T.pack e liftIO exitFailure diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 415f341cb..2f55a1dd0 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -106,7 +106,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo where compactDbStoreLog = \case Just f -> do - logInfo $ "compacting store log " <> T.pack f + logNote $ "compacting store log " <> T.pack f newNtfSTMStore >>= readWriteNtfSTMStore False f >>= closeStoreLog Nothing -> do logError "Error: `--compact-log` used without `enable: on` option in STORE_LOG section of INI file" diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index f59c565bc..a073eee18 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -10,12 +10,15 @@ module Simplex.Messaging.Notifications.Server.Main where +import Control.Logger.Simple (setLogLevel) import Control.Monad ((<$!>)) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Ini (lookupValue, readIniFile) import Data.Int (Int64) import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as T @@ -27,6 +30,7 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Notifications.Protocol (NtfTokenId) import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) @@ -36,8 +40,9 @@ import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore) import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI -import Simplex.Messaging.Server.Env.STM (StartOptions) +import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Main (strParse) import Simplex.Messaging.Server.Main.Init (iniDbOpts) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Server.StoreLog (closeStoreLog) @@ -72,7 +77,7 @@ ntfServerCLI cfgPath logPath = storeLogExists <- doesFileExist storeLogFilePath lastNtfsExists <- doesFileExist defaultLastNtfsFile case cmd of - SCImport + SCImport skipTokens | schemaExists && (storeLogExists || lastNtfsExists) -> exitConfigureNtfStore connstr schema | schemaExists -> do putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr @@ -94,7 +99,7 @@ ntfServerCLI cfgPath logPath = restoreServerLastNtfs stmStore defaultLastNtfsFile let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} ps <- newNtfDbStore storeCfg - (tCnt, sCnt, nCnt) <- importNtfSTMStore ps stmStore + (tCnt, sCnt, nCnt) <- importNtfSTMStore ps stmStore skipTokens renameFile storeLogFile $ storeLogFile <> ".bak" putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications." putStrLn "Configure database options in INI file." @@ -161,9 +166,6 @@ ntfServerCLI cfgPath logPath = <> iniDbOpts dbOptions defaultNtfDBOpts <> "Time to retain deleted entities in the database, days.\n" <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n") - <> "# Last notifications are optionally saved and restored when the server restarts,\n\ - \# they are preserved in the .bak file until the next restart.\n" - <> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n") <> "log_stats: off\n\n\ \[AUTH]\n\ \# control_port_admin_password:\n\ @@ -200,6 +202,7 @@ ntfServerCLI cfgPath logPath = <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n") enableStoreLog' = settingIsOn "STORE_LOG" "enable" runServer startOptions ini = do + setLogLevel $ logLevel startOptions hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config @@ -230,8 +233,8 @@ ntfServerCLI cfgPath logPath = subIdBytes = 24, regCodeBytes = 32, clientQSize = 64, - subQSize = 512, - pushQSize = 16384, + subQSize = 2048, + pushQSize = 32768, smpAgentCfg = defaultSMPClientAgentConfig { smpCfg = @@ -296,7 +299,7 @@ data CliCommand | Delete | Database StoreCmd DBOpts -data StoreCmd = SCImport | SCExport +data StoreCmd = SCImport (Set NtfTokenId) | SCExport data InitOptions = InitOptions { enableStoreLog :: Bool, @@ -332,9 +335,17 @@ cliCommandP cfgPath logPath iniFile = where databaseCmdP = hsubparser - ( command "import" (info (pure SCImport) (progDesc $ "Import store logs into a new PostgreSQL database schema")) + ( command "import" (info (SCImport <$> skipTokensP) (progDesc $ "Import store logs into a new PostgreSQL database schema")) <> command "export" (info (pure SCExport) (progDesc $ "Export PostgreSQL database schema to store logs")) ) + skipTokensP :: Parser (Set NtfTokenId) + skipTokensP = + option + strParse + ( long "skip-tokens" + <> help "Skip tokens during import" + <> value S.empty + ) initP :: Parser InitOptions initP = do enableStoreLog <- diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 7439e4fea..39aeb9329 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -33,15 +33,19 @@ import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.CaseInsensitive as CI import Data.Int (Int64) +import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock.System import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS +import Network.HPACK.Token as HT import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import Network.HTTP2.Client (Request) @@ -330,9 +334,16 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing let status = H.responseStatus response reason' = maybe "" reason $ J.decodeStrict' bodyHead - logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason' + if status == Just N.ok200 + then logDebug $ "APNS response: ok" <> apnsIds response + else logWarn $ "APNS error: " <> T.pack (show status) <> " " <> reason' <> apnsIds response result status reason' where + apnsIds response = headerStr "apns-id" <> headerStr "apns-unique-id" + where + headerStr name = + maybe "" (\(_, v) -> ", " <> name <> ": " <> safeDecodeUtf8 v) $ + find (\(t, _) -> HT.tokenKey t == CI.mk (encodeUtf8 name)) (fst (H.responseHeaders response)) result :: Maybe Status -> Text -> ExceptT PushProviderError IO () result status reason' | status == Just N.ok200 = pure () diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 031eda711..112d4cedd 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -113,7 +113,7 @@ closeNtfDbStore NtfPostgresStore {dbStore, dbStoreLog} = do addNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) addNtfToken st tkn = - withDB "addNtfToken" st $ \db -> + withFastDB "addNtfToken" st $ \db -> E.try (DB.execute db insertNtfTknQuery $ ntfTknToRow tkn) >>= bimapM handleDuplicate (\_ -> withLog "addNtfToken" st (`logCreateToken` tkn)) @@ -127,7 +127,7 @@ insertNtfTknQuery = replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} = - withDB "replaceNtfToken" st $ \db -> runExceptT $ do + withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do ExceptT $ assertUpdated <$> DB.execute db @@ -156,7 +156,7 @@ findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec)) getNtfToken_ st cond params = - withDB' "getNtfToken" st $ \db -> do + withFastDB' "getNtfToken" st $ \db -> do tkn_ <- maybeFirstRow rowToNtfTkn $ DB.query db (ntfTknQuery <> cond) params mapM_ (updateTokenDate st db) tkn_ pure tkn_ @@ -185,7 +185,7 @@ rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey deleteNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType [(SMPServer, [NotifierId])]) deleteNtfToken st tknId = - withDB "deleteNtfToken" st $ \db -> runExceptT $ do + withFastDB "deleteNtfToken" st $ \db -> runExceptT $ do -- This SELECT obtains exclusive lock on token row and prevents any inserts -- into other tables for this token ID until the deletion completes. _ <- ExceptT $ firstRow (fromOnly @Int) AUTH $ @@ -230,7 +230,7 @@ rowToSMPQueue (host, port, kh, nId) = SMPQueueNtf (SMPServer host port kh) nId updateTknCronInterval :: NtfPostgresStore -> NtfTokenId -> Word16 -> IO (Either ErrorType ()) updateTknCronInterval st tknId cronInt = - withDB "updateTknCronInterval" st $ \db -> runExceptT $ do + withFastDB "updateTknCronInterval" st $ \db -> runExceptT $ do ExceptT $ assertUpdated <$> DB.execute db "UPDATE tokens SET cron_interval = ? WHERE token_id = ?" (cronInt, tknId) withLog "updateTknCronInterval" st $ \sl -> logTokenCron sl tknId 0 @@ -254,10 +254,27 @@ getUsedSMPServers st = |] (Only (In [NSNew, NSPending, NSActive, NSInactive])) -foldNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Int -> s -> (s -> ServerNtfSub -> IO s) -> IO s -foldNtfSubscriptions st srv fetchCount state action = - withConnection (dbStore st) $ \db -> - DB.foldWithOptions opts db query params state $ \s -> action s . toServerNtfSub +getServerNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Maybe NtfSubscriptionId -> Int -> IO (Either ErrorType [ServerNtfSub]) +getServerNtfSubscriptions st srv afterSubId_ count = + withDB' "getServerNtfSubscriptions" st $ \db -> do + subs <- + map toServerNtfSub <$> case afterSubId_ of + Nothing -> + DB.query db (query <> orderLimit) (srvToRow srv :. (statusIn, count)) + Just afterSubId -> + DB.query db (query <> " AND s.subscription_id > ?" <> orderLimit) (srvToRow srv :. (statusIn, afterSubId, count)) + void $ + DB.executeMany + db + [sql| + UPDATE subscriptions s + SET status = upd.status + FROM (VALUES(?, ?)) AS upd(status, subscription_id) + WHERE s.subscription_id = (upd.subscription_id :: BYTEA) + AND s.status != upd.status + |] + (map ((NSPending,) . fst) subs) + pure subs where query = [sql| @@ -267,15 +284,15 @@ foldNtfSubscriptions st srv fetchCount state action = WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.status IN ? |] - params = srvToRow srv :. Only (In [NSNew, NSPending, NSActive, NSInactive]) - opts = DB.defaultFoldOptions {DB.fetchQuantity = DB.Fixed fetchCount} + orderLimit = " ORDER BY s.subscription_id LIMIT ?" + statusIn = In [NSNew, NSPending, NSActive, NSInactive] toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey)) -- Returns token and subscription. -- If subscription exists but belongs to another token, returns Left AUTH findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec)) findNtfSubscription st tknId q = - withDB "findNtfSubscription" st $ \db -> runExceptT $ do + withFastDB "findNtfSubscription" st $ \db -> runExceptT $ do tkn@NtfTknRec {ntfTknId, tknStatus} <- ExceptT $ getNtfToken st tknId unless (allowNtfSubCommands tknStatus) $ throwE AUTH liftIO $ updateTokenDate st db tkn @@ -296,7 +313,7 @@ findNtfSubscription st tknId q = getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec)) getNtfSubscription st subId = - withDB "getNtfSubscription" st $ \db -> runExceptT $ do + withFastDB "getNtfSubscription" st $ \db -> runExceptT $ do r@(tkn@NtfTknRec {tknStatus}, _) <- ExceptT $ firstRow rowToNtfTknSub AUTH $ DB.query @@ -333,7 +350,7 @@ mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ()) updateTknStatus st tkn status = - withDB' "updateTknStatus" st $ \db -> updateTknStatus_ st db tkn status + withFastDB' "updateTknStatus" st $ \db -> updateTknStatus_ st db tkn status updateTknStatus_ :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> NtfTknStatus -> IO () updateTknStatus_ st db NtfTknRec {ntfTknId} status = do @@ -343,13 +360,13 @@ updateTknStatus_ st db NtfTknRec {ntfTknId} status = do -- unless it was already active setTknStatusConfirmed :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) setTknStatusConfirmed st NtfTknRec {ntfTknId} = - withDB' "updateTknStatus" st $ \db -> do + withFastDB' "updateTknStatus" st $ \db -> do updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ? AND status != ?" (NTConfirmed, ntfTknId, NTConfirmed, NTActive) when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} = - withDB' "setTokenActive" st $ \db -> do + withFastDB' "setTokenActive" st $ \db -> do updateTknStatus_ st db tkn NTActive -- this removes other instances of the same token, e.g. because of repeated token registration attempts tknIds <- @@ -377,7 +394,7 @@ updateTokenCronSentAt st tknId now = addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool) addNtfSubscription st sub = - withDB "addNtfSubscription" st $ \db -> runExceptT $ do + withFastDB "addNtfSubscription" st $ \db -> runExceptT $ do srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub withLog "addNtfSubscription" st (`logCreateSubscription` sub) @@ -423,14 +440,14 @@ ntfSubToRow srvId NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf _ nId, no deleteNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType ()) deleteNtfSubscription st subId = - withDB "deleteNtfSubscription" st $ \db -> runExceptT $ do + withFastDB "deleteNtfSubscription" st $ \db -> runExceptT $ do ExceptT $ assertUpdated <$> DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId) withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId) updateSrvSubStatus :: NtfPostgresStore -> SMPQueueNtf -> NtfSubStatus -> IO (Either ErrorType ()) updateSrvSubStatus st q status = - withDB' "updateSrvSubStatus" st $ \db -> do + withFastDB' "updateSrvSubStatus" st $ \db -> do subId_ :: Maybe NtfSubscriptionId <- maybeFirstRow fromOnly $ DB.query @@ -507,7 +524,7 @@ batchUpdateStatus_ st srv mkParams = batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty ServerNtfSub -> NtfSubStatus -> IO Int64 batchUpdateSubStatus st subs status = - fmap (fromRight (-1)) $ withDB' "batchUpdateSubStatus" st $ \db -> do + fmap (fromRight (-1)) $ withFastDB' "batchUpdateSubStatus" st $ \db -> do let params = L.toList $ L.map (\(subId, _) -> (status, subId)) subs subIds <- DB.returning @@ -533,7 +550,7 @@ batchUpdateSubStatus st subs status = addTokenLastNtf :: NtfPostgresStore -> PNMessageData -> IO (Either ErrorType (NtfTknRec, NonEmpty PNMessageData)) addTokenLastNtf st newNtf = - withDB "addTokenLastNtf" st $ \db -> runExceptT $ do + withFastDB "addTokenLastNtf" st $ \db -> runExceptT $ do (tkn@NtfTknRec {ntfTknId = tId, tknStatus}, sId) <- ExceptT $ firstRow toTokenSubId AUTH $ DB.query @@ -607,8 +624,8 @@ getEntityCounts st = count (Only n : _) = n count [] = 0 -importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> IO (Int64, Int64, Int64) -importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do +importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, Int64, Int64) +importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do (tIds, tCnt) <- importTokens subLookup <- readTVarIO $ subscriptionLookup stmStore sCnt <- importSubscriptions tIds subLookup @@ -638,6 +655,7 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do case M.lookup (tokenKey tkn) deviceTokens of Just ts | length ts < 2 -> pure True + | ntfTknId `S.member` skipTokens -> False <$ putStrLn ("Skipped token " <> enc ntfTknId <> " from --skip-tokens") | otherwise -> readTVarIO tknStatus >>= \case NTConfirmed -> do @@ -645,8 +663,8 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do if hasSubs then pure True else do - anyActive <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> (NTActive ==) <$> readTVarIO tknStatus') ts - if anyActive + anyBetterToken <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> activeOrInvalid <$> readTVarIO tknStatus') ts + if anyBetterToken then False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId) else case findIndex (\NtfTknData {ntfTknId = tId} -> tId == ntfTknId) ts of Just 0 -> pure True -- keeping the first token @@ -654,6 +672,10 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore = do Nothing -> True <$ putStrLn "Error: no device token in the list" _ -> pure True Nothing -> True <$ putStrLn "Error: no device token in lookup map" + activeOrInvalid = \case + NTActive -> True + NTInvalid _ -> True + _ -> False -- importTkn db !n tkn@NtfTknData {ntfTknId} = do -- tknRow <- ntfTknToRow <$> mkTknRec tkn -- (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) -> @@ -799,12 +821,25 @@ exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFi |] encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n' +withFastDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a) +withFastDB' op st action = withFastDB op st $ fmap Right . action +{-# INLINE withFastDB' #-} + withDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a) withDB' op st action = withDB op st $ fmap Right . action +{-# INLINE withDB' #-} + +withFastDB :: forall a. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) +withFastDB op st = withDB_ op st True +{-# INLINE withFastDB #-} withDB :: forall a. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) -withDB op st action = - E.uninterruptibleMask_ $ E.try (withTransaction (dbStore st) action) >>= either logErr pure +withDB op st = withDB_ op st False +{-# INLINE withDB #-} + +withDB_ :: forall a. String -> NtfPostgresStore -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) +withDB_ op st priority action = + E.uninterruptibleMask_ $ E.try (withTransactionPriority (dbStore st) priority action) >>= either logErr pure where logErr :: E.SomeException -> IO (Either ErrorType a) logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) diff --git a/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql b/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql new file mode 100644 index 000000000..4c98a1161 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql @@ -0,0 +1,178 @@ + + +SET statement_timeout = 0; +SET lock_timeout = 0; +SET idle_in_transaction_session_timeout = 0; +SET client_encoding = 'UTF8'; +SET standard_conforming_strings = on; +SELECT pg_catalog.set_config('search_path', '', false); +SET check_function_bodies = false; +SET xmloption = content; +SET client_min_messages = warning; +SET row_security = off; + + +CREATE SCHEMA ntf_server; + + +SET default_table_access_method = heap; + + +CREATE TABLE ntf_server.last_notifications ( + token_ntf_id bigint NOT NULL, + token_id bytea NOT NULL, + subscription_id bytea NOT NULL, + sent_at timestamp with time zone NOT NULL, + nmsg_nonce bytea NOT NULL, + nmsg_data bytea NOT NULL +); + + + +ALTER TABLE ntf_server.last_notifications ALTER COLUMN token_ntf_id ADD GENERATED ALWAYS AS IDENTITY ( + SEQUENCE NAME ntf_server.last_notifications_token_ntf_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1 +); + + + +CREATE TABLE ntf_server.migrations ( + name text NOT NULL, + ts timestamp without time zone NOT NULL, + down text +); + + + +CREATE TABLE ntf_server.smp_servers ( + smp_server_id bigint NOT NULL, + smp_host text NOT NULL, + smp_port text NOT NULL, + smp_keyhash bytea NOT NULL +); + + + +ALTER TABLE ntf_server.smp_servers ALTER COLUMN smp_server_id ADD GENERATED ALWAYS AS IDENTITY ( + SEQUENCE NAME ntf_server.smp_servers_smp_server_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1 +); + + + +CREATE TABLE ntf_server.subscriptions ( + subscription_id bytea NOT NULL, + token_id bytea NOT NULL, + smp_server_id bigint, + smp_notifier_id bytea NOT NULL, + smp_notifier_key bytea NOT NULL, + status text NOT NULL +); + + + +CREATE TABLE ntf_server.tokens ( + token_id bytea NOT NULL, + push_provider text NOT NULL, + push_provider_token bytea NOT NULL, + status text NOT NULL, + verify_key bytea NOT NULL, + dh_priv_key bytea NOT NULL, + dh_secret bytea NOT NULL, + reg_code bytea NOT NULL, + cron_interval bigint NOT NULL, + cron_sent_at bigint, + updated_at bigint +); + + + +ALTER TABLE ONLY ntf_server.last_notifications + ADD CONSTRAINT last_notifications_pkey PRIMARY KEY (token_ntf_id); + + + +ALTER TABLE ONLY ntf_server.migrations + ADD CONSTRAINT migrations_pkey PRIMARY KEY (name); + + + +ALTER TABLE ONLY ntf_server.smp_servers + ADD CONSTRAINT smp_servers_pkey PRIMARY KEY (smp_server_id); + + + +ALTER TABLE ONLY ntf_server.subscriptions + ADD CONSTRAINT subscriptions_pkey PRIMARY KEY (subscription_id); + + + +ALTER TABLE ONLY ntf_server.tokens + ADD CONSTRAINT tokens_pkey PRIMARY KEY (token_id); + + + +CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id); + + + +CREATE INDEX idx_last_notifications_token_id_sent_at ON ntf_server.last_notifications USING btree (token_id, sent_at); + + + +CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON ntf_server.last_notifications USING btree (token_id, subscription_id); + + + +CREATE UNIQUE INDEX idx_smp_servers ON ntf_server.smp_servers USING btree (smp_host, smp_port, smp_keyhash); + + + +CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON ntf_server.subscriptions USING btree (smp_server_id, smp_notifier_id); + + + +CREATE INDEX idx_subscriptions_smp_server_id_status ON ntf_server.subscriptions USING btree (smp_server_id, status); + + + +CREATE INDEX idx_subscriptions_token_id ON ntf_server.subscriptions USING btree (token_id); + + + +CREATE UNIQUE INDEX idx_tokens_push_provider_token ON ntf_server.tokens USING btree (push_provider, push_provider_token, verify_key); + + + +CREATE INDEX idx_tokens_status_cron_interval_sent_at ON ntf_server.tokens USING btree (status, cron_interval, ((cron_sent_at + (cron_interval * 60)))); + + + +ALTER TABLE ONLY ntf_server.last_notifications + ADD CONSTRAINT last_notifications_subscription_id_fkey FOREIGN KEY (subscription_id) REFERENCES ntf_server.subscriptions(subscription_id) ON UPDATE RESTRICT ON DELETE CASCADE; + + + +ALTER TABLE ONLY ntf_server.last_notifications + ADD CONSTRAINT last_notifications_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE; + + + +ALTER TABLE ONLY ntf_server.subscriptions + ADD CONSTRAINT subscriptions_smp_server_id_fkey FOREIGN KEY (smp_server_id) REFERENCES ntf_server.smp_servers(smp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT; + + + +ALTER TABLE ONLY ntf_server.subscriptions + ADD CONSTRAINT subscriptions_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE; + + + diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 2f3dea57f..db041c4e7 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -208,14 +208,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt sigIntHandler = Just (sigIntAction, toDyn ()) void $ liftIO $ setHandler sigINT sigIntHandler atomically $ readTMVar flagINT - logInfo "Received SIGINT, stopping server..." + logNote "Received SIGINT, stopping server..." stopServer :: Server -> M () stopServer s = do asks serverActive >>= atomically . (`writeTVar` False) - logInfo "Saving server state..." + logNote "Saving server state..." withLock' (savingLock s) "final" $ saveServer True >> closeServer - logInfo "Server stopped" + logNote "Server stopped" saveServer :: Bool -> M () saveServer drainMsgs = do @@ -383,9 +383,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt expire :: forall s. MsgStoreClass s => s -> ServerStats -> Int64 -> IO () expire ms stats interval = do threadDelay' interval - logInfo "Started expiring messages..." + logNote "Started expiring messages..." n <- compactQueues @(StoreQueue s) $ queueStore ms - when (n > 0) $ logInfo $ "Removed " <> tshow n <> " old deleted queues from the database." + when (n > 0) $ logNote $ "Removed " <> tshow n <> " old deleted queues from the database." now <- systemSeconds <$> getSystemTime tryAny (expireOldMessages False ms now ttl) >>= \case Right msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} -> do @@ -1827,15 +1827,15 @@ saveServerMessages :: Bool -> AMsgStore -> IO () saveServerMessages drainMsgs = \case AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> exportMessages False ms f drainMsgs - Nothing -> logInfo "undelivered messages are not saved" - AMS _ SMSJournal _ -> logInfo "closed journal message storage" + Nothing -> logNote "undelivered messages are not saved" + AMS _ SMSJournal _ -> logNote "closed journal message storage" exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () exportMessages tty ms f drainMsgs = do - logInfo $ "saving messages to file " <> T.pack f + logNote $ "saving messages to file " <> T.pack f liftIO $ withFile f WriteMode $ \h -> tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case - Right (Sum total) -> logInfo $ "messages saved: " <> tshow total + Right (Sum total) -> logNote $ "messages saved: " <> tshow total Left e -> do logError $ "error exporting messages: " <> tshow e exitFailure @@ -1864,10 +1864,10 @@ processServerMessages StartOptions {skipWarnings} = do processJournalMessages old_ expire ms | expire = Just <$> case old_ of Just old -> do - logInfo "expiring journal store messages..." + logNote "expiring journal store messages..." run $ processExpireQueue old Nothing -> do - logInfo "validating journal store messages..." + logNote "validating journal store messages..." run processValidateQueue | otherwise = logWarn "skipping message expiration" $> Nothing where @@ -1885,7 +1885,7 @@ processServerMessages StartOptions {skipWarnings} = do importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats importMessages tty ms f old_ skipWarnings = do - logInfo $ "restoring messages from file " <> T.pack f + logNote $ "restoring messages from file " <> T.pack f (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <- foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty)) renameFile f $ f <> ".bak" @@ -1950,17 +1950,17 @@ importMessages tty ms f old_ skipWarnings = do printMessageStats :: T.Text -> MessageStats -> IO () printMessageStats name MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} = - logInfo $ name <> " stored: " <> tshow storedMsgsCount <> ", expired: " <> tshow expiredMsgsCount <> ", queues: " <> tshow storedQueues + logNote $ name <> " stored: " <> tshow storedMsgsCount <> ", expired: " <> tshow expiredMsgsCount <> ", queues: " <> tshow storedQueues saveServerNtfs :: M () saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs where saveNtfs f = do - logInfo $ "saving notifications to file " <> T.pack f + logNote $ "saving notifications to file " <> T.pack f NtfStore ns <- asks ntfStore liftIO . withFile f WriteMode $ \h -> readTVarIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs - logInfo "notifications saved" + logNote "notifications saved" where -- reverse on save, to save notifications in order, will become reversed again when restoring. saveQueueNtfs h (nId, v) = BLD.hPutBuilder h . encodeNtfs nId . reverse =<< readTVarIO v @@ -1973,7 +1973,7 @@ restoreServerNtfs = Nothing -> pure newMessageStats where restoreNtfs f = do - logInfo $ "restoring notifications from file " <> T.pack f + logNote $ "restoring notifications from file " <> T.pack f ns <- asks ntfStore old <- asks (notificationExpiration . config) >>= liftIO . expireBeforeEpoch liftIO $ @@ -1985,7 +1985,7 @@ restoreServerNtfs = renameFile f $ f <> ".bak" let NtfStore ns' = ns storedQueues <- M.size <$> readTVarIO ns' - logInfo $ "notifications restored, " <> tshow lineCount <> " lines processed" + logNote $ "notifications restored, " <> tshow lineCount <> " lines processed" pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where restoreNtf :: NtfStore -> Int64 -> (Int, Int, Int) -> LB.ByteString -> ExceptT String IO (Int, Int, Int) @@ -2006,15 +2006,15 @@ saveServerStats = >>= mapM_ (\f -> asks serverStats >>= liftIO . getServerStatsData >>= liftIO . saveStats f) where saveStats f stats = do - logInfo $ "saving server stats to file " <> T.pack f + logNote $ "saving server stats to file " <> T.pack f B.writeFile f $ strEncode stats - logInfo "server stats saved" + logNote "server stats saved" restoreServerStats :: Maybe MessageStats -> MessageStats -> M () restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats where restoreStats f = whenM (doesFileExist f) $ do - logInfo $ "restoring server stats from file " <> T.pack f + logNote $ "restoring server stats from file " <> T.pack f liftIO (strDecode <$> B.readFile f) >>= \case Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do s <- asks serverStats @@ -2026,12 +2026,12 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >> _msgNtfExpired' = _msgNtfExpired d + expiredMsgsCount ntfStats liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired', _msgNtfExpired = _msgNtfExpired'} renameFile f $ f <> ".bak" - logInfo "server stats restored" + logNote "server stats restored" compareCounts "Queue" statsQCount _qCount compareCounts "Message" statsMsgCount _msgCount compareCounts "Notification" statsNtfCount _ntfCount Left e -> do - logInfo $ "error restoring server stats: " <> T.pack e + logNote $ "error restoring server stats: " <> T.pack e liftIO exitFailure compareCounts name statsCnt storeCnt = when (statsCnt /= storeCnt) $ logWarn $ name <> " count differs: stats: " <> tshow statsCnt <> ", store: " <> tshow storeCnt \ No newline at end of file diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index a678825af..ceb131b7f 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -12,6 +12,7 @@ module Simplex.Messaging.Server.CLI where +import Control.Logger.Simple (LogLevel (..)) import Control.Monad import Data.ASN1.Types (asn1CharacterToString) import Data.ByteString.Char8 (ByteString) @@ -218,6 +219,14 @@ startOptionsP = do ( long "compact-log" <> help "Compact store log (always enabled with `memory` storage for queues)" ) + logLevel <- + option + parseLogLevel + ( long "log-level" + <> metavar "LOG_LEVEL" + <> help "Logging level" + <> value LogInfo + ) skipWarnings <- switch ( long "skip-warnings" @@ -231,7 +240,7 @@ startOptionsP = do <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" <> value MCConsole ) - pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations} + pure StartOptions {maintenance, compactLog, logLevel, skipWarnings, confirmMigrations} where parseConfirmMigrations :: ReadM MigrationConfirmation parseConfirmMigrations = eitherReader $ \case @@ -239,6 +248,16 @@ startOptionsP = do "down" -> Right MCYesUpDown _ -> Left "invalid migration confirmation, pass 'up' or 'down'" +parseLogLevel :: ReadM LogLevel +parseLogLevel = eitherReader $ \case + "trace" -> Right LogTrace + "debug" -> Right LogDebug + "info" -> Right LogInfo + "note" -> Right LogNote + "warn" -> Right LogWarn + "error" -> Right LogError + _ -> Left "Invalid log level" + genOnline :: FilePath -> CertOptions -> IO () genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do (signAlgorithm, commonName) <- diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 5f3be4a98..8895ba8ed 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -136,6 +136,7 @@ data ServerConfig = ServerConfig data StartOptions = StartOptions { maintenance :: Bool, compactLog :: Bool, + logLevel :: LogLevel, skipWarnings :: Bool, confirmMigrations :: MigrationConfirmation } @@ -367,13 +368,13 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp where loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO () loadStoreLog mkQ f st = do - logInfo $ "restoring queues from file " <> T.pack f + logNote $ "restoring queues from file " <> T.pack f sl <- readWriteQueueStore False mkQ f st setStoreLog st sl #if defined(dbServerPostgres) compactDbStoreLog = \case Just f -> do - logInfo $ "compacting queues in file " <> T.pack f + logNote $ "compacting queues in file " <> T.pack f st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota} -- we don't need to have locks in the map sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 844d8d86d..081c91706 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -320,6 +320,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = SPRandom -> BasicAuth <$> randomBase64 32 randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom) runServer startOptions ini = do + setLogLevel $ logLevel startOptions hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config @@ -650,7 +651,7 @@ data CliCommand | Start StartOptions | Delete | Journal StoreCmd - | Database StoreCmd DBOpts + | Database StoreCmd DBOpts data StoreCmd = SCImport | SCExport | SCDelete @@ -835,5 +836,6 @@ cliCommandP cfgPath logPath iniFile = <> metavar (metavar' <> "_COUNTRY") <> help (help' <> " country") ) - strParse :: StrEncoding a => ReadM a - strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack + +strParse :: StrEncoding a => ReadM a +strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 80a2b75aa..dffc818e3 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -267,7 +267,7 @@ readWriteStoreLog readStore writeStore f st = logWarn $ "Server terminated abnormally on last start, restoring state from " <> T.pack tempBackup whenM (doesFileExist f) $ do renameFile f (f <> ".bak") - logInfo $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak") + logNote $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak") renameFile tempBackup f readWriteLog = do -- log backup is made in two steps to mitigate the crash during the compacting. @@ -280,14 +280,14 @@ readWriteStoreLog readStore writeStore f st = pure s writeLog msg = do s <- openWriteStoreLog False f - logInfo msg + logNote msg writeStore s st pure s renameBackup = do ts <- getCurrentTime let timedBackup = f <> "." <> iso8601Show ts renameFile tempBackup timedBackup - logInfo $ "original state preserved as " <> T.pack timedBackup + logNote $ "original state preserved as " <> T.pack timedBackup removeStoreLogBackups :: FilePath -> IO () removeStoreLogBackups f = do diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 1f0d82195..0be54eb7b 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -202,7 +202,7 @@ startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStart sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 withFdSocket sock setCloseOnExecIfNeeded - logInfo $ "binding to " <> tshow (addrAddress addr) + logNote $ "binding to " <> tshow (addrAddress addr) bind sock $ addrAddress addr listen sock 1024 pure sock diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 2d92b4b5e..3d00257a2 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -224,6 +224,7 @@ groupOn = groupBy . eqOn groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]] groupAllOn f = groupOn f . sortOn f +-- n must be > 0 toChunks :: Int -> [a] -> [NonEmpty a] toChunks _ [] = [] toChunks n xs = diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 11d0400d6..f20264cb8 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -34,7 +34,7 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket -import SMPClient (ntfTestPort, prevRange, serverBracket) +import SMPClient (defaultStartOptions, ntfTestPort, prevRange, serverBracket) import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) @@ -48,7 +48,6 @@ import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport @@ -162,7 +161,7 @@ ntfServerCfg = prometheusMetricsFile = ntfTestPrometheusMetricsFile, ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig, - startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} + startOptions = defaultStartOptions } ntfServerCfgVPrev :: NtfServerConfig diff --git a/tests/PostgresSchemaDump.hs b/tests/PostgresSchemaDump.hs new file mode 100644 index 000000000..de96e76ac --- /dev/null +++ b/tests/PostgresSchemaDump.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PostgresSchemaDump (postgresSchemaDumpTest) where + +import Control.Concurrent (threadDelay) +import Control.DeepSeq +import Control.Monad (unless, void) +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import Data.Maybe (fromJust, isJust) +import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Util (ifM, whenM) +import System.Directory (doesFileExist, removeFile) +import System.Environment (lookupEnv) +import System.Process (readCreateProcess, shell) +import Test.Hspec + +testSchemaPath :: FilePath +testSchemaPath = "tests/tmp/test_schema.sql" + +postgresSchemaDumpTest :: [Migration] -> [String] -> DBOpts -> FilePath -> Spec +postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBOpts {connstr, schema = testDBSchema} srcSchemaPath = do + it "verify and overwrite schema dump" testVerifySchemaDump + it "verify schema down migrations" testSchemaMigrations + where + testVerifySchemaDump = do + savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "") + savedSchema `deepseq` pure () + void $ createDBStore testDBOpts migrations MCConsole + getSchema srcSchemaPath `shouldReturn` savedSchema + + testSchemaMigrations = do + let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations + Right st <- createDBStore testDBOpts noDownMigrations MCError + mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations + closeDBStore st + whenM (doesFileExist testSchemaPath) $ removeFile testSchemaPath + where + testDownMigration st m = do + putStrLn $ "down migration " <> name m + let downMigr = fromJust $ toDownMigration m + schema <- getSchema testSchemaPath + Migrations.run st $ MTRUp [m] + schema' <- getSchema testSchemaPath + schema' `shouldNotBe` schema + Migrations.run st $ MTRDown [downMigr] + unless (name m `elem` skipComparisonForDownMigrations) $ do + schema'' <- getSchema testSchemaPath + schema'' `shouldBe` schema + Migrations.run st $ MTRUp [m] + schema''' <- getSchema testSchemaPath + schema''' `shouldBe` schema' + + getSchema :: FilePath -> IO String + getSchema schemaPath = do + ci <- (Just "true" ==) <$> lookupEnv "CI" + let cmd = + ("pg_dump " <> B.unpack connstr <> " --schema " <> B.unpack testDBSchema) + <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > " + <> schemaPath + void $ readCreateProcess (shell cmd) "" + threadDelay 20000 + let sed = (if ci then "sed -i" else "sed -i ''") + void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) "" + sch <- readFile schemaPath + sch `deepseq` pure sch diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 801b7f42e..693049cca 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -14,6 +14,7 @@ module SMPClient where +import Control.Logger.Simple (LogLevel (..)) import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) @@ -223,9 +224,12 @@ cfgMS msType = allowSMPProxy = False, serverClientConcurrency = 2, information = Nothing, - startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} + startOptions = defaultStartOptions } +defaultStartOptions :: StartOptions +defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = LogError, skipWarnings = False, confirmMigrations = MCYesUp} + serverStoreConfig :: AStoreType -> AServerStoreCfg serverStoreConfig = serverStoreConfig_ False diff --git a/tests/ServerTests/SchemaDump.hs b/tests/ServerTests/SchemaDump.hs deleted file mode 100644 index e3ffdb5cb..000000000 --- a/tests/ServerTests/SchemaDump.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module ServerTests.SchemaDump where - -import Control.Concurrent (threadDelay) -import Control.DeepSeq -import Control.Monad (unless, void) -import qualified Data.ByteString.Char8 as B -import Data.List (dropWhileEnd) -import Data.Maybe (fromJust, isJust) -import SMPClient -import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) -import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations -import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) -import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) -import Simplex.Messaging.Util (ifM) -import System.Directory (doesFileExist, removeFile) -import System.Environment (lookupEnv) -import System.Process (readCreateProcess, readCreateProcessWithExitCode, shell) -import Test.Hspec - -testDBSchema :: B.ByteString -testDBSchema = "smp_server" - -serverSchemaPath :: FilePath -serverSchemaPath = "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" - -testSchemaPath :: FilePath -testSchemaPath = "tests/tmp/test_server_schema.sql" - -testServerDBOpts :: DBOpts -testServerDBOpts = - DBOpts - { connstr = testServerDBConnstr, - schema = testDBSchema, - poolSize = 3, - createSchema = True - } - -serverSchemaDumpTest :: Spec -serverSchemaDumpTest = do - it "verify and overwrite schema dump" testVerifySchemaDump - it "verify schema down migrations" testSchemaMigrations - -testVerifySchemaDump :: IO () -testVerifySchemaDump = do - savedSchema <- ifM (doesFileExist serverSchemaPath) (readFile serverSchemaPath) (pure "") - savedSchema `deepseq` pure () - void $ createDBStore testServerDBOpts serverMigrations MCConsole - getSchema serverSchemaPath `shouldReturn` savedSchema - -testSchemaMigrations :: IO () -testSchemaMigrations = do - let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) serverMigrations - Right st <- createDBStore testServerDBOpts noDownMigrations MCError - mapM_ (testDownMigration st) $ drop (length noDownMigrations) serverMigrations - closeDBStore st - removeFile testSchemaPath - where - testDownMigration st m = do - putStrLn $ "down migration " <> name m - let downMigr = fromJust $ toDownMigration m - schema <- getSchema testSchemaPath - Migrations.run st $ MTRUp [m] - schema' <- getSchema testSchemaPath - schema' `shouldNotBe` schema - Migrations.run st $ MTRDown [downMigr] - unless (name m `elem` skipComparisonForDownMigrations) $ do - schema'' <- getSchema testSchemaPath - schema'' `shouldBe` schema - Migrations.run st $ MTRUp [m] - schema''' <- getSchema testSchemaPath - schema''' `shouldBe` schema' - -skipComparisonForDownMigrations :: [String] -skipComparisonForDownMigrations = - [ -- snd_secure moves to the bottom on down migration - "20250320_short_links" - ] - -getSchema :: FilePath -> IO String -getSchema schemaPath = do - ci <- (Just "true" ==) <$> lookupEnv "CI" - let cmd = - ("pg_dump " <> B.unpack testServerDBConnstr <> " --schema " <> B.unpack testDBSchema) - <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > " - <> schemaPath - (code, out, err) <- readCreateProcessWithExitCode (shell cmd) "" - print code - putStrLn $ "out: " <> out - putStrLn $ "err: " <> err - threadDelay 20000 - let sed = (if ci then "sed -i" else "sed -i ''") - void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) "" - sch <- readFile schemaPath - sch `deepseq` pure sch diff --git a/tests/Test.hs b/tests/Test.hs index 653538faf..f0827f5fe 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -43,9 +43,11 @@ import AgentTests.SchemaDump (schemaDumpTest) #if defined(dbServerPostgres) import NtfServerTests (ntfServerTests) -import NtfClient (ntfTestServerDBConnectInfo) -import SMPClient (testServerDBConnectInfo) -import ServerTests.SchemaDump +import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts) +import PostgresSchemaDump (postgresSchemaDumpTest) +import SMPClient (testServerDBConnectInfo, testStoreDBOpts) +import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations) +import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) #endif #if defined(dbPostgres) || defined(dbServerPostgres) @@ -58,7 +60,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do -- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs" - setLogLevel LogError -- LogInfo + setLogLevel LogError -- LogInfo -- also change in SMPClient.hs in defaultStartOptions withGlobalLogging logCfg $ do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" @@ -93,7 +95,13 @@ main = do describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) around_ (postgressBracket testServerDBConnectInfo) $ - describe "Server schema dump" serverSchemaDumpTest + describe "SMP server schema dump" $ + postgresSchemaDumpTest + serverMigrations + [ "20250320_short_links" -- snd_secure moves to the bottom on down migration + ] -- skipComparisonForDownMigrations + testStoreDBOpts + "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" aroundAll_ (postgressBracket testServerDBConnectInfo) $ describe "SMP server via TLS, postgres+jornal message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests @@ -107,6 +115,13 @@ main = do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests #if defined(dbServerPostgres) + around_ (postgressBracket ntfTestServerDBConnectInfo) $ + describe "Ntf server schema dump" $ + postgresSchemaDumpTest + ntfServerMigrations + [] -- skipComparisonForDownMigrations + ntfTestStoreDBOpts + "src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql" aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ do describe "Notifications server" $ ntfServerTests (transport @TLS) aroundAll_ (postgressBracket testServerDBConnectInfo) $ do From 2f0cdc40afb3ad639435c31b46c18471bff37dc0 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 30 Apr 2025 14:57:04 +0100 Subject: [PATCH 7/9] ntf server: fix returned last notifications (#1530) --- .../Messaging/Notifications/Server/Store/Postgres.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 112d4cedd..9a201ff2a 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -579,11 +579,15 @@ addTokenLastNtf st newNtf = sent_at = EXCLUDED.sent_at, nmsg_nonce = EXCLUDED.nmsg_nonce, nmsg_data = EXCLUDED.nmsg_data + RETURNING subscription_id, sent_at, nmsg_nonce, nmsg_data ), last AS ( - SELECT token_ntf_id, subscription_id, sent_at, nmsg_nonce, nmsg_data + SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data FROM last_notifications - WHERE token_id = ? + WHERE token_id = ? AND subscription_id != (SELECT subscription_id FROM new) + UNION + SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data + FROM new ORDER BY sent_at DESC LIMIT ? ), @@ -597,7 +601,7 @@ addTokenLastNtf st newNtf = FROM last l JOIN subscriptions s ON s.subscription_id = l.subscription_id JOIN smp_servers p ON p.smp_server_id = s.smp_server_id - ORDER BY token_ntf_id DESC + ORDER BY sent_at ASC |] (tId, sId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId) let lastNtfs = fromMaybe (newNtf :| []) (L.nonEmpty lastNtfs_) From cf4b9f669df909d7fd984adff26308530b70a631 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 15 May 2025 15:16:44 +0100 Subject: [PATCH 8/9] agent: always enable periodic notifications --- src/Simplex/Messaging/Agent.hs | 6 ++---- src/Simplex/Messaging/Notifications/Protocol.hs | 3 +-- src/Simplex/Messaging/Notifications/Server.hs | 3 --- 3 files changed, 3 insertions(+), 9 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e4b0d4013..799fed250 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -2268,10 +2268,8 @@ verifyNtfToken' c deviceToken nonce code = _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token" setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' () -setCronInterval c tknId tkn@NtfToken {ntfMode} = do - cron <- case ntfMode of - NMPeriodic -> asks $ ntfCron . config - _ -> pure 0 +setCronInterval c tknId tkn = do + cron <- asks $ ntfCron . config void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c tknId tkn cron checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index b23bd4e91..cc2d63bca 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -521,7 +521,6 @@ instance StrEncoding NtfSubStatus where strP = smpP {-# INLINE strP #-} --- TODO [ntfdb] check what happens in agent when token in not yet registered data NtfTknStatus = -- | Token created in DB NTNew @@ -541,7 +540,7 @@ allowNtfSubCommands :: NtfTknStatus -> Bool allowNtfSubCommands = \case NTNew -> False NTRegistered -> False - -- TODO [ntfdb] we could have separate statuses to show whether it became invalid + -- TODO we could have separate statuses to show whether it became invalid -- after verification (allow commands) or before (do not allow) NTInvalid _ -> True NTConfirmed -> False diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 677f14758..b132c0ac9 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -491,7 +491,6 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} ntfs_ <- liftIO $ addTokenLastNtf st newNtf forM_ ntfs_ $ \(tkn, lastNtfs) -> atomically $ writeTBQueue pushQ (tkn, PNMessage lastNtfs) - -- TODO [ntfdb] count queued notifications separately? incNtfStat ntfReceived Right SMP.END -> do whenM (atomically $ activeClientSession' ca sessionId srv) $ do @@ -604,8 +603,6 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do _ -> err e err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e --- TODO [ntfdb] this could be further improved by sending periodic notifications directly from this thread, --- without any queue periodicNtfsThread :: NtfPushServer -> M () periodicNtfsThread NtfPushServer {pushQ} = do st <- asks store From b90e25a3a5fddf19beec3a4bc4d01eeb6589bb14 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 15 May 2025 19:56:48 +0100 Subject: [PATCH 9/9] ntf server: fix repeat token registration when it became invalid (regression) (#1539) --- src/Simplex/Messaging/Notifications/Protocol.hs | 9 +++++++++ src/Simplex/Messaging/Notifications/Server.hs | 12 ++++++++---- tests/AgentTests/NotificationTests.hs | 16 ++++++++++------ 3 files changed, 27 insertions(+), 10 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index cc2d63bca..769c35510 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -536,6 +536,15 @@ data NtfTknStatus NTExpired deriving (Eq, Show) +allowTokenVerification :: NtfTknStatus -> Bool +allowTokenVerification = \case + NTNew -> False + NTRegistered -> True + NTInvalid _ -> False + NTConfirmed -> True + NTActive -> True + NTExpired -> False + allowNtfSubCommands :: NtfTknStatus -> Bool allowNtfSubCommands = \case NTNew -> False diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index b132c0ac9..664ff35b7 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} @@ -729,14 +730,17 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu logDebug "TNEW - registered token" let dhSecret = C.dh' dhPubKey tknDhPrivKey -- it is required that DH secret is the same, to avoid failed verifications if notification is delaying - if tknDhSecret == dhSecret - then do + if + | tknDhSecret /= dhSecret -> pure $ NRErr AUTH + | allowTokenVerification tknStatus -> sendVerification + | otherwise -> withNtfStore (\st -> updateTknStatus st tkn NTRegistered) $ \_ -> sendVerification + where + sendVerification = do atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode) incNtfStatT token ntfVrfQueued pure $ NRTknId ntfTknId $ C.publicKey tknDhPrivKey - else pure $ NRErr AUTH TVFY code -- this allows repeated verification for cases when client connection dropped before server response - | (tknStatus == NTRegistered || tknStatus == NTConfirmed || tknStatus == NTActive) && tknRegCode == code -> do + | allowTokenVerification tknStatus && tknRegCode == code -> do logDebug "TVFY - token verified" withNtfStore (`setTokenActive` tkn) $ \_ -> NROk <$ incNtfStatT token tknVerified | otherwise -> do diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index d2b7b864f..2c3ba40d4 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -58,6 +58,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import Data.Time.Clock.System (systemToUTCTime) +import qualified Database.PostgreSQL.Simple as PSQL import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, ntfTestPort, ntfTestPort2, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') @@ -74,6 +75,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Server.Push.APNS +import Simplex.Messaging.Notifications.Server.Store.Postgres (closeNtfDbStore, newNtfDbStore, withDB') import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..)) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) @@ -122,12 +124,10 @@ notificationTests ps@(t, _) = do it "should keep working with active token until replaced" $ withAPNSMockServer $ \apns -> testNtfTokenChangeServers t apns - -- TODO [ntfdb] modify database in the test - xit "should re-register token in NTInvalid status after register attempt" $ + it "should re-register token in NTInvalid status after register attempt" $ withAPNSMockServer $ \apns -> testNtfTokenReRegisterInvalid t apns - -- TODO [ntfdb] modify database in the test - xit "should re-register token in NTInvalid status after checking token" $ + it "should re-register token in NTInvalid status after checking token" $ withAPNSMockServer $ \apns -> testNtfTokenReRegisterInvalidOnCheck t apns describe "notification server tests" $ do @@ -489,7 +489,9 @@ testNtfTokenReRegisterInvalid t apns = do withNtfServer t $ pure () threadDelay 250000 - replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" + st <- newNtfDbStore ntfTestDBCfg + Right 1 <- withDB' "test" st $ \db -> PSQL.execute db "UPDATE tokens SET status = ? WHERE status = ?" (NTInvalid Nothing, NTActive) + closeNtfDbStore st threadDelay 250000 withNtfServer t $ do @@ -518,7 +520,9 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do withNtfServer t $ pure () threadDelay 250000 - replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" + st <- newNtfDbStore ntfTestDBCfg + Right 1 <- withDB' "test" st $ \db -> PSQL.execute db "UPDATE tokens SET status = ? WHERE status = ?" (NTInvalid Nothing, NTActive) + closeNtfDbStore st threadDelay 250000 withNtfServer t $ do