Skip to content

Commit 98619a9

Browse files
epoberezkinepoberezkin
committed
service certificates in the client
1 parent c74bf4e commit 98619a9

File tree

14 files changed

+242
-155
lines changed

14 files changed

+242
-155
lines changed

‎src/Simplex/Messaging/Agent.hs‎

Lines changed: 24 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -74,8 +74,7 @@ module Simplex.Messaging.Agent
7474
getNotificationConns,
7575
resubscribeConnection,
7676
resubscribeConnections,
77-
-- TODO [certs rcv]
78-
-- subscribeClientService,
77+
subscribeClientServices,
7978
sendMessage,
8079
sendMessages,
8180
sendMessagesB,
@@ -228,6 +227,7 @@ import Simplex.RemoteControl.Client
228227
import Simplex.RemoteControl.Invitation
229228
import Simplex.RemoteControl.Types
230229
import System.Mem.Weak (deRefWeak)
230+
import UnliftIO (mapConcurrently)
231231
import UnliftIO.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
232232
import qualified UnliftIO.Exception as E
233233
import UnliftIO.STM
@@ -465,10 +465,9 @@ resubscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either Agen
465465
resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
466466
{-# INLINE resubscribeConnections #-}
467467

468-
-- TODO [certs rcv] how to communicate that service ID changed - as error or as result?
469-
-- subscribeClientService :: AgentClient -> ClientServiceId -> AE Int
470-
-- subscribeClientService c = withAgentEnv c . subscribeClientService' c
471-
-- {-# INLINE subscribeClientService #-}
468+
subscribeClientServices :: AgentClient -> UserId -> AE (Map SMPServer (Either AgentErrorType Int64))
469+
subscribeClientServices c = withAgentEnv c . subscribeClientServices' c
470+
{-# INLINE subscribeClientServices #-}
472471

473472
-- | Send message to the connection (SEND command)
474473
sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AE (AgentMsgId, PQEncryption)
@@ -717,6 +716,7 @@ createUser' c smp xftp = do
717716
userId <- withStore' c createUserRecord
718717
atomically $ TM.insert userId (mkUserServers smp) $ smpServers c
719718
atomically $ TM.insert userId (mkUserServers xftp) $ xftpServers c
719+
atomically $ TM.insert userId False $ useClientServices c
720720
pure userId
721721

722722
deleteUser' :: AgentClient -> UserId -> Bool -> AM ()
@@ -726,6 +726,7 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
726726
else withStore c (`deleteUserRecord` userId)
727727
atomically $ TM.delete userId $ smpServers c
728728
atomically $ TM.delete userId $ xftpServers c
729+
atomically $ TM.delete userId $ useClientServices c
729730
atomically $ modifyTVar' smpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId)
730731
atomically $ modifyTVar' xftpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId)
731732
lift $ saveServersStats c
@@ -734,19 +735,12 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
734735
whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $
735736
writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId)
736737

737-
-- TODO [certs rcv]
738738
setUserService' :: AgentClient -> UserId -> Bool -> AM ()
739-
setUserService' _c _userId enable
740-
| enable = do
741-
-- check if user already has credentials enabled
742-
-- if not, generate credentials and save
743-
-- update client agent
744-
undefined
745-
| otherwise = do
746-
-- check if user already has credentials disabled
747-
-- if not, disable
748-
-- update client agent
749-
undefined
739+
setUserService' c userId enable = do
740+
wasEnabled <- liftIO $ fromMaybe False <$> TM.lookupIO userId (useClientServices c)
741+
when (enable /= wasEnabled) $ do
742+
atomically $ TM.insert userId enable $ useClientServices c
743+
unless enable $ withStore' c (`deleteClientServices` userId)
750744

751745
newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
752746
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
@@ -982,8 +976,7 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKey
982976
createRcvQueue nonce_ qd e2eKeys = do
983977
AgentConfig {smpClientVRange = vr} <- asks config
984978
ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
985-
-- TODO [certs rcv] save queue association
986-
(rq, qUri, _serviceId, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd (isJust ntfServer_) subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
979+
(rq, qUri, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd (isJust ntfServer_) subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
987980
atomically $ incSMPServerStat c userId srv connCreated
988981
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
989982
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
@@ -1234,8 +1227,7 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode
12341227
createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo
12351228
createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
12361229
ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
1237-
-- TODO [certs rcv] save queue association
1238-
(rq, qUri, _serviceId, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation (isJust ntfServer_) subMode
1230+
(rq, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation (isJust ntfServer_) subMode
12391231
atomically $ incSMPServerStat c userId (qServer rq) connCreated
12401232
let qInfo = toVersionT qUri smpClientVersion
12411233
rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
@@ -1287,6 +1279,7 @@ type QSubResult = QCmdResult (Maybe SMP.ServiceId)
12871279
subscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
12881280
subscribeConnections' _ [] = pure M.empty
12891281
subscribeConnections' c connIds = do
1282+
-- TODO [certs rcv] - it should exclude connections already associated, and then if some don't deliver any response they may be unassociated
12901283
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConns` connIds)
12911284
let (errs, cs) = M.mapEither id conns
12921285
errs' = M.map (Left . storeError) errs
@@ -1368,9 +1361,14 @@ resubscribeConnections' c connIds = do
13681361
-- union is left-biased, so results returned by subscribeConnections' take precedence
13691362
(`M.union` r) <$> subscribeConnections' c connIds'
13701363

1371-
-- TODO [certs rcv]
1372-
-- subscribeClientService' :: AgentClient -> ClientServiceId -> AM Int
1373-
-- subscribeClientService' = undefined
1364+
subscribeClientServices' :: AgentClient -> UserId -> AM (Map SMPServer (Either AgentErrorType Int64))
1365+
subscribeClientServices' c userId =
1366+
ifM useService subscribe $ throwError $ CMD PROHIBITED "no user service allowed"
1367+
where
1368+
useService = liftIO $ (Just True ==) <$> TM.lookupIO userId (useClientServices c)
1369+
subscribe = do
1370+
srvs <- withStore' c (`getClientServiceServers` userId)
1371+
lift $ M.fromList . zip srvs <$> mapConcurrently (tryAgentError' . subscribeClientService c userId) srvs
13741372

13751373
-- requesting messages sequentially, to reduce memory usage
13761374
getConnectionMessages' :: AgentClient -> NonEmpty ConnMsgReq -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
@@ -2031,8 +2029,7 @@ switchDuplexConnection c nm (DuplexConnection cData@ConnData {connId, userId} rq
20312029
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
20322030
-- TODO [notications] possible improvement would be to create ntf credentials here, to avoid creating them after rotation completes.
20332031
-- The problem is that currently subscription already exists, and we do not support queues with credentials but without subscriptions.
2034-
-- TODO [certs rcv] save queue association
2035-
(q, qUri, _serviceId, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation False SMSubscribe
2032+
(q, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation False SMSubscribe
20362033
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
20372034
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
20382035
lift $ addNewQueueSubscription c rq'' tSess sessId

‎src/Simplex/Messaging/Agent/Client.hs‎

Lines changed: 54 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ module Simplex.Messaging.Agent.Client
4848
newRcvQueue,
4949
newRcvQueue_,
5050
subscribeQueues,
51+
subscribeClientService,
5152
getQueueMessage,
5253
decryptSMPMessage,
5354
addSubscription,
@@ -215,6 +216,7 @@ import Data.Text.Encoding
215216
import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
216217
import Data.Time.Clock.System (getSystemTime)
217218
import Data.Word (Word16)
219+
import qualified Data.X509.Validation as XV
218220
import Network.Socket (HostName)
219221
import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
220222
import qualified Simplex.FileTransfer.Client as X
@@ -230,7 +232,8 @@ import Simplex.Messaging.Agent.Protocol
230232
import Simplex.Messaging.Agent.RetryInterval
231233
import Simplex.Messaging.Agent.Stats
232234
import Simplex.Messaging.Agent.Store
233-
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
235+
import Simplex.Messaging.Agent.Store.AgentStore
236+
import Simplex.Messaging.Agent.Store.Common (DBStore)
234237
import qualified Simplex.Messaging.Agent.Store.DB as DB
235238
import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
236239
import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
@@ -284,8 +287,9 @@ import Simplex.Messaging.Session
284287
import Simplex.Messaging.Agent.Store.Entity
285288
import Simplex.Messaging.TMap (TMap)
286289
import qualified Simplex.Messaging.TMap as TM
287-
import Simplex.Messaging.Transport (SMPVersion, ServiceCredentials, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion)
290+
import Simplex.Messaging.Transport (SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion)
288291
import Simplex.Messaging.Transport.Client (TransportHost (..))
292+
import Simplex.Messaging.Transport.Credentials
289293
import Simplex.Messaging.Util
290294
import Simplex.Messaging.Version
291295
import System.Mem.Weak (Weak, deRefWeak)
@@ -321,7 +325,7 @@ data AgentClient = AgentClient
321325
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
322326
smpServers :: TMap UserId (UserServers 'PSMP),
323327
smpClients :: TMap SMPTransportSession SMPClientVar,
324-
smpServiceCreds :: TMap UserId (Maybe (TMap SMPServer ServiceCredentials)), -- Nothing means not to use certificates for this user record
328+
useClientServices :: TMap UserId Bool,
325329
-- smpProxiedRelays:
326330
-- SMPTransportSession defines connection from proxy to relay,
327331
-- SMPServerWithAuth defines client connected to SMP proxy (with the same userId and entityId in TransportSession)
@@ -494,7 +498,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
494498
msgQ <- newTBQueueIO qSize
495499
smpServers <- newTVarIO $ M.map mkUserServers smp
496500
smpClients <- TM.emptyIO
497-
smpServiceCreds <- newTVarIO =<< mapM (\enable -> if enable then Just <$> TM.emptyIO else pure Nothing) useServices
501+
useClientServices <- newTVarIO useServices
498502
smpProxiedRelays <- TM.emptyIO
499503
ntfServers <- newTVarIO ntf
500504
ntfClients <- TM.emptyIO
@@ -533,7 +537,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
533537
msgQ,
534538
smpServers,
535539
smpClients,
536-
smpServiceCreds,
540+
useClientServices,
537541
smpProxiedRelays,
538542
ntfServers,
539543
ntfClients,
@@ -586,6 +590,28 @@ agentDRG :: AgentClient -> TVar ChaChaDRG
586590
agentDRG AgentClient {agentEnv = Env {random}} = random
587591
{-# INLINE agentDRG #-}
588592

593+
getServiceCredentials :: AgentClient -> UserId -> SMPServer -> AM (Maybe (ServiceCredentials, Maybe ServiceId))
594+
getServiceCredentials c userId srv =
595+
liftIO (TM.lookupIO userId $ useClientServices c)
596+
$>>= \useService -> if useService then Just <$> getService else pure Nothing
597+
where
598+
getService :: AM (ServiceCredentials, Maybe ServiceId)
599+
getService = do
600+
let g = agentDRG c
601+
((C.KeyHash kh, serviceCreds), serviceId_) <-
602+
withStore' c $ \db ->
603+
getClientService db userId srv >>= \case
604+
Just service -> pure service
605+
Nothing -> do
606+
cred <- genCredentials g Nothing (25, 24 * 999999) "simplex"
607+
let tlsCreds = tlsCredentials [cred]
608+
createClientService db userId srv tlsCreds
609+
pure (tlsCreds, Nothing)
610+
(_, pk) <- atomically $ C.generateKeyPair g
611+
let serviceSignKey = C.APrivateSignKey C.SEd25519 pk
612+
creds = ServiceCredentials {serviceRole = SRMessaging, serviceCreds, serviceCertHash = XV.Fingerprint kh, serviceSignKey}
613+
pure (creds, serviceId_)
614+
589615
class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where
590616
type Client msg = c | c -> msg
591617
getProtocolServerClient :: AgentClient -> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
@@ -689,19 +715,29 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
689715
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
690716

691717
smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
692-
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, _) prs v =
718+
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(userId, srv, _) prs v =
693719
newProtocolClient c tSess smpClients connectClient v
694720
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
695721
where
696722
connectClient :: SMPClientVar -> AM SMPConnectedClient
697723
connectClient v' = do
698724
cfg <- lift $ getClientConfig c smpCfg
699725
g <- asks random
726+
service <- getServiceCredentials c userId srv
727+
let cfg' = cfg {serviceCredentials = fst <$> service}
700728
env <- ask
701-
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
729+
smp <- liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
702730
ts <- readTVarIO proxySessTs
703-
smp <- ExceptT $ getProtocolClient g nm tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
704-
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
731+
ExceptT $ getProtocolClient g nm tSess cfg' (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
732+
updateClientService service smp
733+
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
734+
updateClientService service smp = case (service, smpClientService smp) of
735+
(Just (_, serviceId_), Just THClientService {serviceId})
736+
| serviceId_ /= Just serviceId -> withStore' c $ \db -> setClientServiceId db userId srv serviceId
737+
| otherwise -> pure ()
738+
(Just _, Nothing) -> withStore' c $ \db -> deleteClientService db userId srv -- e.g., server version downgrade
739+
(Nothing, Just _) -> logError "server returned serviceId without service credentials in request"
740+
(Nothing, Nothing) -> pure ()
705741

706742
smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
707743
smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess@(userId, srv, qId) env v prs client = do
@@ -858,7 +894,6 @@ waitForProtocolClient c nm tSess@(_, srv, _) clients v = do
858894
(throwE e)
859895
Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT
860896

861-
-- clientConnected arg is only passed for SMP server
862897
newProtocolClient ::
863898
forall v err msg.
864899
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
@@ -1355,7 +1390,7 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
13551390
getSessionMode = fmap sessionMode . getNetworkConfig
13561391
{-# INLINE getSessionMode #-}
13571392

1358-
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, Maybe ServiceId, SMPTransportSession, SessionId)
1393+
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
13591394
newRcvQueue c nm userId connId srv vRange cMode enableNtfs subMode = do
13601395
let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing
13611396
e2eKeys <- atomically . C.generateKeyPair =<< asks random
@@ -1376,7 +1411,7 @@ queueReqData = \case
13761411
CQRMessaging d -> QRMessaging $ srvReq <$> d
13771412
CQRContact d -> QRContact $ srvReq <$> d
13781413

1379-
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, Maybe ServiceId, SMPTransportSession, SessionId)
1414+
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
13801415
newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enableNtfs subMode nonce_ (e2eDhKey, e2ePrivKey) = do
13811416
C.AuthAlg a <- asks (rcvAuthAlg . config)
13821417
g <- asks random
@@ -1388,7 +1423,7 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
13881423
withClient c nm tSess $ \(SMPConnectedClient smp _) -> do
13891424
(ntfKeys, ntfCreds) <- liftIO $ mkNtfCreds a g smp
13901425
(thParams smp,ntfKeys,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds
1391-
-- TODO [certs rcv] validate that serviceId is the same as in the client session
1426+
-- TODO [certs rcv] validate that serviceId is the same as in the client session, fail otherwise
13921427
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
13931428
shortLink <- mkShortLinkCreds thParams' qik
13941429
let rq =
@@ -1415,7 +1450,7 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
14151450
deleteErrors = 0
14161451
}
14171452
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey queueMode
1418-
pure (rq, qUri, serviceId, tSess, sessionId thParams')
1453+
pure (rq, qUri, tSess, sessionId thParams')
14191454
where
14201455
mkNtfCreds :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> TVar ChaChaDRG -> SMPClient -> IO (Maybe (C.AAuthKeyPair, C.PrivateKeyX25519), Maybe NewNtfCreds)
14211456
mkNtfCreds a g smp
@@ -1540,6 +1575,11 @@ subscribeQueues c qs = do
15401575
processSubResults = mapM_ $ uncurry $ processSubResult c sessId
15411576
resubscribe = resubscribeSMPSession c tSess `runReaderT` env
15421577

1578+
subscribeClientService :: AgentClient -> UserId -> SMPServer -> AM Int64
1579+
subscribeClientService c userId srv =
1580+
withLogClient c NRMBackground (userId, srv, Nothing) B.empty "SUBS" $
1581+
(`subscribeService` SMP.SRecipientService) . connectedClient
1582+
15431583
activeClientSession :: AgentClient -> SMPTransportSession -> SessionId -> STM Bool
15441584
activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClients c)
15451585
where

0 commit comments

Comments
 (0)