dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-27 17:58:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

implement core + cli

Browse Source
This commit is contained in:
Alain Brenzikofer
2026-09-23 11:01:46 +02:00
parent 54bc83d803
commit a5788dfdb5
5 changed files with 457 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-directory-service/src/Directory/Service.hs
+5 -5
View File
@@ -544,7 +544,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
notifyAdminUsers $ "The " <> gt <> " " <> groupRef <> " is updated" <> byMember <> "."
verifyAndSendToApprove g' gr' n'
sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget link)) PRMAllGroups Nothing) >>= \case
Right (CRConnectionPlan _ _ _ _ (CPGroupLink (GLPKnown {groupInfo = g'}))) ->
Right (CRConnectionPlan _ _ _ _ (CPGroupLink (GLPKnown {groupInfo = g'}) _)) ->
case dbOwnerMemberId gr of
Just ownerGMId ->
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
@@ -779,7 +779,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
when (groupRegStatus == GRSActive || pendingApproval groupRegStatus) $ do
let link = ACL SCMContact $ CLShort groupLink
sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget link)) PRMAllGroups Nothing) >>= \case
Right (CRConnectionPlan _ _ _ _ (CPGroupLink (GLPKnown {groupInfo = g', groupUpdated, linkOwners = ListDef owners}))) ->
Right (CRConnectionPlan _ _ _ _ (CPGroupLink (GLPKnown {groupInfo = g', groupUpdated, linkOwners = ListDef owners}) _)) ->
checkValidOwner dbOwnerMemberId owners $ do
-- re-verify every cycle: a name that stopped resolving to the link must lose verified status
g'' <- verifyGroupDomain_ g'
@@ -917,7 +917,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
mId = MemberId oIdBytes
gt' = groupTypeStr gt
sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget link)) PRMAllGroups (Just ownerSig)) >>= \case
Right (CRConnectionPlan _ (ACCL SCMContact ccLink) _ _ plan) ->
Right (CRConnectionPlan _ (Just (ACCL SCMContact ccLink)) _ _ plan) ->
handleGroupLinkPlan ct ccLink mId ownerSig gt' plan
_ -> sendMessage cc ct "Error: could not connect. Please report it to directory admins."
deChatLinkReceived ct (MCLGroup {groupProfile = GroupProfile {publicGroup = Just pg}}) _ =
@@ -940,7 +940,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
handleGroupLinkPlan :: Contact -> CreatedLinkContact -> MemberId -> LinkOwnerSig -> Text -> ConnectionPlan -> IO ()
handleGroupLinkPlan ct ccLink mId ownerSig gt = \case
CPGroupLink glp -> case glp of
CPGroupLink glp _ -> case glp of
GLPOk {groupSLinkData_, ownerVerification} -> case (groupSLinkData_, ownerVerification) of
(Just groupSLinkData, Just OVVerified) -> joinAndRegisterPublicGroup ct ccLink mId gt groupSLinkData
(_, Just (OVFailed reason)) -> sendMessage cc ct $ "Link signature verification failed: " <> reason <> ".\nYou must be the " <> gt <> " owner to register it."
@@ -1254,7 +1254,7 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
getRegisteredGroupByLink :: AConnectionLink -> IO (Maybe (GroupInfo, GroupReg, CreatedLinkContact))
getRegisteredGroupByLink uri =
sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget uri)) PRMNever Nothing) >>= \case
Right (CRConnectionPlan _ (ACCL SCMContact ccLink) _ _ (CPGroupLink glp)) -> case glp of
Right (CRConnectionPlan _ (Just (ACCL SCMContact ccLink)) _ _ (CPGroupLink glp _)) -> case glp of
GLPOwnLink g -> groupReg g ccLink
GLPKnown {groupInfo = g} -> groupReg g ccLink
GLPConnectingProhibit (Just g) -> groupReg g ccLink
src/Simplex/Chat/Library/Commands.hs
+149 -68
View File
@@ -123,6 +123,7 @@ import Simplex.Messaging.Parsers (base64P)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ErrorType (NAME), MsgFlags (..), NameRecord (..), NameRegistration (..), NameResponse (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, userProtocol)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import Simplex.Messaging.SystemTime (getSystemSeconds)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (defaultSocksProxyWithAuth)
import Simplex.Messaging.Util
@@ -2398,7 +2399,7 @@ processChatCommand cxt nm = \case
CVRSentInvitation conn incognitoProfile -> pure $ CRSentInvitation user (mkPendingContactConnection conn Nothing) incognitoProfile
APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq
Connect incognito (Just ct) -> withUser $ \user -> do
let con m cReq = pure (ACCL m (CCLink cReq Nothing), Nothing, Nothing, CPInvitationLink (ILPOk Nothing Nothing))
let con m cReq = pure (Just (ACCL m (CCLink cReq Nothing)), Nothing, Nothing, CPInvitationLink (ILPOk Nothing Nothing))
(ccLink, planSimplexName, otherSimplexName, plan) <- connectPlan user ct PRMUnknown Nothing Nothing `catchAllErrors` \e -> case ct of
ACTarget m (CTFullContact cReq) -> con m cReq
ACTarget m (CTInv (CLFull cReq)) -> con m cReq
@@ -2441,8 +2442,8 @@ processChatCommand cxt nm = \case
toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct')
throwError e
ConnectSimplex incognito -> withUser $ \user -> do
plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing))
connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) Nothing Nothing plan
plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing False) Nothing)
connectWithPlan user incognito (Just (ACCL SCMContact (CCLink adminContactReq Nothing))) Nothing Nothing plan
DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId Nothing) cdm
ClearContact cName -> withContactName cName $ \chatId -> APIClearChat $ ChatRef CTDirect chatId Nothing
APIListContacts userId -> withUserId userId $ \user ->
@@ -4389,13 +4390,13 @@ processChatCommand cxt nm = \case
pure (gId, chatSettings)
_ -> throwCmdError "not supported"
processChatCommand cxt nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
connectPlan :: User -> AConnectTarget -> PlanResolveMode -> Maybe LinkOwnerSig -> Maybe (Either ChatError NameRecord) -> CM (ACreatedConnLink, Maybe SimplexNameInfo, Maybe SimplexNameInfo, ConnectionPlan)
connectPlan :: User -> AConnectTarget -> PlanResolveMode -> Maybe LinkOwnerSig -> Maybe (Either ChatError NameRegistration) -> CM (Maybe ACreatedConnLink, Maybe SimplexNameInfo, Maybe SimplexNameInfo, ConnectionPlan)
connectPlan user (ACTarget SCMInvitation (CTInv cLink)) _ sig_ _ = case cLink of
CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing Nothing
CLShort l -> do
let l' = serverShortLink l
knownLinkPlans l' >>= \case
Just (createdLink, p) -> pure (createdLink, Nothing, Nothing, p)
Just (createdLink, p) -> pure (Just createdLink, Nothing, Nothing, p)
Nothing -> do
(FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l'
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
@@ -4410,25 +4411,38 @@ processChatCommand cxt nm = \case
Nothing -> bimap inv (CPInvitationLink . ILPKnown) <$$> getContactViaShortLinkToConnect db cxt user l'
invitationReqAndPlan cReq sLnk_ cld ov = do
plan <- invitationRequestPlan user cReq cld ov `catchAllErrors` (pure . CPError)
pure (ACCL SCMInvitation (CCLink cReq sLnk_), Nothing, Nothing, plan)
pure (Just (ACCL SCMInvitation (CCLink cReq sLnk_)), Nothing, Nothing, plan)
connectPlan user (ACTarget SCMContact ct) resolveMode sig_ nameRec = case ct of
CTDomain d
-- local search only: look up #d then @d in the store, without online name resolution
| resolveMode == PRMNever -> connectPlanNoName $ ChatError CENotResolvedLocally
| otherwise ->
tryAllErrors (resolveNameRecord user nm d) >>= \case
Right nr
| isJust (firstNameLink CCTChannel (nrSimplexChannel nr)) ->
(addOther nr <$> connectPlanName NTPublicGroup (Right nr)) `catchAllErrors` \e ->
(addOther nr <$> connectPlanName NTContact (Right nr) `catchAllErrors` \_ -> throwError e)
| isJust (firstNameLink CCTContact (nrSimplexContact nr)) ->
addOther nr <$> connectPlanName NTContact (Right nr)
| otherwise -> connectPlanNoName $ ChatError $ CESimplexDomainNotReady d SDENoValidLink
tryAllErrors (resolveNameRegistration user nm d) >>= \case
Right reg -> do
expired <- nameExpired reg
case reg of
-- a live registration with a usable link connects, as before
NRRegistered {nameRecord = nr}
| not expired && isJust (firstNameLink CCTChannel (nrSimplexChannel nr)) ->
(withReg reg . addOther nr <$> connectPlanName NTPublicGroup (Right reg)) `catchAllErrors` \e ->
(withReg reg . addOther nr <$> connectPlanName NTContact (Right reg) `catchAllErrors` \_ -> throwError e)
| not expired && isJust (firstNameLink CCTContact (nrSimplexContact nr)) ->
withReg reg . addOther nr <$> connectPlanName NTContact (Right reg)
-- expired, available, reserved, or registered with no usable link: nothing to connect
-- to, so the answer is whichever local chat claims the name, or the registration alone
_ -> connectPlanLocal reg
Left e -> connectPlanNoName e
where
connectPlanName nameType nr_ = connectPlan user connTarget resolveMode sig_ (Just nr_)
withReg = withPlanRegistration
-- only the local store is consulted: a name with nothing to connect to must not resolve a link
connectPlanLocal reg =
(withReg reg <$> localPlan NTPublicGroup) `catchAllErrors` \_ ->
(withReg reg <$> localPlan NTContact) `catchAllErrors` \_ ->
pure (Nothing, Nothing, Nothing, CPNameNotConnectable d reg)
where
connTarget = ACTarget SCMContact $ CTShortContact $ CTName $ SimplexNameInfo nameType d
localPlan nameType = connectPlan user (nameTarget nameType) PRMNever sig_ (Just (Right reg))
connectPlanName nameType nr_ = connectPlan user (nameTarget nameType) resolveMode sig_ (Just nr_)
nameTarget nameType = ACTarget SCMContact $ CTShortContact $ CTName $ SimplexNameInfo nameType d
connectPlanNoName e =
connectPlanName NTPublicGroup (Left e) `catchAllErrors` \e' ->
(connectPlanName NTContact (Left e) `catchAllErrors` \_ -> throwError e')
@@ -4442,15 +4456,32 @@ processChatCommand cxt nm = \case
_ -> Nothing
CTFullContact cReq -> do
plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError)
pure (ACCL SCMContact $ CCLink cReq Nothing, Nothing, Nothing, plan)
pure (Just (ACCL SCMContact $ CCLink cReq Nothing), Nothing, Nothing, plan)
CTShortContact nl
-- a name given with its type (@name / #name): the registry decides connectability first,
-- exactly as it does for a bare domain, so band 2 does not depend on the sigil
| CTName ni <- nl, isNothing nameRec, resolveMode /= PRMNever -> do
reg <- resolveNameRegistration user nm (nameDomain ni)
expired <- nameExpired reg
if nameHasLink ni reg && not expired
then withPlanRegistration reg <$> connectPlan user (ACTarget SCMContact (CTShortContact nl)) resolveMode sig_ (Just (Right reg))
else
(withPlanRegistration reg <$> connectPlan user (ACTarget SCMContact (CTShortContact nl)) PRMNever sig_ (Just (Right reg)))
`catchAllErrors` \_ -> pure (Nothing, Nothing, Nothing, CPNameNotConnectable (nameDomain ni) reg)
CTShortContact nl ->
(\(l, p) -> (l, simplexName_, Nothing, p)) <$> case ctType of
(\(l, p) -> (Just l, simplexName_, Nothing, p)) <$> case ctType of
CCTContact ->
knownLinkPlans >>= \case
Just r -> pure r
Nothing -> do
Just r | not (reResolveKnown r) -> pure r
known_ -> do
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
l' <- resolveSLink
case known_ of
-- the name still leads to the chat that claims it: 3a, nothing actionable
Just r | knownLinkOf r == Just l' -> pure r
_ -> (if isJust known_ then second setAddressChanged else id) <$> resolvedPlan l'
where
resolvedPlan l' = do
(FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l'
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
let linkProfile_ = (\ContactShortLinkData {profile} -> profile) <$> contactSLinkData_
@@ -4464,27 +4495,26 @@ processChatCommand cxt nm = \case
withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user l') >>= \case
Just ct' | not (contactDeleted ct') -> do
ct'' <- refreshContact ct'
pure (con l' cReq, CPContactAddress (CAPContactViaAddress ct''))
pure (con l' cReq, CPContactAddress (CAPContactViaAddress ct'') Nothing)
_ -> do
let ContactLinkData _ UserContactData {owners} = cData
ov = verifyLinkOwner rootKey owners l' sig_
plan <- contactRequestPlan user cReq contactSLinkData_ ov
case plan of
CPContactAddress (CAPKnown ct') -> do
CPContactAddress (CAPKnown ct') _ -> do
ct'' <- refreshContact ct'
pure (con l' cReq, CPContactAddress (CAPKnown ct''))
CPContactAddress (CAPContactViaAddress ct') -> do
pure (con l' cReq, CPContactAddress (CAPKnown ct'') Nothing)
CPContactAddress (CAPContactViaAddress ct') _ -> do
ct'' <- refreshContact ct'
pure (con l' cReq, CPContactAddress (CAPContactViaAddress ct''))
pure (con l' cReq, CPContactAddress (CAPContactViaAddress ct'') Nothing)
_ -> pure (con l' cReq, plan)
where
knownLinkPlans :: CM (Maybe (ACreatedConnLink, ConnectionPlan))
knownLinkPlans = withFastStore $ \db ->
liftIO (getUserContactLinkViaTarget db user nl') >>= \case
Just UserContactLink {connLinkContact} -> pure $ Just (ACCL SCMContact connLinkContact, CPContactAddress CAPOwnLink)
Just UserContactLink {connLinkContact} -> pure $ Just (ACCL SCMContact connLinkContact, CPContactAddress CAPOwnLink Nothing)
Nothing ->
getContactToConnect db cxt user nl' >>= \case
Just (ccl, ct') -> pure $ if contactDeleted ct' then Nothing else Just (ACCL SCMContact ccl, CPContactAddress (CAPKnown ct'))
Just (ccl, ct') -> pure $ if contactDeleted ct' then Nothing else Just (ACCL SCMContact ccl, CPContactAddress (CAPKnown ct') Nothing)
Nothing -> (gPlan =<<) <$> getGroupToConnect db cxt user nl'
CCTGroup -> groupShortLinkPlan
CCTChannel -> groupShortLinkPlan
@@ -4501,21 +4531,36 @@ processChatCommand cxt nm = \case
CTLink l' -> pure l'
CTName n -> serverShortLink <$> resolveNameLink n
con l' cReq = ACCL SCMContact $ CCLink cReq (Just l')
gPlan (ccl, g) = if memberRemoved (membership g) then Nothing else Just (ACCL SCMContact ccl, CPGroupLink (GLPKnown g False Nothing (ListDef [])))
-- a name whose chat is known is re-resolved only on PRMAll, to see whether it still leads there (3a/3c)
reResolveKnown (_, p) = resolveMode == PRMAll && isJust simplexName_ && case p of
CPContactAddress (CAPKnown _) _ -> True
CPGroupLink GLPKnown {} _ -> True
_ -> False
knownLinkOf :: (ACreatedConnLink, ConnectionPlan) -> Maybe ShortLinkContact
knownLinkOf (l, _) = case l of
ACCL SCMContact (CCLink _ sl_) -> sl_
_ -> Nothing
gPlan (ccl, g) = if memberRemoved (membership g) then Nothing else Just (ACCL SCMContact ccl, CPGroupLink (GLPKnown g False Nothing (ListDef [])) Nothing)
groupShortLinkPlan :: CM (ACreatedConnLink, ConnectionPlan)
groupShortLinkPlan =
knownLinkPlans >>= \case
Just (_, CPGroupLink (GLPKnown g _ _ _))
| resolveMode == PRMAllGroups -> resolveKnownGroup g
Just r -> pure r
Nothing -> do
Just (_, CPGroupLink (GLPKnown g _ _ _) _)
| resolveMode == PRMAllGroups -> resolveSLink >>= \l' -> resolveKnownGroup l' g
Just r | not (reResolveKnown r) -> pure r
known_ -> do
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
l' <- resolveSLink
case known_ of
-- the name still leads to the channel that claims it: 3a, refreshed as PRMAllGroups does
Just r@(_, CPGroupLink (GLPKnown g _ _ _) _) | knownLinkOf r == Just l' -> resolveKnownGroup l' g
_ -> (if isJust known_ then second setAddressChanged else id) <$> resolvedGroupPlan l'
where
resolvedGroupPlan l' = do
(fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays}), cReq) <- getShortLinkConnReq' nm user l'
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
if
| not direct && unsupportedGroupType groupSLinkData_ -> pure (con l' cReq, CPGroupLink (GLPUpdateRequired groupSLinkData_))
| not direct && null relays -> pure (con l' cReq, CPGroupLink (GLPNoRelays groupSLinkData_))
| not direct && unsupportedGroupType groupSLinkData_ -> pure (con l' cReq, CPGroupLink (GLPUpdateRequired groupSLinkData_) Nothing)
| not direct && null relays -> pure (con l' cReq, CPGroupLink (GLPNoRelays groupSLinkData_) Nothing)
| otherwise -> do
let FixedLinkData {linkEntityId, rootKey} = fd
linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId}
@@ -4533,29 +4578,27 @@ processChatCommand cxt nm = \case
-- e.g. an un-upgraded relay dropped the claim); refresh its profile from the fresh link
-- data and mark it verified, so the check below passes and future by-name lookups match
plan <- case (planDomain, plan0, groupSLinkData_) of
(Just nameDomain, CPGroupLink (GLPKnown g u o os), Just sLinkData) ->
(\(g', _) -> CPGroupLink (GLPKnown g' u o os)) <$> updateGroupFromLinkData user g sLinkData (Just nameDomain)
(Just nameDomain, CPGroupLink (GLPKnown g u o os) _, Just sLinkData) ->
(\(g', _) -> CPGroupLink (GLPKnown g' u o os) Nothing) <$> updateGroupFromLinkData user g sLinkData (Just nameDomain)
_ -> pure plan0
forM_ planDomain $ \nameDomain ->
let domain_ = (\GroupProfile {publicGroup} -> claimDomain <$> (publicGroup >>= publicGroupAccess >>= groupDomainClaim)) =<< case plan of
CPGroupLink (GLPOk _ (Just GroupShortLinkData {groupProfile}) _) -> Just groupProfile
CPGroupLink (GLPKnown GroupInfo {groupProfile} _ _ _) -> Just groupProfile
CPGroupLink (GLPOwnLink GroupInfo {groupProfile}) -> Just groupProfile
CPGroupLink (GLPConnectingProhibit (Just GroupInfo {groupProfile})) -> Just groupProfile
CPGroupLink (GLPOk _ (Just GroupShortLinkData {groupProfile}) _ _) _ -> Just groupProfile
CPGroupLink (GLPKnown GroupInfo {groupProfile} _ _ _) _ -> Just groupProfile
CPGroupLink (GLPOwnLink GroupInfo {groupProfile}) _ -> Just groupProfile
CPGroupLink (GLPConnectingProhibit (Just GroupInfo {groupProfile})) _ -> Just groupProfile
_ -> (\GroupShortLinkData {groupProfile} -> groupProfile) <$> groupSLinkData_
in unless (domain_ == Just nameDomain) $ throwChatError $ CESimplexDomainNotReady nameDomain SDEUnknownDomain
pure (con l' cReq, plan)
where
unsupportedGroupType = \case
Just GroupShortLinkData {groupProfile = GroupProfile {publicGroup = Just PublicGroupProfile {groupType}}} -> groupType /= GTChannel
_ -> False
knownLinkPlans :: CM (Maybe (ACreatedConnLink, ConnectionPlan))
knownLinkPlans = withFastStore $ \db ->
liftIO (getGroupInfoViaUserTarget db cxt user nl') >>= \case
Just (ccl, g) -> pure $ Just (ACCL SCMContact ccl, CPGroupLink (GLPOwnLink g))
Just (ccl, g) -> pure $ Just (ACCL SCMContact ccl, CPGroupLink (GLPOwnLink g) Nothing)
Nothing -> (gPlan =<<) <$> getGroupToConnect db cxt user nl'
resolveKnownGroup g = do
l' <- resolveSLink
resolveKnownGroup l' g = do
(FixedLinkData {rootKey = rk}, cData@(ContactLinkData _ UserContactData {owners}), cReq) <- getShortLinkConnReq' nm user l'
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
let ov = verifyLinkOwner rk owners l' sig_
@@ -4563,27 +4606,30 @@ processChatCommand cxt nm = \case
(g', updated) <- case groupSLinkData_ of
Just sLinkData -> updateGroupFromLinkData user g sLinkData Nothing
_ -> pure (g, False)
pure (con l' cReq, CPGroupLink (GLPKnown g' updated ov (ListDef glOwners)))
pure (con l' cReq, CPGroupLink (GLPKnown g' updated ov (ListDef glOwners)) Nothing)
-- resolve a name to its first contact/channel short link
resolveNameLink :: SimplexNameInfo -> CM (ConnShortLink 'CMContact)
resolveNameLink SimplexNameInfo {nameType, nameDomain} = do
NameRecord {nrSimplexContact, nrSimplexChannel} <- maybe (resolveNameRecord user nm nameDomain) (ExceptT . pure) nameRec
reg <- maybe (resolveNameRegistration user nm nameDomain) (ExceptT . pure) nameRec
NameRecord {nrSimplexContact, nrSimplexChannel} <- case reg of
NRRegistered {nameRecord} -> pure nameRecord
_ -> throwChatError $ CESimplexDomainNotReady nameDomain SDENoValidLink
let (candidates, ctType') = case nameType of
NTContact -> (nrSimplexContact, CCTContact)
NTPublicGroup -> (nrSimplexChannel, CCTChannel)
maybe (throwChatError $ CESimplexDomainNotReady nameDomain SDENoValidLink) pure $ firstNameLink ctType' candidates
connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> Maybe SimplexNameInfo -> Maybe SimplexNameInfo -> ConnectionPlan -> CM ChatResponse
connectWithPlan user@User {userId} incognito ccLink planSimplexName otherSimplexName plan
| connectionPlanProceed plan = do
connectWithPlan :: User -> IncognitoEnabled -> Maybe ACreatedConnLink -> Maybe SimplexNameInfo -> Maybe SimplexNameInfo -> ConnectionPlan -> CM ChatResponse
connectWithPlan user@User {userId} incognito ccLink_ planSimplexName otherSimplexName plan
| Just ccLink <- ccLink_, connectionPlanProceed plan = do
case plan of CPError e -> eToView e; _ -> pure ()
case plan of
CPContactAddress (CAPContactViaAddress Contact {contactId}) ->
CPContactAddress (CAPContactViaAddress Contact {contactId}) _ ->
processChatCommand cxt nm $ APIConnectContactViaAddress userId incognito contactId
CPContactAddress (CAPOk (Just sld) _) | isJust vName -> connectContactViaName sld
CPGroupLink (GLPOk (Just GroupShortLinkInfo {direct = False}) (Just gld) _)
CPContactAddress (CAPOk (Just sld) _ _) _ | isJust vName -> connectContactViaName ccLink sld
CPGroupLink (GLPOk (Just GroupShortLinkInfo {direct = False}) (Just gld) _ _) _
| ACCL SCMContact ccl <- ccLink -> joinChannelViaRelays ccl gld
_ -> processChatCommand cxt nm $ APIConnect userId incognito $ Just ccLink
| otherwise = pure $ CRConnectionPlan user ccLink planSimplexName otherSimplexName plan
| otherwise = pure $ CRConnectionPlan user ccLink_ planSimplexName otherSimplexName plan
where
vName = nameDomain <$> planSimplexName
joinChannelViaRelays :: CreatedLinkContact -> GroupShortLinkData -> CM ChatResponse
@@ -4602,8 +4648,8 @@ processChatCommand cxt nm = \case
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user groupId
deleteGroupConnections user gInfo False
withFastStore' $ \db -> deleteGroup db user gInfo
connectContactViaName :: ContactShortLinkData -> CM ChatResponse
connectContactViaName sld =
connectContactViaName :: ACreatedConnLink -> ContactShortLinkData -> CM ChatResponse
connectContactViaName ccLink sld =
processChatCommand cxt nm (APIPrepareContact userId ccLink vName sld) >>= \case
CRNewPreparedChat _ (AChat SCTDirect (Chat (DirectChat Contact {contactId}) _ _)) ->
processChatCommand cxt nm (APIConnectPreparedContact contactId incognito Nothing)
@@ -4639,7 +4685,7 @@ processChatCommand cxt nm = \case
contactRequestPlan user cReq cld ov = do
let cReqSchemas = contactCReqSchemas cReq
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
plan p = pure $ CPContactAddress p
plan p = pure $ CPContactAddress p Nothing
withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
Just _ -> plan $ CAPOwnLink
Nothing ->
@@ -4647,13 +4693,13 @@ processChatCommand cxt nm = \case
Nothing ->
withFastStore' (\db -> getContactWithoutConnViaAddress db cxt user cReqSchemas) >>= \case
Just ct | not (contactDeleted ct) -> plan $ CAPContactViaAddress ct
_ -> plan $ CAPOk cld ov
_ -> plan $ CAPOk cld ov False
Just (RcvDirectMsgConnection Connection {connStatus} Nothing)
| connStatus == ConnPrepared -> plan $ CAPOk cld ov
| connStatus == ConnPrepared -> plan $ CAPOk cld ov False
| otherwise -> plan CAPConnectingConfirmReconnect
Just (RcvDirectMsgConnection _ (Just ct))
| not (contactReady ct) && contactActive ct -> plan $ CAPConnectingProhibit ct
| contactDeleted ct -> plan $ CAPOk cld ov
| contactDeleted ct -> plan $ CAPOk cld ov False
| otherwise -> plan $ CAPKnown ct
-- TODO [short links] RcvGroupMsgConnection branch is deprecated? (old group link protocol?)
Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing Nothing []
@@ -4662,19 +4708,19 @@ processChatCommand cxt nm = \case
groupJoinRequestPlan user cReq linkInfo gld ov glOwners = do
let cReqSchemas = contactCReqSchemas cReq
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
plan p = pure $ CPGroupLink p
plan p = pure $ CPGroupLink p Nothing
withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db cxt user cReqSchemas) >>= \case
Just g -> plan $ GLPOwnLink g
Nothing -> do
connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db cxt user cReqHashes
gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db cxt user cReqHashes
case (gInfo_, connEnt_) of
(Nothing, Nothing) -> plan $ GLPOk linkInfo gld ov
(Nothing, Nothing) -> plan $ GLPOk linkInfo gld ov False
-- TODO [short links] RcvDirectMsgConnection branches are deprecated? (old group link protocol?)
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> plan $ GLPConnectingConfirmReconnect
(Nothing, Just (RcvDirectMsgConnection _ (Just ct)))
| not (contactReady ct) && contactActive ct -> plan $ GLPConnectingProhibit gInfo_
| otherwise -> plan $ GLPOk linkInfo gld ov
| otherwise -> plan $ GLPOk linkInfo gld ov False
(Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection"
(Just gInfo, _) -> groupPlan gInfo linkInfo gld ov glOwners
groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> [GroupLinkOwner] -> CM ConnectionPlan
@@ -4683,9 +4729,9 @@ processChatCommand cxt nm = \case
| not (memberActive membership) && not (memberRemoved membership) =
plan $ GLPConnectingProhibit $ Just gInfo
| memberActive membership = plan $ GLPKnown gInfo False ov (ListDef glOwners)
| otherwise = plan $ GLPOk linkInfo gld ov
| otherwise = plan $ GLPOk linkInfo gld ov False
where
plan p = pure $ CPGroupLink p
plan p = pure $ CPGroupLink p Nothing
contactCReqSchemas :: ConnReqContact -> (ConnReqContact, ConnReqContact)
contactCReqSchemas (CRContactUri crData e2e) =
( CRContactUri crData {crScheme = SSSimplex} e2e,
@@ -5078,14 +5124,49 @@ firstNameLink ctType = foldr (\t r -> nameLink t <|> r) Nothing
nameResolvesTo :: ConnShortLink 'CMContact -> [Text] -> Bool
nameResolvesTo sLnk = any (either (const False) (sameShortLinkContact sLnk) . strDecode . encodeUtf8)
resolveNameRegistration :: User -> NetworkRequestMode -> SimplexDomain -> CM NameRegistration
resolveNameRegistration user nm domain =
registration <$> withAgent (\a -> resolveSimplexName a nm (aUserId user) domain)
-- the resolver now also reports names that are not registered, which stay the agent's NAME NOT_FOUND
resolveNameRecord :: User -> NetworkRequestMode -> SimplexDomain -> CM NameRecord
resolveNameRecord user nm domain = do
NameResponse {registration} <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) domain
case registration of
resolveNameRecord user nm domain =
resolveNameRegistration user nm domain >>= \case
NRRegistered {nameRecord} -> pure nameRecord
_ -> throwError $ chatErrorAgent $ SMP "" (NAME SMP.NOT_FOUND)
-- a name past its expiry does not connect: only its owner can renew it until the grace ends.
-- an absent expiry (a v20/v21 router sent the record alone) is unknown, so the name is treated as live
nameExpired :: NameRegistration -> CM Bool
nameExpired = \case
NRRegistered {expires = Just expires} -> (expires <) <$> liftIO getSystemSeconds
_ -> pure False
-- does the name's record hold a link of the type the name asks for?
nameHasLink :: SimplexNameInfo -> NameRegistration -> Bool
nameHasLink SimplexNameInfo {nameType} = \case
NRRegistered {nameRecord = NameRecord {nrSimplexContact, nrSimplexChannel}} -> case nameType of
NTContact -> isJust (firstNameLink CCTContact nrSimplexContact)
NTPublicGroup -> isJust (firstNameLink CCTChannel nrSimplexChannel)
_ -> False
withPlanRegistration :: NameRegistration -> (a, b, c, ConnectionPlan) -> (a, b, c, ConnectionPlan)
withPlanRegistration reg (l, pn, on, p) = (l, pn, on, withNameRegistration reg p)
-- the registration a resolved name answered with, attached to whichever plan was built for it
withNameRegistration :: NameRegistration -> ConnectionPlan -> ConnectionPlan
withNameRegistration nr = \case
CPContactAddress p _ -> CPContactAddress p (Just nr)
CPGroupLink p _ -> CPGroupLink p (Just nr)
p -> p
-- 3c: the name resolved to another address than the one the local chat claiming it holds
setAddressChanged :: ConnectionPlan -> ConnectionPlan
setAddressChanged = \case
CPContactAddress (CAPOk cld ov _) nr -> CPContactAddress (CAPOk cld ov True) nr
CPGroupLink (GLPOk li gld ov _) nr -> CPGroupLink (GLPOk li gld ov True) nr
p -> p
verifyEntityDomain :: User -> NetworkRequestMode -> SimplexNameType -> SimplexDomainClaim -> Maybe AConnShortLink -> CM (Maybe Bool, Maybe Text)
verifyEntityDomain user nm nameType SimplexDomainClaim {domain = StrJSON domain, proof = proof_} connLink_ = case (proof_, connLink_) of
(Nothing, _) -> pure (Nothing, Just "no name proof to verify")
src/Simplex/Chat/View.hs
+36 -8
View File
@@ -71,7 +71,9 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, BlockingInfo (..), BlockingReason (..), NetworkError (..), ProtocolServer (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, BlockingInfo (..), BlockingReason (..), NameRegistration (..), NamePricing (..), NetworkError (..), ProtocolServer (..), ProtocolTypeI, SProtocolType (..), USDCents (..), UserProtocol)
import Simplex.Messaging.SimplexName (fullDomainName)
import Simplex.Messaging.SystemTime (roundedSeconds)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
@@ -214,7 +216,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
CRInvitation u ccLink _ -> ttyUser u $ viewConnReqInvitation showFullLinks ccLink
CRConnectionIncognitoUpdated u c customUserProfile -> ttyUser u $ viewConnectionIncognitoUpdated c customUserProfile testView
CRConnectionUserChanged u c c' nu -> ttyUser u $ viewConnectionUserChanged showFullLinks u c nu c'
CRConnectionPlan u connLink _ otherSimplexName connectionPlan -> ttyUser u $ viewConnectionPlan cfg connLink connectionPlan <> otherSimplexNameNote otherSimplexName
CRConnectionPlan u connLink _ otherSimplexName connectionPlan -> ttyUser u $ viewConnectionPlan cfg connLink connectionPlan <> otherSimplexNameNote otherSimplexName <> viewNameRegistration connectionPlan
CRNewPreparedChat u (AChat _ (Chat cInfo _ _)) -> ttyUser u $ case cInfo of
DirectChat ct -> [ttyContact' ct <> ": contact is prepared"]
GroupChat g _ -> [ttyGroup' g <> ": group is prepared"]
@@ -2211,7 +2213,29 @@ otherSimplexNameNote = \case
Just ni@(SimplexNameInfo NTContact _) -> [plain $ "You can also connect to " <> shortNameInfoStr ni <> " in direct chat"]
Nothing -> []
viewConnectionPlan :: ChatConfig -> ACreatedConnLink -> ConnectionPlan -> [StyledString]
-- what the registry said about the name, shown where it changes what the plan means:
-- a chat you already have, your own name, or a name with nothing to connect to
viewNameRegistration :: ConnectionPlan -> [StyledString]
viewNameRegistration = \case
CPContactAddress CAPKnown {} nr_ -> regLine nr_
CPContactAddress CAPOwnLink nr_ -> regLine nr_
CPGroupLink GLPKnown {} nr_ -> regLine nr_
CPGroupLink GLPOwnLink {} nr_ -> regLine nr_
CPNameNotConnectable _ reg -> regLine (Just reg)
_ -> []
where
regLine = \case
Just NRRegistered {expires, graceUntil, reservedReason_} ->
["registered" <> expiryNote expires graceUntil <> maybe "" ((", reserved: " <>) . plain . textEncode) reservedReason_]
Just NRAvailable {pricing = NamePricing {basePrice = USDCents c, minLabelLength}} ->
["available: " <> plain (show c) <> " cents/year, min length " <> plain (show minLabelLength)]
Just NRReserved {reservedReason} -> ["reserved: " <> plain (textEncode reservedReason :: Text)]
Nothing -> []
expiryNote expires graceUntil = case expires of
Nothing -> ""
Just e -> ", expires " <> plain (show (roundedSeconds e)) <> maybe "" (\g -> ", grace until " <> plain (show (roundedSeconds g))) graceUntil
viewConnectionPlan :: ChatConfig -> Maybe ACreatedConnLink -> ConnectionPlan -> [StyledString]
viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
CPInvitationLink ilp -> case ilp of
ILPOk contactSLinkData ov -> [invOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView]
@@ -2231,8 +2255,11 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
Just ContactShortLinkData {business}
| business -> ("business address: " <>)
_ -> ("invitation link: " <>)
CPContactAddress cap -> case cap of
CAPOk contactSLinkData ov -> [addrOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView]
CPContactAddress cap _ -> case cap of
CAPOk contactSLinkData ov addressChanged ->
[addrOrBiz contactSLinkData (if addressChanged then "ok to connect, address changed" else "ok to connect")]
<> viewSigVerification ov
<> [viewJSON contactSLinkData | testView]
CAPOwnLink -> [ctAddr "own address"]
CAPConnectingConfirmReconnect -> [ctAddr "connecting, allowed to reconnect"]
CAPConnectingProhibit ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
@@ -2249,10 +2276,10 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
Just ContactShortLinkData {business}
| business -> ("business address: " <>)
_ -> ("contact address: " <>)
CPGroupLink glp -> case glp of
GLPOk groupSLinkInfo_ groupSLinkData ov ->
CPGroupLink glp _ -> case glp of
GLPOk groupSLinkInfo_ groupSLinkData ov addressChanged ->
let direct = maybe True (\(GroupShortLinkInfo {direct = d}) -> d) groupSLinkInfo_
in [grpLink $ if direct then "ok to connect directly" else "ok to connect via relays"]
in [grpLink $ (if direct then "ok to connect directly" else "ok to connect via relays") <> (if addressChanged then ", address changed" else "")]
<> viewSigVerification ov
<> [viewJSON groupSLinkData | testView]
GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
@@ -2286,6 +2313,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
grpOrBiz GroupInfo {businessChat} = case businessChat of
Just _ -> "business"
Nothing -> "group"
CPNameNotConnectable d _ -> ["SimpleX name " <> plain (fullDomainName d) <> ": nothing to connect to"]
CPError e -> viewChatError False logLevel testView e
where
nextConnectPrepared Contact {preparedContact, activeConn} = case preparedContact of
tests/ChatTests/Names.hs
+201 -3
View File
@@ -8,8 +8,10 @@ import ChatTests.DBUtils
import ChatTests.Groups (memberJoinChannel, prepareChannel1Relay)
import ChatTests.Utils
import Control.Concurrent.Async (concurrently_)
import Data.Text (Text)
import qualified Data.Text as T
import NameResolver
import Simplex.Messaging.Names.Record (NameReservedReason (..))
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..))
import Test.Hspec hiding (it)
@@ -18,7 +20,7 @@ chatNamesTests = do
it "connect by resolved name" testConnectByName
it "connect by name not claimed in link profile is rejected" testConnectByNameNotClaimed
it "connect by name to a known contact not claimed in profile is rejected" testConnectByNameKnownContactNotClaimed
it "connect by unregistered name fails to resolve" testConnectByNameNotFound
it "connect by unregistered name reports the registration" testConnectByNameNotFound
it "set name not resolving to own address is rejected" testSetNameNotOwnAddress
it "channel name is not verified just by joining via link" testChannelDomainLinkJoinUnverified
it "verify channel name, fail on re-point, retain status on refresh" testChannelDomainVerify
@@ -26,12 +28,27 @@ chatNamesTests = do
it "connect by name resolving to channel (primary) and direct contact" testConnectByNameChannelAndContact
it "connect by name resolving to direct contact (primary) and channel" testConnectByNameContactAndChannel
it "connect by name resolving to business (primary) and channel" testConnectByNameBusinessAndChannel
describe "connection plan: the name lookup answers" $ do
it "2b. expired, no local chat" testPlanNameExpired
it "2c. available, no local chat" testPlanNameAvailable
it "2d. reserved for community" testPlanNameReservedCommunity
it "2e. reserved for another reason" testPlanNameReservedOther
it "2f. registered with no usable link" testPlanNameNoValidLink
it "3a. known chat, nothing actionable" testPlanKnownNameLive
it "3b. known chat, name expired" testPlanKnownNameExpired
it "3c. known chat, name moved to a new address" testPlanKnownNameAddressChanged
it "3d. known chat, name now available" testPlanKnownNameAvailable
it "4a. own name, live" testPlanOwnNameLive
it "4c. own name, expired" testPlanOwnNameExpired
it "4d. own name, now available" testPlanOwnNameAvailable
it "2h. the request failed" testPlanNameResolverFailed
it "resolve=never: local hit and miss" testPlanNameResolveNever
testConnectByName :: HasCallStack => TestParams -> IO ()
testConnectByName ps = withSmpServerAndNames $ \reg ->
testChat2 aliceProfile bobProfile (test reg) ps
where
aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
aliceName = aliceSimplexName
test reg alice bob = do
mapM_ enableNamesRole [alice, bob]
alice ##> "/ad"
@@ -105,7 +122,8 @@ testConnectByNameNotFound ps = withSmpServerAndNames $ \_reg ->
test _alice bob = do
enableNamesRole bob
bob ##> "/c @nobody.simplex"
bob .<## "smpErr = NAME {nameErr = NOT_FOUND}}"
bob <## "SimpleX name nobody.simplex: nothing to connect to"
bob <##. "available:"
testSetNameNotOwnAddress :: HasCallStack => TestParams -> IO ()
testSetNameNotOwnAddress ps = withSmpServerAndNames $ \reg ->
@@ -308,3 +326,183 @@ testConnectByNameBusinessAndChannel ps = withSmpServerAndNames $ \reg ->
bob <## "SimpleX name: @biz.simplex (verified)"
where
bizName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "biz" [])
-- The states the name-lookup canvas draws, one test per row. Each sets up the registry answer and
-- asserts the plan the CLI renders for it; the row numbers are the canvas's.
aliceSimplexName :: SimplexNameInfo
aliceSimplexName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
-- alice publishes alice.simplex on her address; the registration is left for the caller to change.
withAliceName :: HasCallStack => (NameRegistry -> Text -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
withAliceName test ps = withSmpServerAndNames $ \reg ->
testChat2 aliceProfile bobProfile (setup reg) ps
where
setup reg alice bob = do
mapM_ enableNamesRole [alice, bob]
alice ##> "/ad"
(shortLink, _) <- getContactLinks alice True
registerName reg aliceSimplexName (contactNameRecord "alice.simplex" (T.pack shortLink))
alice ##> "/_set domain 1 alice.simplex"
alice <## "new contact address set"
test reg (T.pack shortLink) alice bob
-- bob connects to alice by name, so his contact is found by local name search afterwards.
connectBobByName :: HasCallStack => TestCC -> TestCC -> IO ()
connectBobByName alice bob = do
bob ##> "/c @alice.simplex"
bob <## "alice: connection started"
alice <## "bob (Bob) wants to connect to you!"
alice <## "to accept: /ac bob"
alice <## "to reject: /rc bob (the sender will NOT be notified)"
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request, you can send messages to contact"
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
testPlanNameExpired :: HasCallStack => TestParams -> IO ()
testPlanNameExpired = withAliceName $ \reg shortLink _alice bob -> do
registerExpiredName reg aliceSimplexName (contactNameRecord "alice.simplex" shortLink)
bob ##> "/_connect plan 1 @alice.simplex"
bob <## "SimpleX name alice.simplex: nothing to connect to"
bob <##. "registered, expires "
testPlanNameAvailable :: HasCallStack => TestParams -> IO ()
testPlanNameAvailable = withAliceName $ \reg _l _alice bob -> do
registerAvailableName reg sunflower 3
bob ##> "/_connect plan 1 @sunflower.simplex"
bob <## "SimpleX name sunflower.simplex: nothing to connect to"
bob <## "available: 1000 cents/year, min length 3"
where
sunflower = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "sunflower" [])
testPlanNameReservedCommunity :: HasCallStack => TestParams -> IO ()
testPlanNameReservedCommunity = withAliceName $ \reg _l _alice bob -> do
registerReservedName reg privacy NRRCommunity
bob ##> "/_connect plan 1 @privacy.simplex"
bob <## "SimpleX name privacy.simplex: nothing to connect to"
bob <## "reserved: community"
where
privacy = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "privacy" [])
testPlanNameReservedOther :: HasCallStack => TestParams -> IO ()
testPlanNameReservedOther = withAliceName $ \reg _l _alice bob -> do
registerReservedName reg acme NRRTrademark
bob ##> "/_connect plan 1 @acme.simplex"
bob <## "SimpleX name acme.simplex: nothing to connect to"
bob <## "reserved: trademark"
where
acme = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "acme" [])
testPlanNameNoValidLink :: HasCallStack => TestParams -> IO ()
testPlanNameNoValidLink = withAliceName $ \reg _l _alice bob -> do
registerName reg boogaloo (emptyNameRecord "boogaloo.simplex")
bob ##> "/_connect plan 1 @boogaloo.simplex"
bob <## "SimpleX name boogaloo.simplex: nothing to connect to"
bob <## "registered"
where
boogaloo = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "boogaloo" [])
testPlanKnownNameLive :: HasCallStack => TestParams -> IO ()
testPlanKnownNameLive = withAliceName $ \_reg _l alice bob -> do
connectBobByName alice bob
bob ##> "/_connect plan 1 @alice.simplex resolve=all"
bob <## "contact address: known contact alice"
bob <## "SimpleX name: @alice.simplex (verified)"
bob <## "use @alice <message> to send messages"
bob <## "registered"
testPlanKnownNameExpired :: HasCallStack => TestParams -> IO ()
testPlanKnownNameExpired = withAliceName $ \reg shortLink alice bob -> do
connectBobByName alice bob
registerExpiredName reg aliceSimplexName (contactNameRecord "alice.simplex" shortLink)
bob ##> "/_connect plan 1 @alice.simplex resolve=all"
bob <## "contact address: known contact alice"
bob <## "SimpleX name: @alice.simplex (verified)"
bob <## "use @alice <message> to send messages"
bob <##. "registered, expires "
testPlanKnownNameAvailable :: HasCallStack => TestParams -> IO ()
testPlanKnownNameAvailable = withAliceName $ \reg _l alice bob -> do
connectBobByName alice bob
unregisterName reg aliceSimplexName
bob ##> "/_connect plan 1 @alice.simplex resolve=all"
bob <## "contact address: known contact alice"
bob <## "SimpleX name: @alice.simplex (verified)"
bob <## "use @alice <message> to send messages"
bob <## "available: 1000 cents/year, min length 1"
testPlanOwnNameLive :: HasCallStack => TestParams -> IO ()
testPlanOwnNameLive = withAliceName $ \_reg _l alice _bob -> do
alice ##> "/_connect plan 1 @alice.simplex resolve=all"
alice <## "contact address: own address"
alice <## "registered"
testPlanOwnNameExpired :: HasCallStack => TestParams -> IO ()
testPlanOwnNameExpired = withAliceName $ \reg shortLink alice _bob -> do
registerExpiredName reg aliceSimplexName (contactNameRecord "alice.simplex" shortLink)
alice ##> "/_connect plan 1 @alice.simplex resolve=all"
alice <## "contact address: own address"
alice <##. "registered, expires "
testPlanOwnNameAvailable :: HasCallStack => TestParams -> IO ()
testPlanOwnNameAvailable = withAliceName $ \reg _l alice _bob -> do
unregisterName reg aliceSimplexName
alice ##> "/_connect plan 1 @alice.simplex resolve=all"
alice <## "contact address: own address"
alice <## "available: 1000 cents/year, min length 1"
testPlanNameResolveNever :: HasCallStack => TestParams -> IO ()
testPlanNameResolveNever = withAliceName $ \_reg _l alice bob -> do
connectBobByName alice bob
-- a hit answers from the store, with no registration attached
bob ##> "/_connect plan 1 @alice.simplex resolve=never"
bob <## "contact address: known contact alice"
bob <## "SimpleX name: @alice.simplex (verified)"
bob <## "use @alice <message> to send messages"
-- a miss is not resolved online, and is reported as such
bob ##> "/_connect plan 1 @nobody.simplex resolve=never"
bob <## "no matching chat found, name resolution is disabled"
-- 3c: bob has a chat found by alice.simplex, then the name is re-pointed at cath's address, which
-- claims it in turn. Only resolve=all re-resolves a name whose chat is known, and the plan that
-- comes back is the new address, marked as changed; bob's existing chat is what resolve=never returns.
testPlanKnownNameAddressChanged :: HasCallStack => TestParams -> IO ()
testPlanKnownNameAddressChanged ps = withSmpServerAndNames $ \reg ->
testChat3 aliceProfile bobProfile cathProfile (test reg) ps
where
test reg alice bob cath = do
mapM_ enableNamesRole [alice, bob, cath]
alice ##> "/ad"
(aliceLink, _) <- getContactLinks alice True
registerName reg aliceSimplexName (contactNameRecord "alice.simplex" (T.pack aliceLink))
alice ##> "/_set domain 1 alice.simplex"
alice <## "new contact address set"
connectBobByName alice bob
-- the name now leads to cath, who claims it
cath ##> "/ad"
(cathLink, _) <- getContactLinks cath True
registerName reg aliceSimplexName (contactNameRecord "alice.simplex" (T.pack cathLink))
cath ##> "/_set domain 1 alice.simplex"
cath <## "new contact address set"
-- resolve=unknown keeps answering from the store, so the move is not noticed
bob ##> "/_connect plan 1 @alice.simplex"
bob <## "contact address: known contact alice"
bob <## "SimpleX name: @alice.simplex (verified)"
bob <## "use @alice <message> to send messages"
bob <## "registered"
-- resolve=all re-resolves it and reports the new address
bob ##> "/_connect plan 1 @alice.simplex resolve=all"
bob <## "contact address: ok to connect, address changed"
-- the chat bob already has is still what a local-only lookup returns
bob ##> "/_connect plan 1 @alice.simplex resolve=never"
bob <## "contact address: known contact alice"
-- 2h: the registry could not be asked. As today, this stays an error rather than a plan.
testPlanNameResolverFailed :: HasCallStack => TestParams -> IO ()
testPlanNameResolverFailed = withAliceName $ \reg _l _alice bob -> do
failNameResolution reg broken
bob ##> "/_connect plan 1 @broken.simplex"
bob .<## "smpErr = NAME {nameErr = RESOLVER {resolverErr = \"HTTP 500\"}}}"
where
broken = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "broken" [])
tests/NameResolver.hs
+66 -12
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -9,6 +10,14 @@ module NameResolver
( NameRegistry,
withNameResolver,
registerName,
registerRegistration,
registerExpiredName,
registerReservedName,
registerAvailableName,
unregisterName,
failNameResolution,
testPricing,
emptyNameRecord,
contactNameRecord,
channelNameRecord,
contactAndChannelNameRecord,
@@ -22,37 +31,78 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Network.HTTP.Types (hContentType, notFound404, ok200)
import Network.HTTP.Types (hContentType, internalServerError500, notFound404, ok200)
import Network.Wai (Application, pathInfo, responseLBS)
import qualified Network.Wai.Handler.Warp as Warp
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Names.Record (NamePricing (..), NameRecord (..), NameRegistration (..), NameResponse (..), USDCents (..))
import Simplex.Messaging.Names.Record (NamePricing (..), NameRecord (..), NameRegistration (..), NameReservedReason, NameResponse (..), USDCents (..))
import Simplex.Messaging.Server.Names (NamesConfig (..))
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexNameInfo (..), labelHash)
import Simplex.Messaging.SystemTime (RoundedSystemTime (..), getSystemSeconds)
type NameRegistry = TVar (Map Text NameRecord)
-- what the test resolver answers for a name: a registration, or a failed request (2h)
data TestNameAnswer = AnswerRegistration NameRegistration | AnswerFails
type NameRegistry = TVar (Map Text TestNameAnswer)
-- | Run an action with a local resolver on a free port and its registry (keyed
-- by the query the resolver looks the name up by).
withNameResolver :: (Int -> TVar (Map Text NameRecord) -> IO a) -> IO a
withNameResolver :: (Int -> NameRegistry -> IO a) -> IO a
withNameResolver action = do
reg <- newTVarIO M.empty
Warp.withApplication (pure (app reg)) $ \port -> action port reg
where
app :: TVar (Map Text NameRecord) -> Application
app :: NameRegistry -> Application
app reg req send = do
(st, body) <- case pathInfo req of
["health"] -> pure (ok200, "{}")
["v2", "resolve", q] -> (\r -> (ok200, J.encode $ nameResponse r)) . M.lookup q <$> readTVarIO reg
["v2", "resolve", q] -> answer . M.lookup q <$> readTVarIO reg
_ -> pure (notFound404, "{}")
send $ responseLBS st [(hContentType, "application/json")] body
nameResponse (Just nameRecord) = NameResponse {lastBlockTs = Nothing, registration = NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord}}
nameResponse Nothing = NameResponse {lastBlockTs = Nothing, registration = NRAvailable {pricing = NamePricing {registrationPrices = M.empty, basePrice = USDCents 1000, minLabelLength = 1}}}
answer = \case
Just AnswerFails -> (internalServerError500, "{}")
Just (AnswerRegistration registration) -> (ok200, J.encode NameResponse {lastBlockTs = Nothing, registration})
Nothing -> (ok200, J.encode NameResponse {lastBlockTs = Nothing, registration = NRAvailable {pricing = testPricing 1}})
-- | Register a name's domain to resolve to the given record.
registerName :: TVar (Map Text NameRecord) -> SimplexNameInfo -> NameRecord -> IO ()
registerName reg SimplexNameInfo {nameDomain = SimplexDomain {nameTLD, domain}} r =
atomically $ modifyTVar' reg $ M.insert (decodeLatin1 $ strEncode (labelHash domain) <> strEncode nameTLD) r
-- | Register a name's domain to resolve to the given record, as a live registration.
registerName :: NameRegistry -> SimplexNameInfo -> NameRecord -> IO ()
registerName reg ni nameRecord =
registerRegistration reg ni NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord}
-- | Register any registration the registry could answer with.
registerRegistration :: NameRegistry -> SimplexNameInfo -> NameRegistration -> IO ()
registerRegistration reg ni r = atomically $ modifyTVar' reg $ M.insert (registryKey ni) (AnswerRegistration r)
-- | A name that expired a day ago, renewable by its owner for another 30 days.
registerExpiredName :: NameRegistry -> SimplexNameInfo -> NameRecord -> IO ()
registerExpiredName reg ni nameRecord = do
RoundedSystemTime now <- getSystemSeconds
let expires = Just $ RoundedSystemTime (now - 86400)
graceUntil = Just $ RoundedSystemTime (now + 30 * 86400)
registerRegistration reg ni NRRegistered {expires, graceUntil, reservedReason_ = Nothing, nameRecord}
-- | A name the registry holds back.
registerReservedName :: NameRegistry -> SimplexNameInfo -> NameReservedReason -> IO ()
registerReservedName reg ni reservedReason = registerRegistration reg ni NRReserved {reservedReason}
-- | A name that is free, priced with the given minimum label length.
registerAvailableName :: NameRegistry -> SimplexNameInfo -> Int -> IO ()
registerAvailableName reg ni minLen = registerRegistration reg ni NRAvailable {pricing = testPricing minLen}
-- | Make the resolver fail for this name, as a registry that is down or erroring would.
failNameResolution :: NameRegistry -> SimplexNameInfo -> IO ()
failNameResolution reg ni = atomically $ modifyTVar' reg $ M.insert (registryKey ni) AnswerFails
-- | Drop a name, so it resolves as available again.
unregisterName :: NameRegistry -> SimplexNameInfo -> IO ()
unregisterName reg ni = atomically $ modifyTVar' reg $ M.delete (registryKey ni)
registryKey :: SimplexNameInfo -> Text
registryKey SimplexNameInfo {nameDomain = SimplexDomain {nameTLD, domain}} =
decodeLatin1 $ strEncode (labelHash domain) <> strEncode nameTLD
testPricing :: Int -> NamePricing
testPricing minLabelLength = NamePricing {registrationPrices = M.empty, basePrice = USDCents 1000, minLabelLength}
contactNameRecord :: Text -> Text -> NameRecord
contactNameRecord name link = (emptyRecord name) {nrSimplexContact = [link]}
@@ -65,6 +115,10 @@ contactAndChannelNameRecord :: Text -> Text -> Text -> NameRecord
contactAndChannelNameRecord name contactLink channelLink =
(emptyRecord name) {nrSimplexContact = [contactLink], nrSimplexChannel = [channelLink]}
-- | A registered name whose record holds no usable link.
emptyNameRecord :: Text -> NameRecord
emptyNameRecord = emptyRecord
emptyRecord :: Text -> NameRecord
emptyRecord name =
NameRecord