diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index b0dda4aad1..557904a9a5 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -390,13 +390,14 @@ updatedServerOperators presetOps storedOps = -- This function should be used inside DB transaction to update servers. updatedUserServers :: (Maybe PresetOperator, UserOperatorServers) -> UpdatedUserOperatorServers -updatedUserServers (presetOp_, UserOperatorServers {operator, smpServers, xftpServers}) = - UpdatedUserOperatorServers {operator, smpServers = smp', xftpServers = xftp', chatRelays = []} +updatedUserServers (presetOp_, UserOperatorServers {operator, smpServers, xftpServers, chatRelays}) = + UpdatedUserOperatorServers {operator, smpServers = smp', xftpServers = xftp', chatRelays = cRelays'} where stored = map (AUS SDBStored) - (smp', xftp') = case presetOp_ of - Nothing -> (stored smpServers, stored xftpServers) - Just presetOp -> (updated SPSMP smpServers, updated SPXFTP xftpServers) + storedRelays = map (AUCR SDBStored) + (smp', xftp', cRelays') = case presetOp_ of + Nothing -> (stored smpServers, stored xftpServers, storedRelays chatRelays) + Just presetOp -> (updated SPSMP smpServers, updated SPXFTP xftpServers, updatedRelays chatRelays) where updated :: forall p. UserProtocol p => SProtocolType p -> [UserServer p] -> [AUserServer p] updated p srvs = map userServer presetSrvs <> stored (filter customServer srvs) @@ -411,10 +412,27 @@ updatedUserServers (presetOp_, UserOperatorServers {operator, smpServers, xftpSe presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs userServer :: NewUserServer p -> AUserServer p userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs) + updatedRelays :: [UserChatRelay] -> [AUserChatRelay] + updatedRelays relays = map userRelay presetRelays <> storedRelays (filter customRelay relays) + where + customRelay :: UserChatRelay -> Bool + customRelay UserChatRelay {preset, address} = + not preset && not (any (sameShortLinkContact address . chatRelayAddress) presetRelays) + presetRelays :: [NewUserChatRelay] + presetRelays = + let PresetOperator {chatRelays = crs} = presetOp + in crs + userRelay :: NewUserChatRelay -> AUserChatRelay + userRelay relay@UserChatRelay {address} = + maybe (AUCR SDBNew relay) (AUCR SDBStored) $ + find (sameShortLinkContact address . chatRelayAddress) relays srvHost :: UserServer' s p -> NonEmpty TransportHost srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv +chatRelayAddress :: UserChatRelay' s -> ShortLinkContact +chatRelayAddress UserChatRelay {address} = address + agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)] -> [UserServer' s p] -> [ServerCfg p] agentServerCfgs p opDomains = mapMaybe agentServer where diff --git a/tests/OperatorTests.hs b/tests/OperatorTests.hs index b63898ed68..d735a40bff 100644 --- a/tests/OperatorTests.hs +++ b/tests/OperatorTests.hs @@ -78,14 +78,17 @@ updatedServersTest = describe "validate user servers" $ do all addedPreset ops' `shouldBe` True let ops'' :: [(Maybe PresetOperator, Maybe ServerOperator)] = saveOps ops' -- mock getUpdateServerOperators - uss <- groupByOperator' (ops'', [], [], []) -- no stored servers + uss <- groupByOperator' (ops'', [], [], []) -- no stored servers or relays length uss `shouldBe` 3 [op1, op2, op3] <- pure $ map updatedUserServers uss [p1, p2] <- pure operators -- presets sameServers p1 op1 + sameRelays p1 op1 sameServers p2 op2 + sameRelays p2 op2 null (servers' SPSMP op3) `shouldBe` True null (servers' SPXFTP op3) `shouldBe` True + null (chatRelays' op3) `shouldBe` True it "adding preset operators and assigning servers to operator for existing users" $ do let ops' = updatedServerOperators operators [] ops'' = saveOps ops' @@ -94,25 +97,34 @@ updatedServersTest = describe "validate user servers" $ do ( ops'', saveSrvs $ take 3 simplexChatSMPServers <> [newUserServer "smp://abcd@smp.example.im"], saveSrvs $ map (presetServer True) $ L.take 3 defaultXFTPServers, - [] + saveRelays $ take 2 simplexChatRelays <> [newChatRelay "custom_relay" ["example.im"] customRelayAddr] ) [op1, op2, op3] <- pure $ map updatedUserServers uss [p1, p2] <- pure operators -- presets sameServers p1 op1 + sameRelays p1 op1 sameServers p2 op2 + sameRelays p2 op2 map srvHost' (servers' SPSMP op3) `shouldBe` [["smp.example.im"]] null (servers' SPXFTP op3) `shouldBe` True + map relayName' (chatRelays' op3) `shouldBe` ["custom_relay"] where addedPreset = \case (Just PresetOperator {operator = Just op}, Just (ASO SDBNew op')) -> operatorTag op == operatorTag op' _ -> False saveOps = zipWith (\i -> second ((\(ASO _ op) -> op {operatorId = DBEntityId i}) <$>)) [1 ..] saveSrvs = zipWith (\i srv -> srv {serverId = DBEntityId i}) [1 ..] + saveRelays = zipWith (\i relay -> relay {chatRelayId = DBEntityId i}) [1 ..] sameServers preset op = do map srvHost (pServers SPSMP preset) `shouldBe` map srvHost' (servers' SPSMP op) map srvHost (pServers SPXFTP preset) `shouldBe` map srvHost' (servers' SPXFTP op) + sameRelays PresetOperator {chatRelays = presetRelays} op = + map chatRelayAddress presetRelays `shouldBe` map relayAddr' (chatRelays' op) srvHost' (AUS _ s) = srvHost s + relayAddr' (AUCR _ r) = chatRelayAddress r + relayName' (AUCR _ UserChatRelay {name}) = name PresetServers {operators} = presetServers defaultChatConfig + customRelayAddr = either error id $ strDecode "https://relay.example.im/r#Pz9qz7ZVljMofoRxiDDpL_w2DZSazK8IgafxqnWKv6Y" deriving instance Eq User