core: fix preset relays population (#6707)

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

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