From 3d9ceff691c8a5ac05b7c9ea18fcc3b707eafeb8 Mon Sep 17 00:00:00 2001 From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Date: Sun, 4 Jul 2021 04:48:24 +1000 Subject: [PATCH] ask client for confirmation of sender; make establishment of connection asynchronous (#163) Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- apps/smp-server/Main.hs | 2 +- migrations/20210624_confirmations.sql | 9 + src/Simplex/Messaging/Agent.hs | 202 ++++++++++++++------ src/Simplex/Messaging/Agent/Client.hs | 67 +++++-- src/Simplex/Messaging/Agent/Protocol.hs | 101 +++++----- src/Simplex/Messaging/Agent/Store.hs | 28 ++- src/Simplex/Messaging/Agent/Store/SQLite.hs | 93 ++++++++- src/Simplex/Messaging/Crypto.hs | 39 +++- src/Simplex/Messaging/Server/Env/STM.hs | 2 +- tests/AgentTests.hs | 49 +++-- tests/AgentTests/SQLiteTests.hs | 6 +- 11 files changed, 446 insertions(+), 152 deletions(-) create mode 100644 migrations/20210624_confirmations.sql diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index c0802a66b..05161bde1 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -222,7 +222,7 @@ confirm msg = do when (map toLower ok /= "y") exitFailure serverKeyHash :: C.FullPrivateKey -> B.ByteString -serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey +serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey' openStoreLog :: ServerOpts -> IniOpts -> IO (Maybe (StoreLog 'ReadMode)) openStoreLog ServerOpts {enableStoreLog = l} IniOpts {enableStoreLog = l', storeLogFile = f} diff --git a/migrations/20210624_confirmations.sql b/migrations/20210624_confirmations.sql new file mode 100644 index 000000000..f7b1e8e85 --- /dev/null +++ b/migrations/20210624_confirmations.sql @@ -0,0 +1,9 @@ +CREATE TABLE conn_confirmations ( + confirmation_id BLOB NOT NULL PRIMARY KEY, + conn_alias BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, + sender_key BLOB NOT NULL, + sender_conn_info BLOB NOT NULL, + accepted INTEGER NOT NULL, + own_conn_info BLOB, + created_at TEXT NOT NULL DEFAULT (datetime('now')) +) WITHOUT ROWID; diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index b27aeab14..2581a9dc0 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -39,6 +40,7 @@ module Simplex.Messaging.Agent getSMPAgentClient, createConnection, joinConnection, + allowConnection, sendIntroduction, acceptInvitation, subscribeConnection, @@ -47,6 +49,7 @@ module Simplex.Messaging.Agent deleteConnection, createConnection', joinConnection', + allowConnection', sendIntroduction', acceptInvitation', subscribeConnection', @@ -111,7 +114,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort} = runReader c <- getAgentClient logConnection c True race_ (connectClient h c) (runAgentClient c) - `E.finally` disconnectServers c + `E.finally` disconnectAgentClient c -- | Creates an SMP agent client instance getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient @@ -119,11 +122,11 @@ getSMPAgentClient cfg = newSMPAgentEnv cfg >>= runReaderT runAgent where runAgent = do c <- getAgentClient - action <- async $ subscriber c `E.finally` disconnectServers c + action <- async $ subscriber c `E.finally` disconnectAgentClient c pure c {smpSubscriber = action} -disconnectServers :: MonadUnliftIO m => AgentClient -> m () -disconnectServers c = closeSMPServerClients c >> logConnection c False +disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m () +disconnectAgentClient c = closeAgentClient c >> logConnection c False -- | type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m) @@ -137,12 +140,16 @@ createConnection :: AgentErrorMonad m => AgentClient -> Maybe ConnId -> m (ConnI createConnection c = (`runReaderT` agentEnv c) . createConnection' c -- | Join SMP agent connection (JOIN command) in Reader monad -joinConnection' :: AgentMonad m => AgentClient -> Maybe ConnId -> SMPQueueInfo -> m ConnId -joinConnection' c connId qInfo = joinConn c (fromMaybe "" connId) qInfo (ReplyMode On) Nothing 0 +joinConnection' :: AgentMonad m => AgentClient -> Maybe ConnId -> SMPQueueInfo -> ConnInfo -> m ConnId +joinConnection' c connId qInfo cInfo = joinConn c (fromMaybe "" connId) qInfo cInfo Nothing 0 -- | Join SMP agent connection (JOIN command) -joinConnection :: AgentErrorMonad m => AgentClient -> Maybe ConnId -> SMPQueueInfo -> m ConnId -joinConnection c = (`runReaderT` agentEnv c) .: joinConnection' c +joinConnection :: AgentErrorMonad m => AgentClient -> Maybe ConnId -> SMPQueueInfo -> ConnInfo -> m ConnId +joinConnection c = (`runReaderT` agentEnv c) .:. joinConnection' c + +-- | Approve confirmation (LET command) +allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m () +allowConnection c = (`runReaderT` agentEnv c) .:. allowConnection' c -- | Accept invitation (ACPT command) in Reader monad acceptInvitation' :: AgentMonad m => AgentClient -> InvitationId -> ConnInfo -> m ConnId @@ -150,7 +157,7 @@ acceptInvitation' c = acceptInv c "" -- | Accept invitation (ACPT command) acceptInvitation :: AgentErrorMonad m => AgentClient -> InvitationId -> ConnInfo -> m ConnId -acceptInvitation c = (`runReaderT` agentEnv c) .: acceptInvitation c +acceptInvitation c = (`runReaderT` agentEnv c) .: acceptInvitation' c -- | Send introduction of the second connection the first (INTRO command) sendIntroduction :: AgentErrorMonad m => AgentClient -> ConnId -> ConnId -> ConnInfo -> m () @@ -244,7 +251,8 @@ withStore action = do processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent) processCommand c (connId, cmd) = case cmd of NEW -> second INV <$> newConn c connId Nothing 0 - JOIN smpQueueInfo replyMode -> (,OK) <$> joinConn c connId smpQueueInfo replyMode Nothing 0 + JOIN smpQueueInfo connInfo -> (,OK) <$> joinConn c connId smpQueueInfo connInfo Nothing 0 + LET confId ownConnInfo -> allowConnection' c connId confId ownConnInfo $> (connId, OK) INTRO reConnId reInfo -> sendIntroduction' c connId reConnId reInfo $> (connId, OK) ACPT invId connInfo -> (,OK) <$> acceptInv c connId invId connInfo SUB -> subscribeConnection' c connId $> (connId, OK) @@ -255,31 +263,69 @@ processCommand c (connId, cmd) = case cmd of newConn :: AgentMonad m => AgentClient -> ConnId -> Maybe InvitationId -> Int -> m (ConnId, SMPQueueInfo) newConn c connId viaInv connLevel = do srv <- getSMPServer - (rq, qInfo) <- newReceiveQueue c srv + (rq, qInfo) <- newRcvQueue c srv g <- asks idsDrg let cData = ConnData {connId, viaInv, connLevel} connId' <- withStore $ \st -> createRcvConn st g cData rq addSubscription c rq connId' pure (connId', qInfo) -joinConn :: forall m. AgentMonad m => AgentClient -> ConnId -> SMPQueueInfo -> ReplyMode -> Maybe InvitationId -> Int -> m ConnId -joinConn c connId qInfo (ReplyMode replyMode) viaInv connLevel = do - (sq, senderKey, verifyKey) <- newSendQueue qInfo +minute :: Int +minute = 60_000_000 + +onlineInterval :: RetryInterval +onlineInterval = + RetryInterval + { initialInterval = 1_000_000, + increaseAfter = minute, + maxInterval = 10 * minute + } + +resumeInterval :: RetryInterval +resumeInterval = + RetryInterval + { initialInterval = 5_000_000, + increaseAfter = 0, + maxInterval = 10 * minute + } + +joinConn :: AgentMonad m => AgentClient -> ConnId -> SMPQueueInfo -> ConnInfo -> Maybe InvitationId -> Int -> m ConnId +joinConn c connId qInfo cInfo viaInv connLevel = do + (sq, senderKey, verifyKey) <- newSndQueue qInfo g <- asks idsDrg let cData = ConnData {connId, viaInv, connLevel} connId' <- withStore $ \st -> createSndConn st g cData sq - connectToSendQueue c sq senderKey verifyKey - when (replyMode == On) $ createReplyQueue connId' sq + confirmQueue c sq senderKey cInfo + activateQueueJoining c connId' sq verifyKey onlineInterval pure connId' + +activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueJoining c connId sq verifyKey retryInterval = + activateQueue c connId sq verifyKey retryInterval createReplyQueue where - createReplyQueue :: ConnId -> SndQueue -> m () - createReplyQueue cId sq = do + createReplyQueue :: m () + createReplyQueue = do srv <- getSMPServer - (rq, qInfo') <- newReceiveQueue c srv - addSubscription c rq cId - withStore $ \st -> upgradeSndConnToDuplex st cId rq + (rq, qInfo') <- newRcvQueue c srv + addSubscription c rq connId + withStore $ \st -> upgradeSndConnToDuplex st connId rq sendControlMessage c sq $ REPLY qInfo' +-- | Approve confirmation (LET command) in Reader monad +allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m () +allowConnection' c connId confId ownConnInfo = + withStore (`getConn` connId) >>= \case + SomeConn SCRcv (RcvConnection _ rq) -> do + AcceptedConfirmation {senderKey} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo + processConfirmation c rq senderKey + _ -> throwError $ CMD PROHIBITED + +processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m () +processConfirmation c rq sndKey = do + withStore $ \st -> setRcvQueueStatus st rq Confirmed + secureQueue c rq sndKey + withStore $ \st -> setRcvQueueStatus st rq Secured + -- | Send introduction of the second connection the first (INTRO command) in Reader monad sendIntroduction' :: AgentMonad m => AgentClient -> ConnId -> ConnId -> ConnInfo -> m () sendIntroduction' c toConn reConn reInfo = @@ -302,19 +348,40 @@ acceptInv c connId invId connInfo = sendControlMessage c sq $ A_INV externalIntroId qInfo' connInfo pure connId' Just qInfo' -> do - connId' <- joinConn c connId qInfo' (ReplyMode On) (Just invId) (connLevel + 1) + -- TODO remove invitations from protocol + connId' <- joinConn c connId qInfo' connInfo (Just invId) (connLevel + 1) withStore $ \st -> addInvitationConn st invId connId' pure connId' _ -> throwError $ CONN SIMPLEX _ -> throwError $ CMD PROHIBITED -- | Subscribe to receive connection messages (SUB command) in Reader monad -subscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m () +subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () subscribeConnection' c connId = withStore (`getConn` connId) >>= \case - SomeConn _ (DuplexConnection _ rq _) -> subscribeQueue c rq connId + SomeConn _ (DuplexConnection _ rq sq) -> case status (sq :: SndQueue) of + Confirmed -> withVerifyKey sq $ \sndKey -> do + secureQueue c rq sndKey + withStore $ \st -> setRcvQueueStatus st rq Secured + activateSecuredQueue rq sq sndKey + Secured -> withVerifyKey sq $ activateSecuredQueue rq sq + Active -> subscribeQueue c rq connId + _ -> throwError $ INTERNAL "unexpected queue status" + SomeConn _ (SndConnection _ sq) -> case status (sq :: SndQueue) of + Confirmed -> withVerifyKey sq $ \sndKey -> + activateQueueJoining c connId sq sndKey resumeInterval + Active -> throwError $ CONN SIMPLEX + _ -> throwError $ INTERNAL "unexpected queue status" SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId - _ -> throwError $ CONN SIMPLEX + where + withVerifyKey :: SndQueue -> (C.PublicKey -> m ()) -> m () + withVerifyKey sq action = + let err = throwError $ INTERNAL "missing send queue public key" + in maybe err action . C.publicKey $ sndPrivateKey sq + activateSecuredQueue :: RcvQueue -> SndQueue -> C.PublicKey -> m () + activateSecuredQueue rq sq sndKey = do + activateQueueInitiating c connId sq sndKey resumeInterval + subscribeQueue c rq connId -- | Send message to the connection (SEND command) in Reader monad sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgBody -> m InternalId @@ -408,7 +475,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do let msgHash = C.sha256Hash msg case parseSMPMessage msg of Left e -> notify $ ERR e - Right (SMPConfirmation senderKey) -> smpConfirmation senderKey + Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} -> case agentMessage of HELLO verifyKey _ -> helloMsg verifyKey msgBody @@ -434,17 +501,20 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do prohibited :: m () prohibited = notify . ERR $ AGENT A_PROHIBITED - smpConfirmation :: SenderPublicKey -> m () - smpConfirmation senderKey = do + smpConfirmation :: SenderPublicKey -> ConnInfo -> m () + smpConfirmation senderKey cInfo = do logServer "<--" c srv rId "MSG " case status of - New -> do - -- TODO currently it automatically allows whoever sends the confirmation - -- TODO create invitation and send REQ - withStore $ \st -> setRcvQueueStatus st rq Confirmed - -- TODO update sender key in the store? - secureQueue c rq senderKey - withStore $ \st -> setRcvQueueStatus st rq Secured + New -> case cType of + SCRcv -> do + g <- asks idsDrg + let newConfirmation = NewConfirmation {connId, senderKey, senderConnInfo = cInfo} + confId <- withStore $ \st -> createConfirmation st g newConfirmation + notify $ CONF confId cInfo + SCDuplex -> do + notify $ INFO cInfo + processConfirmation c rq senderKey + _ -> prohibited _ -> prohibited helloMsg :: SenderPublicKey -> ByteString -> m () @@ -456,7 +526,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do void $ verifyMessage (Just verifyKey) msgBody withStore $ \st -> setRcvQueueActive st rq verifyKey case cType of - SCDuplex -> connected + SCDuplex -> notifyConnected c connId _ -> pure () replyMsg :: SMPQueueInfo -> m () @@ -464,21 +534,14 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do logServer "<--" c srv rId "MSG " case cType of SCRcv -> do - (sq, senderKey, verifyKey) <- newSendQueue qInfo + AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId) + (sq, senderKey, verifyKey) <- newSndQueue qInfo withStore $ \st -> upgradeRcvConnToDuplex st connId sq - connectToSendQueue c sq senderKey verifyKey - connected + confirmQueue c sq senderKey ownConnInfo + withStore (`removeConfirmations` connId) + activateQueueInitiating c connId sq verifyKey onlineInterval _ -> prohibited - connected :: m () - connected = do - withStore (`getConnInvitation` connId) >>= \case - Just (Invitation {invId, externalIntroId}, DuplexConnection _ _ sq) -> do - withStore $ \st -> setInvitationStatus st invId InvCon - sendControlMessage c sq $ A_CON externalIntroId - _ -> pure () - notify CON - introMsg :: IntroId -> ConnInfo -> m () introMsg introId reInfo = do logServer "<--" c srv rId "MSG " @@ -557,16 +620,45 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash | otherwise = MsgError MsgDuplicate -- this case is not possible -connectToSendQueue :: AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> VerificationKey -> m () -connectToSendQueue c sq senderKey verifyKey = do - sendConfirmation c sq senderKey +confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m () +confirmQueue c sq senderKey cInfo = do + sendConfirmation c sq senderKey cInfo withStore $ \st -> setSndQueueStatus st sq Confirmed - sendHello c sq verifyKey - withStore $ \st -> setSndQueueStatus st sq Active -newSendQueue :: +activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueInitiating c connId sq verifyKey retryInterval = + activateQueue c connId sq verifyKey retryInterval $ notifyConnected c connId + +activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () -> m () +activateQueue c connId sq verifyKey retryInterval afterActivation = + getActivation c connId >>= \case + Nothing -> async runActivation >>= addActivation c connId + Just _ -> pure () + where + runActivation :: m () + runActivation = do + sendHello c sq verifyKey retryInterval + withStore $ \st -> setSndQueueStatus st sq Active + removeActivation c connId + removeVerificationKey + afterActivation + removeVerificationKey :: m () + removeVerificationKey = + let safeSignKey = C.removePublicKey $ signKey sq + in withStore $ \st -> updateSignKey st sq safeSignKey + +notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m () +notifyConnected c connId = do + withStore (`getConnInvitation` connId) >>= \case + Just (Invitation {invId, externalIntroId}, DuplexConnection _ _ sq) -> do + withStore $ \st -> setInvitationStatus st invId InvCon + sendControlMessage c sq $ A_CON externalIntroId + _ -> pure () + atomically $ writeTBQueue (subQ c) ("", connId, CON) + +newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, VerificationKey) -newSendQueue (SMPQueueInfo smpServer senderId encryptKey) = do +newSndQueue (SMPQueueInfo smpServer senderId encryptKey) = do size <- asks $ rsaKeySize . config (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size (verifyKey, signKey) <- liftIO $ C.generateKeyPair size diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 7af54fb37..b4ff3069a 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -12,11 +12,12 @@ module Simplex.Messaging.Agent.Client newAgentClient, AgentMonad, getSMPServerClient, - closeSMPServerClients, - newReceiveQueue, + closeAgentClient, + newRcvQueue, subscribeQueue, addSubscription, sendConfirmation, + RetryInterval (..), sendHello, secureQueue, sendAgentMessage, @@ -28,10 +29,13 @@ module Simplex.Messaging.Agent.Client logServer, removeSubscription, cryptoError, + addActivation, + getActivation, + removeActivation, ) where -import Control.Concurrent.Async (Async) +import Control.Concurrent.Async (Async, uninterruptibleCancel) import Control.Concurrent.STM (stateTVar) import Control.Logger.Simple import Control.Monad.Except @@ -66,6 +70,7 @@ data AgentClient = AgentClient smpClients :: TVar (Map SMPServer SMPClient), subscrSrvrs :: TVar (Map SMPServer (Set ConnId)), subscrConns :: TVar (Map ConnId SMPServer), + activations :: TVar (Map ConnId (Async ())), -- activations of send queues in progress clientId :: Int, agentEnv :: Env, smpSubscriber :: Async () @@ -80,8 +85,9 @@ newAgentClient agentEnv = do smpClients <- newTVar M.empty subscrSrvrs <- newTVar M.empty subscrConns <- newTVar M.empty + activations <- newTVar M.empty clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1) - return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, clientId, agentEnv, smpSubscriber = undefined} + return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, activations, clientId, agentEnv, smpSubscriber = undefined} -- | Agent monad with MonadReader Env and MonadError AgentErrorType type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) @@ -126,8 +132,16 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv = notifySub :: ConnId -> IO () notifySub connId = atomically $ writeTBQueue (subQ c) ("", connId, END) -closeSMPServerClients :: MonadUnliftIO m => AgentClient -> m () -closeSMPServerClients c = liftIO $ readTVarIO (smpClients c) >>= mapM_ closeSMPClient +closeAgentClient :: MonadUnliftIO m => AgentClient -> m () +closeAgentClient c = liftIO $ do + closeSMPServerClients c + cancelActivations c + +closeSMPServerClients :: AgentClient -> IO () +closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ closeSMPClient + +cancelActivations :: AgentClient -> IO () +cancelActivations c = readTVarIO (activations c) >>= mapM_ uninterruptibleCancel withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a withSMP_ c srv action = @@ -164,8 +178,8 @@ smpClientError = \case SMPTransportError e -> BROKER $ TRANSPORT e e -> INTERNAL $ show e -newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo) -newReceiveQueue c srv = do +newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo) +newRcvQueue c srv = do size <- asks $ rsaKeySize . config (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size logServer "-->" c srv "" "NEW" @@ -178,7 +192,6 @@ newReceiveQueue c srv = do rcvId, rcvPrivateKey, sndId = Just sId, - sndKey = Nothing, decryptKey, verifyKey = Nothing, status = New @@ -213,6 +226,15 @@ removeSubscription AgentClient {subscrConns, subscrSrvrs} connId = atomically $ let cs' = S.delete connId cs in if S.null cs' then Nothing else Just cs' +addActivation :: MonadUnliftIO m => AgentClient -> ConnId -> Async () -> m () +addActivation c connId a = atomically . modifyTVar (activations c) $ M.insert connId a + +getActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m (Maybe (Async ())) +getActivation c connId = M.lookup connId <$> readTVarIO (activations c) + +removeActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m () +removeActivation c connId = atomically . modifyTVar (activations c) $ M.delete connId + logServer :: AgentMonad 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] @@ -223,20 +245,26 @@ showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv) logSecret :: ByteString -> ByteString logSecret bs = encode $ B.take 3 bs -sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> m () -sendConfirmation c sq@SndQueue {server, sndId} senderKey = +sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m () +sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo = withLogSMP_ c server sndId "SEND " $ \smp -> do msg <- mkConfirmation smp liftSMP $ sendSMPMessage smp Nothing sndId msg where mkConfirmation :: SMPClient -> m MsgBody - mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey + mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo -sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> m () -sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey = +data RetryInterval = RetryInterval + { initialInterval :: Int, + increaseAfter :: Int, + maxInterval :: Int + } + +sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> RetryInterval -> m () +sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey RetryInterval {initialInterval, increaseAfter, maxInterval} = withLogSMP_ c server sndId "SEND (retrying)" $ \smp -> do msg <- mkHello smp $ AckMode On - liftSMP $ send 8 100000 msg smp + liftSMP $ send 0 initialInterval msg smp where mkHello :: SMPClient -> AckMode -> m ByteString mkHello smp ackMode = do @@ -250,12 +278,15 @@ sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey = } send :: Int -> Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO () - send 0 _ _ _ = throwE $ SMPServerError AUTH - send retry delay msg smp = + send elapsedTime delay msg smp = sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case SMPServerError AUTH -> do threadDelay delay - send (retry - 1) (delay * 3 `div` 2) msg smp + let newDelay = + if elapsedTime < increaseAfter || delay == maxInterval + then delay + else min (delay * 3 `div` 2) maxInterval + send (elapsedTime + delay) newDelay msg smp e -> throwE e secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m () diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 0b81b6f9b..590ca63c5 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -46,9 +46,9 @@ module Simplex.Messaging.Agent.Protocol ATransmissionOrError, ARawTransmission, ConnId, + ConfirmationId, IntroId, InvitationId, - ReplyMode (..), AckMode (..), OnOff (..), MsgIntegrity (..), @@ -155,10 +155,13 @@ type ConnInfo = ByteString data ACommand (p :: AParty) where NEW :: ACommand Client -- response INV INV :: SMPQueueInfo -> ACommand Agent - JOIN :: SMPQueueInfo -> ReplyMode -> ACommand Client -- response OK + JOIN :: SMPQueueInfo -> ConnInfo -> ACommand Client -- response OK + CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender + LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client INTRO :: ConnId -> ConnInfo -> ACommand Client REQ :: InvitationId -> ConnInfo -> ACommand Agent ACPT :: InvitationId -> ConnInfo -> ACommand Client + INFO :: ConnInfo -> ACommand Agent CON :: ACommand Agent -- notification that connection is established ICON :: ConnId -> ACommand Agent SUB :: ACommand Client @@ -192,7 +195,12 @@ data MsgMeta = MsgMeta data SMPMessage = -- | SMP confirmation -- (see ) - SMPConfirmation SenderPublicKey + SMPConfirmation + { -- | sender's public key to use for authentication of sender's commands at the recepient's server + senderKey :: SenderPublicKey, + -- | sender's information to be associated with the connection, e.g. sender's profile information + connInfo :: ConnInfo + } | -- | Agent message header and envelope for client messages -- (see ) SMPMessage @@ -232,12 +240,10 @@ parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE where smpMessageP :: Parser SMPMessage - smpMessageP = - smpConfirmationP <* A.endOfLine - <|> A.endOfLine *> smpClientMessageP + smpMessageP = A.endOfLine *> smpClientMessageP <|> smpConfirmationP smpConfirmationP :: Parser SMPMessage - smpConfirmationP = SMPConfirmation <$> ("KEY " *> C.pubKeyP <* A.endOfLine) + smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.pubKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine) smpClientMessageP :: Parser SMPMessage smpClientMessageP = @@ -252,7 +258,7 @@ parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE -- | Serialize SMP message. serializeSMPMessage :: SMPMessage -> ByteString serializeSMPMessage = \case - SMPConfirmation sKey -> smpMessage ("KEY " <> C.serializePubKey sKey) "" "" + SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializePubKey sKey) "" (serializeBinary cInfo) <> "\n" SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} -> let header = messageHeader senderMsgId senderTimestamp previousMsgHash body = serializeAgentMessage agentMessage @@ -274,15 +280,12 @@ agentMessageP = where hello = HELLO <$> C.pubKeyP <*> ackMode reply = REPLY <$> smpQueueInfoP - a_msg = A_MSG <$> binaryBody - a_intro = A_INTRO <$> A.takeTill (== ' ') <* A.space <*> binaryBody + a_msg = A_MSG <$> binaryBodyP <* A.endOfLine + a_intro = A_INTRO <$> A.takeTill (== ' ') <* A.space <*> binaryBodyP <* A.endOfLine a_inv = invP A_INV a_req = invP A_REQ a_con = A_CON <$> A.takeTill wordEnd - invP f = f <$> A.takeTill (== ' ') <* A.space <*> smpQueueInfoP <* A.space <*> binaryBody - binaryBody = do - size :: Int <- A.decimal <* A.endOfLine - A.take size <* A.endOfLine + invP f = f <$> A.takeTill (== ' ') <* A.space <*> smpQueueInfoP <* A.space <*> binaryBodyP <* A.endOfLine ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On) -- | SMP queue information parser. @@ -302,14 +305,14 @@ serializeAgentMessage :: AMessage -> ByteString serializeAgentMessage = \case HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo - A_MSG body -> "MSG " <> serializeMsg body <> "\n" - A_INTRO introId cInfo -> "INTRO " <> introId <> " " <> serializeMsg cInfo <> "\n" + A_MSG body -> "MSG " <> serializeBinary body <> "\n" + A_INTRO introId cInfo -> "INTRO " <> introId <> " " <> serializeBinary cInfo <> "\n" A_INV introId qInfo cInfo -> "INV " <> serializeInv introId qInfo cInfo A_REQ introId qInfo cInfo -> "REQ " <> serializeInv introId qInfo cInfo A_CON introId -> "CON " <> introId where serializeInv introId qInfo cInfo = - B.intercalate " " [introId, serializeSmpQueueInfo qInfo, serializeMsg cInfo] <> "\n" + B.intercalate " " [introId, serializeSmpQueueInfo qInfo, serializeBinary cInfo] <> "\n" -- | Serialize SMP queue information that is sent out-of-band. serializeSmpQueueInfo :: SMPQueueInfo -> ByteString @@ -335,6 +338,8 @@ instance IsString SMPServer where -- | SMP agent connection alias. type ConnId = ByteString +type ConfirmationId = ByteString + type IntroId = ByteString type InvitationId = ByteString @@ -351,9 +356,6 @@ newtype AckMode = AckMode OnOff deriving (Eq, Show) data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey deriving (Eq, Show) --- | Connection reply mode (used in JOIN command). -newtype ReplyMode = ReplyMode OnOff deriving (Eq, Show) - -- | Public key used to E2E encrypt SMP messages. type EncryptionKey = C.PublicKey @@ -361,7 +363,7 @@ type EncryptionKey = C.PublicKey type DecryptionKey = C.SafePrivateKey -- | Private key used to sign SMP commands -type SignatureKey = C.SafePrivateKey +type SignatureKey = C.APrivateKey -- | Public key used by SMP server to authorize (verify) SMP commands. type VerificationKey = C.PublicKey @@ -476,9 +478,12 @@ commandP = "NEW" $> ACmd SClient NEW <|> "INV " *> invResp <|> "JOIN " *> joinCmd + <|> "CONF " *> confCmd + <|> "LET " *> letCmd <|> "INTRO " *> introCmd <|> "REQ " *> reqCmd <|> "ACPT " *> acptCmd + <|> "INFO " *> infoCmd <|> "SUB" $> ACmd SClient SUB <|> "END" $> ACmd SAgent END <|> "SEND " *> sendCmd @@ -492,10 +497,13 @@ commandP = <|> "OK" $> ACmd SAgent OK where invResp = ACmd SAgent . INV <$> smpQueueInfoP - joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <*> replyMode) + joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <* A.space <*> A.takeByteString) + confCmd = ACmd SAgent <$> (CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString) + letCmd = ACmd SClient <$> (LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString) introCmd = ACmd SClient <$> introP INTRO reqCmd = ACmd SAgent <$> introP REQ acptCmd = ACmd SClient <$> introP ACPT + infoCmd = ACmd SAgent . INFO <$> A.takeByteString sendCmd = ACmd SClient . SEND <$> A.takeByteString sentResp = ACmd SAgent . SENT <$> A.decimal iconMsg = ACmd SAgent . ICON <$> A.takeTill wordEnd @@ -507,7 +515,6 @@ commandP = sender <- " S=" *> partyMeta A.decimal pure MsgMeta {integrity, recipient, broker, sender} introP f = f <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString - replyMode = ReplyMode <$> (" NO_REPLY" $> Off <|> pure On) partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P agentError = ACmd SAgent . ERR <$> agentErrorTypeP @@ -529,16 +536,19 @@ serializeCommand :: ACommand p -> ByteString serializeCommand = \case NEW -> "NEW" INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo - JOIN qInfo rMode -> "JOIN " <> serializeSmpQueueInfo qInfo <> replyMode rMode - INTRO connId cInfo -> "INTRO " <> connId <> " " <> serializeMsg cInfo - REQ invId cInfo -> "REQ " <> invId <> " " <> serializeMsg cInfo - ACPT invId cInfo -> "ACPT " <> invId <> " " <> serializeMsg cInfo + JOIN qInfo cInfo -> "JOIN " <> serializeSmpQueueInfo qInfo <> " " <> serializeBinary cInfo + CONF confId cInfo -> "CONF " <> confId <> " " <> serializeBinary cInfo + LET confId cInfo -> "LET " <> confId <> " " <> serializeBinary cInfo + INTRO connId cInfo -> "INTRO " <> connId <> " " <> serializeBinary cInfo + REQ invId cInfo -> "REQ " <> invId <> " " <> serializeBinary cInfo + ACPT invId cInfo -> "ACPT " <> invId <> " " <> serializeBinary cInfo + INFO cInfo -> "INFO " <> serializeBinary cInfo SUB -> "SUB" END -> "END" - SEND msgBody -> "SEND " <> serializeMsg msgBody + SEND msgBody -> "SEND " <> serializeBinary msgBody SENT mId -> "SENT " <> bshow mId MSG msgMeta msgBody -> - "MSG " <> serializeMsgMeta msgMeta <> " " <> serializeMsg msgBody + "MSG " <> serializeMsgMeta msgMeta <> " " <> serializeBinary msgBody OFF -> "OFF" DEL -> "DEL" CON -> "CON" @@ -546,10 +556,6 @@ serializeCommand = \case ERR e -> "ERR " <> serializeAgentError e OK -> "OK" where - replyMode :: ReplyMode -> ByteString - replyMode = \case - ReplyMode Off -> " NO_REPLY" - ReplyMode On -> "" showTs :: UTCTime -> ByteString showTs = B.pack . formatISO8601Millis serializeMsgMeta :: MsgMeta -> ByteString @@ -590,8 +596,13 @@ serializeAgentError = \case BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e e -> bshow e -serializeMsg :: ByteString -> ByteString -serializeMsg body = bshow (B.length body) <> "\n" <> body +binaryBodyP :: Parser ByteString +binaryBodyP = do + size :: Int <- A.decimal <* A.endOfLine + A.take size + +serializeBinary :: ByteString -> ByteString +serializeBinary body = bshow (B.length body) <> "\n" <> body -- | Send raw (unparsed) SMP agent protocol transmission to TCP connection. tPutRaw :: Transport c => c -> ARawTransmission -> IO () @@ -639,17 +650,21 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p)) cmdWithMsgBody = \case - SEND body -> SEND <$$> getMsgBody body - MSG msgMeta body -> MSG msgMeta <$$> getMsgBody body - INTRO introId cInfo -> INTRO introId <$$> getMsgBody cInfo - REQ introId cInfo -> REQ introId <$$> getMsgBody cInfo - ACPT introId cInfo -> ACPT introId <$$> getMsgBody cInfo + SEND body -> SEND <$$> getBody body + MSG msgMeta body -> MSG msgMeta <$$> getBody body + INTRO introId cInfo -> INTRO introId <$$> getBody cInfo + REQ introId cInfo -> REQ introId <$$> getBody cInfo + ACPT introId cInfo -> ACPT introId <$$> getBody cInfo + JOIN qInfo cInfo -> JOIN qInfo <$$> getBody cInfo + CONF confId cInfo -> CONF confId <$$> getBody cInfo + LET confId cInfo -> LET confId <$$> getBody cInfo + INFO cInfo -> INFO <$$> getBody cInfo cmd -> pure $ Right cmd -- TODO refactor with server - getMsgBody :: MsgBody -> m (Either AgentErrorType MsgBody) - getMsgBody msgBody = - case B.unpack msgBody of + getBody :: ByteString -> m (Either AgentErrorType ByteString) + getBody binary = + case B.unpack binary of ':' : body -> return . Right $ B.pack body str -> case readMaybe str :: Maybe Int of Just size -> liftIO $ do diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index cad975570..6b49ad280 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -46,14 +46,19 @@ class Monad m => MonadAgentStore s m where setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m () setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m () setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m () + updateSignKey :: s -> SndQueue -> SignatureKey -> m () + + -- Confirmations + createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId + acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation + getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation + removeConfirmations :: s -> ConnId -> m () -- Msg management updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) createRcvMsg :: s -> ConnId -> RcvMsgData -> m () - updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash) createSndMsg :: s -> ConnId -> SndMsgData -> m () - getMsg :: s -> ConnId -> InternalId -> m Msg -- Introductions @@ -76,7 +81,6 @@ data RcvQueue = RcvQueue rcvId :: SMP.RecipientId, rcvPrivateKey :: RecipientPrivateKey, sndId :: Maybe SMP.SenderId, - sndKey :: Maybe SenderPublicKey, decryptKey :: DecryptionKey, verifyKey :: Maybe VerificationKey, status :: QueueStatus @@ -152,6 +156,22 @@ deriving instance Show SomeConn data ConnData = ConnData {connId :: ConnId, viaInv :: Maybe InvitationId, connLevel :: Int} deriving (Eq, Show) +-- * Confirmation types + +data NewConfirmation = NewConfirmation + { connId :: ConnId, + senderKey :: SenderPublicKey, + senderConnInfo :: ConnInfo + } + +data AcceptedConfirmation = AcceptedConfirmation + { confirmationId :: ConfirmationId, + connId :: ConnId, + senderKey :: SenderPublicKey, + senderConnInfo :: ConnInfo, + ownConnInfo :: ConnInfo + } + -- * Message integrity validation types type MsgHash = ByteString @@ -372,6 +392,8 @@ data StoreError | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa. -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error. SEBadConnType ConnType + | -- | Confirmation not found. + SEConfirmationNotFound | -- | Introduction ID not found. SEIntroNotFound | -- | Invitation ID not found. diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 3d3ec8d67..38ec4c23b 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -184,7 +184,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto getAllConnIds :: SQLiteStore -> m [ConnId] getAllConnIds st = - liftIO . withConnection st $ \db -> do + liftIO . withConnection st $ \db -> concat <$> (DB.query_ db "SELECT conn_alias FROM connections;" :: IO [[ConnId]]) getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn @@ -278,6 +278,86 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto |] [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId] + updateSignKey :: SQLiteStore -> SndQueue -> SignatureKey -> m () + updateSignKey st SndQueue {sndId, server = SMPServer {host, port}} signatureKey = + liftIO . withConnection st $ \db -> + DB.executeNamed + db + [sql| + UPDATE snd_queues + SET sign_key = :sign_key + WHERE host = :host AND port = :port AND snd_id = :snd_id; + |] + [":sign_key" := signatureKey, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId] + + createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId + createConfirmation st gVar NewConfirmation {connId, senderKey, senderConnInfo} = + liftIOEither . withTransaction st $ \db -> + createWithRandomId gVar $ \confirmationId -> + DB.execute + db + [sql| + INSERT INTO conn_confirmations + (confirmation_id, conn_alias, sender_key, sender_conn_info, accepted) VALUES (?, ?, ?, ?, 0); + |] + (confirmationId, connId, senderKey, senderConnInfo) + + acceptConfirmation :: SQLiteStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation + acceptConfirmation st confirmationId ownConnInfo = + liftIOEither . withTransaction st $ \db -> do + DB.executeNamed + db + [sql| + UPDATE conn_confirmations + SET accepted = 1, + own_conn_info = :own_conn_info + WHERE confirmation_id = :confirmation_id; + |] + [ ":own_conn_info" := ownConnInfo, + ":confirmation_id" := confirmationId + ] + confirmation + <$> DB.query + db + [sql| + SELECT conn_alias, sender_key, sender_conn_info + FROM conn_confirmations + WHERE confirmation_id = ?; + |] + (Only confirmationId) + where + confirmation [(connId, senderKey, senderConnInfo)] = + Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo} + confirmation _ = Left SEConfirmationNotFound + + getAcceptedConfirmation :: SQLiteStore -> ConnId -> m AcceptedConfirmation + getAcceptedConfirmation st connId = + liftIOEither . withConnection st $ \db -> + confirmation + <$> DB.query + db + [sql| + SELECT confirmation_id, sender_key, sender_conn_info, own_conn_info + FROM conn_confirmations + WHERE conn_alias = ? AND accepted = 1; + |] + (Only connId) + where + confirmation [(confirmationId, senderKey, senderConnInfo, ownConnInfo)] = + Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo} + confirmation _ = Left SEConfirmationNotFound + + removeConfirmations :: SQLiteStore -> ConnId -> m () + removeConfirmations st connId = + liftIO . withConnection st $ \db -> + DB.executeNamed + db + [sql| + DELETE FROM conn_confirmations + WHERE conn_alias = :conn_alias; + |] + [":conn_alias" := connId] + updateRcvIds :: SQLiteStore -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds st connId = liftIO . withTransaction st $ \db -> do @@ -548,9 +628,9 @@ insertRcvQueue_ dbConn connId RcvQueue {..} = do dbConn [sql| INSERT INTO rcv_queues - ( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, snd_key, decrypt_key, verify_key, status) + ( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, decrypt_key, verify_key, status) VALUES - (:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:snd_key,:decrypt_key,:verify_key,:status); + (:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:decrypt_key,:verify_key,:status); |] [ ":host" := host server, ":port" := port_, @@ -558,7 +638,6 @@ insertRcvQueue_ dbConn connId RcvQueue {..} = do ":conn_alias" := connId, ":rcv_private_key" := rcvPrivateKey, ":snd_id" := sndId, - ":snd_key" := sndKey, ":decrypt_key" := decryptKey, ":verify_key" := verifyKey, ":status" := status @@ -655,16 +734,16 @@ getRcvQueueByConnAlias_ dbConn connId = dbConn [sql| SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, - q.snd_id, q.snd_key, q.decrypt_key, q.verify_key, q.status + q.snd_id, q.decrypt_key, q.verify_key, q.status FROM rcv_queues q INNER JOIN servers s ON q.host = s.host AND q.port = s.port WHERE q.conn_alias = ?; |] (Only connId) where - rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, sndId, sndKey, decryptKey, verifyKey, status)] = + rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, sndId, decryptKey, verifyKey, status)] = let srv = SMPServer host (deserializePort_ port) keyHash - in Just $ RcvQueue srv rcvId rcvPrivateKey sndId sndKey decryptKey verifyKey status + in Just $ RcvQueue srv rcvId rcvPrivateKey sndId decryptKey verifyKey status rcvQueue _ = Nothing getSndQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index c56161712..bc709e377 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -20,18 +20,20 @@ -- . module Simplex.Messaging.Crypto ( -- * RSA keys - PrivateKey (rsaPrivateKey), - SafePrivateKey, -- constructor is not exported + PrivateKey (rsaPrivateKey, publicKey), + SafePrivateKey (..), -- constructor is not exported FullPrivateKey (..), + APrivateKey (..), PublicKey (..), SafeKeyPair, FullKeyPair, KeyHash (..), generateKeyPair, - publicKey, + publicKey', publicKeySize, validKeySize, safePrivateKey, + removePublicKey, -- * E2E hybrid encryption scheme encrypt, @@ -121,6 +123,9 @@ newtype SafePrivateKey = SafePrivateKey {unPrivateKey :: R.PrivateKey} deriving -- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (with PublicKey inside). newtype FullPrivateKey = FullPrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) +-- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (PublicKey may be inside). +newtype APrivateKey = APrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) + -- | Type-class used for both private key types: SafePrivateKey and FullPrivateKey. class PrivateKey k where -- unwraps 'Crypto.PubKey.RSA.PrivateKey' @@ -132,16 +137,36 @@ class PrivateKey k where -- smart constructor removing public key from SafePrivateKey but keeping it in FullPrivateKey mkPrivateKey :: R.PrivateKey -> k + -- extracts public key from private key + publicKey :: k -> Maybe PublicKey + +-- | Remove public key exponent from APrivateKey. +removePublicKey :: APrivateKey -> APrivateKey +removePublicKey (APrivateKey R.PrivateKey {private_pub = k, private_d}) = + APrivateKey $ unPrivateKey (safePrivateKey (R.public_size k, R.public_n k, private_d) :: SafePrivateKey) + instance PrivateKey SafePrivateKey where rsaPrivateKey = unPrivateKey _privateKey = SafePrivateKey mkPrivateKey R.PrivateKey {private_pub = k, private_d} = safePrivateKey (R.public_size k, R.public_n k, private_d) + publicKey _ = Nothing instance PrivateKey FullPrivateKey where rsaPrivateKey = unPrivateKey _privateKey = FullPrivateKey mkPrivateKey = FullPrivateKey + publicKey = Just . PublicKey . R.private_pub . rsaPrivateKey + +instance PrivateKey APrivateKey where + rsaPrivateKey = unPrivateKey + _privateKey = APrivateKey + mkPrivateKey = APrivateKey + publicKey pk = + let k = R.private_pub $ rsaPrivateKey pk + in if R.public_e k == 0 + then Nothing + else Just $ PublicKey k instance IsString FullPrivateKey where fromString = parseString (decode >=> decodePrivKey) @@ -151,10 +176,14 @@ instance IsString PublicKey where instance ToField SafePrivateKey where toField = toField . encodePrivKey +instance ToField APrivateKey where toField = toField . encodePrivKey + instance ToField PublicKey where toField = toField . encodePubKey instance FromField SafePrivateKey where fromField = blobFieldParser binaryPrivKeyP +instance FromField APrivateKey where fromField = blobFieldParser binaryPrivKeyP + instance FromField PublicKey where fromField = blobFieldParser binaryPubKeyP -- | Tuple of RSA 'PublicKey' and 'PrivateKey'. @@ -217,8 +246,8 @@ generateKeyPair size = loop privateKeySize :: PrivateKey k => k -> Int privateKeySize = R.public_size . R.private_pub . rsaPrivateKey -publicKey :: FullPrivateKey -> PublicKey -publicKey = PublicKey . R.private_pub . rsaPrivateKey +publicKey' :: FullPrivateKey -> PublicKey +publicKey' = PublicKey . R.private_pub . rsaPrivateKey publicKeySize :: PublicKey -> Int publicKeySize = R.public_size . rsaPublicKey diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 61873af27..83282f03f 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -86,7 +86,7 @@ newEnv config = do idsDrg <- drgNew >>= newTVarIO s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig) let pk = serverPrivateKey config - serverKeyPair = (C.publicKey pk, pk) + serverKeyPair = (C.publicKey' pk, pk) return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'} where restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 576c2ea63..2f0866de2 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -107,11 +107,14 @@ testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnection _ alice bob = do ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW") let qInfo' = serializeSmpQueueInfo qInfo - bob #: ("11", "alice", "JOIN " <> qInfo') #> ("11", "alice", OK) + bob #: ("11", "alice", "JOIN " <> qInfo' <> " 14\nbob's connInfo") #> ("11", "alice", OK) + ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:) + alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) + bob <# ("", "alice", INFO "alice's connInfo") bob <# ("", "alice", CON) alice <# ("", "bob", CON) - alice #: ("2", "bob", "SEND :hello") #> ("2", "bob", SENT 1) - alice #: ("3", "bob", "SEND :how are you?") #> ("3", "bob", SENT 2) + alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", SENT 1) + alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", SENT 2) bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", SENT 3) @@ -129,8 +132,11 @@ testAgentClient = do bob <- getSMPAgentClient cfg {dbFile = testDB2} Right () <- runExceptT $ do (bobId, qInfo) <- createConnection alice Nothing - aliceId <- joinConnection bob Nothing qInfo + aliceId <- joinConnection bob Nothing qInfo "bob's connInfo" + ("", _, CONF confId "bob's connInfo") <- get alice + allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) + get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) InternalId 1 <- sendMessage alice bobId "hello" InternalId 2 <- sendMessage alice bobId "how are you?" @@ -163,7 +169,11 @@ testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnRandomIds _ alice bob = do ("1", bobConn, Right (INV qInfo)) <- alice #: ("1", "", "NEW") let qInfo' = serializeSmpQueueInfo qInfo - ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> qInfo') + ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> qInfo' <> " 14\nbob's connInfo") + ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:) + bobConn' `shouldBe` bobConn + alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False + bob <# ("", aliceConn, INFO "alice's connInfo") bob <# ("", aliceConn, CON) alice <# ("", bobConn, CON) alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, SENT 1) @@ -209,11 +219,12 @@ testIntroduction _ alice bob tom = do ("", "alice", Right (REQ invId1 "meet tom")) <- (bob <#:) bob #: ("2", "tom_via_alice", "ACPT " <> invId1 <> " 7\nI'm bob") #> ("2", "tom_via_alice", OK) ("", "alice", Right (REQ invId2 "I'm bob")) <- (tom <#:) - -- TODO info "tom here" is not used, either JOIN command also should have eInfo parameter - -- or this should be another command, not ACPT tom #: ("3", "bob_via_alice", "ACPT " <> invId2 <> " 8\ntom here") #> ("3", "bob_via_alice", OK) - tom <# ("", "bob_via_alice", CON) + ("", "tom_via_alice", Right (CONF confId "tom here")) <- (bob <#:) + bob #: ("3.1", "tom_via_alice", "LET " <> confId <> " 7\nI'm bob") #> ("3.1", "tom_via_alice", OK) bob <# ("", "tom_via_alice", CON) + tom <# ("", "bob_via_alice", INFO "I'm bob") + tom <# ("", "bob_via_alice", CON) alice <# ("", "bob", ICON "tom") -- they can message each other now tom #: ("4", "bob_via_alice", "SEND :hello") #> ("4", "bob_via_alice", SENT 1) @@ -230,14 +241,16 @@ testIntroductionRandomIds _ alice bob tom = do alice #: ("1", bobA, "INTRO " <> tomA <> " 8\nmeet tom") #> ("1", bobA, OK) ("", aliceB', Right (REQ invId1 "meet tom")) <- (bob <#:) aliceB' `shouldBe` aliceB - ("2", tomB, Right OK) <- bob #: ("2", "C:", "ACPT " <> invId1 <> " 7\nI'm bob") + ("2", tomB, Right OK) <- bob #: ("2", "", "ACPT " <> invId1 <> " 7\nI'm bob") ("", aliceT', Right (REQ invId2 "I'm bob")) <- (tom <#:) aliceT' `shouldBe` aliceT - -- TODO info "tom here" is not used, either JOIN command also should have eInfo parameter - -- or this should be another command, not ACPT ("3", bobT, Right OK) <- tom #: ("3", "", "ACPT " <> invId2 <> " 8\ntom here") - tom <# ("", bobT, CON) + ("", tomB', Right (CONF confId "tom here")) <- (bob <#:) + tomB' `shouldBe` tomB + bob #: ("3.1", tomB, "LET " <> confId <> " 7\nI'm bob") =#> \case ("3.1", c, OK) -> c == tomB; _ -> False bob <# ("", tomB, CON) + tom <# ("", bobT, INFO "I'm bob") + tom <# ("", bobT, CON) alice <# ("", bobA, ICON tomA) -- they can message each other now tom #: ("4", bobT, "SEND :hello") #> ("4", bobT, SENT 1) @@ -249,7 +262,10 @@ connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO () connect (h1, name1) (h2, name2) = do ("c1", _, Right (INV qInfo)) <- h1 #: ("c1", name2, "NEW") let qInfo' = serializeSmpQueueInfo qInfo - h2 #: ("c2", name1, "JOIN " <> qInfo') #> ("c2", name1, OK) + h2 #: ("c2", name1, "JOIN " <> qInfo' <> " 5\ninfo2") #> ("c2", name1, OK) + ("", _, Right (CONF connId "info2")) <- (h1 <#:) + h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) + h2 <# ("", name1, INFO "info1") h2 <# ("", name1, CON) h1 <# ("", name2, CON) @@ -257,7 +273,10 @@ connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString) connect' h1 h2 = do ("c1", conn2, Right (INV qInfo)) <- h1 #: ("c1", "", "NEW") let qInfo' = serializeSmpQueueInfo qInfo - ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> qInfo') + ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> qInfo' <> " 5\ninfo2") + ("", _, Right (CONF connId "info2")) <- (h1 <#:) + h1 #: ("c3", conn2, "LET " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False + h2 <# ("", conn1, INFO "info1") h2 <# ("", conn1, CON) h1 <# ("", conn2, CON) pure (conn1, conn2) @@ -281,7 +300,7 @@ syntaxTests t = do -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided) -- TODO: add tests with defined connection alias it "using same server as in invitation" $ - ("311", "a", "JOIN smp::localhost:5000::1234::" <> samplePublicKey) >#> ("311", "a", "ERR SMP AUTH") + ("311", "a", "JOIN smp::localhost:5000::1234::" <> samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH") describe "invalid" do -- TODO: JOIN is not merged yet - to be added it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX") diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 56fd88514..0f364c969 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -156,7 +156,6 @@ rcvQueue1 = rcvId = "1234", rcvPrivateKey = C.safePrivateKey (1, 2, 3), sndId = Just "2345", - sndKey = Nothing, decryptKey = C.safePrivateKey (1, 2, 3), verifyKey = Nothing, status = New @@ -169,7 +168,7 @@ sndQueue1 = sndId = "3456", sndPrivateKey = C.safePrivateKey (1, 2, 3), encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = C.safePrivateKey (1, 2, 3), + signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey), status = New } @@ -309,7 +308,7 @@ testUpgradeRcvConnToDuplex = sndId = "2345", sndPrivateKey = C.safePrivateKey (1, 2, 3), encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = C.safePrivateKey (1, 2, 3), + signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey), status = New } upgradeRcvConnToDuplex store "conn1" anotherSndQueue @@ -329,7 +328,6 @@ testUpgradeSndConnToDuplex = rcvId = "3456", rcvPrivateKey = C.safePrivateKey (1, 2, 3), sndId = Just "4567", - sndKey = Nothing, decryptKey = C.safePrivateKey (1, 2, 3), verifyKey = Nothing, status = New