agent schema/methods/types/store methods for notifications tokens (#348)

* agent schema/methods/types/store methods for notifications tokens

* register notification token on the server

* agent commands for notification tokens

* refactor initial servers from AgentConfig

* agent store functions for notification tokens

* server STM store methods for tokens

* fix protocol client for ntfs (use generic handshake), minimal server and agent tests

* server command to verify ntf token

tests/AgentTests/FunctionalAPITests.hs

@@ -9,11 +9,13 @@ module AgentTests.FunctionalAPITests (functionalAPITests) where
 
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Unlift
+import NtfClient (withNtfServer)
 import SMPAgentClient
 import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (DeviceToken), PushProvider (PPApple))
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import Simplex.Messaging.Transport (ATransport (..))
 import System.Timeout
@@ -48,11 +50,14 @@ functionalAPITests t = do
       testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
+  describe "Notification server" $ do
+    it "should register device token" $
+      withNtfServer t testNotificationToken
 
 testAgentClient :: IO ()
 testAgentClient = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
@@ -95,13 +100,13 @@ testAgentClient = do
 
 testAsyncInitiatingOffline :: IO ()
 testAsyncInitiatingOffline = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
     (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
     aliceId <- joinConnection bob cReq "bob's connInfo"
-    alice' <- liftIO $ getSMPAgentClient cfg
+    alice' <- liftIO $ getSMPAgentClient cfg initAgentServers
     subscribeConnection alice' bobId
     ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
@@ -113,15 +118,15 @@ testAsyncInitiatingOffline = do
 
 testAsyncJoiningOfflineBeforeActivation :: IO ()
 testAsyncJoiningOfflineBeforeActivation = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
     disconnectAgentClient bob
     ("", _, CONF confId "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
+    bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -131,18 +136,18 @@ testAsyncJoiningOfflineBeforeActivation = do
 
 testAsyncBothOffline :: IO ()
 testAsyncBothOffline = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
     (bobId, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
     aliceId <- joinConnection bob cReq "bob's connInfo"
     disconnectAgentClient bob
-    alice' <- liftIO $ getSMPAgentClient cfg
+    alice' <- liftIO $ getSMPAgentClient cfg initAgentServers
     subscribeConnection alice' bobId
     ("", _, CONF confId "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
+    bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -152,8 +157,8 @@ testAsyncBothOffline = do
 
 testAsyncServerOffline :: ATransport -> IO ()
 testAsyncServerOffline t = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2} initAgentServers
   -- create connection and shutdown the server
   Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
     runExceptT $ createConnection alice SCMInvitation
@@ -176,8 +181,8 @@ testAsyncServerOffline t = do
 
 testAsyncHelloTimeout :: IO ()
 testAsyncHelloTimeout = do
-  alice <- getSMPAgentClient cfg
-  bob <- getSMPAgentClient cfg {dbFile = testDB2, helloTimeout = 1}
+  alice <- getSMPAgentClient cfg initAgentServers
+  bob <- getSMPAgentClient cfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
   Right () <- runExceptT $ do
     (_, cReq) <- createConnection alice SCMInvitation
     disconnectAgentClient alice
@@ -185,6 +190,13 @@ testAsyncHelloTimeout = do
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
   pure ()
 
+testNotificationToken :: IO ()
+testNotificationToken = do
+  alice <- getSMPAgentClient cfg initAgentServers
+  Right () <- runExceptT $ do
+    registerNtfToken alice $ DeviceToken PPApple "abcd"
+  pure ()
+
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings alice bobId bob aliceId = do
   5 <- sendMessage alice bobId "hello"

tests/NtfClient.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module NtfClient where
+
+import Control.Monad.Except (runExceptT)
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.ByteString.Char8 (ByteString)
+import Network.Socket
+import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
+import Simplex.Messaging.Notifications.Server.Env
+import Simplex.Messaging.Notifications.Transport
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Client
+import Simplex.Messaging.Transport.KeepAlive
+import UnliftIO.Concurrent
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
+import UnliftIO.Timeout (timeout)
+
+testHost :: HostName
+testHost = "localhost"
+
+testPort :: ServiceName
+testPort = "6001"
+
+testKeyHash :: C.KeyHash
+testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
+
+testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
+testNtfClient client =
+  runTransportClient testHost testPort testKeyHash (Just defaultKeepAliveOpts) $ \h ->
+    liftIO (runExceptT $ ntfClientHandshake h testKeyHash) >>= \case
+      Right th -> client th
+      Left e -> error $ show e
+
+cfg :: NtfServerConfig
+cfg =
+  NtfServerConfig
+    { transports = undefined,
+      subIdBytes = 24,
+      regCodeBytes = 32,
+      clientQSize = 1,
+      subQSize = 1,
+      pushQSize = 1,
+      smpAgentCfg = defaultSMPClientAgentConfig,
+      -- CA certificate private key is not needed for initialization
+      caCertificateFile = "tests/fixtures/ca.crt",
+      privateKeyFile = "tests/fixtures/server.key",
+      certificateFile = "tests/fixtures/server.crt"
+    }
+
+withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withNtfServerThreadOn t port' =
+  serverBracket
+    (\started -> runNtfServerBlocking started cfg {transports = [(port', t)]})
+    (pure ())
+
+serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
+serverBracket process afterProcess f = do
+  started <- newEmptyTMVarIO
+  E.bracket
+    (forkIOWithUnmask ($ process started))
+    (\t -> killThread t >> afterProcess >> waitFor started "stop")
+    (\t -> waitFor started "start" >> f t)
+  where
+    waitFor started s =
+      5_000_000 `timeout` atomically (takeTMVar started) >>= \case
+        Nothing -> error $ "server did not " <> s
+        _ -> pure ()
+
+withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
+withNtfServerOn t port' = withNtfServerThreadOn t port' . const
+
+withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withNtfServer t = withNtfServerOn t testPort
+
+runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
+
+ntfServerTest ::
+  forall c smp.
+  (Transport c, Encoding smp) =>
+  TProxy c ->
+  (Maybe C.ASignature, ByteString, ByteString, smp) ->
+  IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
+ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
+  where
+    tPut' h (sig, corrId, queueId, smp) = do
+      let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
+      Right () <- tPut h (sig, t')
+      pure ()
+    tGet' h = do
+      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
+      pure (Nothing, corrId, qId, cmd)

tests/NtfServerTests.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module NtfServerTests where
+
+import Data.ByteString.Char8 (ByteString)
+import NtfClient
+import ServerTests (sampleDhPubKey, samplePubKey, sampleSig)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Transport
+import Test.Hspec
+
+ntfServerTests :: ATransport -> Spec
+ntfServerTests t = do
+  describe "notifications server protocol syntax" $ ntfSyntaxTests t
+
+ntfSyntaxTests :: ATransport -> Spec
+ntfSyntaxTests (ATransport t) = do
+  it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
+  describe "NEW" $ do
+    it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
+    it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
+    it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
+    it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
+  where
+    (>#>) ::
+      Encoding smp =>
+      (Maybe C.ASignature, ByteString, ByteString, smp) ->
+      (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
+      Expectation
+    command >#> response = ntfServerTest t command `shouldReturn` response

tests/SMPAgentClient.hs

@@ -154,11 +154,17 @@ smpAgentTest1_1_1 test' =
     _test [h] = test' h
     _test _ = error "expected 1 handle"
 
+initAgentServers :: InitialAgentServers
+initAgentServers =
+  InitialAgentServers
+    { smp = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
+      ntf = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
+    }
+
 cfg :: AgentConfig
 cfg =
   defaultAgentConfig
     { tcpPort = agentTestPort,
-      initialSMPServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
       tbqSize = 1,
       dbFile = testDB,
       smpCfg =
@@ -167,7 +173,7 @@ cfg =
             defaultTransport = (testPort, transport @TLS),
             tcpTimeout = 500_000
           },
-      reconnectInterval = (reconnectInterval defaultAgentConfig) {initialInterval = 50_000},
+      reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"
@@ -175,9 +181,10 @@ cfg =
 
 withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
 withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
-  let cfg' = cfg {tcpPort = port', dbFile = db', initialSMPServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
+  let cfg' = cfg {tcpPort = port', dbFile = db'}
+      initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
    in serverBracket
-        (\started -> runSMPAgentBlocking t started cfg')
+        (\started -> runSMPAgentBlocking t started cfg' initServers')
         afterProcess
 
 withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a

tests/Test.hs

@@ -4,6 +4,7 @@ import AgentTests (agentTests)
 import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.VersionRangeTests
+import NtfServerTests (ntfServerTests)
 import ServerTests
 import Simplex.Messaging.Transport (TLS, Transport (..))
 import Simplex.Messaging.Transport.WebSockets (WS)
@@ -20,5 +21,6 @@ main = do
       describe "Version range" versionRangeTests
     describe "SMP server via TLS" $ serverTests (transport @TLS)
     describe "SMP server via WebSockets" $ serverTests (transport @WS)
+    describe "Ntf server via TLS" $ ntfServerTests (transport @TLS)
     describe "SMP client agent" $ agentTests (transport @TLS)
   removeDirectoryRecursive "tests/tmp"