APNS/HTTP2 push client for notifications server (#350)

* APN push client (WIP) * APNS push client works * TODO comments * comment * send notification and process the response * config * e2e encryption for notification parameter * read apns key filename and ID from env * connect APNS client to server, fix notification JSON encoding to use dash case * do not connect to APNS on start to pass CI tests * fix CI test * remove redundant import
2026-05-19 11:05:11 +00:00 · 2022-04-14 11:33:17 +01:00
parent 327f7112d0
commit 45ddecc4b8
21 changed files with 791 additions and 204 deletions
@@ -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
@@ -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.*
@@ -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.*
@@ -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 ()

@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 -- ?
@@ -0,0 +1 @@
+local.env
@@ -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"
@@ -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}
@@ -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 ((<$$>))
@@ -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)
@@ -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]
@@ -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
+          }
@@ -12,6 +12,7 @@ data KeepAliveOpts = KeepAliveOpts
    keepIntvl :: Int,
    keepCnt :: Int
  }
+  deriving (Show)

 defaultKeepAliveOpts :: KeepAliveOpts
 defaultKeepAliveOpts =
@@ -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",
@@ -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
+    command >#> response = ntfServerTest t command `shouldReturn` response
@@ -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
@@ -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