diff --git a/apps/ntf-server/Main.hs b/apps/ntf-server/Main.hs index 928b9e514..478077e25 100644 --- a/apps/ntf-server/Main.hs +++ b/apps/ntf-server/Main.hs @@ -5,6 +5,7 @@ module Main where import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) +import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI) import System.FilePath (combine) @@ -44,6 +45,7 @@ ntfServerCLIConfig = subQSize = 64, pushQSize = 128, smpAgentCfg = defaultSMPClientAgentConfig, + apnsConfig = defaultAPNSPushClientConfig, caCertificateFile = caCrtFile, privateKeyFile = serverKeyFile, certificateFile = serverCrtFile diff --git a/package.yaml b/package.yaml index 7b804a55f..61e000158 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - base >= 4.7 && < 5 - base64-bytestring >= 1.0 && < 1.3 - bytestring == 0.10.* + - case-insensitive == 1.2.* - composition == 1.0.* - constraints >= 0.12 && < 0.14 - containers == 0.6.* @@ -41,6 +42,7 @@ dependencies: - directory == 1.3.* - filepath == 1.4.* - http-types == 0.12.* + - http2 == 3.0.* - generic-random >= 1.3 && < 1.5 - ini == 0.4.* - iso8601-time == 0.1.* @@ -58,6 +60,7 @@ dependencies: - template-haskell == 2.16.* - text == 1.2.* - time == 1.9.* + - time-manager == 0.0.* - tls >= 1.5.7 && < 1.6 - transformers == 0.5.* - unliftio == 0.2.* diff --git a/simplexmq.cabal b/simplexmq.cabal index 61c2001ad..6a64f8214 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -47,6 +47,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft Simplex.Messaging.Client Simplex.Messaging.Client.Agent Simplex.Messaging.Crypto @@ -57,6 +58,7 @@ library Simplex.Messaging.Notifications.Protocol Simplex.Messaging.Notifications.Server Simplex.Messaging.Notifications.Server.Env + Simplex.Messaging.Notifications.Server.Push.APNS Simplex.Messaging.Notifications.Server.Subscriptions Simplex.Messaging.Notifications.Transport Simplex.Messaging.Parsers @@ -72,6 +74,7 @@ library Simplex.Messaging.TMap Simplex.Messaging.Transport Simplex.Messaging.Transport.Client + Simplex.Messaging.Transport.Client.HTTP2 Simplex.Messaging.Transport.KeepAlive Simplex.Messaging.Transport.Server Simplex.Messaging.Transport.WebSockets @@ -93,6 +96,7 @@ library , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* + , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 , containers ==0.6.* @@ -104,6 +108,7 @@ library , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* + , http2 ==3.0.* , ini ==0.4.* , iso8601-time ==0.1.* , memory ==0.15.* @@ -119,117 +124,7 @@ library , template-haskell ==2.16.* , text ==1.2.* , time ==1.9.* - , tls >=1.5.7 && <1.6 - , transformers ==0.5.* - , unliftio ==0.2.* - , unliftio-core ==0.2.* - , websockets ==0.12.* - , x509 ==1.7.* - , x509-store ==1.6.* - , x509-validation ==1.6.* - if flag(swift) - ghc-options: -DswiftJSON - default-language: Haskell2010 - -executable smp-agent - main-is: Main.hs - other-modules: - Paths_simplexmq - hs-source-dirs: - apps/smp-agent - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded - build-depends: - QuickCheck ==2.14.* - , aeson ==2.0.* - , ansi-terminal >=0.10 && <0.12 - , asn1-encoding ==0.9.* - , asn1-types ==0.3.* - , async ==2.2.* - , attoparsec ==0.14.* - , base >=4.7 && <5 - , base64-bytestring >=1.0 && <1.3 - , bytestring ==0.10.* - , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 - , cryptostore ==0.2.* - , data-default ==0.7.* - , direct-sqlite ==2.3.* - , directory ==1.3.* - , filepath ==1.4.* - , generic-random >=1.3 && <1.5 - , http-types ==0.12.* - , iso8601-time ==0.1.* - , memory ==0.15.* - , mtl ==2.2.* - , network ==3.1.2.* - , network-transport ==0.5.* - , random >=1.1 && <1.3 - , simple-logger ==0.1.* - , simplexmq - , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* - , text ==1.2.* - , time ==1.9.* - , tls >=1.5.7 && <1.6 - , transformers ==0.5.* - , unliftio ==0.2.* - , unliftio-core ==0.2.* - , websockets ==0.12.* - , x509 ==1.7.* - , x509-store ==1.6.* - , x509-validation ==1.6.* - if flag(swift) - ghc-options: -DswiftJSON - default-language: Haskell2010 - -executable smp-server - main-is: Main.hs - other-modules: - Paths_simplexmq - hs-source-dirs: - apps/smp-server - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded - build-depends: - QuickCheck ==2.14.* - , aeson ==2.0.* - , ansi-terminal >=0.10 && <0.12 - , asn1-encoding ==0.9.* - , asn1-types ==0.3.* - , async ==2.2.* - , attoparsec ==0.14.* - , base >=4.7 && <5 - , base64-bytestring >=1.0 && <1.3 - , bytestring ==0.10.* - , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 - , cryptostore ==0.2.* - , data-default ==0.7.* - , direct-sqlite ==2.3.* - , directory ==1.3.* - , filepath ==1.4.* - , generic-random >=1.3 && <1.5 - , http-types ==0.12.* - , ini ==0.4.* - , iso8601-time ==0.1.* - , memory ==0.15.* - , mtl ==2.2.* - , network ==3.1.2.* - , network-transport ==0.5.* - , optparse-applicative >=0.15 && <0.17 - , process ==1.6.* - , random >=1.1 && <1.3 - , simple-logger ==0.1.* - , simplexmq - , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* - , text ==1.2.* - , time ==1.9.* + , time-manager ==0.0.* , tls >=1.5.7 && <1.6 , transformers ==0.5.* , unliftio ==0.2.* @@ -260,6 +155,7 @@ executable ntf-server , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* + , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 , containers ==0.6.* @@ -271,6 +167,7 @@ executable ntf-server , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* + , http2 ==3.0.* , ini ==0.4.* , iso8601-time ==0.1.* , memory ==0.15.* @@ -287,6 +184,7 @@ executable ntf-server , template-haskell ==2.16.* , text ==1.2.* , time ==1.9.* + , time-manager ==0.0.* , tls >=1.5.7 && <1.6 , transformers ==0.5.* , unliftio ==0.2.* @@ -295,6 +193,128 @@ executable ntf-server , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + if flag(swift) + ghc-options: -DswiftJSON + default-language: Haskell2010 + +executable smp-agent + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/smp-agent + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.14.* + , aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , case-insensitive ==1.2.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , cryptostore ==0.2.* + , data-default ==0.7.* + , direct-sqlite ==2.3.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random >=1.3 && <1.5 + , http-types ==0.12.* + , http2 ==3.0.* + , ini ==0.4.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.2.* + , network-transport ==0.5.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , text ==1.2.* + , time ==1.9.* + , time-manager ==0.0.* + , tls >=1.5.7 && <1.6 + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , websockets ==0.12.* + , x509 ==1.7.* + , x509-store ==1.6.* + , x509-validation ==1.6.* + if flag(swift) + ghc-options: -DswiftJSON + default-language: Haskell2010 + +executable smp-server + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/smp-server + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.14.* + , aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , case-insensitive ==1.2.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , cryptostore ==0.2.* + , data-default ==0.7.* + , direct-sqlite ==2.3.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random >=1.3 && <1.5 + , http-types ==0.12.* + , http2 ==3.0.* + , ini ==0.4.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.2.* + , network-transport ==0.5.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , text ==1.2.* + , time ==1.9.* + , time-manager ==0.0.* + , tls >=1.5.7 && <1.6 + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , websockets ==0.12.* + , x509 ==1.7.* + , x509-store ==1.6.* + , x509-validation ==1.6.* + if flag(swift) + ghc-options: -DswiftJSON default-language: Haskell2010 test-suite smp-server-test @@ -309,7 +329,7 @@ test-suite smp-server-test CoreTests.EncodingTests CoreTests.ProtocolErrorTests CoreTests.VersionRangeTests - NtfClient, + NtfClient NtfServerTests ServerTests SMPAgentClient @@ -330,6 +350,7 @@ test-suite smp-server-test , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* + , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 , containers ==0.6.* @@ -343,11 +364,15 @@ test-suite smp-server-test , hspec ==2.7.* , hspec-core ==2.7.* , http-types ==0.12.* + , http2 ==3.0.* + , ini ==0.4.* , iso8601-time ==0.1.* , memory ==0.15.* , mtl ==2.2.* , network ==3.1.2.* , network-transport ==0.5.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplexmq @@ -356,6 +381,7 @@ test-suite smp-server-test , template-haskell ==2.16.* , text ==1.2.* , time ==1.9.* + , time-manager ==0.0.* , timeit ==2.0.* , tls >=1.5.7 && <1.6 , transformers ==0.5.* diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index efcd87d3c..5a2c246ac 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -79,7 +79,9 @@ class Monad m => MonadAgentStore s m where -- Notification device token persistence createNtfToken :: s -> NtfToken -> m () - getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken) -- return current token if it exists and mark any old tokens for deletion + + -- TODO this should also return old tokens so that they are deleted from the server + getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken) -- return current token if it exists updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m () updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m () diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 8ff256e6d..dbe47d5f6 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -161,7 +161,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc thVar <- newEmptyTMVarIO action <- async $ - runTransportClient (host protocolServer) port' (keyHash protocolServer) tcpKeepAlive (client t c thVar) + runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar) `finally` atomically (putTMVar thVar $ Left PCENetworkError) th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar) pure $ case th_ of diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 92ff4f75e..9f275e805 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -103,6 +103,10 @@ module Simplex.Messaging.Crypto cbDecrypt, cbNonce, randomCbNonce, + pseudoRandomCbNonce, + + -- * pseudo-random bytes + pseudoRandomBytes, -- * SHA256 hash sha256Hash, @@ -116,6 +120,7 @@ module Simplex.Messaging.Crypto ) where +import Control.Concurrent.STM import Control.Exception (Exception) import Control.Monad.Except import Control.Monad.Trans.Except @@ -129,7 +134,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519 import qualified Crypto.PubKey.Curve448 as X448 import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 -import Crypto.Random (getRandomBytes) +import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate) import Data.ASN1.BinaryEncoding import Data.ASN1.Encoding import Data.ASN1.Types @@ -876,6 +881,16 @@ cbNonce s randomCbNonce :: IO CbNonce randomCbNonce = CbNonce <$> getRandomBytes 24 +pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce +pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar + +pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString +pseudoRandomBytes n gVar = do + g <- readTVar gVar + let (bytes, g') = randomBytesGenerate n g + writeTVar gVar g' + return bytes + instance Encoding CbNonce where smpEncode = unCbNonce smpP = CbNonce <$> A.take 24 diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 64312e717..942b2db42 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -14,13 +14,13 @@ import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Crypto.Random (MonadRandom) -import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import Network.Socket (ServiceName) import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Env +import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Subscriptions import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut) @@ -60,7 +60,7 @@ runNtfServerBlocking started cfg@NtfServerConfig {transports} = do Right th -> runNtfClientTransport th Left _ -> pure () -ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m () +ntfSubscriber :: forall m. MonadUnliftIO m => NtfSubscriber -> m () ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do raceAny_ [subscribe, receiveSMP, receiveAgent] where @@ -71,11 +71,11 @@ ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case Right _ -> pure () -- update subscription status - Left e -> pure () + Left _e -> pure () receiveSMP :: m () receiveSMP = forever $ do - (srv, sessId, ntfId, msg) <- atomically $ readTBQueue msgQ + (_srv, _sessId, _ntfId, msg) <- atomically $ readTBQueue msgQ case msg of SMP.NMSG -> do -- check when the last NMSG was received from this queue @@ -92,26 +92,37 @@ ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} forever $ atomically (readTBQueue agentQ) >>= \case CAConnected _ -> pure () - CADisconnected srv subs -> do + CADisconnected _srv _subs -> do -- update subscription statuses pure () CAReconnected _ -> pure () - CAResubscribed srv sub -> do + CAResubscribed _srv _sub -> do -- update subscription status pure () - CASubError srv sub err -> do + CASubError _srv _sub _err -> do -- update subscription status pure () -ntfPush :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfPushServer -> m () -ntfPush NtfPushServer {pushQ} = forever $ do - atomically (readTBQueue pushQ) >>= \case - (NtfTknData {tknStatus}, notification) -> do - liftIO $ print $ J.encode notification - -- TODO status update should happen after the token status successfully sent - case notification of - PNVerification _ -> atomically $ writeTVar tknStatus NTConfirmed - _ -> pure () +ntfPush :: MonadUnliftIO m => NtfPushServer -> m () +ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do + (tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ) + liftIO $ putStrLn $ "sending push notification to " <> show pp + status <- readTVarIO tknStatus + case (status, ntf) of + (_, PNVerification _) -> do + -- TODO check token status + deliverNotification pp tkn ntf + atomically $ writeTVar tknStatus NTConfirmed + (NTActive, PNCheckMessages) -> do + deliverNotification pp tkn ntf + _ -> do + liftIO $ putStrLn "bad notification token status" + where + deliverNotification :: PushProvider -> PushProviderClient + deliverNotification pp tkn ntf = do + deliver <- liftIO $ getPushClient s pp + -- TODO retry later based on the error + deliver tkn ntf `catchError` \e -> liftIO (putStrLn $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m () runNtfClientTransport th@THandle {sessionId} = do @@ -128,6 +139,7 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m () receive th NtfServerClient {rcvQ, sndQ} = forever $ do t@(_, _, (corrId, subId, cmdOrError)) <- tGet th + liftIO $ putStrLn "receive" case cmdOrError of Left e -> write sndQ (corrId, subId, NRErr e) Right cmd -> @@ -181,7 +193,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do -- _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFail client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m () -client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ} NtfPushServer {pushQ} = +client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ} = forever $ atomically (readTBQueue rcvQ) >>= processCommand @@ -190,6 +202,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ} NtfPushServer {pushQ} = processCommand :: NtfRequest -> m (Transmission NtfResponse) processCommand = \case NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do + liftIO $ putStrLn "TNEW" st <- asks store (srvDhPubKey, srvDrivDhKey) <- liftIO C.generateKeyPair' let dhSecret = C.dh' dhPubKey srvDrivDhKey @@ -203,18 +216,20 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ} NtfPushServer {pushQ} = NtfReqCmd SToken (NtfTkn NtfTknData {tknStatus, tknRegCode}) (corrId, tknId, cmd) -> do status <- readTVarIO tknStatus (corrId,tknId,) <$> case cmd of - TNEW newTkn -> pure NROk -- TODO when duplicate token sent + TNEW _newTkn -> do + liftIO $ putStrLn "TNEW'" + pure NROk -- TODO when duplicate token sent TVFY code -- this allows repeated verification for cases when client connection dropped before server response | (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do atomically $ writeTVar tknStatus NTActive pure NROk | otherwise -> pure $ NRErr AUTH TDEL -> pure NROk - TCRN int -> pure NROk - NtfReqNew corrId (ANE SSubscription newSub) -> pure (corrId, "", NROk) - NtfReqCmd SSubscription sub (corrId, subId, cmd) -> + TCRN _int -> pure NROk + NtfReqNew corrId (ANE SSubscription _newSub) -> pure (corrId, "", NROk) + NtfReqCmd SSubscription _sub (corrId, subId, cmd) -> (corrId,subId,) <$> case cmd of - SNEW newSub -> pure NROk + SNEW _newSub -> pure NROk SCHK -> pure NROk SDEL -> pure NROk PING -> pure NRPong @@ -225,7 +240,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ} NtfPushServer {pushQ} = getRandomBytes :: Int -> m ByteString getRandomBytes n = do gVar <- asks idsDrg - atomically (randomBytes n gVar) + atomically (C.pseudoRandomBytes n gVar) -- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk) -- do diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index e76c63375..67b83f1af 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -1,28 +1,27 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} module Simplex.Messaging.Notifications.Server.Env where import Control.Monad.IO.Unlift import Crypto.Random -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import Data.X509.Validation (Fingerprint (..)) -import GHC.Generics import Network.Socket import qualified Network.TLS as T 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.Subscriptions -import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) import Simplex.Messaging.Protocol (CorrId, Transmission) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport) import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams) import UnliftIO.STM @@ -35,22 +34,13 @@ data NtfServerConfig = NtfServerConfig subQSize :: Natural, pushQSize :: Natural, smpAgentCfg :: SMPClientAgentConfig, + apnsConfig :: APNSPushClientConfig, -- CA certificate private key is not needed for initialization caCertificateFile :: FilePath, privateKeyFile :: FilePath, certificateFile :: FilePath } -data PushNotification = PNVerification {code :: NtfRegCode} | PNPeriodic - deriving (Show, Generic) - -instance FromJSON PushNotification where - parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "PN" - -instance ToJSON PushNotification where - toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "PN" - toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "PN" - data NtfEnv = NtfEnv { config :: NtfServerConfig, subscriber :: NtfSubscriber, @@ -63,11 +53,13 @@ data NtfEnv = NtfEnv } newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, caCertificateFile, certificateFile, privateKeyFile} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, caCertificateFile, certificateFile, privateKeyFile} = do idsDrg <- newTVarIO =<< drgNew store <- atomically newNtfStore subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg - pushServer <- atomically $ newNtfPushServer pushQSize + pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig + -- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server + -- void . liftIO $ newPushClient pushServer PPApple tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp} @@ -83,14 +75,28 @@ newNtfSubscriber qSize smpAgentCfg = do subQ <- newTBQueue qSize pure NtfSubscriber {smpAgent, subQ} -newtype NtfPushServer = NtfPushServer - { pushQ :: TBQueue (NtfTknData, PushNotification) +data NtfPushServer = NtfPushServer + { pushQ :: TBQueue (NtfTknData, PushNotification), + pushClients :: TMap PushProvider PushProviderClient, + apnsConfig :: APNSPushClientConfig } -newNtfPushServer :: Natural -> STM NtfPushServer -newNtfPushServer qSize = do +newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer +newNtfPushServer qSize apnsConfig = do pushQ <- newTBQueue qSize - pure NtfPushServer {pushQ} + pushClients <- TM.empty + pure NtfPushServer {pushQ, pushClients, apnsConfig} + +newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient +newPushClient NtfPushServer {apnsConfig, pushClients} = \case + PPApple -> do + c <- apnsPushProviderClient <$> createAPNSPushClient apnsConfig + atomically $ TM.insert PPApple c pushClients + pure c + +getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient +getPushClient s@NtfPushServer {pushClients} pp = + atomically (TM.lookup pp pushClients) >>= maybe (newPushClient s pp) pure data NtfRequest = NtfReqNew CorrId ANewNtfEntity diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs deleted file mode 100644 index 87b475f2a..000000000 --- a/src/Simplex/Messaging/Notifications/Server/Push.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Simplex.Messaging.Notifications.Server.Push where - -import Control.Concurrent.STM -import Data.ByteString.Char8 (ByteString) -import Simplex.Messaging.Protocol (NotifierId, SMPServer) - -data NtfPushPayload = NPVerification ByteString | NPNotification SMPServer NotifierId | NPPing - -class PushProvider p where - newPushProvider :: STM p - requestBody :: p -> NtfPushPayload -> ByteString -- ? diff --git a/src/Simplex/Messaging/Notifications/Server/Push/.gitignore b/src/Simplex/Messaging/Notifications/Server/Push/.gitignore new file mode 100644 index 000000000..61d5e2e09 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push/.gitignore @@ -0,0 +1 @@ +local.env diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs new file mode 100644 index 000000000..8a67f9fcf --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Notifications.Server.Push.APNS where + +import Control.Monad.Except +import Crypto.Hash.Algorithms (SHA256 (..)) +import qualified Crypto.PubKey.ECC.ECDSA as EC +import qualified Crypto.PubKey.ECC.Types as ECT +import Crypto.Random (ChaChaDRG, drgNew) +import qualified Crypto.Store.PKCS8 as PK +import Data.ASN1.BinaryEncoding (DER (..)) +import Data.ASN1.Encoding +import Data.ASN1.Types +import Data.Aeson (FromJSON, ToJSON, (.=)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Encoding as JE +import Data.Bifunctor (first) +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.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Time.Clock.System +import qualified Data.X509 as X +import GHC.Generics +import Network.HTTP.Types (HeaderName, Status, hAuthorization, methodPost) +import qualified Network.HTTP.Types as N +import Network.HTTP2.Client (Request) +import qualified Network.HTTP2.Client as H +import Network.Socket (HostName, ServiceName) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Server.Subscriptions (NtfTknData (..)) +import Simplex.Messaging.Protocol (NotifierId, SMPServer) +import Simplex.Messaging.Transport.Client.HTTP2 +import System.Environment (getEnv) +import UnliftIO.STM + +data JWTHeader = JWTHeader + { alg :: Text, -- key algorithm, ES256 for APNS + kid :: Text -- key ID + } + deriving (Show, Generic) + +instance ToJSON JWTHeader where toEncoding = J.genericToEncoding J.defaultOptions + +data JWTClaims = JWTClaims + { iss :: Text, -- issuer, team ID for APNS + iat :: Int64 -- issue time, seconds from epoch + } + deriving (Show, Generic) + +instance ToJSON JWTClaims where toEncoding = J.genericToEncoding J.defaultOptions + +data JWTToken = JWTToken JWTHeader JWTClaims + deriving (Show) + +mkJWTToken :: JWTHeader -> Text -> IO JWTToken +mkJWTToken hdr iss = do + iat <- systemSeconds <$> getSystemTime + pure $ JWTToken hdr JWTClaims {iss, iat} + +type SignedJWTToken = ByteString + +signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken +signedJWTToken pk (JWTToken hdr claims) = do + let hc = jwtEncode hdr <> "." <> jwtEncode claims + sig <- EC.sign pk SHA256 hc + pure $ hc <> "." <> serialize sig + where + jwtEncode :: ToJSON a => a -> ByteString + jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode + serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence] + +readECPrivateKey :: FilePath -> IO EC.PrivateKey +readECPrivateKey f = do + -- TODO this is specific to APNS key + [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f + pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv} + +data PushNotification + = PNVerification NtfRegCode + | PNMessage SMPServer NotifierId + | PNAlert Text + | PNCheckMessages + +data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value} + deriving (Show, Generic) + +instance ToJSON APNSNotification where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +data APNSNotificationBody + = APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text} + | APNSBackground {contentAvailable :: Int} + | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text} + deriving (Show, Generic) + +apnsJSONOptions :: J.Options +apnsJSONOptions = J.defaultOptions {J.omitNothingFields = True, J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'} + +instance ToJSON APNSNotificationBody where + toJSON = J.genericToJSON apnsJSONOptions + toEncoding = J.genericToEncoding apnsJSONOptions + +type APNSNotificationData = Map Text Text + +data APNSAlertBody = APNSAlertObject {title :: Text, subtitle :: Text, body :: Text} | APNSAlertText Text + deriving (Show) + +instance ToJSON APNSAlertBody where + toEncoding = \case + APNSAlertObject {title, subtitle, body} -> J.pairs $ "title" .= title <> "subtitle" .= subtitle <> "body" .= body + APNSAlertText t -> JE.text t + toJSON = \case + APNSAlertObject {title, subtitle, body} -> J.object ["title" .= title, "subtitle" .= subtitle, "body" .= body] + APNSAlertText t -> J.String t + +-- APNS notification types +-- +-- Visible alerts: +-- { +-- "aps" : { +-- "alert" : { +-- "title" : "Game Request", +-- "subtitle" : "Five Card Draw", +-- "body" : "Bob wants to play poker" +-- }, +-- "badge" : 9, +-- "sound" : "bingbong.aiff", +-- "category" : "GAME_INVITATION" +-- }, +-- "gameID" : "12345678" +-- } +-- +-- Simple text alert: +-- {"aps":{"alert":"you have a new message"}} +-- +-- Background notification to fetch content +-- {"aps":{"content-available":1}} +-- +-- Mutable content notification that must be shown but can be processed before before being shown (up to 30 sec) +-- { +-- "aps" : { +-- "category" : "SECRET", +-- "mutable-content" : 1, +-- "alert" : { +-- "title" : "Secret Message!", +-- "body" : "(Encrypted)" +-- }, +-- }, +-- "ENCRYPTED_DATA" : "Salted__·öîQÊ$UDì_¶Ù∞èΩ^¬%gq∞NÿÒQùw" +-- } + +data APNSPushClientConfig = APNSPushClientConfig + { tokenTTL :: Int64, + authKeyFileEnv :: String, + authKeyAlg :: Text, + authKeyIdEnv :: String, + paddedNtfLength :: Int, + appName :: ByteString, + appTeamId :: Text, + apnHost :: HostName, + apnPort :: ServiceName, + https2cfg :: HTTP2SClientConfig + } + deriving (Show) + +defaultAPNSPushClientConfig :: APNSPushClientConfig +defaultAPNSPushClientConfig = + APNSPushClientConfig + { tokenTTL = 1200, -- 20 minutes + authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start + authKeyAlg = "ES256", + authKeyIdEnv = "APNS_KEY_ID", + paddedNtfLength = 256, + appName = "chat.simplex.app", + appTeamId = "5NN7GUYB6T", + apnHost = "api.sandbox.push.apple.com", + apnPort = "443", + https2cfg = defaultHTTP2SClientConfig + } + +data APNSPushClient = APNSPushClient + { https2Client :: TVar (Maybe HTTPS2Client), + privateKey :: EC.PrivateKey, + jwtHeader :: JWTHeader, + jwtToken :: TVar (JWTToken, SignedJWTToken), + nonceDrg :: TVar ChaChaDRG, + apnsCfg :: APNSPushClientConfig + } + +createAPNSPushClient :: APNSPushClientConfig -> IO APNSPushClient +createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do + https2Client <- newTVarIO Nothing + void $ connectHTTPS2 apnsCfg https2Client + privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv + authKeyId <- T.pack <$> getEnv authKeyIdEnv + putStrLn $ authKeyIdEnv <> "=" <> T.unpack authKeyId + let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId} + jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey + nonceDrg <- drgNew >>= newTVarIO + pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsCfg} + +getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken +getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do + (jwt, signedJWT) <- readTVarIO jwtToken + age <- jwtTokenAge jwt + if age < tokenTTL + then pure signedJWT + else do + t@(_, signedJWT') <- mkApnsJWTToken appTeamId jwtHeader privateKey + atomically $ writeTVar jwtToken t + pure signedJWT' + where + jwtTokenAge (JWTToken _ JWTClaims {iat}) = (iat -) . systemSeconds <$> getSystemTime + +mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken) +mkApnsJWTToken appTeamId jwtHeader privateKey = do + jwt <- mkJWTToken jwtHeader appTeamId + signedJWT <- signedJWTToken privateKey jwt + pure (jwt, signedJWT) + +connectHTTPS2 :: APNSPushClientConfig -> TVar (Maybe HTTPS2Client) -> IO (Either HTTPS2ClientError HTTPS2Client) +connectHTTPS2 APNSPushClientConfig {apnHost, apnPort, https2cfg} https2Client = do + r <- getHTTPS2Client apnHost apnPort https2cfg disconnected + case r of + Right client -> atomically . writeTVar https2Client $ Just client + Left e -> putStrLn $ "Error connecting to APNS: " <> show e + pure r + where + disconnected = atomically $ writeTVar https2Client Nothing + +getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTPS2ClientError HTTPS2Client) +getApnsHTTP2Client APNSPushClient {https2Client, apnsCfg} = + readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right) + +disconnectApnsHTTP2Client :: APNSPushClient -> IO () +disconnectApnsHTTP2Client APNSPushClient {https2Client} = + readTVarIO https2Client >>= mapM_ closeHTTPS2Client >> atomically (writeTVar https2Client Nothing) + +apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification +apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case + PNVerification (NtfRegCode code) -> + encrypt code $ \code' -> + apn APNSBackground {contentAvailable = 1} . Just $ J.object ["verification" .= code'] + PNMessage srv nId -> + encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue -> + apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue] + PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing + PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True] + where + encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification + encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen + apn aps notificationData = APNSNotification {aps, notificationData} + apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or some other app event", category = Nothing} + apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing} + safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?' + +apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request +apnsRequest c tkn ntf@APNSNotification {aps} = do + signedJWT <- getApnsJWTToken c + pure $ H.requestBuilder methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf) + where + path = "/3/device/" <> tkn + headers signedJWT = + [ (hApnsTopic, appName $ apnsCfg (c :: APNSPushClient)), + (hApnsPushType, pushType aps), + (hAuthorization, "bearer " <> signedJWT) + ] + <> [(hApnsPriority, "5") | isBackground aps] + isBackground = \case + APNSBackground {} -> True + _ -> False + pushType = \case + APNSBackground {} -> "background" + _ -> "alert" + +data PushProviderError + = PPConnection HTTPS2ClientError + | PPCryptoError C.CryptoError + | PPResponseError (Maybe Status) Text + | PPTokenInvalid + | PPRetryLater + | PPPermanentError + deriving (Show) + +type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO () + +newtype APNSErrorReponse = APNSErrorReponse {reason :: Text} + deriving (Generic, FromJSON) + +apnsPushProviderClient :: APNSPushClient -> PushProviderClient +apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApple tknStr} pn = do + http2 <- liftHTTPS2 $ getApnsHTTP2Client c + nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg + apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn + liftIO $ putStrLn $ "APNS notification: " <> show apnsNtf + req <- liftIO $ apnsRequest c tknStr apnsNtf + liftIO $ putStrLn $ "APNS request: " <> show req + HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req + let status = H.responseStatus response + reason = fromMaybe "" $ J.decodeStrict' =<< respBody + liftIO $ putStrLn $ "APNS response: " <> show status <> " " <> T.unpack reason + result status reason + where + result :: Maybe Status -> Text -> ExceptT PushProviderError IO () + result status reason + | status == Just N.ok200 = pure () + | status == Just N.badRequest400 = + case reason of + "BadDeviceToken" -> throwError PPTokenInvalid + "DeviceTokenNotForTopic" -> throwError PPTokenInvalid + "TopicDisallowed" -> throwError PPPermanentError + _ -> err status reason + | status == Just N.forbidden403 = case reason of + "ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed + "InvalidProviderToken" -> throwError PPPermanentError + _ -> err status reason + | status == Just N.gone410 = throwError PPTokenInvalid + | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater + -- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token + | otherwise = err status reason + err :: Maybe Status -> Text -> ExceptT PushProviderError IO () + err s r = throwError $ PPResponseError s r + liftHTTPS2 a = ExceptT $ first PPConnection <$> a + +hApnsTopic :: HeaderName +hApnsTopic = CI.mk "apns-topic" + +hApnsPushType :: HeaderName +hApnsPushType = CI.mk "apns-push-type" + +hApnsPriority :: HeaderName +hApnsPriority = CI.mk "apns-priority" diff --git a/src/Simplex/Messaging/Notifications/Server/Push/testpush.sh b/src/Simplex/Messaging/Notifications/Server/Push/testpush.sh new file mode 100755 index 000000000..204fce599 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push/testpush.sh @@ -0,0 +1,20 @@ +#!/bin/sh + +export TEAM_ID=5NN7GUYB6T +# export APNS_KEY_FILE="" +# export APNS_KEY_ID="" +export TOPIC=chat.simplex.app +# export DEVICE_TOKEN="" +export APNS_HOST_NAME=api.sandbox.push.apple.com + +export JWT_ISSUE_TIME=$(date +%s) +export JWT_HEADER=$(printf '{"alg":"ES256","kid":"%s"}' "${APNS_KEY_ID}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =) +export JWT_CLAIMS=$(printf '{"iss":"%s","iat":%d}' "${TEAM_ID}" "${JWT_ISSUE_TIME}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =) +export JWT_HEADER_CLAIMS="${JWT_HEADER}.${JWT_CLAIMS}" + +export JWT_SIGNED_HEADER_CLAIMS=$(printf "${JWT_HEADER_CLAIMS}" | openssl dgst -binary -sha256 -sign "${APNS_KEY_FILE}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =) +export AUTHENTICATION_TOKEN="${JWT_HEADER}.${JWT_CLAIMS}.${JWT_SIGNED_HEADER_CLAIMS}" + +# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN} + +curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: background" --header "apns-priority: 5" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"content-available":1}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN} diff --git a/src/Simplex/Messaging/Notifications/Server/Subscriptions.hs b/src/Simplex/Messaging/Notifications/Server/Subscriptions.hs index fa5790d85..366ba26c2 100644 --- a/src/Simplex/Messaging/Notifications/Server/Subscriptions.hs +++ b/src/Simplex/Messaging/Notifications/Server/Subscriptions.hs @@ -2,21 +2,13 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Notifications.Server.Subscriptions where import Control.Concurrent.STM -import Control.Monad -import Crypto.PubKey.Curve25519 (dhSecret) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Protocol (ErrorType (..), NotifierId, NtfPrivateSignKey, ProtocolServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util ((<$$>)) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index c3d62bb02..eaa342c1d 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -23,7 +23,7 @@ -- and optional append only log of SMP queue records. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md -module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking, verifyCmdSignature, dummyVerifyCmd, randomBytes) where +module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking, verifyCmdSignature, dummyVerifyCmd) where import Control.Monad import Control.Monad.Except @@ -439,11 +439,4 @@ withLog action = do randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString randomId n = do gVar <- asks idsDrg - atomically (randomBytes n gVar) - -randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString -randomBytes n gVar = do - g <- readTVar gVar - let (bytes, g') = randomBytesGenerate n g - writeTVar gVar g' - return bytes + atomically (C.pseudoRandomBytes n gVar) diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 3771da99e..cf24c75ef 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Transport.Client ( runTransportClient, + runTLSTransportClient, smpClientHandshake, ) where @@ -26,9 +28,12 @@ import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E -- | Connect to passed TCP host:port and pass handle to the client. -runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a -runTransportClient host port keyHash keepAliveOpts client = do - let clientParams = mkTLSClientParams host port keyHash +runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a +runTransportClient = runTLSTransportClient supportedParameters Nothing + +runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a +runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do + let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash c <- liftIO $ startTCPClient host port clientParams keepAliveOpts client c `E.finally` liftIO (closeConnection c) @@ -56,13 +61,15 @@ startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >> ctx <- connectTLS clientParams sock getClientConnection ctx -mkTLSClientParams :: HostName -> ServiceName -> C.KeyHash -> T.ClientParams -mkTLSClientParams host port keyHash = do +-- readCertificateStore :: FilePath -> IO (Maybe CertificateStore) + +mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams +mkTLSClientParams supported caStore_ host port keyHash_ = do let p = B.pack port (T.defaultParamsClient host p) - { T.clientShared = def, - T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}, - T.clientSupported = supportedParameters + { T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_, + T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_, + T.clientSupported = supported } validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason] diff --git a/src/Simplex/Messaging/Transport/Client/HTTP2.hs b/src/Simplex/Messaging/Transport/Client/HTTP2.hs new file mode 100644 index 000000000..8e3a35741 --- /dev/null +++ b/src/Simplex/Messaging/Transport/Client/HTTP2.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Transport.Client.HTTP2 where + +import Control.Concurrent.Async +import Control.Exception (IOException, catch, finally) +import qualified Control.Exception as E +import Control.Monad.Except +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Default (def) +import Data.Maybe (isNothing) +import qualified Data.X509.CertificateStore as XS +import Foreign (mallocBytes) +import Network.HPACK (BufferSize, HeaderTable) +import Network.HTTP2.Client (ClientConfig (..), Config (..), Request, Response) +import qualified Network.HTTP2.Client as H +import Network.Socket (HostName, ServiceName) +import qualified Network.TLS as T +import qualified Network.TLS.Extra as TE +import Numeric.Natural (Natural) +import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut)) +import Simplex.Messaging.Transport.Client (runTLSTransportClient) +import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts) +import qualified System.TimeManager as TI +import UnliftIO.STM +import UnliftIO.Timeout + +data HTTPS2Client = HTTPS2Client + { action :: Async (), + connected :: TVar Bool, + host :: HostName, + port :: ServiceName, + config :: HTTP2SClientConfig, + reqQ :: TBQueue (Request, TMVar HTTP2Response) + } + +data HTTP2Response = HTTP2Response + { response :: Response, + respBody :: Maybe ByteString, + respTrailers :: Maybe HeaderTable + } + +data HTTP2SClientConfig = HTTP2SClientConfig + { qSize :: Natural, + maxBody :: Int, + connTimeout :: Int, + tcpKeepAlive :: Maybe KeepAliveOpts, + caStoreFile :: FilePath, + suportedTLSParams :: T.Supported + } + deriving (Show) + +defaultHTTP2SClientConfig :: HTTP2SClientConfig +defaultHTTP2SClientConfig = + HTTP2SClientConfig + { qSize = 64, + maxBody = 500000, + connTimeout = 5000000, + tcpKeepAlive = Nothing, + caStoreFile = "/etc/ssl/cert.pem", + suportedTLSParams = + def + { T.supportedVersions = [T.TLS13, T.TLS12], + T.supportedCiphers = TE.ciphersuite_strong_det, + T.supportedSecureRenegotiation = False + } + } + +data HTTPS2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOException + deriving (Show) + +getHTTPS2Client :: HostName -> ServiceName -> HTTP2SClientConfig -> IO () -> IO (Either HTTPS2ClientError HTTPS2Client) +getHTTPS2Client host port config@HTTP2SClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected = + (atomically mkHTTPS2Client >>= runClient) + `catch` \(e :: IOException) -> pure . Left $ HCIOError e + where + mkHTTPS2Client :: STM HTTPS2Client + mkHTTPS2Client = do + connected <- newTVar False + reqQ <- newTBQueue $ qSize config + pure HTTPS2Client {action = undefined, connected, host, port, config, reqQ} + + runClient :: HTTPS2Client -> IO (Either HTTPS2ClientError HTTPS2Client) + runClient c = do + cVar <- newEmptyTMVarIO + caStore <- XS.readCertificateStore caStoreFile + when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile + action <- + async $ + runHTTPS2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar) + `finally` atomically (putTMVar cVar $ Left HCNetworkError) + conn_ <- connTimeout `timeout` atomically (takeTMVar cVar) + pure $ case conn_ of + Just (Right ()) -> Right c {action} + Just (Left e) -> Left e + Nothing -> Left HCNetworkError + + client :: HTTPS2Client -> TMVar (Either HTTPS2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO () + client c cVar sendReq = do + atomically $ do + writeTVar (connected c) True + putTMVar cVar $ Right () + process c sendReq `finally` disconnected + + process :: HTTPS2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO () + process HTTPS2Client {reqQ} sendReq = forever $ do + (req, respVar) <- atomically $ readTBQueue reqQ + sendReq req $ \r -> do + let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers} + case H.responseBodySize r of + Just sz -> + if sz <= maxBody config + then do + respBody <- getResponseBody r "" sz + respTrailers <- join <$> mapM (const $ H.getResponseTrailers r) respBody + writeResp respBody respTrailers + else writeResp Nothing Nothing + _ -> writeResp Nothing Nothing + + getResponseBody :: Response -> ByteString -> Int -> IO (Maybe ByteString) + getResponseBody r s sz = + H.getResponseBodyChunk r >>= \chunk -> do + if chunk == "" + then pure (if B.length s == sz then Just s else Nothing) + else do + let s' = s <> chunk + if B.length s' > sz then pure Nothing else getResponseBody r s' sz + +-- | Disconnects client from the server and terminates client threads. +closeHTTPS2Client :: HTTPS2Client -> IO () +-- TODO disconnect +closeHTTPS2Client = uninterruptibleCancel . action + +sendRequest :: HTTPS2Client -> Request -> IO (Either HTTPS2ClientError HTTP2Response) +sendRequest HTTPS2Client {reqQ, config} req = do + resp <- newEmptyTMVarIO + atomically $ writeTBQueue reqQ (req, resp) + maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp)) + +runHTTPS2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO () +runHTTPS2Client tlsParams caStore host port keepAliveOpts client = + runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts https2Client + where + cfg = ClientConfig "https" (B.pack host) 20 + https2Client :: TLS -> IO () + https2Client c = + E.bracket + (allocTlsConfig c 16384) + H.freeSimpleConfig + (\conf -> H.run cfg conf client) + + allocTlsConfig :: TLS -> BufferSize -> IO Config + allocTlsConfig c sz = do + buf <- mallocBytes sz + tm <- TI.initialize $ 30 * 1000000 + pure + Config + { confWriteBuffer = buf, + confBufferSize = sz, + confSendAll = cPut c, + confReadN = cGet c, + confPositionReadMaker = H.defaultPositionReadMaker, + confTimeoutManager = tm + } diff --git a/src/Simplex/Messaging/Transport/KeepAlive.hs b/src/Simplex/Messaging/Transport/KeepAlive.hs index c949394a0..08d17d47c 100644 --- a/src/Simplex/Messaging/Transport/KeepAlive.hs +++ b/src/Simplex/Messaging/Transport/KeepAlive.hs @@ -12,6 +12,7 @@ data KeepAliveOpts = KeepAliveOpts keepIntvl :: Int, keepCnt :: Int } + deriving (Show) defaultKeepAliveOpts :: KeepAliveOpts defaultKeepAliveOpts = diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index bb7f6dec6..c9ef301ab 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -19,6 +19,7 @@ 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.Server.Push.APNS (defaultAPNSPushClientConfig) import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol import Simplex.Messaging.Transport @@ -40,7 +41,7 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a testNtfClient client = - runTransportClient testHost testPort testKeyHash (Just defaultKeepAliveOpts) $ \h -> + runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> liftIO (runExceptT $ ntfClientHandshake h testKeyHash) >>= \case Right th -> client th Left e -> error $ show e @@ -55,6 +56,7 @@ cfg = subQSize = 1, pushQSize = 1, smpAgentCfg = defaultSMPClientAgentConfig, + apnsConfig = defaultAPNSPushClientConfig, -- CA certificate private key is not needed for initialization caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 93195e8ac..680676dea 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -1,11 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module NtfServerTests where @@ -37,4 +33,4 @@ ntfSyntaxTests (ATransport t) = do (Maybe C.ASignature, ByteString, ByteString, smp) -> (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> Expectation - command >#> response = ntfServerTest t command `shouldReturn` response \ No newline at end of file + command >#> response = ntfServerTest t command `shouldReturn` response diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 304ba9674..be3de3e2c 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -198,7 +198,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB) testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a testSMPAgentClientOn port' client = do - runTransportClient agentTestHost port' testKeyHash (Just defaultKeepAliveOpts) $ \h -> do + runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do line <- liftIO $ getLn h if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion then client h diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index e5a57ab72..90f090b6f 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -45,7 +45,7 @@ testStoreLogFile = "tests/tmp/smp-server-store.log" testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a testSMPClient client = - runTransportClient testHost testPort testKeyHash (Just defaultKeepAliveOpts) $ \h -> + runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> liftIO (runExceptT $ smpClientHandshake h testKeyHash) >>= \case Right th -> client th Left e -> error $ show e