diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 943c30c5a..2c3d2e4df 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -11,12 +11,14 @@ module Simplex.Messaging.Notifications.Protocol where +import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) import Data.Kind import Data.Maybe (isNothing) import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -406,10 +408,12 @@ instance Encoding DeviceToken where instance StrEncoding DeviceToken where strEncode (DeviceToken p t) = strEncode p <> " " <> t - strP = DeviceToken <$> strP <* A.space <*> hexStringP + strP = nullToken <|> hexToken where + nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token" + hexToken = DeviceToken <$> strP <* A.space <*> hexStringP hexStringP = - A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s -> + A.takeWhile (`B.elem` "0123456789abcdef") >>= \s -> if even (B.length s) then pure s else fail "odd number of hex characters" instance ToJSON DeviceToken where diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 2580e58fd..55ab40718 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -108,7 +108,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do logServerStats :: Int64 -> Int64 -> FilePath -> M () logServerStats startAt logInterval statsFilePath = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime - liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath + logInfo $ "server stats log enabled: " <> T.pack statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats let interval = 1000000 * logInterval @@ -442,7 +442,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu where processCommand :: NtfRequest -> M (Transmission NtfResponse) processCommand = \case - NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do + NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do logDebug "TNEW - new token" st <- asks store ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random @@ -453,9 +453,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ addNtfToken st tknId tkn atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) withNtfLog (`logCreateToken` tkn) - incNtfStat tknCreated + incNtfStatT token tknCreated pure (corrId, "", NRTknId tknId srvDhPubKey) - NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do + NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do status <- readTVarIO tknStatus (corrId,tknId,) <$> case cmd of TNEW (NewNtfTkn _ _ dhPubKey) -> do @@ -474,7 +474,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu updateTknStatus tkn NTActive tIds <- atomically $ removeInactiveTokenRegistrations st tkn forM_ tIds cancelInvervalNotifications - incNtfStat tknVerified + incNtfStatT token tknVerified pure NROk | otherwise -> do logDebug "TVFY - incorrect code or token status" @@ -493,8 +493,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu addNtfToken st tknId tkn' writeTBQueue pushQ (tkn', PNVerification regCode) withNtfLog $ \s -> logUpdateToken s tknId token' regCode - incNtfStat tknDeleted - incNtfStat tknCreated + incNtfStatT token tknDeleted + incNtfStatT token tknCreated pure NROk TDEL -> do logDebug "TDEL" @@ -504,7 +504,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ removeSubscription ca smpServer (SPNotifier, notifierId) cancelInvervalNotifications tknId withNtfLog (`logDeleteToken` tknId) - incNtfStat tknDeleted + incNtfStatT token tknDeleted pure NROk TCRN 0 -> do logDebug "TCRN 0" @@ -583,6 +583,10 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M () withNtfLog action = liftIO . mapM_ action =<< asks storeLog +incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M () +incNtfStatT (DeviceToken PPApnsNull _) _ = pure () +incNtfStatT _ statSel = incNtfStat statSel + incNtfStat :: (NtfServerStats -> TVar Int) -> M () incNtfStat statSel = do stats <- asks serverStats diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 9c3de04df..151f5e044 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -54,7 +54,7 @@ import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (EncNMsgMeta) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2.Client -import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Environment (getEnv) import UnliftIO.STM @@ -258,11 +258,11 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client) connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do caStore_ <- XS.readCertificateStore caStoreFile - when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile + when (isNothing caStore_) $ logError $ "Error loading CertificateStore from " <> T.pack caStoreFile r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected case r of Right client -> atomically . writeTVar https2Client $ Just client - Left e -> putStrLn $ "Error connecting to APNS: " <> show e + Left e -> logError $ "Error connecting to APNS: " <> tshow e pure r where disconnected = atomically $ writeTVar https2Client Nothing diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index 1f206cecc..d43700ad3 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -24,10 +24,12 @@ module Simplex.Messaging.Notifications.Server.StoreLog where import Control.Concurrent.STM +import Control.Logger.Simple import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.Text as T import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -35,7 +37,7 @@ import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Protocol (NtfPrivateAuthKey) import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (whenM) +import Simplex.Messaging.Util (safeDecodeUtf8, whenM) import System.Directory (doesFileExist, renameFile) import System.IO @@ -193,7 +195,7 @@ readNtfStore :: FilePath -> NtfStore -> IO () readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f where addNtfLogRecord s = case strDecode s of - Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s + Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s) Right lr -> atomically $ case lr of CreateToken r@NtfTknRec {ntfTknId} -> do tkn <- mkTknData r