diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 0e04f154d1..8602fcf460 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index c3d5624cb1..5e3f9c848e 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -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") diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 007dc8af0b..839eac0884 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 diff --git a/tests/ChatTests/Names.hs b/tests/ChatTests/Names.hs index 8e37c5e2d2..b8e0b59364 100644 --- a/tests/ChatTests/Names.hs +++ b/tests/ChatTests/Names.hs @@ -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 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 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 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 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 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" []) diff --git a/tests/NameResolver.hs b/tests/NameResolver.hs index 3020e95833..ab1ed1fb1b 100644 --- a/tests/NameResolver.hs +++ b/tests/NameResolver.hs @@ -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