dandri/simplexmq
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-10-22 13:12:01 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #334 from simplex-chat/notifications-server

Browse Source 
push notifications server
This commit is contained in:
Evgeny Poberezkin authored and GitHub committed 2022-04-21 17:21:09 +01:00
2 parents 5eb2822d25 a2204c9b84
commit 43d24d07dd
59 files changed
+4058 -736
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

apps/ntf-server/Main.hs
+59
View File
@@ -0,0 +1,59 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main where
import Control.Logger.Simple
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)
cfgPath :: FilePath
cfgPath = "/etc/opt/simplex-notifications"
logPath :: FilePath
logPath = "/var/opt/simplex-notifications"
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
main :: IO ()
main = do
setLogLevel LogError
withGlobalLogging logCfg $ protocolServerCLI ntfServerCLIConfig runNtfServer
ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig
ntfServerCLIConfig =
let caCrtFile = combine cfgPath "ca.crt"
serverKeyFile = combine cfgPath "server.key"
serverCrtFile = combine cfgPath "server.crt"
in ServerCLIConfig
{ cfgDir = cfgPath,
logDir = logPath,
iniFile = combine cfgPath "ntf-server.ini",
storeLogFile = combine logPath "ntf-server-store.log",
caKeyFile = combine cfgPath "ca.key",
caCrtFile,
serverKeyFile,
serverCrtFile,
fingerprintFile = combine cfgPath "fingerprint",
defaultServerPort = "443",
executableName = "ntf-server",
serverVersion = "SMP notifications server v0.1.0",
mkServerConfig = \_storeLogFile transports ->
NtfServerConfig
{ transports,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 16,
subQSize = 64,
pushQSize = 128,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
caCertificateFile = caCrtFile,
privateKeyFile = serverKeyFile,
certificateFile = serverCrtFile
}
}
apps/smp-agent/Main.hs
+9 -2
View File
@@ -11,7 +11,14 @@ import Simplex.Messaging.Agent.Server (runSMPAgent)
import Simplex.Messaging.Transport (TLS, Transport (..))
cfg :: AgentConfig
cfg = defaultAgentConfig {initialSMPServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
cfg = defaultAgentConfig
servers :: InitialAgentServers
servers =
InitialAgentServers
{ smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
ntf = []
}
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -20,4 +27,4 @@ main :: IO ()
main = do
putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
setLogLevel LogInfo -- LogError
withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg
withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
apps/smp-server/Main.hs
+42 -307
View File
@@ -1,322 +1,57 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Control.Monad.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (HostName, ServiceName)
import Options.Applicative
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath)
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (loadFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
import System.Exit (exitFailure)
import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport (simplexMQVersion)
import System.FilePath (combine)
import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile)
import System.Process (readCreateProcess, shell)
import Text.Read (readMaybe)
cfgDir :: FilePath
cfgDir = "/etc/opt/simplex"
cfgPath :: FilePath
cfgPath = "/etc/opt/simplex"
logDir :: FilePath
logDir = "/var/opt/simplex"
iniFile :: FilePath
iniFile = combine cfgDir "smp-server.ini"
storeLogFile :: FilePath
storeLogFile = combine logDir "smp-server-store.log"
caKeyFile :: FilePath
caKeyFile = combine cfgDir "ca.key"
caCrtFile :: FilePath
caCrtFile = combine cfgDir "ca.crt"
serverKeyFile :: FilePath
serverKeyFile = combine cfgDir "server.key"
serverCrtFile :: FilePath
serverCrtFile = combine cfgDir "server.crt"
fingerprintFile :: FilePath
fingerprintFile = combine cfgDir "fingerprint"
logPath :: FilePath
logPath = "/var/opt/simplex"
main :: IO ()
main = do
getCliCommand >>= \case
Init opts ->
doesFileExist iniFile >>= \case
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`."
_ -> initializeServer opts
Start ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`."
Delete -> cleanup >> putStrLn "Deleted configuration and log files"
main = protocolServerCLI smpServerCLIConfig runSMPServer
exitError :: String -> IO ()
exitError msg = putStrLn msg >> exitFailure
data CliCommand
= Init InitOptions
| Start
| Delete
data InitOptions = InitOptions
{ enableStoreLog :: Bool,
signAlgorithm :: SignAlgorithm,
ip :: HostName,
fqdn :: Maybe HostName
}
deriving (Show)
data SignAlgorithm = ED448 | ED25519
deriving (Read, Show)
getCliCommand :: IO CliCommand
getCliCommand =
customExecParser
(prefs showHelpOnEmpty)
( info
(helper <*> versionOption <*> cliCommandP)
(header version <> fullDesc)
)
where
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
cliCommandP :: Parser CliCommand
cliCommandP =
hsubparser
( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
)
where
initP :: Parser CliCommand
initP =
Init
<$> ( InitOptions
<$> switch
( long "store-log"
<> short 'l'
<> help "Enable store log for SMP queues persistence"
)
<*> option
(maybeReader readMaybe)
( long "sign-algorithm"
<> short 'a'
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
<> value ED448
<> showDefault
<> metavar "ALG"
)
<*> strOption
( long "ip"
<> help
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
<> value "127.0.0.1"
<> showDefault
<> metavar "IP"
)
<*> (optional . strOption)
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
)
initializeServer :: InitOptions -> IO ()
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
cleanup
createDirectoryIfMissing True cfgDir
createDirectoryIfMissing True logDir
createX509
fp <- saveFingerprint
createIni
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server."
printServiceInfo fp
warnCAPrivateKeyFile
where
createX509 = do
createOpensslCaConf
createOpensslServerConf
-- CA certificate (identity/offline)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
-- server certificate (online)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
where
run cmd = void $ readCreateProcess (shell cmd) ""
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
opensslServerConfFile = combine cfgDir "openssl_server.conf"
serverCsrFile = combine cfgDir "server.csr"
createOpensslCaConf =
writeFile
opensslCaConfFile
"[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n\
\CN = SMP server CA\n\
\O = SimpleX\n\n\
\[v3]\n\
\subjectKeyIdentifier = hash\n\
\authorityKeyIdentifier = keyid:always\n\
\basicConstraints = critical,CA:true\n"
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
-- as Subject Alternative Name, unless the following validation hook is disabled:
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
createOpensslServerConf =
writeFile
opensslServerConfFile
( "[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n"
<> ("CN = " <> cn <> "\n\n")
<> "[v3]\n\
\basicConstraints = CA:FALSE\n\
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
\extendedKeyUsage = serverAuth\n"
)
where
cn = fromMaybe ip fqdn
saveFingerprint = do
Fingerprint fp <- loadFingerprint caCrtFile
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
pure fp
createIni = do
writeFile iniFile $
"[STORE_LOG]\n\
\# The server uses STM memory to store SMP queues and messages,\n\
\# that will be lost on restart (e.g., as with redis).\n\
\# This option enables saving SMP queues to append only log,\n\
\# and restoring them when the server is started.\n\
\# Log is compacted on start (deleted queues are removed).\n\
\# The messages in the queues are not logged.\n"
<> ("enable: " <> (if enableStoreLog then "on" else "off # on") <> "\n\n")
<> "[TRANSPORT]\n\
\port: 5223\n\
\websockets: off\n"
warnCAPrivateKeyFile =
putStrLn $
"----------\n\
\You should store CA private key securely and delete it from the server.\n\
\If server TLS credential is compromised this key can be used to sign a new one, \
\keeping the same server identity and established connections.\n\
\CA private key location:\n"
<> caKeyFile
<> "\n----------"
data IniOptions = IniOptions
{ enableStoreLog :: Bool,
port :: ServiceName,
enableWebsockets :: Bool
}
-- TODO ? properly parse ini as a whole
mkIniOptions :: Ini -> IniOptions
mkIniOptions ini =
IniOptions
{ enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",
port = T.unpack $ strict "TRANSPORT" "port",
enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"
}
where
strict :: String -> String -> T.Text
strict section key =
fromRight (error ("no key " <> key <> " in section " <> section)) $
lookupValue (T.pack section) (T.pack key) ini
runServer :: IniOptions -> IO ()
runServer IniOptions {enableStoreLog, port, enableWebsockets} = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint
printServiceInfo fp
storeLog <- openStoreLog
let cfg = mkServerConfig storeLog
printServerConfig cfg
runSMPServer cfg
where
checkSavedFingerprint = do
savedFingerprint <- loadSavedFingerprint
Fingerprint fp <- loadFingerprint caCrtFile
when (B.pack savedFingerprint /= strEncode fp) $
exitError "Stored fingerprint is invalid."
pure fp
mkServerConfig storeLog =
ServerConfig
{ transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],
tbqSize = 16,
serverTbqSize = 64,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
caCertificateFile = caCrtFile,
privateKeyFile = serverKeyFile,
certificateFile = serverCrtFile,
storeLog,
allowNewQueues = True,
messageTTL = Just $ 7 * 86400, -- 7 days
expireMessagesInterval = Just 21600_000000 -- microseconds, 6 hours
smpServerCLIConfig :: ServerCLIConfig ServerConfig
smpServerCLIConfig =
let caCrtFile = combine cfgPath "ca.crt"
serverKeyFile = combine cfgPath "server.key"
serverCrtFile = combine cfgPath "server.crt"
in ServerCLIConfig
{ cfgDir = cfgPath,
logDir = logPath,
iniFile = combine cfgPath "smp-server.ini",
storeLogFile = combine logPath "smp-server-store.log",
caKeyFile = combine cfgPath "ca.key",
caCrtFile,
serverKeyFile,
serverCrtFile,
fingerprintFile = combine cfgPath "fingerprint",
defaultServerPort = "5223",
executableName = "smp-server",
serverVersion = "SMP server v" <> simplexMQVersion,
mkServerConfig = \storeLogFile transports ->
ServerConfig
{ transports,
tbqSize = 16,
serverTbqSize = 64,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
caCertificateFile = caCrtFile,
privateKeyFile = serverKeyFile,
certificateFile = serverCrtFile,
storeLogFile,
allowNewQueues = True,
messageTTL = Just $ 7 * 86400, -- 7 days
expireMessagesInterval = Just 21600_000000 -- microseconds, 6 hours
}
}
openStoreLog :: IO (Maybe (StoreLog 'ReadMode))
openStoreLog =
if enableStoreLog
then Just <$> openReadStoreLog storeLogFile
else pure Nothing
printServerConfig ServerConfig {storeLog, transports} = do
putStrLn $ case storeLog of
Just s -> "Store log: " <> storeLogFilePath s
Nothing -> "Store log disabled."
forM_ transports $ \(p, ATransport t) ->
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
cleanup :: IO ()
cleanup = do
deleteDirIfExists cfgDir
deleteDirIfExists logDir
where
deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
printServiceInfo :: ByteString -> IO ()
printServiceInfo fpStr = do
putStrLn version
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
version :: String
version = "SMP server v" <> simplexMQVersion
loadSavedFingerprint :: IO String
loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine
package.yaml
+14 -3
View File
@@ -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,13 +42,17 @@ 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.*
- memory == 0.15.*
- mtl == 2.2.*
- network == 3.1.2.*
- network-transport == 0.5.*
- optparse-applicative >= 0.15 && < 0.17
- QuickCheck == 2.14.*
- process == 1.6.*
- random >= 1.1 && < 1.3
- simple-logger == 0.1.*
- sqlite-simple == 0.4.*
@@ -55,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.*
@@ -83,9 +89,14 @@ executables:
source-dirs: apps/smp-server
main: Main.hs
dependencies:
- ini == 0.4.*
- optparse-applicative >= 0.15 && < 0.17
- process == 1.6.*
- simplexmq
ghc-options:
- -threaded
ntf-server:
source-dirs: apps/ntf-server
main: Main.hs
dependencies:
- simplexmq
ghc-options:
- -threaded
protocol/diagrams/notifications/register-token.mmd
+30
View File
@@ -0,0 +1,30 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant A as agent
participant P as push server
participant APN as APN
note over M, APN: get device token
M ->> APN: registerForRemoteNotifications()
APN ->> M: device token
note over M, P: register device token with push server
M ->> C: /_ntf register <token>
C ->> A: registerNtfToken(<token>)
A ->> P: TNEW
P ->> A: ID (tokenId)
A ->> C: registered
C ->> M: registered
note over M, APN: verify device token
P ->> APN: E2E encrypted code<br>in background<br>notification
APN ->> M: deliver background notification with e2ee verification token
M ->> C: /_ntf verify <e2ee code>
C ->> A: verifyNtfToken(<e2ee code>)
A ->> P: TVFY code
P ->> A: OK / ERR
A ->> C: verified
C ->> M: verified
note over M, APN: now token ID can be used
protocol/simplex-messaging.md
+1 -1
View File
@@ -770,7 +770,7 @@ The syntax for error responses:
```abnf
error = %s"ERR " errorType
errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY"
```
Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
protocol/simplex-uri-request.txt
+2 -2
View File
@@ -13,6 +13,6 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
References:
The syntax for connection requests in the latest version of SimpleX Agent Protocol:
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/agent-protocol.md#connection-request
https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#connection-request
SimpleX Messaging Protocol:
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md
https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
protocol/smp-uri-request.txt
+1 -1
View File
@@ -13,4 +13,4 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
References:
The syntax for message queue URIs in the latest version of SimpleX Messaging Protocol:
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md#smp-queue-uri
https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#smp-queue-uri
rfcs/2022-03-22-nofication-server.md
+91
View File
@@ -0,0 +1,91 @@
# Notification server
## Background and motivation
SimpleX Chat clients should receive message notifications when not being online and/or subscribed to SMP servers.
To avoid revealing identities of clients directly to SMP servers via any kind of push notification tokens, a new party called SimpleX Notification Server is introduced to act as a service for subscribing to SMP server queue notifications on behalf of clients and sending push notifications to them.
## Proposal
TCP service using the same TLS transport as SMP server, with the fixed size blocks (256 bytes?) and the following set of commands:
### Protocol
#### Create subscription
Command:
`%s"CREATE " ntfSmpQueueURI ntfPrivateKey token subPublicKey`
Response:
`s%"OK"`
#### Check subscription status
Command:
`%s"CHECK " ntfSmpQueueURI`
Response:
```abnf
statusResp = %s"STAT " status
status = %s"ERR AUTH" / "ERR SMP AUTH" / %s"ERR SMP TIMEOUT" / %s"ACTIVE" / %s"PENDING"
```
#### Update subscription device token
Command:
`%s"TOKEN " ntfSmpQueueURI token`
Response:
`s%"OK" / %s"ERR"`
#### Delete subscription (e.g. when deleting the queue or moving to another notification server)
Command:
`%s"DELETE " SP ntfSmpQueueURI`
Response:
`s%"OK" / %s"ERR"`
### Agent schema changes
See [migration](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220322_notifications.hs)
### Agent code
```haskell
data NtfOptions = NtfOptions
{ ntfServer :: Server, -- same type as for SMP servers, probably will be renamed
ntfToken :: ByteString,
ntfInitialCheckDelay :: Int, -- initial check delay after subscription is created, seconds
ntfPeriodicCheckInterval :: Int -- subscription check interval, seconds
}
data AgentConfig = AgentConfig {
-- ...
initialNtfOpts :: Maybe NtfOptions
-- ...
}
data AgentClient = AgentClient {
-- ...
ntfOpts :: TVar (Maybe NtfOptions)
-- ...
}
```
A configuration parameter `initialNtfOpts :: Maybe NtfOptions` - if it is set or changes the agent would automatically manage subscriptions as SMP queues are subscribed/created/deleted and as the token or server changes.
There will be a method to update notifications configuration in case token or server changes.
All subscriptions will be managed in a separate subscription management loop, that would always take the earliest un-updated subscription that requires some action (ntf_sub_action column) and perform this action - the table of subscription would serve both as the table of existing subscriptions and required actions.
E.g. if the queue is subscribed and there is no notification subscription, it will be created in the table with "create" action, and the loop would create it and schedule "check" action on it.
simplexmq.cabal
+98
View File
@@ -46,14 +46,25 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations
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
Simplex.Messaging.Crypto.Ratchet
Simplex.Messaging.Encoding
Simplex.Messaging.Encoding.String
Simplex.Messaging.Notifications.Client
Simplex.Messaging.Notifications.Protocol
Simplex.Messaging.Notifications.Server
Simplex.Messaging.Notifications.Server.Env
Simplex.Messaging.Notifications.Server.Push.APNS
Simplex.Messaging.Notifications.Server.Store
Simplex.Messaging.Notifications.Transport
Simplex.Messaging.Parsers
Simplex.Messaging.Protocol
Simplex.Messaging.Server
Simplex.Messaging.Server.CLI
Simplex.Messaging.Server.Env.STM
Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.STM
@@ -63,6 +74,9 @@ library
Simplex.Messaging.TMap
Simplex.Messaging.Transport
Simplex.Messaging.Transport.Client
Simplex.Messaging.Transport.HTTP2
Simplex.Messaging.Transport.HTTP2.Client
Simplex.Messaging.Transport.HTTP2.Server
Simplex.Messaging.Transport.KeepAlive
Simplex.Messaging.Transport.Server
Simplex.Messaging.Transport.WebSockets
@@ -84,6 +98,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.*
@@ -95,11 +110,15 @@ 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.*
, 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.*
, sqlite-simple ==0.4.*
@@ -107,6 +126,67 @@ library
, 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 ntf-server
main-is: Main.hs
other-modules:
Paths_simplexmq
hs-source-dirs:
apps/ntf-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.*
@@ -137,6 +217,7 @@ executable smp-agent
, 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.*
@@ -148,11 +229,15 @@ executable smp-agent
, 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
@@ -161,6 +246,7 @@ executable smp-agent
, 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.*
@@ -191,6 +277,7 @@ executable smp-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.*
@@ -202,6 +289,7 @@ executable smp-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.*
@@ -218,6 +306,7 @@ executable smp-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.*
@@ -238,10 +327,13 @@ test-suite smp-server-test
AgentTests.ConnectionRequestTests
AgentTests.DoubleRatchetTests
AgentTests.FunctionalAPITests
AgentTests.NotificationTests
AgentTests.SQLiteTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
CoreTests.VersionRangeTests
NtfClient
NtfServerTests
ServerTests
SMPAgentClient
SMPClient
@@ -261,6 +353,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.*
@@ -274,11 +367,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
@@ -287,6 +384,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.*
src/Simplex/Messaging/Agent.hs
+155 -14
View File
@@ -48,6 +48,12 @@ module Simplex.Messaging.Agent
suspendConnection,
deleteConnection,
setSMPServers,
setNtfServers,
registerNtfToken,
verifyNtfToken,
enableNtfCron,
checkNtfToken,
deleteNtfToken,
logConnection,
)
where
@@ -58,7 +64,7 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Crypto.Random (MonadRandom)
import Data.Bifunctor (first, second)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Char8 (ByteString)
import Data.Composition ((.:), (.:.))
import Data.Functor (($>))
@@ -69,6 +75,7 @@ import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.System (systemToUTCTime)
import Data.Word (Word16)
import Database.SQLite.Simple (SQLError)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
@@ -76,15 +83,17 @@ import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Client (SMPClient (..), SMPServerTransmission)
import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..))
import Simplex.Messaging.Parsers (parse)
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody)
import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM)
import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM, ($>>=))
import Simplex.Messaging.Version
import System.Random (randomR)
import UnliftIO.Async (async, race_)
@@ -92,11 +101,11 @@ import qualified UnliftIO.Exception as E
import UnliftIO.STM
-- | Creates an SMP agent client instance
getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient
getSMPAgentClient cfg = newSMPAgentEnv cfg >>= runReaderT runAgent
getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> m AgentClient
getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
where
runAgent = do
c <- getAgentClient
c <- getAgentClient initServers
action <- async $ subscriber c `E.finally` disconnectAgentClient c
pure c {smpSubscriber = action}
@@ -149,6 +158,27 @@ deleteConnection c = withAgentEnv c . deleteConnection' c
setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers c = withAgentEnv c . setSMPServers' c
setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
setNtfServers c = withAgentEnv c . setNtfServers' c
-- | Register device notifications token
registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m ()
registerNtfToken c = withAgentEnv c . registerNtfToken' c
-- | Verify device notifications token
verifyNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c
-- | Enable/disable periodic notifications
enableNtfCron :: AgentErrorMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
enableNtfCron c = withAgentEnv c .: enableNtfCron' c
checkNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
checkNtfToken c = withAgentEnv c . checkNtfToken' c
deleteNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m ()
deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
withAgentEnv c = (`runReaderT` agentEnv c)
@@ -156,8 +186,8 @@ withAgentEnv c = (`runReaderT` agentEnv c)
-- withAgentClient c = withAgentLock c . withAgentEnv c
-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient
getAgentClient = ask >>= atomically . newAgentClient
getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => InitialAgentServers -> m AgentClient
getAgentClient initServers = ask >>= atomically . newAgentClient initServers
logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
logConnection c connected =
@@ -491,10 +521,110 @@ deleteConnection' c connId =
withStore (`deleteConn` connId)
-- | Change servers to be used for creating new queues, in Reader monad
setSMPServers' :: forall m. AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers' c servers = do
atomically $ writeTVar (smpServers c) servers
registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> m ()
registerNtfToken' c deviceToken =
withStore (`getDeviceNtfToken` deviceToken) >>= \case
(Just tkn@NtfToken {ntfTokenId, ntfTknStatus, ntfTknAction}, prevTokens) -> do
mapM_ (deleteToken_ c) prevTokens
case (ntfTokenId, ntfTknAction) of
(Nothing, Just NTARegister) -> registerToken tkn
-- TODO minimal time before repeat registration
(Just _, Nothing) -> when (ntfTknStatus == NTRegistered) $ registerToken tkn
(Just tknId, Just (NTAVerify code)) ->
t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
(Just tknId, Just (NTACron interval)) ->
t tkn (cronSuccess interval) $ agentNtfEnableCron c tknId tkn interval
(Just _tknId, Just NTACheck) -> pure () -- TODO
-- agentNtfCheckToken c tknId tkn >>= \case
(Just tknId, Just NTADelete) -> do
agentNtfDeleteToken c tknId tkn
withStore $ \st -> removeNtfToken st tkn
_ -> pure ()
_ ->
getNtfServer c >>= \case
Just ntfServer ->
asks (cmdSignAlg . config) >>= \case
C.SignAlg a -> do
tknKeys <- liftIO $ C.generateSignatureKeyPair a
dhKeys <- liftIO C.generateKeyPair'
let tkn = newNtfToken deviceToken ntfServer tknKeys dhKeys
withStore $ \st -> createNtfToken st tkn
registerToken tkn
_ -> throwError $ CMD PROHIBITED
where
t tkn = withToken c tkn Nothing
registerToken :: NtfToken -> m ()
registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
(tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
let dhSecret = C.dh' srvPubDhKey privDhKey
withStore $ \st -> updateNtfTokenRegistration st tkn tknId dhSecret
-- TODO decrypt verification code
verifyNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> ByteString -> C.CbNonce -> m ()
verifyNtfToken' c deviceToken code nonce =
withStore (`getDeviceNtfToken` deviceToken) >>= \case
(Just tkn@NtfToken {ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret}, _) -> do
code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
agentNtfVerifyToken c tknId tkn code'
_ -> throwError $ CMD PROHIBITED
enableNtfCron' :: AgentMonad m => AgentClient -> DeviceToken -> Word16 -> m ()
enableNtfCron' c deviceToken interval = do
when (interval < 20) . throwError $ CMD PROHIBITED
withStore (`getDeviceNtfToken` deviceToken) >>= \case
(Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive}, _) ->
withToken c tkn (Just (NTActive, NTACron interval)) (cronSuccess interval) $
agentNtfEnableCron c tknId tkn interval
_ -> throwError $ CMD PROHIBITED
cronSuccess :: Word16 -> (NtfTknStatus, Maybe NtfTknAction)
cronSuccess interval
| interval == 0 = (NTActive, Just NTACheck)
| otherwise = (NTActive, Just $ NTACron interval)
checkNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m NtfTknStatus
checkNtfToken' c deviceToken =
withStore (`getDeviceNtfToken` deviceToken) >>= \case
(Just tkn@NtfToken {ntfTokenId = Just tknId}, _) -> agentNtfCheckToken c tknId tkn
_ -> throwError $ CMD PROHIBITED
deleteNtfToken' :: AgentMonad m => AgentClient -> DeviceToken -> m ()
deleteNtfToken' c deviceToken =
withStore (`getDeviceNtfToken` deviceToken) >>= \case
(Just tkn, _) -> deleteToken_ c tkn
_ -> throwError $ CMD PROHIBITED
deleteToken_ :: AgentMonad m => AgentClient -> NtfToken -> m ()
deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
forM_ ntfTokenId $ \tknId -> do
withStore $ \st -> updateNtfToken st tkn ntfTknStatus (Just NTADelete)
agentNtfDeleteToken c tknId tkn `catchError` \case
NTF AUTH -> pure ()
e -> throwError e
withStore $ \st -> removeNtfToken st tkn
withToken :: AgentMonad m => AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> m a -> m a
withToken c tkn@NtfToken {deviceToken} from_ (toStatus, toAction_) f = do
forM_ from_ $ \(status, action) -> withStore $ \st -> updateNtfToken st tkn status (Just action)
tryError f >>= \case
Right res -> do
withStore $ \st -> updateNtfToken st tkn toStatus toAction_
pure res
Left e@(NTF AUTH) -> do
withStore $ \st -> removeNtfToken st tkn
registerNtfToken' c deviceToken
throwError e
Left e -> throwError e
setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
setNtfServers' c servers = do
atomically $ writeTVar (ntfServers c) servers
getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
getSMPServer c = do
smpServers <- readTVarIO $ smpServers c
@@ -502,8 +632,19 @@ getSMPServer c = do
srv :| [] -> pure srv
servers -> do
gen <- asks randomServer
i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1)
pure $ servers L.!! i
atomically . stateTVar gen $
first (servers L.!!) . randomR (0, L.length servers - 1)
getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
getNtfServer c = do
ntfServers <- readTVarIO $ ntfServers c
case ntfServers of
[] -> pure Nothing
[srv] -> pure $ Just srv
servers -> do
gen <- asks randomServer
atomically . stateTVar gen $
first (Just . (servers !!)) . randomR (0, length servers - 1)
subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
subscriber c@AgentClient {msgQ} = forever $ do
@@ -512,7 +653,7 @@ subscriber c@AgentClient {msgQ} = forever $ do
Left e -> liftIO $ print e
Right _ -> return ()
processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SMPServerTransmission -> m ()
processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd) = do
withStore (\st -> getRcvConn st srv rId) >>= \case
SomeConn SCDuplex (DuplexConnection cData rq _) -> processSMP SCDuplex cData rq
@@ -555,7 +696,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
_ -> prohibited >> ack
_ -> prohibited >> ack
SMP.END ->
atomically (TM.lookup srv smpClients >>= fmap join . mapM tryReadTMVar >>= processEND)
atomically (TM.lookup srv smpClients $>>= tryReadTMVar >>= processEND)
>>= logServer "<--" c srv rId
where
processEND = \case
src/Simplex/Messaging/Agent/Client.hs
+182 -120
View File
@@ -1,15 +1,15 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Agent.Client
( AgentClient (..),
@@ -25,6 +25,11 @@ module Simplex.Messaging.Agent.Client
RetryInterval (..),
secureQueue,
sendAgentMessage,
agentNtfRegisterToken,
agentNtfVerifyToken,
agentNtfCheckToken,
agentNtfDeleteToken,
agentNtfEnableCron,
agentCbEncrypt,
agentCbDecrypt,
cryptoError,
@@ -52,14 +57,18 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import Data.Text.Encoding
import Data.Word (Word16)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol (QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
@@ -67,18 +76,23 @@ import Simplex.Messaging.Util (bshow, liftEitherError, liftError, tryError, when
import Simplex.Messaging.Version
import System.Timeout (timeout)
import UnliftIO (async, forConcurrently_)
import UnliftIO.Exception (Exception, IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type ClientVar msg = TMVar (Either AgentErrorType (ProtocolClient msg))
type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
data AgentClient = AgentClient
{ rcvQ :: TBQueue (ATransmission 'Client),
subQ :: TBQueue (ATransmission 'Agent),
msgQ :: TBQueue SMPServerTransmission,
msgQ :: TBQueue (ServerTransmission BrokerMsg),
smpServers :: TVar (NonEmpty SMPServer),
ntfServers :: TVar [NtfServer],
smpClients :: TMap SMPServer SMPClientVar,
ntfClients :: TMap NtfServer NtfClientVar,
subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
subscrConns :: TMap ConnId SMPServer,
@@ -93,14 +107,16 @@ data AgentClient = AgentClient
lock :: TMVar ()
}
newAgentClient :: Env -> STM AgentClient
newAgentClient agentEnv = do
newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
let qSize = tbqSize $ config agentEnv
rcvQ <- newTBQueue qSize
subQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
smpServers <- newTVar $ initialSMPServers (config agentEnv)
smpServers <- newTVar smp
ntfServers <- newTVar ntf
smpClients <- TM.empty
ntfClients <- TM.empty
subscrSrvrs <- TM.empty
pendingSubscrSrvrs <- TM.empty
subscrConns <- TM.empty
@@ -111,80 +127,35 @@ newAgentClient agentEnv = do
asyncClients <- newTVar []
clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
lock <- newTMVar ()
return AgentClient {rcvQ, subQ, msgQ, smpServers, smpClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
return AgentClient {rcvQ, subQ, msgQ, smpServers, ntfServers, smpClients, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
-- | Agent monad with MonadReader Env and MonadError AgentErrorType
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
class ProtocolServerClient msg where
getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
protocolError :: ErrorType -> AgentErrorType
instance Exception e => Exception (InternalException e)
instance ProtocolServerClient BrokerMsg where
getProtocolServerClient = getSMPServerClient
protocolError = SMP
instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
withRunInIO exceptToIO =
withExceptT unInternalException . ExceptT . E.try $
withRunInIO $ \run ->
exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
instance ProtocolServerClient NtfResponse where
getProtocolServerClient = getNtfServerClient
protocolError = NTF
getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
atomically getClientVar >>= either newSMPClient waitForSMPClient
atomically (getClientVar srv smpClients)
>>= either
(newProtocolClient c srv smpClients connectClient reconnectClient)
(waitForProtocolClient smpCfg)
where
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
newClientVar :: STM SMPClientVar
newClientVar = do
smpVar <- newEmptyTMVar
TM.insert srv smpVar smpClients
pure smpVar
waitForSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
waitForSMPClient smpVar = do
SMPClientConfig {tcpTimeout} <- asks $ smpCfg . config
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER TIMEOUT
newSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> m a) -> m () -> m a
tryConnectClient successAction retryAction =
tryError connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
successAction smp
Left e -> do
if e == BROKER NETWORK || e == BROKER TIMEOUT
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
TM.delete srv smpClients
throwError e
tryConnectAsync :: m ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients c) (a :)
connectAsync :: m ()
connectAsync = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
connectClient :: m SMPClient
connectClient = do
cfg <- asks $ smpCfg . config
u <- askUnliftIO
liftEitherError smpClientError (getSMPClient srv cfg msgQ $ clientDisconnected u)
`E.catch` internalError
where
internalError :: IOException -> m SMPClient
internalError = throwError . INTERNAL . show
liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
clientDisconnected :: UnliftIO m -> IO ()
clientDisconnected u = do
@@ -194,13 +165,14 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
cVar_ <- TM.lookupDelete srv $ subscrSrvrs c
forM cVar_ $ \cVar -> do
cs <- readTVar cVar
modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
addPendingSubs cVar cs
pure cs
TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
where
updateSubs cVar = do
cs <- readTVar cVar
modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
addPendingSubs cVar cs
pure cs
addPendingSubs cVar cs = do
let ps = pendingSubscrSrvrs c
TM.lookup srv ps >>= \case
@@ -225,30 +197,100 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
reconnectClient :: m ()
reconnectClient =
withAgentLock c . withSMP c srv $ \smp -> do
withAgentLock c . withClient c srv $ \smp -> do
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSubscrSrvrs c)
forConcurrently_ (maybe [] M.toList cs) $ \sub@(connId, _) ->
whenM (atomically $ isNothing <$> TM.lookup connId (subscrConns c)) $
subscribe_ smp sub `catchError` handleError connId
where
subscribe_ :: SMPClient -> (ConnId, RcvQueue) -> ExceptT SMPClientError IO ()
subscribe_ :: SMPClient -> (ConnId, RcvQueue) -> ExceptT ProtocolClientError IO ()
subscribe_ smp (connId, rq@RcvQueue {rcvPrivateKey, rcvId}) = do
subscribeSMPQueue smp rcvPrivateKey rcvId
addSubscription c rq connId
liftIO $ notifySub UP connId
handleError :: ConnId -> SMPClientError -> ExceptT SMPClientError IO ()
handleError :: ConnId -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
handleError connId = \case
e@SMPResponseTimeout -> throwError e
e@SMPNetworkError -> throwError e
e@PCEResponseTimeout -> throwError e
e@PCENetworkError -> throwError e
e -> do
liftIO $ notifySub (ERR $ smpClientError e) connId
liftIO $ notifySub (ERR $ protocolClientError SMP e) connId
atomically $ removePendingSubscription c srv connId
notifySub :: ACommand 'Agent -> ConnId -> IO ()
notifySub cmd connId = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
closeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient
getNtfServerClient c@AgentClient {ntfClients} srv =
atomically (getClientVar srv ntfClients)
>>= either
(newProtocolClient c srv ntfClients connectClient $ pure ())
(waitForProtocolClient ntfCfg)
where
connectClient :: m NtfClient
connectClient = do
cfg <- asks $ ntfCfg . config
liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
clientDisconnected :: IO ()
clientDisconnected = do
atomically $ TM.delete srv ntfClients
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getClientVar :: forall a. ProtocolServer -> TMap ProtocolServer (TMVar a) -> STM (Either (TMVar a) (TMVar a))
getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
where
newClientVar :: STM (TMVar a)
newClientVar = do
var <- newEmptyTMVar
TM.insert srv var clients
pure var
waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
waitForProtocolClient clientConfig clientVar = do
ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
liftEither $ case client_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER TIMEOUT
newProtocolClient ::
forall msg m.
AgentMonad m =>
AgentClient ->
ProtocolServer ->
TMap ProtocolServer (ClientVar msg) ->
m (ProtocolClient msg) ->
m () ->
ClientVar msg ->
m (ProtocolClient msg)
newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
tryConnectClient successAction retryAction =
tryError connectClient >>= \r -> case r of
Right client -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar clientVar r
successAction client
Left e -> do
if e == BROKER NETWORK || e == BROKER TIMEOUT
then retryAction
else atomically $ do
putTMVar clientVar (Left e)
TM.delete srv clients
throwError e
tryConnectAsync :: m ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients c) (a :)
connectAsync :: m ()
connectAsync = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
closeAgentClient :: MonadIO m => AgentClient -> m ()
closeAgentClient c = liftIO $ do
closeSMPServerClients c
cancelActions $ reconnections c
@@ -260,7 +302,7 @@ closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeCli
where
closeClient smpVar =
atomically (readTMVar smpVar) >>= \case
Right smp -> closeSMPClient smp `E.catch` \(_ :: E.SomeException) -> pure ()
Right smp -> closeProtocolClient smp `E.catch` \(_ :: E.SomeException) -> pure ()
_ -> pure ()
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
@@ -272,40 +314,40 @@ withAgentLock AgentClient {lock} =
(void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ())
withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ c srv action =
(getSMPServerClient c srv >>= action) `catchError` logServerError
withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> m a) -> m a
withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
where
logServerError :: AgentErrorType -> m a
logServerError e = do
logServer "<--" c srv "" $ bshow e
throwError e
withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
withLogSMP_ c srv qId cmdStr action = do
withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
withLogClient_ c srv qId cmdStr action = do
logServer "-->" c srv qId cmdStr
res <- withSMP_ c srv action
res <- withClient_ c srv action
logServer "<--" c srv qId "OK"
return res
withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withSMP c srv action = withSMP_ c srv $ liftSMP . action
withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withClient c srv action = withClient_ c srv $ liftClient (protocolError @msg) . action
withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action
withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (protocolError @msg) . action
liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
liftSMP = liftError smpClientError
liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
liftClient = liftError . protocolClientError
smpClientError :: SMPClientError -> AgentErrorType
smpClientError = \case
SMPServerError e -> SMP e
SMPResponseError e -> BROKER $ RESPONSE e
SMPUnexpectedResponse -> BROKER UNEXPECTED
SMPResponseTimeout -> BROKER TIMEOUT
SMPNetworkError -> BROKER NETWORK
SMPTransportError e -> BROKER $ TRANSPORT e
e -> INTERNAL $ show e
protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
protocolClientError protocolError_ = \case
PCEProtocolError e -> protocolError_ e
PCEResponseError e -> BROKER $ RESPONSE e
PCEUnexpectedResponse -> BROKER UNEXPECTED
PCEResponseTimeout -> BROKER TIMEOUT
PCENetworkError -> BROKER NETWORK
PCETransportError e -> BROKER $ TRANSPORT e
e@PCESignatureError {} -> INTERNAL $ show e
e@PCEIOError {} -> INTERNAL $ show e
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
newRcvQueue c srv =
@@ -324,7 +366,7 @@ newRcvQueue_ a c srv = do
(e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
logServer "-->" c srv "" "NEW"
QIK {rcvId, sndId, rcvPublicDhKey} <-
withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
let rq =
RcvQueue
@@ -342,15 +384,15 @@ newRcvQueue_ a c srv = do
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
atomically $ addPendingSubscription c rq connId
withLogSMP c server rcvId "SUB" $ \smp -> do
withLogClient c server rcvId "SUB" $ \smp -> do
liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
Left e -> do
atomically . when (e /= SMPNetworkError && e /= SMPResponseTimeout) $
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription c server connId
throwError e
Right _ -> addSubscription c rq connId
addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addSubscription c rq@RcvQueue {server} connId = atomically $ do
TM.insert connId server $ subscrConns c
addSubs_ (subscrSrvrs c) rq connId
@@ -377,12 +419,12 @@ removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> S
removeSubs_ ss server connId =
TM.lookup server ss >>= mapM_ (TM.delete connId)
logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
logServer :: MonadIO m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
logServer dir AgentClient {clientId} srv qId cmdStr =
logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
showServer :: SMPServer -> ByteString
showServer SMPServer {host, port} =
showServer ProtocolServer {host, port} =
B.pack $ host <> if null port then "" else ':' : port
logSecret :: ByteString -> ByteString
@@ -390,17 +432,17 @@ logSecret bs = encode $ B.take 3 bs
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
withLogSMP_ c server sndId "SEND <CONF>" $ \smp -> do
withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
liftSMP $ sendSMPMessage smp Nothing sndId msg
liftClient SMP $ sendSMPMessage smp Nothing sndId msg
sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do
withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
msg <- mkInvitation
liftSMP $ sendSMPMessage smp Nothing senderId msg
liftClient SMP $ sendSMPMessage smp Nothing senderId msg
where
mkInvitation :: m ByteString
-- this is only encrypted with per-queue E2E, not with double ratchet
@@ -411,30 +453,50 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) co
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
withLogSMP c server rcvId "KEY <key>" $ \smp ->
withLogClient c server rcvId "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogSMP c server rcvId "ACK" $ \smp ->
withLogClient c server rcvId "ACK" $ \smp ->
ackSMPMessage smp rcvPrivateKey rcvId
suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogSMP c server rcvId "OFF" $ \smp ->
withLogClient c server rcvId "OFF" $ \smp ->
suspendSMPQueue smp rcvPrivateKey rcvId
deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogSMP c server rcvId "DEL" $ \smp ->
withLogClient c server rcvId "DEL" $ \smp ->
deleteSMPQueue smp rcvPrivateKey rcvId
sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
withLogSMP_ c server sndId "SEND <MSG>" $ \smp -> do
withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c ntfServer $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus
agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m ()
agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
src/Simplex/Messaging/Agent/Env/SQLite.hs
+25 -12
View File
@@ -2,11 +2,14 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
module Simplex.Messaging.Agent.Env.SQLite
( AgentConfig (..),
InitialAgentServers (..),
defaultAgentConfig,
defaultReconnectInterval,
Env (..),
newSMPAgentEnv,
)
@@ -24,19 +27,26 @@ import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Client (NtfServer)
import Simplex.Messaging.Transport (TLS, Transport (..))
import System.Random (StdGen, newStdGen)
import UnliftIO.STM
data InitialAgentServers = InitialAgentServers
{ smp :: NonEmpty SMPServer,
ntf :: [NtfServer]
}
data AgentConfig = AgentConfig
{ tcpPort :: ServiceName,
initialSMPServers :: NonEmpty SMPServer,
cmdSignAlg :: C.SignAlg,
connIdBytes :: Int,
tbqSize :: Natural,
dbFile :: FilePath,
dbPoolSize :: Int,
yesToMigrations :: Bool,
smpCfg :: SMPClientConfig,
smpCfg :: ProtocolClientConfig,
ntfCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
helloTimeout :: NominalDiffTime,
caCertificateFile :: FilePath,
@@ -44,24 +54,29 @@ data AgentConfig = AgentConfig
certificateFile :: FilePath
}
defaultReconnectInterval :: RetryInterval
defaultReconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
}
where
second = 1_000_000
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
{ tcpPort = "5224",
initialSMPServers = undefined, -- TODO move it elsewhere?
cmdSignAlg = C.SignAlg C.SEd448,
connIdBytes = 12,
tbqSize = 64,
dbFile = "smp-agent.db",
dbPoolSize = 4,
yesToMigrations = False,
smpCfg = smpDefaultConfig,
reconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
},
smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
reconnectInterval = defaultReconnectInterval,
helloTimeout = 2 * nominalDay,
-- CA certificate private key is not needed for initialization
-- ! we do not generate these
@@ -69,8 +84,6 @@ defaultAgentConfig =
privateKeyFile = "/etc/opt/simplex-agent/agent.key",
certificateFile = "/etc/opt/simplex-agent/agent.crt"
}
where
second = 1_000_000
data Env = Env
{ config :: AgentConfig,
src/Simplex/Messaging/Agent/Protocol.hs
+9 -3
View File
@@ -7,6 +7,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -49,7 +50,8 @@ module Simplex.Messaging.Agent.Protocol
AgentMessageType (..),
APrivHeader (..),
AMessage (..),
SMPServer (..),
SMPServer,
pattern SMPServer,
SrvLoc (..),
SMPQueueUri (..),
SMPQueueInfo (..),
@@ -131,9 +133,10 @@ import Simplex.Messaging.Protocol
( ErrorType,
MsgBody,
MsgId,
SMPServer (..),
SMPServer,
SndPublicVerifyKey,
SrvLoc (..),
pattern SMPServer,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
@@ -539,7 +542,6 @@ data SMPQueueUri = SMPQueueUri
}
deriving (Eq, Show)
-- TODO change SMP queue URI format to include version range and allow unknown parameters
instance StrEncoding SMPQueueUri where
-- v1 uses short SMP queue URI format
strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
@@ -684,6 +686,8 @@ data AgentErrorType
CONN {connErr :: ConnectionErrorType}
| -- | SMP protocol errors forwarded to agent clients
SMP {smpErr :: ErrorType}
| -- | NTF protocol errors forwarded to agent clients
NTF {ntfErr :: ErrorType}
| -- | SMP server errors
BROKER {brokerErr :: BrokerErrorType}
| -- | errors of other agents
@@ -772,6 +776,7 @@ instance StrEncoding AgentErrorType where
"CMD " *> (CMD <$> parseRead1)
<|> "CONN " *> (CONN <$> parseRead1)
<|> "SMP " *> (SMP <$> strP)
<|> "NTF " *> (NTF <$> strP)
<|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> strP)
<|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
<|> "BROKER " *> (BROKER <$> parseRead1)
@@ -781,6 +786,7 @@ instance StrEncoding AgentErrorType where
CMD e -> "CMD " <> bshow e
CONN e -> "CONN " <> bshow e
SMP e -> "SMP " <> strEncode e
NTF e -> "NTF " <> strEncode e
BROKER (RESPONSE e) -> "BROKER RESPONSE " <> strEncode e
BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
BROKER e -> "BROKER " <> bshow e
src/Simplex/Messaging/Agent/Server.hs
+6 -6
View File
@@ -31,17 +31,17 @@ import UnliftIO.STM
-- | Runs an SMP agent as a TCP service using passed configuration.
--
-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
runSMPAgent t cfg = do
runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
runSMPAgent t cfg initServers = do
started <- newEmptyTMVarIO
runSMPAgentBlocking t started cfg
runSMPAgentBlocking t started cfg initServers
-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
--
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} = do
runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
where
smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
@@ -50,7 +50,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
c <- getAgentClient
c <- getAgentClient initServers
logConnection c True
race_ (connectClient h c) (runAgentClient c)
`E.finally` disconnectAgentClient c
src/Simplex/Messaging/Agent/Store.hs
+10
View File
@@ -20,6 +20,8 @@ import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys)
import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfTknStatus, NtfTokenId)
import Simplex.Messaging.Protocol
( MsgBody,
MsgId,
@@ -75,6 +77,14 @@ class Monad m => MonadAgentStore s m where
getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys
updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
-- Notification device token persistence
createNtfToken :: s -> NtfToken -> m ()
getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
removeNtfToken :: s -> NtfToken -> m ()
-- * Queue types
-- | A receive queue. SMP queue through which the agent receives messages from a sender.
src/Simplex/Messaging/Agent/Store/SQLite.hs
+97 -21
View File
@@ -9,6 +9,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -22,7 +23,6 @@ module Simplex.Messaging.Agent.Store.SQLite
connectSQLiteStore,
withConnection,
withTransaction,
fromTextField_,
firstRow,
)
where
@@ -33,21 +33,21 @@ import Control.Exception (bracket)
import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
import Data.Bifunctor (second)
import Data.Bifunctor (first, second)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as U
import Data.Char (toLower)
import Data.Functor (($>))
import Data.List (find, foldl')
import Data.List (find, foldl', partition)
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, ToRow, field)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLError, ToRow, field)
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.QQ (sql)
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Protocol
@@ -58,8 +58,10 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (blobFieldParser)
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Notifications.Client (NtfServer, NtfTknAction, NtfToken (..))
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus (..), NtfTokenId)
import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
import Simplex.Messaging.Protocol (MsgBody, ProtocolServer (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (bshow, liftIOEither)
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
@@ -206,7 +208,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
getConn_ db connId
getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn
getRcvConn st SMPServer {host, port} rcvId =
getRcvConn st ProtocolServer {host, port} rcvId =
liftIOEither . withTransaction st $ \db ->
DB.queryNamed
db
@@ -251,7 +253,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
_ -> pure $ Left SEConnNotFound
setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus st RcvQueue {rcvId, server = SMPServer {host, port}} status =
setRcvQueueStatus st RcvQueue {rcvId, server = ProtocolServer {host, port}} status =
-- ? throw error if queue does not exist?
liftIO . withTransaction st $ \db ->
DB.executeNamed
@@ -264,7 +266,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
[":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
setRcvQueueConfirmedE2E :: SQLiteStore -> RcvQueue -> C.DhSecretX25519 -> m ()
setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eDhSecret =
setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
@@ -282,7 +284,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
]
setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus st SndQueue {sndId, server = SMPServer {host, port}} status =
setSndQueueStatus st SndQueue {sndId, server = ProtocolServer {host, port}} status =
-- ? throw error if queue does not exist?
liftIO . withTransaction st $ \db ->
DB.executeNamed
@@ -564,6 +566,75 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
forM_ (M.assocs mks) $ \(msgN, mk) ->
DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
createNtfToken :: SQLiteStore -> NtfToken -> m ()
createNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction} =
liftIO . withTransaction st $ \db -> do
upsertNtfServer_ db srv
DB.execute
db
[sql|
INSERT INTO ntf_tokens
(provider, device_token, ntf_host, ntf_port, tkn_id, tkn_pub_key, tkn_priv_key, tkn_pub_dh_key, tkn_priv_dh_key, tkn_dh_secret, tkn_status, tkn_action) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
|]
(provider, token, host, port, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction)
getDeviceNtfToken :: SQLiteStore -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
getDeviceNtfToken st t =
liftIO . withTransaction st $ \db -> do
tokens <-
map ntfToken
<$> DB.query_
db
[sql|
SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, t.tkn_status, t.tkn_action
FROM ntf_tokens t
JOIN ntf_servers s USING (ntf_host, ntf_port)
|]
pure . first listToMaybe $ partition ((t ==) . deviceToken) tokens
where
ntfToken (host, port, keyHash, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret, ntfTknStatus, ntfTknAction) =
let ntfServer = ProtocolServer {host, port, keyHash}
ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
in NtfToken {deviceToken = t, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction}
updateNtfTokenRegistration :: SQLiteStore -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
updateNtfTokenRegistration st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret =
liftIO . withTransaction st $ \db -> do
updatedAt <- getCurrentTime
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_id = ?, tkn_dh_secret = ?, tkn_status = ?, tkn_action = ?, updated_at = ?
WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
|]
(tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
updateNtfToken :: SQLiteStore -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
updateNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction =
liftIO . withTransaction st $ \db -> do
updatedAt <- getCurrentTime
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_status = ?, tkn_action = ?, updated_at = ?
WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
|]
(tknStatus, tknAction, updatedAt, provider, token, host, port)
removeNtfToken :: SQLiteStore -> NtfToken -> m ()
removeNtfToken st NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} =
liftIO . withTransaction st $ \db ->
DB.execute
db
[sql|
DELETE FROM ntf_tokens
WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ?
|]
(provider, token, host, port)
-- * Auxiliary helpers
instance ToField QueueStatus where toField = toField . serializeQueueStatus
@@ -610,14 +681,6 @@ instance ToField (SConnectionMode c) where toField = toField . connMode
instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT
fromTextField_ :: (E.Typeable a) => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ fromText = \case
f@(Field (SQLText t) _) ->
case fromText t of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
f -> returnError ConversionFailed f "expecting SQLText column type"
listToEither :: e -> [a] -> Either e a
listToEither _ (x : _) = Right x
listToEither e _ = Left e
@@ -656,7 +719,7 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
-- * Server upsert helper
upsertServer_ :: DB.Connection -> SMPServer -> IO ()
upsertServer_ dbConn SMPServer {host, port, keyHash} = do
upsertServer_ dbConn ProtocolServer {host, port, keyHash} = do
DB.executeNamed
dbConn
[sql|
@@ -668,6 +731,19 @@ upsertServer_ dbConn SMPServer {host, port, keyHash} = do
|]
[":host" := host, ":port" := port, ":key_hash" := keyHash]
upsertNtfServer_ :: DB.Connection -> NtfServer -> IO ()
upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
DB.executeNamed
db
[sql|
INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (:host,:port,:key_hash)
ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET
ntf_host=excluded.ntf_host,
ntf_port=excluded.ntf_port,
ntf_key_hash=excluded.ntf_key_hash;
|]
[":host" := host, ":port" := port, ":key_hash" := keyHash]
-- * createRcvConn helpers
insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -26,6 +26,7 @@ import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
@@ -33,7 +34,8 @@ data Migration = Migration {name :: String, up :: Text}
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial),
("20220301_snd_queue_keys", m20220301_snd_queue_keys)
("20220301_snd_queue_keys", m20220301_snd_queue_keys),
("20220322_notifications", m20220322_notifications)
]
-- | The list of migrations in ascending order by date
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220322_notifications.hs
+39
View File
@@ -0,0 +1,39 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220322_notifications :: Query
m20220322_notifications =
[sql|
CREATE TABLE ntf_servers (
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_key_hash BLOB NOT NULL,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')),
PRIMARY KEY (ntf_host, ntf_port)
) WITHOUT ROWID;
CREATE TABLE ntf_tokens (
provider TEXT NOT NULL, -- apn
device_token TEXT NOT NULL,
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
tkn_id BLOB, -- token ID assigned by notifications server
tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands (used by server, for repeat registraions)
tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key (for repeat registraions)
tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key (for repeat registraions)
tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
tkn_status TEXT NOT NULL,
tkn_action BLOB,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')), -- this is to check token status periodically to know when it was last checked
PRIMARY KEY (provider, device_token, ntf_host, ntf_port),
FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220404_ntf_subscriptions_draft.hs
+38
View File
@@ -0,0 +1,38 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220404_ntf_subscriptions_draft :: Query
m20220404_ntf_subscriptions_draft =
[sql|
ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
CREATE TABLE ntf_subscriptions (
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_sub_id BLOB NOT NULL,
ntf_sub_status TEXT NOT NULL, -- new, created, active, pending, error_auth
ntf_sub_action TEXT, -- if there is an action required on this subscription: create / check / token / delete
ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
ntf_token TEXT NOT NULL, -- or BLOB?
smp_host TEXT NOT NULL,
smp_port TEXT NOT NULL,
smp_ntf_id BLOB NOT NULL,
created_at TEXT NOT NULL,
updated_at TEXT NOT NULL, -- this is to check subscription status periodically to know when it was last checked
PRIMARY KEY (ntf_host, ntf_port, ntf_sub_id),
FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE,
FOREIGN KEY (smp_host, smp_port, smp_ntf_id) REFERENCES rcv_queues (host, port, ntf_id)
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
|]
src/Simplex/Messaging/Client.hs
+110 -101
View File
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -23,9 +24,10 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Client
( -- * Connect (disconnect) client to (from) SMP server
SMPClient (sessionId),
getSMPClient,
closeSMPClient,
ProtocolClient (sessionId),
SMPClient,
getProtocolClient,
closeProtocolClient,
-- * SMP protocol command functions
createSMPQueue,
@@ -37,13 +39,13 @@ module Simplex.Messaging.Client
ackSMPMessage,
suspendSMPQueue,
deleteSMPQueue,
sendSMPCommand,
sendProtocolCommand,
-- * Supporting types and client configuration
SMPClientError (..),
SMPClientConfig (..),
smpDefaultConfig,
SMPServerTransmission,
ProtocolClientError (..),
ProtocolClientConfig (..),
defaultClientConfig,
ServerTransmission,
)
where
@@ -60,7 +62,7 @@ import Data.Maybe (fromMaybe)
import Network.Socket (ServiceName)
import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
@@ -72,31 +74,30 @@ import System.Timeout (timeout)
-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- The only exported selector is blockSize that is negotiated
-- with the server during the TCP transport handshake.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data SMPClient = SMPClient
data ProtocolClient msg = ProtocolClient
{ action :: Async (),
connected :: TVar Bool,
sessionId :: SessionId,
smpServer :: SMPServer,
protocolServer :: ProtocolServer,
tcpTimeout :: Int,
clientCorrId :: TVar Natural,
sentCommands :: TMap CorrId Request,
sentCommands :: TMap CorrId (Request msg),
sndQ :: TBQueue SentRawTransmission,
rcvQ :: TBQueue (SignedTransmission BrokerMsg),
msgQ :: TBQueue SMPServerTransmission
rcvQ :: TBQueue (SignedTransmission msg),
msgQ :: Maybe (TBQueue (ServerTransmission msg))
}
-- | Type synonym for transmission from some SPM server queue.
type SMPServerTransmission = (SMPServer, SessionId, RecipientId, BrokerMsg)
type SMPClient = ProtocolClient SMP.BrokerMsg
-- | SMP client configuration.
data SMPClientConfig = SMPClientConfig
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission msg = (ProtocolServer, SessionId, QueueId, msg)
-- | protocol client configuration.
data ProtocolClientConfig = ProtocolClientConfig
{ -- | size of TBQueue to use for server commands and responses
qSize :: Natural,
-- | default SMP server port if port is not specified in SMPServer
-- | default server port if port is not specified in ProtocolServer
defaultTransport :: (ServiceName, ATransport),
-- | timeout of TCP commands (microseconds)
tcpTimeout :: Int,
@@ -106,46 +107,47 @@ data SMPClientConfig = SMPClientConfig
smpPing :: Int
}
-- | Default SMP client configuration.
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig =
SMPClientConfig
-- | Default protocol client configuration.
defaultClientConfig :: ProtocolClientConfig
defaultClientConfig =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("5223", transport @TLS),
defaultTransport = ("443", transport @TLS),
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPing = 600_000_000 -- 10min
}
data Request = Request
data Request msg = Request
{ queueId :: QueueId,
responseVar :: TMVar Response
responseVar :: TMVar (Response msg)
}
type Response = Either SMPClientError BrokerMsg
type Response msg = Either ProtocolClientError msg
-- | Connects to 'SMPServer' using passed client configuration
-- | Connects to 'ProtocolServer' using passed client configuration
-- and queue for messages and notifications.
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
atomically mkSMPClient >>= runClient useTransport
getProtocolClient :: forall msg. Protocol msg => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
(atomically mkProtocolClient >>= runClient useTransport)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
where
mkSMPClient :: STM SMPClient
mkSMPClient = do
mkProtocolClient :: STM (ProtocolClient msg)
mkProtocolClient = do
connected <- newTVar False
clientCorrId <- newTVar 0
sentCommands <- TM.empty
sndQ <- newTBQueue qSize
rcvQ <- newTBQueue qSize
return
SMPClient
ProtocolClient
{ action = undefined,
sessionId = undefined,
connected,
smpServer,
protocolServer,
tcpTimeout,
clientCorrId,
sentCommands,
@@ -154,50 +156,51 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, tcpKeepAlive, smp
msgQ
}
runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
runClient (port', ATransport t) c = do
thVar <- newEmptyTMVarIO
action <-
async $
runTransportClient (host smpServer) port' (keyHash smpServer) tcpKeepAlive (client t c thVar)
`finally` atomically (putTMVar thVar $ Left SMPNetworkError)
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
Just (Right THandle {sessionId}) -> Right c {action, sessionId}
Just (Left e) -> Left e
Nothing -> Left SMPNetworkError
Nothing -> Left PCENetworkError
useTransport :: (ServiceName, ATransport)
useTransport = case port smpServer of
useTransport = case port protocolServer of
"" -> defaultTransport cfg
"80" -> ("80", transport @WS)
p -> (p, transport @TLS)
client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()
client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
client _ c thVar h =
runExceptT (clientHandshake h $ keyHash smpServer) >>= \case
Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
runExceptT (protocolClientHandshake @msg h $ keyHash protocolServer) >>= \case
Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
Right th@THandle {sessionId} -> do
atomically $ do
writeTVar (connected c) True
putTMVar thVar $ Right th
let c' = c {sessionId} :: SMPClient
let c' = c {sessionId} :: ProtocolClient msg
-- TODO remove ping if 0 is passed (or Nothing?)
raceAny_ [send c' th, process c', receive c' th, ping c']
`finally` disconnected
send :: Transport c => SMPClient -> THandle c -> IO ()
send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
receive :: Transport c => SMPClient -> THandle c -> IO ()
receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
ping :: SMPClient -> IO ()
ping :: ProtocolClient msg -> IO ()
ping c = forever $ do
threadDelay smpPing
runExceptT $ sendSMPCommand c Nothing "" PING
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
process :: SMPClient -> IO ()
process SMPClient {sessionId, rcvQ, sentCommands} = forever $ do
process :: ProtocolClient msg -> IO ()
process ProtocolClient {sessionId, rcvQ, sentCommands} = forever $ do
(_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
if B.null $ bs corrId
then sendMsg qId respOrErr
@@ -209,45 +212,48 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, tcpKeepAlive, smp
putTMVar responseVar $
if queueId == qId
then case respOrErr of
Left e -> Left $ SMPResponseError e
Right (ERR e) -> Left $ SMPServerError e
Right r -> Right r
else Left SMPUnexpectedResponse
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
else Left PCEUnexpectedResponse
where
sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO ()
sendMsg :: QueueId -> Either ErrorType msg -> IO ()
sendMsg qId = \case
Right cmd -> atomically $ writeTBQueue msgQ (smpServer, sessionId, qId, cmd)
Right cmd -> atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, qId, cmd)) msgQ
-- TODO send everything else to errQ and log in agent
_ -> return ()
-- | Disconnects SMP client from the server and terminates client threads.
closeSMPClient :: SMPClient -> IO ()
closeSMPClient = uninterruptibleCancel . action
-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient msg -> IO ()
closeProtocolClient = uninterruptibleCancel . action
-- | SMP client error type.
data SMPClientError
data ProtocolClientError
= -- | Correctly parsed SMP server ERR response.
-- This error is forwarded to the agent client as `ERR SMP err`.
SMPServerError ErrorType
PCEProtocolError ErrorType
| -- | Invalid server response that failed to parse.
-- Forwarded to the agent client as `ERR BROKER RESPONSE`.
SMPResponseError ErrorType
PCEResponseError ErrorType
| -- | Different response from what is expected to a certain SMP command,
-- e.g. server should respond `IDS` or `ERR` to `NEW` command,
-- other responses would result in this error.
-- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
SMPUnexpectedResponse
PCEUnexpectedResponse
| -- | Used for TCP connection and command response timeouts.
-- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
SMPResponseTimeout
PCEResponseTimeout
| -- | Failure to establish TCP connection.
-- Forwarded to the agent client as `ERR BROKER NETWORK`.
SMPNetworkError
PCENetworkError
| -- | TCP transport handshake or some other transport error.
-- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
SMPTransportError TransportError
PCETransportError TransportError
| -- | Error when cryptographically "signing" the command.
SMPSignatureError C.CryptoError
PCESignatureError C.CryptoError
| -- | IO Error
PCEIOError IOException
deriving (Eq, Show, Exception)
-- | Create a new SMP queue.
@@ -258,92 +264,95 @@ createSMPQueue ::
RcvPrivateSignKey ->
RcvPublicVerifyKey ->
RcvPublicDhKey ->
ExceptT SMPClientError IO QueueIdsKeys
ExceptT ProtocolClientError IO QueueIdsKeys
createSMPQueue c rpKey rKey dhKey =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
IDS qik -> pure qik
_ -> throwE SMPUnexpectedResponse
_ -> throwE PCEUnexpectedResponse
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue c@SMPClient {smpServer, sessionId, msgQ} rpKey rId =
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
subscribeSMPQueue c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId SUB >>= \case
OK -> return ()
cmd@MSG {} ->
lift . atomically $ writeTBQueue msgQ (smpServer, sessionId, rId, cmd)
_ -> throwE SMPUnexpectedResponse
lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
_ -> throwE PCEUnexpectedResponse
-- | Subscribe to the SMP queue notifications.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT ProtocolClientError IO ()
subscribeSMPQueueNotifications = okSMPCommand NSUB
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT ProtocolClientError IO NotifierId
enableSMPQueueNotifications c rpKey rId notifierKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
NID nId -> pure nId
_ -> throwE SMPUnexpectedResponse
_ -> throwE PCEUnexpectedResponse
-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT ProtocolClientError IO ()
sendSMPMessage c spKey sId msg =
sendSMPCommand c spKey sId (SEND msg) >>= \case
OK -> pure ()
_ -> throwE SMPUnexpectedResponse
_ -> throwE PCEUnexpectedResponse
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage c@SMPClient {smpServer, sessionId, msgQ} rpKey rId =
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId ACK >>= \case
OK -> return ()
cmd@MSG {} ->
lift . atomically $ writeTBQueue msgQ (smpServer, sessionId, rId, cmd)
_ -> throwE SMPUnexpectedResponse
lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
_ -> throwE PCEUnexpectedResponse
-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
suspendSMPQueue = okSMPCommand OFF
-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
deleteSMPQueue = okSMPCommand DEL
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
OK -> return ()
_ -> throwE SMPUnexpectedResponse
_ -> throwE PCEUnexpectedResponse
-- | Send SMP command
-- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient)
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
-- | Send Protocol command
sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
corrId <- lift_ getNextCorrId
t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
ExceptT $ sendRecv corrId t
where
lift_ :: STM a -> ExceptT SMPClientError IO a
lift_ :: STM a -> ExceptT ProtocolClientError IO a
lift_ action = ExceptT $ Right <$> atomically action
getNextCorrId :: STM CorrId
@@ -351,20 +360,20 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeou
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
pure . CorrId $ bshow i
signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission
signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
signTransmission t = case pKey of
Nothing -> return (Nothing, t)
Just pk -> do
sig <- liftError SMPSignatureError $ C.sign pk t
sig <- liftError PCESignatureError $ C.sign pk t
return (Just sig, t)
-- two separate "atomically" needed to avoid blocking
sendRecv :: CorrId -> SentRawTransmission -> IO Response
sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
where
withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
send :: CorrId -> SentRawTransmission -> STM (TMVar Response)
send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
send corrId t = do
r <- newEmptyTMVar
TM.insert corrId (Request qId r) sentCommands
src/Simplex/Messaging/Client/Agent.hs
+301
View File
@@ -0,0 +1,301 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Client.Agent where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import Data.Text.Encoding
import Numeric.Natural
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (tryE, whenM, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async, forConcurrently_)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type SMPClientVar = TMVar (Either ProtocolClientError SMPClient)
data SMPClientAgentEvent
= CAConnected SMPServer
| CADisconnected SMPServer (Set SMPSub)
| CAReconnected SMPServer
| CAResubscribed SMPServer SMPSub
| CASubError SMPServer SMPSub ProtocolClientError
data SMPSubParty = SPRecipient | SPNotifier
deriving (Eq, Ord)
type SMPSub = (SMPSubParty, QueueId)
-- type SMPServerSub = (SMPServer, SMPSub)
data SMPClientAgentConfig = SMPClientAgentConfig
{ smpCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
msgQSize :: Natural,
agentQSize :: Natural
}
defaultSMPClientAgentConfig :: SMPClientAgentConfig
defaultSMPClientAgentConfig =
SMPClientAgentConfig
{ smpCfg = defaultClientConfig,
reconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
},
msgQSize = 64,
agentQSize = 64
}
where
second = 1000000
data SMPClientAgent = SMPClientAgent
{ agentCfg :: SMPClientAgentConfig,
msgQ :: TBQueue (ServerTransmission BrokerMsg),
agentQ :: TBQueue SMPClientAgentEvent,
smpClients :: TMap SMPServer SMPClientVar,
srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
reconnections :: TVar [Async ()],
asyncClients :: TVar [Async ()]
}
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
withRunInIO exceptToIO =
withExceptT unInternalException . ExceptT . E.try $
withRunInIO $ \run ->
exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
msgQ <- newTBQueue msgQSize
agentQ <- newTBQueue agentQSize
smpClients <- TM.empty
srvSubs <- TM.empty
pendingSrvSubs <- TM.empty
reconnections <- newTVar []
asyncClients <- newTVar []
pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT ProtocolClientError IO SMPClient
getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
atomically getClientVar >>= either newSMPClient waitForSMPClient
where
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
newClientVar :: STM SMPClientVar
newClientVar = do
smpVar <- newEmptyTMVar
TM.insert srv smpVar smpClients
pure smpVar
waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
waitForSMPClient smpVar = do
let ProtocolClientConfig {tcpTimeout} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left PCEResponseTimeout
newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
tryConnectClient successAction retryAction =
tryE connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
successAction smp
Left e -> do
if e == PCENetworkError || e == PCEResponseTimeout
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
TM.delete srv smpClients
throwE e
tryConnectAsync :: ExceptT ProtocolClientError IO ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients ca) (a :)
connectAsync :: ExceptT ProtocolClientError IO ()
connectAsync =
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
void $ tryConnectClient (const reconnectClient) loop
connectClient :: ExceptT ProtocolClientError IO SMPClient
connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
clientDisconnected :: IO ()
clientDisconnected = do
removeClientAndSubs >>= (`forM_` serverDown)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
where
updateSubs sVar = do
ss <- readTVar sVar
addPendingSubs sVar ss
pure ss
addPendingSubs sVar ss = do
let ps = pendingSrvSubs ca
TM.lookup srv ps >>= \case
Just v -> TM.union ss v
_ -> TM.insert srv sVar ps
serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
serverDown ss = unless (M.null ss) . void . runExceptT $ do
notify . CADisconnected srv $ M.keysSet ss
reconnectServer
reconnectServer :: ExceptT ProtocolClientError IO ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections ca) (a :)
tryReconnectClient :: ExceptT ProtocolClientError IO ()
tryReconnectClient = do
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
reconnectClient `catchE` const loop
reconnectClient :: ExceptT ProtocolClientError IO ()
reconnectClient = do
withSMP ca srv $ \smp -> do
notify $ CAReconnected srv
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
whenM (atomically $ hasSub (srvSubs ca) srv s) $
subscribe_ smp sub `catchE` handleError s
where
subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
subscribe_ smp sub@(s, _) = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
notify $ CAResubscribed srv s
handleError :: SMPSub -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
handleError s = \case
e@PCEResponseTimeout -> throwE e
e@PCENetworkError -> throwE e
e -> do
notify $ CASubError srv s e
atomically $ removePendingSubscription ca srv s
notify :: SMPClientAgentEvent -> ExceptT ProtocolClientError IO ()
notify evt = atomically $ writeTBQueue (agentQ ca) evt
closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
closeSMPClientAgent c = liftIO $ do
closeSMPServerClients c
cancelActions $ reconnections c
cancelActions $ asyncClients c
closeSMPServerClients :: SMPClientAgent -> IO ()
closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
where
closeClient smpVar =
atomically (readTMVar smpVar) >>= \case
Right smp -> closeProtocolClient smp `E.catch` \(_ :: E.SomeException) -> pure ()
_ -> pure ()
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO a
withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
where
logSMPError :: ProtocolClientError -> ExceptT ProtocolClientError IO a
logSMPError e = do
liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
throwE e
subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
subscribeQueue ca srv sub = do
atomically $ addPendingSubscription ca srv sub
withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
where
subscribe_ smp = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
handleError e = do
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv $ fst sub
throwE e
showServer :: SMPServer -> ByteString
showServer ProtocolServer {host, port} =
B.pack $ host <> if null port then "" else ':' : port
smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
where
subscribe_ = case party of
SPRecipient -> subscribeSMPQueue
SPNotifier -> subscribeSMPQueueNotifications
addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSubscription ca srv sub = do
addSub_ (srvSubs ca) srv sub
removePendingSubscription ca srv $ fst sub
addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addPendingSubscription = addSub_ . pendingSrvSubs
addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSub_ subs srv (s, key) =
TM.lookup srv subs >>= \case
Just m -> TM.insert s key m
_ -> TM.singleton s key >>= \v -> TM.insert srv v subs
removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removeSubscription = removeSub_ . srvSubs
removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removePendingSubscription = removeSub_ . pendingSrvSubs
removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs
src/Simplex/Messaging/Crypto.hs
+31 -1
View File
@@ -52,6 +52,7 @@ module Simplex.Messaging.Crypto
CryptoPublicKey (..),
CryptoPrivateKey (..),
KeyPair,
ASignatureKeyPair,
DhSecret (..),
DhSecretX25519,
ADhSecret (..),
@@ -103,6 +104,10 @@ module Simplex.Messaging.Crypto
cbDecrypt,
cbNonce,
randomCbNonce,
pseudoRandomCbNonce,
-- * pseudo-random bytes
pseudoRandomBytes,
-- * SHA256 hash
sha256Hash,
@@ -116,6 +121,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 +135,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
@@ -284,6 +290,12 @@ instance Eq APrivateSignKey where
deriving instance Show APrivateSignKey
instance Encoding APrivateSignKey where
smpEncode = smpEncode . encodePrivKey
{-# INLINE smpEncode #-}
smpDecode = decodePrivKey
{-# INLINE smpDecode #-}
data APublicVerifyKey
= forall a.
(AlgorithmI a, SignatureAlgorithm a) =>
@@ -859,6 +871,14 @@ cbDecrypt secret (CbNonce nonce) packet
newtype CbNonce = CbNonce {unCbNonce :: ByteString}
deriving (Show)
instance StrEncoding CbNonce where
strEncode (CbNonce s) = strEncode s
strP = cbNonce <$> strP
instance ToJSON CbNonce where
toJSON = strToJSON
toEncoding = strToJEncoding
cbNonce :: ByteString -> CbNonce
cbNonce s
| len == 24 = CbNonce s
@@ -870,6 +890,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
src/Simplex/Messaging/Encoding.hs
+4
View File
@@ -141,3 +141,7 @@ instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c,
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
src/Simplex/Messaging/Encoding/String.hs
+7 -1
View File
@@ -2,7 +2,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Encoding.String
( StrEncoding (..),
( TextEncoding (..),
StrEncoding (..),
Str (..),
strP_,
strToJSON,
@@ -26,11 +27,16 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum)
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Word (Word16)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util ((<$?>))
class TextEncoding a where
textEncode :: a -> Text
textDecode :: Text -> Maybe a
-- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols
class StrEncoding a where
{-# MINIMAL strEncode, (strDecode | strP) #-}
src/Simplex/Messaging/Notifications/Client.hs
+132
View File
@@ -0,0 +1,132 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Notifications.Client where
import Control.Monad.Except
import Control.Monad.Trans.Except
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Word (Word16)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Parsers (blobFieldDecoder)
import Simplex.Messaging.Protocol (ProtocolServer)
type NtfServer = ProtocolServer
type NtfClient = ProtocolClient NtfResponse
ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c pKey newTkn =
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
NRId tknId dhKey -> pure (tknId, dhKey)
_ -> throwE PCEUnexpectedResponse
ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
ntfCheckToken c pKey tknId =
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
NRTkn stat -> pure stat
_ -> throwE PCEUnexpectedResponse
ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
ntfDeleteToken = okNtfCommand TDEL
ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
ntfCreateSubsciption :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO (NtfSubscriptionId, C.PublicKeyX25519)
ntfCreateSubsciption c pKey newSub =
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
NRId tknId dhKey -> pure (tknId, dhKey)
_ -> throwE PCEUnexpectedResponse
ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
ntfCheckSubscription c pKey subId =
sendNtfCommand c (Just pKey) subId SCHK >>= \case
NRSub stat -> pure stat
_ -> throwE PCEUnexpectedResponse
ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
ntfDeleteSubscription = okNtfCommand SDEL
-- | Send notification server command
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
okNtfCommand cmd c pKey entId =
sendNtfCommand c (Just pKey) entId cmd >>= \case
NROk -> return ()
_ -> throwE PCEUnexpectedResponse
data NtfTknAction
= NTARegister
| NTAVerify NtfRegCode -- code to verify token
| NTACheck
| NTACron Word16
| NTADelete
deriving (Show)
instance Encoding NtfTknAction where
smpEncode = \case
NTARegister -> "R"
NTAVerify code -> smpEncode ('V', code)
NTACheck -> "C"
NTACron interval -> smpEncode ('I', interval)
NTADelete -> "D"
smpP =
A.anyChar >>= \case
'R' -> pure NTARegister
'V' -> NTAVerify <$> smpP
'C' -> pure NTACheck
'I' -> NTACron <$> smpP
'D' -> pure NTADelete
_ -> fail "bad NtfTknAction"
instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
instance ToField NtfTknAction where toField = toField . smpEncode
data NtfToken = NtfToken
{ deviceToken :: DeviceToken,
ntfServer :: NtfServer,
ntfTokenId :: Maybe NtfTokenId,
-- | key used by the ntf server to verify transmissions
ntfPubKey :: C.APublicVerifyKey,
-- | key used by the ntf client to sign transmissions
ntfPrivKey :: C.APrivateSignKey,
-- | client's DH keys (to repeat registration if necessary)
ntfDhKeys :: C.KeyPair 'C.X25519,
-- | shared DH secret used to encrypt/decrypt notifications e2e
ntfDhSecret :: Maybe C.DhSecretX25519,
-- | token status
ntfTknStatus :: NtfTknStatus,
-- | pending token action and the earliest time
ntfTknAction :: Maybe NtfTknAction
}
deriving (Show)
newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NtfToken
newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys =
NtfToken
{ deviceToken,
ntfServer,
ntfTokenId = Nothing,
ntfPubKey,
ntfPrivKey,
ntfDhKeys,
ntfDhSecret = Nothing,
ntfTknStatus = NTNew,
ntfTknAction = Just NTARegister
}
src/Simplex/Messaging/Notifications/Protocol.hs
+428
View File
@@ -0,0 +1,428 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Simplex.Messaging.Notifications.Protocol where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Kind
import Data.Maybe (isNothing)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Type.Equality
import Data.Word (Word16)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
import Simplex.Messaging.Parsers (fromTextField_)
import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
import Simplex.Messaging.Util ((<$?>))
data NtfEntity = Token | Subscription
deriving (Show)
data SNtfEntity :: NtfEntity -> Type where
SToken :: SNtfEntity 'Token
SSubscription :: SNtfEntity 'Subscription
instance TestEquality SNtfEntity where
testEquality SToken SToken = Just Refl
testEquality SSubscription SSubscription = Just Refl
testEquality _ _ = Nothing
deriving instance Show (SNtfEntity e)
class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e
instance NtfEntityI 'Token where sNtfEntity = SToken
instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
data NtfCommandTag (e :: NtfEntity) where
TNEW_ :: NtfCommandTag 'Token
TVFY_ :: NtfCommandTag 'Token
TCHK_ :: NtfCommandTag 'Token
TDEL_ :: NtfCommandTag 'Token
TCRN_ :: NtfCommandTag 'Token
SNEW_ :: NtfCommandTag 'Subscription
SCHK_ :: NtfCommandTag 'Subscription
SDEL_ :: NtfCommandTag 'Subscription
PING_ :: NtfCommandTag 'Subscription
deriving instance Show (NtfCommandTag e)
data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)
instance NtfEntityI e => Encoding (NtfCommandTag e) where
smpEncode = \case
TNEW_ -> "TNEW"
TVFY_ -> "TVFY"
TCHK_ -> "TCHK"
TDEL_ -> "TDEL"
TCRN_ -> "TCRN"
SNEW_ -> "SNEW"
SCHK_ -> "SCHK"
SDEL_ -> "SDEL"
PING_ -> "PING"
smpP = messageTagP
instance Encoding NtfCmdTag where
smpEncode (NCT _ t) = smpEncode t
smpP = messageTagP
instance ProtocolMsgTag NtfCmdTag where
decodeTag = \case
"TNEW" -> Just $ NCT SToken TNEW_
"TVFY" -> Just $ NCT SToken TVFY_
"TCHK" -> Just $ NCT SToken TCHK_
"TDEL" -> Just $ NCT SToken TDEL_
"TCRN" -> Just $ NCT SToken TCRN_
"SNEW" -> Just $ NCT SSubscription SNEW_
"SCHK" -> Just $ NCT SSubscription SCHK_
"SDEL" -> Just $ NCT SSubscription SDEL_
"PING" -> Just $ NCT SSubscription PING_
_ -> Nothing
instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
newtype NtfRegCode = NtfRegCode ByteString
deriving (Eq, Show)
instance Encoding NtfRegCode where
smpEncode (NtfRegCode code) = smpEncode code
smpP = NtfRegCode <$> smpP
instance StrEncoding NtfRegCode where
strEncode (NtfRegCode m) = strEncode m
strDecode s = NtfRegCode <$> strDecode s
strP = NtfRegCode <$> strP
instance FromJSON NtfRegCode where
parseJSON = strParseJSON "NtfRegCode"
instance ToJSON NtfRegCode where
toJSON = strToJSON
toEncoding = strToJEncoding
data NewNtfEntity (e :: NtfEntity) where
NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NewNtfEntity 'Subscription
deriving instance Show (NewNtfEntity e)
data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
instance NtfEntityI e => Encoding (NewNtfEntity e) where
smpEncode = \case
NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
NewNtfSub tknId smpQueue -> smpEncode ('S', tknId, smpQueue)
smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
instance Encoding ANewNtfEntity where
smpEncode (ANE _ e) = smpEncode e
smpP =
A.anyChar >>= \case
'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP)
_ -> fail "bad ANewNtfEntity"
instance Protocol NtfResponse where
type ProtocolCommand NtfResponse = NtfCmd
protocolClientHandshake = ntfClientHandshake
protocolPing = NtfCmd SSubscription PING
protocolError = \case
NRErr e -> Just e
_ -> Nothing
data NtfCommand (e :: NtfEntity) where
-- | register new device token for notifications
TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
-- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
TVFY :: NtfRegCode -> NtfCommand 'Token
-- | check token status
TCHK :: NtfCommand 'Token
-- | delete token - all subscriptions will be removed and no more notifications will be sent
TDEL :: NtfCommand 'Token
-- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
TCRN :: Word16 -> NtfCommand 'Token
-- | create SMP subscription
SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
-- | check SMP subscription status (response is STAT)
SCHK :: NtfCommand 'Subscription
-- | delete SMP subscription
SDEL :: NtfCommand 'Subscription
-- | keep-alive command
PING :: NtfCommand 'Subscription
deriving instance Show (NtfCommand e)
data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
deriving instance Show NtfCmd
instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
type Tag (NtfCommand e) = NtfCommandTag e
encodeProtocol = \case
TNEW newTkn -> e (TNEW_, ' ', newTkn)
TVFY code -> e (TVFY_, ' ', code)
TCHK -> e TCHK_
TDEL -> e TDEL_
TCRN int -> e (TCRN_, ' ', int)
SNEW newSub -> e (SNEW_, ' ', newSub)
SCHK -> e SCHK_
SDEL -> e SDEL_
PING -> e PING_
where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP (NCT (sNtfEntity @e) tag)
checkCredentials (sig, _, entityId, _) cmd = case cmd of
-- TNEW and SNEW must have signature but NOT token/subscription IDs
TNEW {} -> sigNoEntity
SNEW {} -> sigNoEntity
PING
| isNothing sig && B.null entityId -> Right cmd
| otherwise -> Left $ CMD HAS_AUTH
-- other client commands must have both signature and entity ID
_
| isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
where
sigNoEntity
| isNothing sig = Left $ CMD NO_AUTH
| not (B.null entityId) = Left $ CMD HAS_AUTH
| otherwise = Right cmd
instance ProtocolEncoding NtfCmd where
type Tag NtfCmd = NtfCmdTag
encodeProtocol (NtfCmd _ c) = encodeProtocol c
protocolP = \case
NCT SToken tag ->
NtfCmd SToken <$> case tag of
TNEW_ -> TNEW <$> _smpP
TVFY_ -> TVFY <$> _smpP
TCHK_ -> pure TCHK
TDEL_ -> pure TDEL
TCRN_ -> TCRN <$> _smpP
NCT SSubscription tag ->
NtfCmd SSubscription <$> case tag of
SNEW_ -> SNEW <$> _smpP
SCHK_ -> pure SCHK
SDEL_ -> pure SDEL
PING_ -> pure PING
checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
data NtfResponseTag
= NRId_
| NROk_
| NRErr_
| NRTkn_
| NRSub_
| NRPong_
deriving (Show)
instance Encoding NtfResponseTag where
smpEncode = \case
NRId_ -> "ID"
NROk_ -> "OK"
NRErr_ -> "ERR"
NRTkn_ -> "TKN"
NRSub_ -> "SUB"
NRPong_ -> "PONG"
smpP = messageTagP
instance ProtocolMsgTag NtfResponseTag where
decodeTag = \case
"ID" -> Just NRId_
"OK" -> Just NROk_
"ERR" -> Just NRErr_
"TKN" -> Just NRTkn_
"SUB" -> Just NRSub_
"PONG" -> Just NRPong_
_ -> Nothing
data NtfResponse
= NRId NtfEntityId C.PublicKeyX25519
| NROk
| NRErr ErrorType
| NRTkn NtfTknStatus
| NRSub NtfSubStatus
| NRPong
deriving (Show)
instance ProtocolEncoding NtfResponse where
type Tag NtfResponse = NtfResponseTag
encodeProtocol = \case
NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
NROk -> e NROk_
NRErr err -> e (NRErr_, ' ', err)
NRTkn stat -> e (NRTkn_, ' ', stat)
NRSub stat -> e (NRSub_, ' ', stat)
NRPong -> e NRPong_
where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP = \case
NRId_ -> NRId <$> _smpP <*> smpP
NROk_ -> pure NROk
NRErr_ -> NRErr <$> _smpP
NRTkn_ -> NRTkn <$> _smpP
NRSub_ -> NRSub <$> _smpP
NRPong_ -> pure NRPong
checkCredentials (_, _, entId, _) cmd = case cmd of
-- ID response must not have queue ID
NRId {} -> noEntity
-- ERR response does not always have entity ID
NRErr _ -> Right cmd
-- PONG response must not have queue ID
NRPong -> noEntity
-- other server responses must have entity ID
_
| B.null entId -> Left $ CMD NO_ENTITY
| otherwise -> Right cmd
where
noEntity
| B.null entId = Right cmd
| otherwise = Left $ CMD HAS_AUTH
data SMPQueueNtf = SMPQueueNtf
{ smpServer :: ProtocolServer,
notifierId :: NotifierId,
notifierKey :: NtfPrivateSignKey
}
deriving (Show)
instance Encoding SMPQueueNtf where
smpEncode SMPQueueNtf {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
smpP = do
(smpServer, notifierId, notifierKey) <- smpP
pure $ SMPQueueNtf smpServer notifierId notifierKey
data PushProvider = PPApns
deriving (Eq, Ord, Show)
instance Encoding PushProvider where
smpEncode = \case
PPApns -> "A"
smpP =
A.anyChar >>= \case
'A' -> pure PPApns
_ -> fail "bad PushProvider"
instance TextEncoding PushProvider where
textEncode = \case
PPApns -> "apple"
textDecode = \case
"apple" -> Just PPApns
_ -> Nothing
instance FromField PushProvider where fromField = fromTextField_ textDecode
instance ToField PushProvider where toField = toField . textEncode
data DeviceToken = DeviceToken PushProvider ByteString
deriving (Eq, Ord, Show)
instance Encoding DeviceToken where
smpEncode (DeviceToken p t) = smpEncode (p, t)
smpP = DeviceToken <$> smpP <*> smpP
type NtfEntityId = ByteString
type NtfSubscriptionId = NtfEntityId
type NtfTokenId = NtfEntityId
data NtfSubStatus
= -- | state after SNEW
NSNew
| -- | pending connection/subscription to SMP server
NSPending
| -- | connected and subscribed to SMP server
NSActive
| -- | NEND received (we currently do not support it)
NSEnd
| -- | SMP AUTH error
NSSMPAuth
deriving (Eq, Show)
instance Encoding NtfSubStatus where
smpEncode = \case
NSNew -> "NEW"
NSPending -> "PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
NSActive -> "ACTIVE"
NSEnd -> "END"
NSSMPAuth -> "SMP_AUTH"
smpP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NSNew
"PENDING" -> pure NSPending
"ACTIVE" -> pure NSActive
"END" -> pure NSEnd
"SMP_AUTH" -> pure NSSMPAuth
_ -> fail "bad NtfSubStatus"
data NtfTknStatus
= -- | Token created in DB
NTNew
| -- | state after registration (TNEW)
NTRegistered
| -- | if initial notification failed (push provider error) or verification failed
NTInvalid
| -- | Token confirmed via notification (accepted by push provider or verification code received by client)
NTConfirmed
| -- | after successful verification (TVFY)
NTActive
| -- | after it is no longer valid (push provider error)
NTExpired
deriving (Eq, Show)
instance Encoding NtfTknStatus where
smpEncode = \case
NTNew -> "NEW"
NTRegistered -> "REGISTERED"
NTInvalid -> "INVALID"
NTConfirmed -> "CONFIRMED"
NTActive -> "ACTIVE"
NTExpired -> "EXPIRED"
smpP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NTNew
"REGISTERED" -> pure NTRegistered
"INVALID" -> pure NTInvalid
"CONFIRMED" -> pure NTConfirmed
"ACTIVE" -> pure NTActive
"EXPIRED" -> pure NTExpired
_ -> fail "bad NtfTknStatus"
instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
Just Refl -> Right c
Nothing -> Left "bad command party"
checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
checkEntity' c = case testEquality (sNtfEntity @p) (sNtfEntity @p') of
Just Refl -> Just c
_ -> Nothing
src/Simplex/Messaging/Notifications/Server.hs
+325
View File
@@ -0,0 +1,325 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Notifications.Server where
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Crypto.Random (MonadRandom)
import Data.ByteString.Char8 (ByteString)
import qualified Data.Text as T
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.Store
import Simplex.Messaging.Notifications.Transport
import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport)
import Simplex.Messaging.Transport.Server (runTransportServer)
import Simplex.Messaging.Util
import UnliftIO (async, uninterruptibleCancel)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception
import UnliftIO.STM
runNtfServer :: (MonadRandom m, MonadUnliftIO m) => NtfServerConfig -> m ()
runNtfServer cfg = do
started <- newEmptyTMVarIO
runNtfServerBlocking started cfg
runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfServerConfig -> m ()
runNtfServerBlocking started cfg@NtfServerConfig {transports} = do
env <- newNtfServerEnv cfg
runReaderT ntfServer env
where
ntfServer :: (MonadUnliftIO m', MonadReader NtfEnv m') => m' ()
ntfServer = do
s <- asks subscriber
ps <- asks pushServer
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
runServer :: (MonadUnliftIO m', MonadReader NtfEnv m') => (ServiceName, ATransport) -> m' ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams (runClient t)
runClient :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ ntfServerHandshake h kh) >>= \case
Right th -> runNtfClientTransport th
Left _ -> pure ()
ntfSubscriber :: forall m. MonadUnliftIO m => NtfSubscriber -> m ()
ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
raceAny_ [subscribe, receiveSMP, receiveAgent]
where
subscribe :: m ()
subscribe = forever $ do
atomically (readTBQueue subQ) >>= \case
NtfSub NtfSubData {smpQueue} -> do
let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue
liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
Right _ -> pure () -- update subscription status
Left _e -> pure ()
receiveSMP :: m ()
receiveSMP = forever $ do
(_srv, _sessId, _ntfId, msg) <- atomically $ readTBQueue msgQ
case msg of
SMP.NMSG -> do
-- check when the last NMSG was received from this queue
-- update timestamp
-- check what was the last hidden notification was sent (and whether to this queue)
-- decide whether it should be sent as hidden or visible
-- construct and possibly encrypt notification
-- send it
pure ()
_ -> pure ()
pure ()
receiveAgent =
forever $
atomically (readTBQueue agentQ) >>= \case
CAConnected _ -> pure ()
CADisconnected _srv _subs -> do
-- update subscription statuses
pure ()
CAReconnected _ -> pure ()
CAResubscribed _srv _sub -> do
-- update subscription status
pure ()
CASubError _srv _sub _err -> do
-- update subscription status
pure ()
ntfPush :: MonadUnliftIO m => NtfPushServer -> m ()
ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
(tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
logDebug $ "sending push notification to " <> T.pack (show pp)
status <- readTVarIO tknStatus
case (status, ntf) of
(_, PNVerification _) -> do
-- TODO check token status
deliverNotification pp tkn ntf
atomically $ modifyTVar tknStatus $ \status' -> if status' == NTActive then NTActive else NTConfirmed
(NTActive, PNCheckMessages) -> do
deliverNotification pp tkn ntf
_ -> do
logError "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 -> logError (T.pack $ "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
qSize <- asks $ clientQSize . config
c <- atomically $ newNtfServerClient qSize sessionId
s <- asks subscriber
ps <- asks pushServer
raceAny_ [send th c, client c s ps, receive th c]
`finally` clientDisconnected c
clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
receive th NtfServerClient {rcvQ, sndQ} = forever $ do
t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
logDebug "received transmission"
case cmdOrError of
Left e -> write sndQ (corrId, entId, NRErr e)
Right cmd ->
verifyNtfTransmission t cmd >>= \case
VRVerified req -> write rcvQ req
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
where
write q t = atomically $ writeTBQueue q t
send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
send h NtfServerClient {sndQ, sessionId} = forever $ do
t <- atomically $ readTBQueue sndQ
liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
data VerificationResult = VRVerified NtfRequest | VRFailed
verifyNtfTransmission ::
forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => SignedTransmission NtfCmd -> NtfCmd -> m VerificationResult
verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
st <- asks store
case cmd of
NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do
r_ <- atomically $ getNtfTokenRegistration st tkn
pure $
if verifyCmdSignature sig_ signed k
then case r_ of
Just t@NtfTknData {tknVerifyKey}
| k == tknVerifyKey -> verifiedTknCmd t c
| otherwise -> VRFailed
_ -> VRVerified (NtfReqNew corrId (ANE SToken tkn))
else VRFailed
NtfCmd SToken c -> do
t_ <- atomically $ getNtfToken st entId
pure $ case t_ of
Just t@NtfTknData {tknVerifyKey}
| verifyCmdSignature sig_ signed tknVerifyKey -> verifiedTknCmd t c
| otherwise -> VRFailed
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
_ -> pure VRFailed
where
verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ, intervalNotifiers} =
forever $
atomically (readTBQueue rcvQ)
>>= processCommand
>>= atomically . writeTBQueue sndQ
where
processCommand :: NtfRequest -> m (Transmission NtfResponse)
processCommand = \case
NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
logDebug "TNEW - new token"
st <- asks store
ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
let dhSecret = C.dh' dhPubKey srvDhPrivKey
tknId <- getId
regCode <- getRegCode
atomically $ do
tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
addNtfToken st tknId tkn
writeTBQueue pushQ (tkn, PNVerification regCode)
pure (corrId, "", NRId tknId srvDhPubKey)
NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (corrId, tknId, cmd) -> do
status <- readTVarIO tknStatus
(corrId,tknId,) <$> case cmd of
TNEW (NewNtfTkn _ _ dhPubKey) -> do
logDebug "TNEW - registered token"
let dhSecret = C.dh' dhPubKey srvDhPrivKey
-- it is required that DH secret is the same, to avoid failed verifications if notification is delaying
if tknDhSecret == dhSecret
then do
atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
pure $ NRId ntfTknId srvDhPubKey
else pure $ NRErr AUTH
TVFY code -- this allows repeated verification for cases when client connection dropped before server response
| (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
logDebug "TVFY - token verified"
st <- asks store
atomically $ writeTVar tknStatus NTActive
tIds <- atomically $ removeInactiveTokenRegistrations st tkn
forM_ tIds cancelInvervalNotifications
pure NROk
| otherwise -> do
logDebug "TVFY - incorrect code or token status"
pure $ NRErr AUTH
TCHK -> pure $ NRTkn status
TDEL -> do
logDebug "TDEL"
st <- asks store
atomically $ deleteNtfToken st tknId
cancelInvervalNotifications tknId
pure NROk
TCRN 0 -> do
logDebug "TCRN 0"
cancelInvervalNotifications tknId
pure NROk
TCRN int
| int < 20 -> pure $ NRErr QUOTA
| otherwise -> do
logDebug "TCRN"
atomically (TM.lookup tknId intervalNotifiers) >>= \case
Nothing -> runIntervalNotifier int
Just IntervalNotifier {interval, action} ->
unless (interval == int) $ do
uninterruptibleCancel action
runIntervalNotifier int
pure NROk
where
runIntervalNotifier interval = do
action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
let notifier = IntervalNotifier {action, token = tkn, interval}
atomically $ TM.insert tknId notifier intervalNotifiers
where
intervalNotifier delay = forever $ do
threadDelay delay
atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
NtfReqNew corrId (ANE SSubscription _newSub) -> pure (corrId, "", NROk)
NtfReqCmd SSubscription _sub (corrId, subId, cmd) ->
(corrId,subId,) <$> case cmd of
SNEW _newSub -> pure NROk
SCHK -> pure NROk
SDEL -> pure NROk
PING -> pure NRPong
getId :: m NtfEntityId
getId = getRandomBytes =<< asks (subIdBytes . config)
getRegCode :: m NtfRegCode
getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
getRandomBytes :: Int -> m ByteString
getRandomBytes n = do
gVar <- asks idsDrg
atomically (C.pseudoRandomBytes n gVar)
cancelInvervalNotifications :: NtfTokenId -> m ()
cancelInvervalNotifications tknId =
atomically (TM.lookupDelete tknId intervalNotifiers)
>>= mapM_ (uninterruptibleCancel . action)
-- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk)
-- do
-- st <- asks store
-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
-- let dhSecret = C.dh' dhPubKey privDhKey
-- sub <- atomically $ mkNtfSubsciption smpQueue token verifyKey dhSecret
-- addSubRetry 3 st sub >>= \case
-- Nothing -> pure (corrId, "", NRErr INTERNAL)
-- Just sId -> do
-- atomically $ writeTBQueue subQ sub
-- pure (corrId, sId, NRSubId pubDhKey)
-- where
-- addSubRetry :: Int -> NtfSubscriptionsStore -> NtfSubsciption -> m (Maybe NtfSubsciptionId)
-- addSubRetry 0 _ _ = pure Nothing
-- addSubRetry n st sub = do
-- sId <- getId
-- -- create QueueRec record with these ids and keys
-- atomically (addNtfSub st sId sub) >>= \case
-- Nothing -> addSubRetry (n - 1) st sub
-- _ -> pure $ Just sId
-- getId :: m NtfSubsciptionId
-- getId = do
-- n <- asks $ subIdBytes . config
-- gVar <- asks idsDrg
-- atomically (randomBytes n gVar)
-- NReqCommand sub@NtfSubsciption {tokenId, subStatus} (corrId, subId, cmd) ->
-- (corrId,subId,) <$> case cmd of
-- NCSubCreate tokenId smpQueue -> pure NROk
-- do
-- st <- asks store
-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
-- let dhSecret = C.dh' (dhPubKey newSub) privDhKey
-- atomically (updateNtfSub st sub newSub dhSecret) >>= \case
-- Nothing -> pure $ NRErr INTERNAL
-- _ -> atomically $ do
-- whenM ((== NSEnd) <$> readTVar status) $ writeTBQueue subQ sub
-- pure $ NRSubId pubDhKey
-- NCSubCheck -> NRStat <$> readTVarIO subStatus
-- NCSubDelete -> do
-- st <- asks store
-- atomically (deleteNtfSub st subId) $> NROk
src/Simplex/Messaging/Notifications/Server/Env.hs
+128
View File
@@ -0,0 +1,128 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Notifications.Server.Env where
import Control.Concurrent.Async (Async)
import Control.Monad (void)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.Word (Word16)
import Data.X509.Validation (Fingerprint (..))
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.Store
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
data NtfServerConfig = NtfServerConfig
{ transports :: [(ServiceName, ATransport)],
subIdBytes :: Int,
regCodeBytes :: Int,
clientQSize :: Natural,
subQSize :: Natural,
pushQSize :: Natural,
smpAgentCfg :: SMPClientAgentConfig,
apnsConfig :: APNSPushClientConfig,
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
}
data NtfEnv = NtfEnv
{ config :: NtfServerConfig,
subscriber :: NtfSubscriber,
pushServer :: NtfPushServer,
store :: NtfStore,
idsDrg :: TVar ChaChaDRG,
serverIdentity :: C.KeyHash,
tlsServerParams :: T.ServerParams,
serverIdentity :: C.KeyHash
}
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
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 apnsConfig
-- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server
void . liftIO $ newPushClient pushServer PPApns
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
data NtfSubscriber = NtfSubscriber
{ subQ :: TBQueue (NtfEntityRec 'Subscription),
smpAgent :: SMPClientAgent
}
newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
newNtfSubscriber qSize smpAgentCfg = do
smpAgent <- newSMPClientAgent smpAgentCfg
subQ <- newTBQueue qSize
pure NtfSubscriber {smpAgent, subQ}
data NtfPushServer = NtfPushServer
{ pushQ :: TBQueue (NtfTknData, PushNotification),
pushClients :: TMap PushProvider PushProviderClient,
intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
apnsConfig :: APNSPushClientConfig
}
data IntervalNotifier = IntervalNotifier
{ action :: Async (),
token :: NtfTknData,
interval :: Word16
}
newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
newNtfPushServer qSize apnsConfig = do
pushQ <- newTBQueue qSize
pushClients <- TM.empty
intervalNotifiers <- TM.empty
pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
newPushClient NtfPushServer {apnsConfig, pushClients} = \case
PPApns -> do
c <- apnsPushProviderClient <$> createAPNSPushClient apnsConfig
atomically $ TM.insert PPApns 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
| forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
data NtfServerClient = NtfServerClient
{ rcvQ :: TBQueue NtfRequest,
sndQ :: TBQueue (Transmission NtfResponse),
sessionId :: ByteString,
connected :: TVar Bool
}
newNtfServerClient :: Natural -> ByteString -> STM NtfServerClient
newNtfServerClient qSize sessionId = do
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
connected <- newTVar True
return NtfServerClient {rcvQ, sndQ, sessionId, connected}
src/Simplex/Messaging/Notifications/Server/Push/.gitignore
+1
View File
@@ -0,0 +1 @@
local.env
src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+349
View File
@@ -0,0 +1,349 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
module Simplex.Messaging.Notifications.Server.Push.APNS where
import Control.Logger.Simple
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.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 (Generic)
import Network.HTTP.Types (HeaderName, Status)
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.Store (NtfTknData (..))
import Simplex.Messaging.Protocol (NotifierId, SMPServer)
import Simplex.Messaging.Transport.HTTP2.Client
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,
apnsHost :: HostName,
apnsPort :: ServiceName,
http2cfg :: HTTP2ClientConfig
}
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",
apnsHost = "api.sandbox.push.apple.com",
apnsPort = "443",
http2cfg = defaultHTTP2ClientConfig
}
data APNSPushClient = APNSPushClient
{ https2Client :: TVar (Maybe HTTP2Client),
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
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}) = subtract 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 HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
connectHTTPS2 APNSPushClientConfig {apnsHost, apnsPort, http2cfg} https2Client = do
r <- getHTTP2Client apnsHost apnsPort http2cfg 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 HTTP2ClientError HTTP2Client)
getApnsHTTP2Client APNSPushClient {https2Client, apnsCfg} =
readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right)
disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
disconnectApnsHTTP2Client APNSPushClient {https2Client} =
readTVarIO https2Client >>= mapM_ closeHTTP2Client >> 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', "nonce" .= nonce]
PNMessage srv nId ->
encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue ->
apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue, "nonce" .= nonce]
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 N.methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf)
where
path = "/3/device/" <> tkn
headers signedJWT =
[ (hApnsTopic, appName $ apnsCfg (c :: APNSPushClient)),
(hApnsPushType, pushType aps),
(N.hAuthorization, "bearer " <> signedJWT)
]
<> [(hApnsPriority, "5") | isBackground aps]
isBackground = \case
APNSBackground {} -> True
_ -> False
pushType = \case
APNSBackground {} -> "background"
_ -> "alert"
data PushProviderError
= PPConnection HTTP2ClientError
| PPCryptoError C.CryptoError
| PPResponseError (Maybe Status) Text
| PPTokenInvalid
| PPRetryLater
| PPPermanentError
deriving (Show)
type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
-- this is not a newtype on purpose to have a correct JSON encoding as a record
data APNSErrorResponse = APNSErrorResponse {reason :: Text}
deriving (Generic, FromJSON)
apnsPushProviderClient :: APNSPushClient -> PushProviderClient
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApns tknStr} pn = do
http2 <- liftHTTPS2 $ getApnsHTTP2Client c
nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
req <- liftIO $ apnsRequest c tknStr apnsNtf
HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
let status = H.responseStatus response
reason' = maybe "" reason $ J.decodeStrict' respBody
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> 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"
src/Simplex/Messaging/Notifications/Server/Push/testpush.sh
Executable
+20
View File
@@ -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}
src/Simplex/Messaging/Notifications/Server/Store.hs
+155
View File
@@ -0,0 +1,155 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Notifications.Server.Store where
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.Map.Strict as M
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (whenM, ($>>=))
data NtfStore = NtfStore
{ tokens :: TMap NtfTokenId NtfTknData,
tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId)
}
newNtfStore :: STM NtfStore
newNtfStore = do
tokens <- TM.empty
tokenRegistrations <- TM.empty
pure NtfStore {tokens, tokenRegistrations}
data NtfTknData = NtfTknData
{ ntfTknId :: NtfTokenId,
token :: DeviceToken,
tknStatus :: TVar NtfTknStatus,
tknVerifyKey :: C.APublicVerifyKey,
tknDhKeys :: C.KeyPair 'C.X25519,
tknDhSecret :: C.DhSecretX25519,
tknRegCode :: NtfRegCode
}
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
tknStatus <- newTVar NTRegistered
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode}
-- data NtfSubscriptionsStore = NtfSubscriptionsStore
-- { subscriptions :: TMap NtfSubsciptionId NtfSubsciption,
-- activeSubscriptions :: TMap (SMPServer, NotifierId) NtfSubsciptionId
-- }
-- do
-- subscriptions <- newTVar M.empty
-- activeSubscriptions <- newTVar M.empty
-- pure NtfSubscriptionsStore {subscriptions, activeSubscriptions}
data NtfSubData = NtfSubData
{ smpQueue :: SMPQueueNtf,
tokenId :: NtfTokenId,
subStatus :: TVar NtfSubStatus
}
data NtfEntityRec (e :: NtfEntity) where
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
getNtfToken st tknId = TM.lookup tknId (tokens st)
addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
TM.insert tknId tkn $ tokens st
TM.lookup token regs >>= \case
Just tIds -> TM.insert regKey tknId tIds
_ -> do
tIds <- TM.singleton regKey tknId
TM.insert token tIds regs
where
regs = tokenRegistrations st
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
TM.lookup token (tokenRegistrations st)
$>>= TM.lookup regKey
$>>= (`TM.lookup` tokens st)
where
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
TM.lookup token (tokenRegistrations st)
>>= maybe (pure []) removeRegs
where
removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId]
removeRegs tknRegs = do
tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs
forM_ tIds $ \(regKey, tId') -> do
TM.delete regKey tknRegs
TM.delete tId' $ tokens st
pure $ map snd tIds
deleteNtfToken :: NtfStore -> NtfTokenId -> STM ()
deleteNtfToken st tknId = do
TM.lookupDelete tknId (tokens st)
>>= mapM_
( \NtfTknData {token, tknVerifyKey} ->
TM.lookup token regs
>>= mapM_
( \tIds -> do
TM.delete (regKey tknVerifyKey) tIds
whenM (TM.null tIds) $ TM.delete token regs
)
)
where
regs = tokenRegistrations st
regKey = C.toPubKey C.pubKeyBytes
-- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
-- getNtfRec st ent entId = case ent of
-- SToken -> NtfTkn <$$> TM.lookup entId (tokens st)
-- SSubscription -> pure Nothing
-- getNtfVerifyKey :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e, C.APublicVerifyKey))
-- getNtfVerifyKey st ent entId =
-- getNtfRec st ent entId >>= \case
-- Just r@(NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
-- Just r@(NtfSub NtfSubData {tokenId}) ->
-- getNtfRec st SToken tokenId >>= \case
-- Just (NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
-- _ -> pure Nothing
-- _ -> pure Nothing
-- mkNtfSubsciption :: SMPQueueNtf -> NtfTokenId -> STM NtfSubsciption
-- mkNtfSubsciption smpQueue tokenId = do
-- subStatus <- newTVar NSNew
-- pure NtfSubsciption {smpQueue, tokenId, subStatus}
-- getNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM (Maybe NtfSubsciption)
-- getNtfSub st subId = pure Nothing -- maybe (pure $ Left AUTH) (fmap Right . readTVar) . M.lookup subId . subscriptions =<< readTVar st
-- getNtfSubViaSMPQueue :: NtfSubscriptionsStore -> SMPQueueNtf -> STM (Maybe NtfSubsciption)
-- getNtfSubViaSMPQueue st smpQueue = pure Nothing
-- -- replace keeping status
-- updateNtfSub :: NtfSubscriptionsStore -> NtfSubsciption -> SMPQueueNtf -> NtfTokenId -> C.DhSecretX25519 -> STM (Maybe ())
-- updateNtfSub st sub smpQueue tokenId dhSecret = pure Nothing
-- addNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> NtfSubsciption -> STM (Maybe ())
-- addNtfSub st subId sub = pure Nothing
-- deleteNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM ()
-- deleteNtfSub st subId = pure ()
src/Simplex/Messaging/Notifications/Transport.hs
+19
View File
@@ -0,0 +1,19 @@
module Simplex.Messaging.Notifications.Transport where
import Control.Monad.Except
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Transport
ntfBlockSize :: Int
ntfBlockSize = 512
-- | Notifcations server transport handshake.
ntfServerHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
ntfServerHandshake c _ = pure $ ntfTHandle c
-- | Notifcations server client transport handshake.
ntfClientHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
ntfClientHandshake c _ = pure $ ntfTHandle c
ntfTHandle :: Transport c => c -> THandle c
ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}
src/Simplex/Messaging/Parsers.hs
+10
View File
@@ -13,6 +13,8 @@ import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum, toLower)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.ISO8601 (parseISO8601)
import Data.Typeable (Typeable)
@@ -81,6 +83,14 @@ blobFieldDecoder dec = \case
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
f -> returnError ConversionFailed f "expecting SQLBlob column type"
fromTextField_ :: (Typeable a) => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ fromText = \case
f@(Field (SQLText t) _) ->
case fromText t of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
f -> returnError ConversionFailed f "expecting SQLText column type"
fstToLower :: String -> String
fstToLower "" = ""
fstToLower (h : t) = toLower h : t
src/Simplex/Messaging/Protocol.hs
+70 -43
View File
@@ -1,23 +1,26 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
-- |
-- Module : Simplex.Messaging.Protocol
-- Module : Simplex.Messaging.ProtocolEncoding
-- Copyright : (c) simplex.chat
-- License : AGPL-3
--
@@ -37,7 +40,7 @@ module Simplex.Messaging.Protocol
e2eEncMessageLength,
-- * SMP protocol types
Protocol,
ProtocolEncoding (..),
Command (..),
Party (..),
Cmd (..),
@@ -55,7 +58,10 @@ module Simplex.Messaging.Protocol
PubHeader (..),
ClientMessage (..),
PrivHeader (..),
SMPServer (..),
Protocol (..),
ProtocolServer (..),
SMPServer,
pattern SMPServer,
SrvLoc (..),
CorrId (..),
QueueId,
@@ -74,9 +80,11 @@ module Simplex.Messaging.Protocol
MsgBody,
-- * Parse and serialize
ProtocolMsgTag (..),
messageTagP,
encodeTransmission,
transmissionP,
encodeProtocol,
_smpP,
-- * TCP transport functions
tPut,
@@ -108,7 +116,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Transport (SessionId, THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (bshow, (<$?>))
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
@@ -161,7 +169,7 @@ data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
deriving instance Show Cmd
-- | Parsed SMP transmission without signature, size and session ID.
type Transmission c = (CorrId, QueueId, c)
type Transmission c = (CorrId, EntityId, c)
-- | signed parsed transmission, with original raw bytes and parsing error.
type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
@@ -174,9 +182,10 @@ data RawTransmission = RawTransmission
signed :: ByteString,
sessId :: SessionId,
corrId :: ByteString,
queueId :: ByteString,
entityId :: ByteString,
command :: ByteString
}
deriving (Show)
-- | unparsed sent SMP transmission with signature, without session ID.
type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
@@ -194,7 +203,9 @@ type SenderId = QueueId
type NotifierId = QueueId
-- | SMP queue ID on the server.
type QueueId = ByteString
type QueueId = EntityId
type EntityId = ByteString
-- | Parameterized type for SMP protocol commands from all clients.
data Command (p :: Party) where
@@ -264,7 +275,7 @@ class ProtocolMsgTag t where
messageTagP :: ProtocolMsgTag t => Parser t
messageTagP =
maybe (fail "bad command") pure . decodeTag
maybe (fail "bad message") pure . decodeTag
=<< (A.takeTill (== ' ') <* optional A.space)
instance PartyI p => Encoding (CommandTag p) where
@@ -372,34 +383,39 @@ instance Encoding ClientMessage where
smpEncode (ClientMessage h msg) = smpEncode h <> msg
smpP = ClientMessage <$> smpP <*> A.takeByteString
type SMPServer = ProtocolServer
pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer
pattern SMPServer host port keyHash = ProtocolServer host port keyHash
-- | SMP server location and transport key digest (hash).
data SMPServer = SMPServer
data ProtocolServer = ProtocolServer
{ host :: HostName,
port :: ServiceName,
keyHash :: C.KeyHash
}
deriving (Eq, Ord, Show)
instance IsString SMPServer where
instance IsString ProtocolServer where
fromString = parseString strDecode
instance Encoding SMPServer where
smpEncode SMPServer {host, port, keyHash} =
instance Encoding ProtocolServer where
smpEncode ProtocolServer {host, port, keyHash} =
smpEncode (host, port, keyHash)
smpP = do
(host, port, keyHash) <- smpP
pure SMPServer {host, port, keyHash}
pure ProtocolServer {host, port, keyHash}
instance StrEncoding SMPServer where
strEncode SMPServer {host, port, keyHash} =
instance StrEncoding ProtocolServer where
strEncode ProtocolServer {host, port, keyHash} =
"smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
strP = do
_ <- "smp://"
keyHash <- strP <* A.char '@'
SrvLoc host port <- strP
pure SMPServer {host, port, keyHash}
pure ProtocolServer {host, port, keyHash}
instance ToJSON SMPServer where
instance ToJSON ProtocolServer where
toJSON = strToJSON
toEncoding = strToJEncoding
@@ -512,8 +528,8 @@ data CommandError
NO_AUTH
| -- | transmission has credentials that are not allowed for this command
HAS_AUTH
| -- | transmission has no required queue ID
NO_QUEUE
| -- | transmission has no required entity ID (e.g. SMP queue)
NO_ENTITY
deriving (Eq, Generic, Read, Show)
instance ToJSON CommandError where
@@ -534,17 +550,31 @@ transmissionP = do
trn signature signed = do
sessId <- smpP
corrId <- smpP
queueId <- smpP
entityId <- smpP
command <- A.takeByteString
pure RawTransmission {signature, signed, sessId, corrId, queueId, command}
pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
class Protocol msg where
class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
type ProtocolCommand msg = cmd | cmd -> msg
protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
protocolPing :: ProtocolCommand msg
protocolError :: msg -> Maybe ErrorType
instance Protocol BrokerMsg where
type ProtocolCommand BrokerMsg = Cmd
protocolClientHandshake = smpClientHandshake
protocolPing = Cmd SSender PING
protocolError = \case
ERR e -> Just e
_ -> Nothing
class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
type Tag msg
encodeProtocol :: msg -> ByteString
protocolP :: Tag msg -> Parser msg
checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
instance PartyI p => Protocol (Command p) where
instance PartyI p => ProtocolEncoding (Command p) where
type Tag (Command p) = CommandTag p
encodeProtocol = \case
NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
@@ -571,7 +601,7 @@ instance PartyI p => Protocol (Command p) where
| otherwise -> Right cmd
-- SEND must have queue ID, signature is not always required
SEND _
| B.null queueId -> Left $ CMD NO_QUEUE
| B.null queueId -> Left $ CMD NO_ENTITY
| otherwise -> Right cmd
-- PING must not have queue ID or signature
PING
@@ -582,7 +612,7 @@ instance PartyI p => Protocol (Command p) where
| isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
instance Protocol Cmd where
instance ProtocolEncoding Cmd where
type Tag Cmd = CmdTag
encodeProtocol (Cmd _ c) = encodeProtocol c
@@ -604,7 +634,7 @@ instance Protocol Cmd where
checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
instance Protocol BrokerMsg where
instance ProtocolEncoding BrokerMsg where
type Tag BrokerMsg = BrokerMsgTag
encodeProtocol = \case
IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
@@ -630,7 +660,7 @@ instance Protocol BrokerMsg where
PONG_ -> pure PONG
checkCredentials (_, _, queueId, _) cmd = case cmd of
-- IDS response must not have queue ID
-- IDS response should not have queue ID
IDS _ -> Right cmd
-- ERR response does not always have queue ID
ERR _ -> Right cmd
@@ -640,14 +670,14 @@ instance Protocol BrokerMsg where
| otherwise -> Left $ CMD HAS_AUTH
-- other broker responses must have queue ID
_
| B.null queueId -> Left $ CMD NO_QUEUE
| B.null queueId -> Left $ CMD NO_ENTITY
| otherwise -> Right cmd
_smpP :: Encoding a => Parser a
_smpP = A.space *> smpP
-- | Parse SMP protocol commands and broker messages
parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg
parseProtocol :: ProtocolEncoding msg => ByteString -> Either ErrorType msg
parseProtocol s =
let (tag, params) = B.break (== ' ') s
in case decodeTag tag of
@@ -695,21 +725,22 @@ instance Encoding CommandError where
SYNTAX -> "SYNTAX"
NO_AUTH -> "NO_AUTH"
HAS_AUTH -> "HAS_AUTH"
NO_QUEUE -> "NO_QUEUE"
NO_ENTITY -> "NO_ENTITY"
smpP =
A.takeTill (== ' ') >>= \case
"UNKNOWN" -> pure UNKNOWN
"SYNTAX" -> pure SYNTAX
"NO_AUTH" -> pure NO_AUTH
"HAS_AUTH" -> pure HAS_AUTH
"NO_QUEUE" -> pure NO_QUEUE
"NO_ENTITY" -> pure NO_ENTITY
"NO_QUEUE" -> pure NO_ENTITY
_ -> fail "bad command error type"
-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString
encodeTransmission :: ProtocolEncoding c => ByteString -> Transmission c -> ByteString
encodeTransmission sessionId (CorrId corrId, queueId, command) =
smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
@@ -718,18 +749,14 @@ tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmissi
tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
-- | Receive client and server transmissions (determined by `cmd` type).
tGet ::
forall cmd c m.
(Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) =>
THandle c ->
m (SignedTransmission cmd)
tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
where
decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
decodeParseValidate = \case
Right RawTransmission {signature, signed, sessId, corrId, queueId, command}
Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
| sessId == sessionId ->
let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature
let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
| otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
Left _ -> tError ""
@@ -738,6 +765,6 @@ tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
tParseValidate signed t@(sig, corrId, queueId, command) = do
tParseValidate signed t@(sig, corrId, entityId, command) = do
let cmd = parseProtocol command >>= checkCredentials t
pure (sig, signed, (CorrId corrId, queueId, cmd))
pure (sig, signed, (CorrId corrId, entityId, cmd))
src/Simplex/Messaging/Server.hs
+17 -22
View File
@@ -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) where
module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking, verifyCmdSignature, dummyVerifyCmd) where
import Control.Monad
import Control.Monad.Except
@@ -98,7 +98,7 @@ smpServer started = do
m ()
serverThread s subQ subs clientSubs unsub = forever $ do
atomically updateSubscribers
>>= fmap join . mapM endPreviousSubscriptions
$>>= endPreviousSubscriptions
>>= mapM_ unsub
where
updateSubscribers :: STM (Maybe (QueueId, Client))
@@ -110,8 +110,7 @@ smpServer started = do
else do
yes <- readTVar $ connected c'
pure $ if yes then Just (qId, c') else Nothing
TM.lookupInsert qId clnt (subs s)
>>= fmap join . mapM clientToBeNotified
TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
endPreviousSubscriptions (qId, c) = do
void . forkIO . atomically $
@@ -139,7 +138,7 @@ smpServer started = do
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ serverHandshake h kh) >>= \case
liftIO (runExceptT $ smpServerHandshake h kh) >>= \case
Right th -> runClientTransport th
Left _ -> pure ()
@@ -194,8 +193,8 @@ verifyTransmission ::
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
verifyTransmission sig_ signed queueId cmd = do
case cmd of
Cmd SRecipient (NEW k _) -> pure $ verifySignature k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SSender PING -> pure True
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
@@ -204,18 +203,21 @@ verifyTransmission sig_ signed queueId cmd = do
verifyCmd party f = do
st <- asks queueStore
q <- atomically $ getQueue st party queueId
pure $ either (const $ maybe False dummyVerify sig_ `seq` False) f q
pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
verifyMaybe = maybe (isNothing sig_) verifySignature
verifySignature :: C.APublicVerifyKey -> Bool
verifySignature key = maybe False (verify key) sig_
verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
where
verify :: C.APublicVerifyKey -> C.ASignature -> Bool
verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =
case (testEquality a a', C.signatureSize k == C.signatureSize s) of
(Just Refl, True) -> C.verify' k s signed
_ -> dummyVerify sig `seq` False
dummyVerify :: C.ASignature -> Bool
dummyVerify (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
_ -> dummyVerifyCmd signed sig `seq` False
dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
-- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
@@ -459,11 +461,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)
src/Simplex/Messaging/Server/CLI.hs
+285
View File
@@ -0,0 +1,285 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Server.CLI where
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (HostName, ServiceName)
import Options.Applicative
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
import Simplex.Messaging.Transport.Server (loadFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
import System.Exit (exitFailure)
import System.FilePath (combine)
import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile)
import System.Process (readCreateProcess, shell)
import Text.Read (readMaybe)
data ServerCLIConfig cfg = ServerCLIConfig
{ cfgDir :: FilePath,
logDir :: FilePath,
iniFile :: FilePath,
storeLogFile :: FilePath,
caKeyFile :: FilePath,
caCrtFile :: FilePath,
serverKeyFile :: FilePath,
serverCrtFile :: FilePath,
fingerprintFile :: FilePath,
defaultServerPort :: ServiceName,
executableName :: String,
serverVersion :: String,
mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> cfg
}
protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
getCliCommand cliCfg >>= \case
Init opts ->
doesFileExist iniFile >>= \case
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
_ -> initializeServer cliCfg opts
Start ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runServer cliCfg server . mkIniOptions)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
Delete -> cleanup cliCfg >> putStrLn "Deleted configuration and log files"
exitError :: String -> IO ()
exitError msg = putStrLn msg >> exitFailure
data CliCommand
= Init InitOptions
| Start
| Delete
data InitOptions = InitOptions
{ enableStoreLog :: Bool,
signAlgorithm :: SignAlgorithm,
ip :: HostName,
fqdn :: Maybe HostName
}
deriving (Show)
data SignAlgorithm = ED448 | ED25519
deriving (Read, Show)
getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
getCliCommand cliCfg =
customExecParser
(prefs showHelpOnEmpty)
( info
(helper <*> versionOption <*> cliCommandP cliCfg)
(header version <> fullDesc)
)
where
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
version = serverVersion cliCfg
cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
hsubparser
( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
)
where
initP :: Parser CliCommand
initP =
Init
<$> ( InitOptions
<$> switch
( long "store-log"
<> short 'l'
<> help "Enable store log for persistence"
)
<*> option
(maybeReader readMaybe)
( long "sign-algorithm"
<> short 'a'
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
<> value ED448
<> showDefault
<> metavar "ALG"
)
<*> strOption
( long "ip"
<> help
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
<> value "127.0.0.1"
<> showDefault
<> metavar "IP"
)
<*> (optional . strOption)
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
)
initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
cleanup cliCfg
createDirectoryIfMissing True cfgDir
createDirectoryIfMissing True logDir
createX509
fp <- saveFingerprint
createIni
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
printServiceInfo cliCfg fp
warnCAPrivateKeyFile
where
ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort} = cliCfg
createX509 = do
createOpensslCaConf
createOpensslServerConf
-- CA certificate (identity/offline)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
-- server certificate (online)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
where
run cmd = void $ readCreateProcess (shell cmd) ""
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
opensslServerConfFile = combine cfgDir "openssl_server.conf"
serverCsrFile = combine cfgDir "server.csr"
createOpensslCaConf =
writeFile
opensslCaConfFile
"[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n\
\CN = SMP server CA\n\
\O = SimpleX\n\n\
\[v3]\n\
\subjectKeyIdentifier = hash\n\
\authorityKeyIdentifier = keyid:always\n\
\basicConstraints = critical,CA:true\n"
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
-- as Subject Alternative Name, unless the following validation hook is disabled:
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
createOpensslServerConf =
writeFile
opensslServerConfFile
( "[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n"
<> ("CN = " <> cn <> "\n\n")
<> "[v3]\n\
\basicConstraints = CA:FALSE\n\
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
\extendedKeyUsage = serverAuth\n"
)
where
cn = fromMaybe ip fqdn
saveFingerprint = do
Fingerprint fp <- loadFingerprint caCrtFile
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
pure fp
createIni = do
writeFile iniFile $
"[STORE_LOG]\n\
\# The server uses STM memory for persistence,\n\
\# that will be lost on restart (e.g., as with redis).\n\
\# This option enables saving memory to append only log,\n\
\# and restoring it when the server is started.\n\
\# Log is compacted on start (deleted objects are removed).\n\
\# The messages are not logged.\n"
<> ("enable: " <> (if enableStoreLog then "on" else "off # on") <> "\n\n")
<> "[TRANSPORT]\n\
\port: "
<> defaultServerPort
<> "\n\
\websockets: off\n"
warnCAPrivateKeyFile =
putStrLn $
"----------\n\
\You should store CA private key securely and delete it from the server.\n\
\If server TLS credential is compromised this key can be used to sign a new one, \
\keeping the same server identity and established connections.\n\
\CA private key location:\n"
<> caKeyFile
<> "\n----------"
data IniOptions = IniOptions
{ enableStoreLog :: Bool,
port :: ServiceName,
enableWebsockets :: Bool
}
-- TODO ? properly parse ini as a whole
mkIniOptions :: Ini -> IniOptions
mkIniOptions ini =
IniOptions
{ enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",
port = T.unpack $ strict "TRANSPORT" "port",
enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"
}
where
strict :: String -> String -> T.Text
strict section key =
fromRight (error ("no key " <> key <> " in section " <> section)) $
lookupValue (T.pack section) (T.pack key) ini
runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IniOptions -> IO ()
runServer cliCfg server IniOptions {enableStoreLog, port, enableWebsockets} = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint
printServiceInfo cliCfg fp
let transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
logFile = if enableStoreLog then Just storeLogFile else Nothing
cfg = mkServerConfig logFile transports
printServerConfig logFile transports
server cfg
where
ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
checkSavedFingerprint = do
savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
Fingerprint fp <- loadFingerprint caCrtFile
when (B.pack savedFingerprint /= strEncode fp) $
exitError "Stored fingerprint is invalid."
pure fp
printServerConfig logFile transports = do
putStrLn $ case logFile of
Just f -> "Store log: " <> f
_ -> "Store log disabled."
forM_ transports $ \(p, ATransport t) ->
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
cleanup :: ServerCLIConfig cfg -> IO ()
cleanup ServerCLIConfig {cfgDir, logDir} = do
deleteDirIfExists cfgDir
deleteDirIfExists logDir
where
deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
putStrLn serverVersion
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
src/Simplex/Messaging/Server/Env/STM.hs
+4 -3
View File
@@ -36,7 +36,7 @@ data ServerConfig = ServerConfig
msgQueueQuota :: Natural,
queueIdBytes :: Int,
msgIdBytes :: Int,
storeLog :: Maybe (StoreLog 'ReadMode),
storeLogFile :: Maybe FilePath,
-- | set to False to prohibit creating new queues
allowNewQueues :: Bool,
-- | time after which the messages can be removed from the queues, seconds
@@ -106,12 +106,13 @@ newSubscription = do
return Sub {subThread = NoSub, delivered}
newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
server <- atomically $ newServer (serverTbqSize config)
queueStore <- atomically newQueueStore
msgStore <- atomically newMsgStore
idsDrg <- drgNew >>= newTVarIO
s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
s' <- restoreQueues queueStore `mapM` storeLog
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
let serverIdentity = KeyHash fp
src/Simplex/Messaging/Server/QueueStore/STM.hs
+4 -5
View File
@@ -18,7 +18,7 @@ import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (ifM)
import Simplex.Messaging.Util (ifM, ($>>=))
import UnliftIO.STM
data QueueStore = QueueStore
@@ -51,9 +51,8 @@ instance MonadQueueStore QueueStore STM where
where
getVar = case party of
SRecipient -> TM.lookup qId queues
SSender -> TM.lookup qId senders >>= get
SNotifier -> TM.lookup qId notifiers >>= get
get = fmap join . mapM (`TM.lookup` queues)
SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
secureQueue QueueStore {queues} rId sKey =
@@ -91,4 +90,4 @@ toResult :: Maybe a -> Either ErrorType a
toResult = maybe (Left AUTH) Right
withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
withQueue rId queues f = toResult <$> (TM.lookup rId queues >>= fmap join . mapM f)
withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
src/Simplex/Messaging/TMap.hs
+12
View File
@@ -2,6 +2,7 @@ module Simplex.Messaging.TMap
( TMap,
empty,
singleton,
Simplex.Messaging.TMap.null,
Simplex.Messaging.TMap.lookup,
member,
insert,
@@ -11,6 +12,7 @@ module Simplex.Messaging.TMap
adjust,
update,
alter,
alterF,
union,
)
where
@@ -29,6 +31,10 @@ singleton :: k -> a -> STM (TMap k a)
singleton k v = newTVar $ M.singleton k v
{-# INLINE singleton #-}
null :: TMap k a -> STM Bool
null m = M.null <$> readTVar m
{-# INLINE null #-}
lookup :: Ord k => k -> TMap k a -> STM (Maybe a)
lookup k m = M.lookup k <$> readTVar m
{-# INLINE lookup #-}
@@ -65,6 +71,12 @@ alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM ()
alter f k m = modifyTVar' m $ M.alter f k
{-# INLINE alter #-}
alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM ()
alterF f k m = do
mv <- M.alterF f k =<< readTVar m
writeTVar m $! mv
{-# INLINE alterF #-}
union :: Ord k => Map k a -> TMap k a -> STM ()
union m' m = modifyTVar' m $ M.union m'
{-# INLINE union #-}
src/Simplex/Messaging/Transport.hs
+19 -20
View File
@@ -26,7 +26,6 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
module Simplex.Messaging.Transport
( -- * SMP transport parameters
smpBlockSize,
supportedSMPVersions,
simplexMQVersion,
@@ -47,8 +46,8 @@ module Simplex.Messaging.Transport
-- * SMP transport
THandle (..),
TransportError (..),
serverHandshake,
clientHandshake,
smpServerHandshake,
smpClientHandshake,
tPutBlock,
tGetBlock,
serializeTransportError,
@@ -252,8 +251,9 @@ trimCR s = if B.last s == '\r' then B.init s else s
data THandle c = THandle
{ connection :: c,
sessionId :: SessionId,
-- | agreed SMP server protocol version
smpVersion :: Version
blockSize :: Int,
-- | agreed server protocol version
thVersion :: Version
}
-- | TLS-unique channel binding
@@ -336,45 +336,45 @@ serializeTransportError = \case
-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
tPutBlock THandle {connection = c} block =
tPutBlock THandle {connection = c, blockSize} block =
bimapM (const $ pure TELargeMsg) (cPut c) $
C.pad block smpBlockSize
C.pad block blockSize
-- | Receive block from SMP transport.
tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
tGetBlock THandle {connection = c} =
cGet c smpBlockSize >>= \case
tGetBlock THandle {connection = c, blockSize} =
cGet c blockSize >>= \case
"" -> ioe_EOF
msg -> pure . first (const TELargeMsg) $ C.unPad msg
-- | Server SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
serverHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
serverHandshake c kh = do
let th@THandle {sessionId} = tHandle c
smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
smpServerHandshake c kh = do
let th@THandle {sessionId} = smpTHandle c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
getHandshake th >>= \case
ClientHandshake {smpVersion, keyHash}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
| smpVersion `isCompatible` supportedSMPVersions -> do
pure (th :: THandle c) {smpVersion}
pure (th :: THandle c) {thVersion = smpVersion}
| otherwise -> throwE $ TEHandshake VERSION
-- | Client SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
clientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
clientHandshake c keyHash = do
let th@THandle {sessionId} = tHandle c
smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
smpClientHandshake c keyHash = do
let th@THandle {sessionId} = smpTHandle c
ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
if sessionId /= sessId
then throwE TEBadSession
else case smpVersionRange `compatibleVersion` supportedSMPVersions of
Just (Compatible smpVersion) -> do
sendHandshake th $ ClientHandshake {smpVersion, keyHash}
pure (th :: THandle c) {smpVersion}
pure (th :: THandle c) {thVersion = smpVersion}
Nothing -> throwE $ TEHandshake VERSION
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
@@ -383,6 +383,5 @@ sendHandshake th = ExceptT . tPutBlock th . smpEncode
getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
tHandle :: Transport c => c -> THandle c
tHandle c =
THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0}
smpTHandle :: Transport c => c -> THandle c
smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}
src/Simplex/Messaging/Transport/Client.hs
+16 -9
View File
@@ -1,8 +1,10 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Transport.Client
( runTransportClient,
clientHandshake,
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]
src/Simplex/Messaging/Transport/HTTP2.hs
+36
View File
@@ -0,0 +1,36 @@
module Simplex.Messaging.Transport.HTTP2 where
import qualified Control.Exception as E
import Data.Default (def)
import Foreign (mallocBytes)
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
import qualified Network.TLS as T
import qualified Network.TLS.Extra as TE
import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
import qualified System.TimeManager as TI
withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
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 = defaultPositionReadMaker,
confTimeoutManager = tm
}
http2TLSParams :: T.Supported
http2TLSParams =
def
{ T.supportedVersions = [T.TLS13, T.TLS12],
T.supportedCiphers = TE.ciphersuite_strong_det,
T.supportedSecureRenegotiation = False
}
src/Simplex/Messaging/Transport/HTTP2/Client.hs
+128
View File
@@ -0,0 +1,128 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Transport.HTTP2.Client where
import Control.Concurrent.Async
import Control.Exception (IOException)
import qualified Control.Exception as E
import Control.Monad.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (isNothing)
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (HeaderTable)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
import qualified Network.HTTP2.Client as H
import Network.Socket (HostName, ServiceName)
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Transport.Client (runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
import UnliftIO.STM
import UnliftIO.Timeout
data HTTP2Client = HTTP2Client
{ action :: Async (),
connected :: TVar Bool,
host :: HostName,
port :: ServiceName,
config :: HTTP2ClientConfig,
reqQ :: TBQueue (Request, TMVar HTTP2Response)
}
data HTTP2Response = HTTP2Response
{ response :: Response,
respBody :: ByteString,
respTrailers :: Maybe HeaderTable
}
data HTTP2ClientConfig = HTTP2ClientConfig
{ qSize :: Natural,
connTimeout :: Int,
tcpKeepAlive :: Maybe KeepAliveOpts,
caStoreFile :: FilePath,
suportedTLSParams :: T.Supported
}
deriving (Show)
defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
HTTP2ClientConfig
{ qSize = 64,
connTimeout = 10000000,
tcpKeepAlive = Nothing,
caStoreFile = "/etc/ssl/cert.pem",
suportedTLSParams = http2TLSParams
}
data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
deriving (Show)
getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
(atomically mkHTTPS2Client >>= runClient)
`E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
where
mkHTTPS2Client :: STM HTTP2Client
mkHTTPS2Client = do
connected <- newTVar False
reqQ <- newTBQueue $ qSize config
pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
runClient c = do
cVar <- newEmptyTMVarIO
caStore <- XS.readCertificateStore caStoreFile
when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
action <-
async $
runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
`E.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 HCNetworkError1
client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
client c cVar sendReq = do
atomically $ do
writeTVar (connected c) True
putTMVar cVar $ Right ()
process c sendReq `E.finally` disconnected
process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
process HTTP2Client {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}
respBody <- getResponseBody r ""
respTrailers <- H.getResponseTrailers r
writeResp respBody respTrailers
getResponseBody :: Response -> ByteString -> IO ByteString
getResponseBody r s =
H.getResponseBodyChunk r >>= \chunk ->
if B.null chunk then pure s else getResponseBody r $ s <> chunk
-- | Disconnects client from the server and terminates client threads.
closeHTTP2Client :: HTTP2Client -> IO ()
-- TODO disconnect
closeHTTP2Client = uninterruptibleCancel . action
sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
sendRequest HTTP2Client {reqQ, config} req = do
resp <- newEmptyTMVarIO
atomically $ writeTBQueue reqQ (req, resp)
maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
runHTTP2Client tlsParams caStore host port keepAliveOpts client =
runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
withTlsConfig c 16384 (`run` client)
where
run = H.run $ ClientConfig "https" (B.pack host) 20
src/Simplex/Messaging/Transport/HTTP2/Server.hs
+70
View File
@@ -0,0 +1,70 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Transport.HTTP2.Server where
import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Network.HPACK (HeaderTable)
import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
import qualified Network.HTTP2.Server as H
import Network.Socket
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
data HTTP2ServerConfig = HTTP2ServerConfig
{ qSize :: Natural,
http2Port :: ServiceName,
serverSupported :: T.Supported,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
}
deriving (Show)
data HTTP2Request = HTTP2Request
{ request :: Request,
reqBody :: ByteString,
reqTrailers :: Maybe HeaderTable,
sendResponse :: Response -> IO ()
}
data HTTP2Server = HTTP2Server
{ action :: Async (),
reqQ :: TBQueue HTTP2Request
}
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
started <- newEmptyTMVarIO
reqQ <- newTBQueueIO qSize
action <- async $
runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
reqBody <- getRequestBody r ""
reqTrailers <- H.getRequestTrailers r
atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
void . atomically $ takeTMVar started
pure HTTP2Server {action, reqQ}
where
getRequestBody :: Request -> ByteString -> IO ByteString
getRequestBody r s =
H.getRequestBodyChunk r >>= \chunk ->
if B.null chunk then pure s else getRequestBody r $ s <> chunk
closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server = uninterruptibleCancel . action
runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port serverParams http2Server =
runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
where
server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
server req _aux sendResp = http2Server req (`sendResp` [])
src/Simplex/Messaging/Transport/KeepAlive.hs
+1
View File
@@ -12,6 +12,7 @@ data KeepAliveOpts = KeepAliveOpts
keepIntvl :: Int,
keepCnt :: Int
}
deriving (Show)
defaultKeepAliveOpts :: KeepAliveOpts
defaultKeepAliveOpts =
src/Simplex/Messaging/Transport/Server.hs
+7 -3
View File
@@ -5,9 +5,10 @@
module Simplex.Messaging.Transport.Server
( runTransportServer,
runTCPServer,
loadSupportedTLSServerParams,
loadTLSServerParams,
loadFingerprint,
serverHandshake,
smpServerHandshake,
)
where
@@ -84,7 +85,10 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
setStarted sock = atomically (tryPutTMVar started True) >> pure sock
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
fromCredential <$> loadServerCredential
where
loadServerCredential :: IO T.Credential
@@ -98,7 +102,7 @@ loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
{ T.serverWantClientCert = False,
T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
T.serverHooks = def,
T.serverSupported = supportedParameters
T.serverSupported = serverSupported
}
loadFingerprint :: FilePath -> IO Fingerprint
src/Simplex/Messaging/Util.hs
+3
View File
@@ -65,3 +65,6 @@ whenM b a = ifM b a $ pure ()
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM b = ifM b $ pure ()
{-# INLINE unlessM #-}
($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
f $>>= g = f >>= fmap join . mapM g
tests/AgentTests/ConnectionRequestTests.hs
+2 -2
View File
@@ -11,7 +11,7 @@ import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (smpClientVRange)
import Simplex.Messaging.Protocol (ProtocolServer (..), smpClientVRange)
import Simplex.Messaging.Version
import Test.Hspec
@@ -20,7 +20,7 @@ uri = "smp.simplex.im"
srv :: SMPServer
srv =
SMPServer
ProtocolServer
{ host = "smp.simplex.im",
port = "5223",
keyHash = C.KeyHash "\215m\248\251"
tests/AgentTests/FunctionalAPITests.hs
+16 -16
View File
@@ -51,8 +51,8 @@ functionalAPITests t = do
testAgentClient :: IO ()
testAgentClient = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
@@ -95,13 +95,13 @@ testAgentClient = do
testAsyncInitiatingOffline :: IO ()
testAsyncInitiatingOffline = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
(bobId, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
aliceId <- joinConnection bob cReq "bob's connInfo"
alice' <- liftIO $ getSMPAgentClient cfg
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
subscribeConnection alice' bobId
("", _, CONF confId "bob's connInfo") <- get alice'
allowConnection alice' bobId confId "alice's connInfo"
@@ -113,15 +113,15 @@ testAsyncInitiatingOffline = do
testAsyncJoiningOfflineBeforeActivation :: IO ()
testAsyncJoiningOfflineBeforeActivation = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
disconnectAgentClient bob
("", _, CONF confId "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
subscribeConnection bob' aliceId
get alice ##> ("", bobId, CON)
get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -131,18 +131,18 @@ testAsyncJoiningOfflineBeforeActivation = do
testAsyncBothOffline :: IO ()
testAsyncBothOffline = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
(bobId, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
aliceId <- joinConnection bob cReq "bob's connInfo"
disconnectAgentClient bob
alice' <- liftIO $ getSMPAgentClient cfg
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
subscribeConnection alice' bobId
("", _, CONF confId "bob's connInfo") <- get alice'
allowConnection alice' bobId confId "alice's connInfo"
bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
subscribeConnection bob' aliceId
get alice' ##> ("", bobId, CON)
get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -152,8 +152,8 @@ testAsyncBothOffline = do
testAsyncServerOffline :: ATransport -> IO ()
testAsyncServerOffline t = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-- create connection and shutdown the server
Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
runExceptT $ createConnection alice SCMInvitation
@@ -176,8 +176,8 @@ testAsyncServerOffline t = do
testAsyncHelloTimeout :: IO ()
testAsyncHelloTimeout = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2, helloTimeout = 1}
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
Right () <- runExceptT $ do
(_, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
tests/AgentTests/NotificationTests.hs
+167
View File
@@ -0,0 +1,167 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module AgentTests.NotificationTests where
-- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
import Control.Concurrent (threadDelay)
import Control.Monad.Except
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import Data.Text.Encoding (encodeUtf8)
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Protocol (ErrorType (AUTH))
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Util (tryE)
import System.Directory (removeFile)
import Test.Hspec
import UnliftIO.STM
notificationTests :: ATransport -> Spec
notificationTests t =
after_ (removeFile testDB) $
describe "Managing notification tokens" $ do
it "should register and verify notification token" $
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationToken apns
it "should allow repeated registration with the same credentials" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNtfTokenRepeatRegistration apns
it "should allow the second registration with different credentials and delete the first after verification" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNtfTokenSecondRegistration apns
it "should re-register token when notification server is restarted" $ \_ ->
withAPNSMockServer $ \apns ->
testNtfTokenServerRestart t apns
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken APNSMockServer {apnsQ} = do
a <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApns "abcd"
registerNtfToken a tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn verification nonce
enableNtfCron a tkn 30
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
pure ()
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
v .-> key = do
J.Object o <- pure v
liftEither . bimap INTERNAL (U.decodeLenient . encodeUtf8) $ JT.parseEither (J..: key) o
-- logCfg :: LogConfig
-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
a <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApns "abcd"
registerNtfToken a tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
registerNtfToken a tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
_ <- ntfData' .-> "verification"
_ <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- can still use the first verification code, it is the same after decryption
verifyNtfToken a tkn verification nonce
enableNtfCron a tkn 30
NTActive <- checkNtfToken a tkn
pure ()
pure ()
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
a <- getSMPAgentClient agentCfg initAgentServers
a' <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApns "abcd"
registerNtfToken a tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn verification nonce
registerNtfToken a' tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- at this point the first token is still active
NTActive <- checkNtfToken a tkn
-- and the second is not yet verified
NTConfirmed <- checkNtfToken a' tkn
-- now the second token registration is verified
verifyNtfToken a' tkn verification' nonce'
-- the first registration is removed
Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
-- and the second is active
NTActive <- checkNtfToken a' tkn
enableNtfCron a' tkn 30
pure ()
pure ()
testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
a <- getSMPAgentClient agentCfg initAgentServers
let tkn = DeviceToken PPApns "abcd"
Right ntfData <- withNtfServer t . runExceptT $ do
registerNtfToken a tkn
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
pure ntfData
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
threadDelay 1000000
disconnectAgentClient a
a' <- getSMPAgentClient agentCfg initAgentServers
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
Right () <- withNtfServer t . runExceptT $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn verification nonce
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
verifyNtfToken a' tkn verification' nonce'
NTActive <- checkNtfToken a' tkn
enableNtfCron a' tkn 30
pure ()
tests/NtfClient.hs
+193
View File
@@ -0,0 +1,193 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module NtfClient where
import Control.Monad
import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import Data.ByteString.Builder (lazyByteString)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.HTTP.Types (Status)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
import Simplex.Messaging.Notifications.Server.Env
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Transport
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Client
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.KeepAlive
import UnliftIO.Async
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost = "localhost"
ntfTestPort :: ServiceName
ntfTestPort = "6001"
apnsTestPort :: ServiceName
apnsTestPort = "6010"
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
testNtfClient client =
runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ ntfClientHandshake h testKeyHash) >>= \case
Right th -> client th
Left e -> error $ show e
ntfServerCfg :: NtfServerConfig
ntfServerCfg =
NtfServerConfig
{ transports = undefined,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 1,
subQSize = 1,
pushQSize = 1,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig =
defaultAPNSPushClientConfig
{ apnsHost = "localhost",
apnsPort = apnsTestPort,
http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
},
-- CA certificate private key is not needed for initialization
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
}
withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withNtfServerThreadOn t port' =
serverBracket
(\started -> runNtfServerBlocking started ntfServerCfg {transports = [(port', t)]})
(pure ())
serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
E.bracket
(forkIOWithUnmask ($ process started))
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t)
where
waitFor started s =
5_000_000 `timeout` atomically (takeTMVar started) >>= \case
Nothing -> error $ "server did not " <> s
_ -> pure ()
withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
withNtfServerOn t port' = withNtfServerThreadOn t port' . const
withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
withNtfServer t = withNtfServerOn t ntfTestPort
runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
TProxy c ->
(Maybe C.ASignature, ByteString, ByteString, smp) ->
IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
where
tPut' h (sig, corrId, queueId, smp) = do
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
Right () <- tPut h (sig, t')
pure ()
tGet' h = do
(Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
pure (Nothing, corrId, qId, cmd)
data APNSMockRequest = APNSMockRequest
{ notification :: APNSNotification,
sendApnsResponse :: APNSMockResponse -> IO ()
}
data APNSMockResponse = APNSRespOk | APNSRespError Status Text
data APNSMockServer = APNSMockServer
{ action :: Async (),
apnsQ :: TBQueue APNSMockRequest,
http2Server :: HTTP2Server
}
apnsMockServerConfig :: HTTP2ServerConfig
apnsMockServerConfig =
HTTP2ServerConfig
{ qSize = 1,
http2Port = apnsTestPort,
serverSupported = http2TLSParams,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
}
withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
deriving instance Generic APNSAlertBody
deriving instance FromJSON APNSAlertBody
instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions
deriving instance FromJSON APNSNotification
deriving instance ToJSON APNSErrorResponse
getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
http2Server <- getHTTP2Server config
apnsQ <- newTBQueueIO qSize
action <- async $ runAPNSMockServer apnsQ http2Server
pure APNSMockServer {action, apnsQ, http2Server}
where
runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do
HTTP2Request {reqBody, sendResponse} <- atomically $ readTBQueue reqQ
let sendApnsResponse = \case
APNSRespOk -> sendResponse $ H.responseNoBody N.ok200 []
APNSRespError status reason ->
sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason}
case J.decodeStrict' reqBody of
Just notification -> atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
_ -> sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
closeAPNSMockServer :: APNSMockServer -> IO ()
closeAPNSMockServer APNSMockServer {action, http2Server} = do
closeHTTP2Server http2Server
uninterruptibleCancel action
tests/NtfServerTests.hs
+36
View File
@@ -0,0 +1,36 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module NtfServerTests where
import Data.ByteString.Char8 (ByteString)
import NtfClient
import ServerTests (sampleDhPubKey, samplePubKey, sampleSig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport
import Test.Hspec
ntfServerTests :: ATransport -> Spec
ntfServerTests t = do
describe "notifications server protocol syntax" $ ntfSyntaxTests t
ntfSyntaxTests :: ATransport -> Spec
ntfSyntaxTests (ATransport t) = do
it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
describe "NEW" $ do
it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
where
(>#>) ::
Encoding smp =>
(Maybe C.ASignature, ByteString, ByteString, smp) ->
(Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
Expectation
command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
tests/SMPAgentClient.hs
+22 -9
View File
@@ -11,6 +11,7 @@ import Crypto.Random
import qualified Data.ByteString.Char8 as B
import qualified Data.List.NonEmpty as L
import Network.Socket (HostName, ServiceName)
import NtfClient (ntfTestPort)
import SMPClient
( serverBracket,
testKeyHash,
@@ -24,7 +25,7 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.KeepAlive
@@ -154,20 +155,31 @@ smpAgentTest1_1_1 test' =
_test [h] = test' h
_test _ = error "expected 1 handle"
cfg :: AgentConfig
cfg =
initAgentServers :: InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
ntf = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
}
agentCfg :: AgentConfig
agentCfg =
defaultAgentConfig
{ tcpPort = agentTestPort,
initialSMPServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
tbqSize = 1,
dbFile = testDB,
smpCfg =
smpDefaultConfig
defaultClientConfig
{ qSize = 1,
defaultTransport = (testPort, transport @TLS),
tcpTimeout = 500_000
},
reconnectInterval = (reconnectInterval defaultAgentConfig) {initialInterval = 50_000},
ntfCfg =
defaultClientConfig
{ qSize = 1,
defaultTransport = (ntfTestPort, transport @TLS)
},
reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
@@ -175,9 +187,10 @@ cfg =
withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
let cfg' = cfg {tcpPort = port', dbFile = db', initialSMPServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
let cfg' = agentCfg {tcpPort = port', dbFile = db'}
initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
in serverBracket
(\started -> runSMPAgentBlocking t started cfg')
(\started -> runSMPAgentBlocking t started cfg' initServers')
afterProcess
withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a
@@ -191,7 +204,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
tests/SMPClient.hs
+4 -7
View File
@@ -19,7 +19,6 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.KeepAlive
@@ -46,8 +45,8 @@ 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 ->
liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case
runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ smpClientHandshake h testKeyHash) >>= \case
Right th -> client th
Left e -> error $ show e
@@ -60,7 +59,7 @@ cfg =
msgQueueQuota = 4,
queueIdBytes = 24,
msgIdBytes = 24,
storeLog = Nothing,
storeLogFile = Nothing,
allowNewQueues = True,
messageTTL = Just $ 7 * 86400, -- seconds, 7 days
expireMessagesInterval = Just 21600_000000, -- microseconds, 6 hours
@@ -70,9 +69,7 @@ cfg =
}
withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerStoreLogOn t port' client = do
s <- liftIO $ openReadStoreLog testStoreLogFile
withSmpServerConfigOn t cfg {storeLog = Just s} port' client
withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile}
withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerConfigOn t cfg' port' =
tests/ServerTests.hs
+1 -1
View File
@@ -562,7 +562,7 @@ syntaxTests (ATransport t) = do
describe "SEND" $ do
it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_QUEUE)
it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
describe "PING" $ do
it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)
describe "broker response not allowed" $ do
tests/Test.hs
+8
View File
@@ -1,18 +1,23 @@
{-# LANGUAGE TypeApplications #-}
import AgentTests (agentTests)
import AgentTests.NotificationTests (notificationTests)
import CoreTests.EncodingTests
import CoreTests.ProtocolErrorTests
import CoreTests.VersionRangeTests
import NtfServerTests (ntfServerTests)
import ServerTests
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import System.Environment (setEnv)
import Test.Hspec
main :: IO ()
main = do
createDirectoryIfMissing False "tests/tmp"
setEnv "APNS_KEY_ID" "H82WD9K9AQ"
setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
hspec $ do
describe "Core tests" $ do
describe "Encoding tests" encodingTests
@@ -20,5 +25,8 @@ main = do
describe "Version range" versionRangeTests
describe "SMP server via TLS" $ serverTests (transport @TLS)
describe "SMP server via WebSockets" $ serverTests (transport @WS)
describe "Notifications server" $ do
ntfServerTests (transport @TLS)
notificationTests (transport @TLS)
describe "SMP client agent" $ agentTests (transport @TLS)
removeDirectoryRecursive "tests/tmp"
tests/fixtures/AuthKey_H82WD9K9AQ.p8
Vendored
+6
View File
@@ -0,0 +1,6 @@
-----BEGIN PRIVATE KEY-----
MIGTAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBHkwdwIBAQQgWuPap5jF6eioxuHM
XWZWUK78LdcxkTnMXWg2GqyXuBugCgYIKoZIzj0DAQehRANCAAQn64CvAIbEEzvM
KwYjlOxVD5SxlgP1ZcYvVM/+VHLFu0aCkG7ueICTi3qWyqoB5hjjuAqwtc3EK0q0
yupyM7Yx
-----END PRIVATE KEY-----