mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-30 20:45:49 +00:00
97df069730
* core: add support for server operators * migration * update schema and queries, rfc * add usage conditions tables * core: server operators new apis draft * update * conditions * update * add get conditions api * add get conditions API * WIP * compiles * fix schema * core: ui logic in types (#5139) * update --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
54 lines
2.0 KiB
Haskell
54 lines
2.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
|
|
module RandomServers where
|
|
|
|
import Control.Monad (replicateM)
|
|
import qualified Data.List.NonEmpty as L
|
|
import Simplex.Chat (cfgServers, cfgServersToUse, defaultChatConfig, randomServers)
|
|
import Simplex.Chat.Controller (ChatConfig (..))
|
|
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..))
|
|
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
|
|
import Test.Hspec
|
|
|
|
randomServersTests :: Spec
|
|
randomServersTests = describe "choosig random servers" $ do
|
|
it "should choose 4 random SMP servers and keep the rest disabled" testRandomSMPServers
|
|
it "should keep all 6 XFTP servers" testRandomXFTPServers
|
|
|
|
deriving instance Eq ServerRoles
|
|
|
|
deriving instance Eq (ServerCfg p)
|
|
|
|
testRandomSMPServers :: IO ()
|
|
testRandomSMPServers = do
|
|
[srvs1, srvs2, srvs3] <-
|
|
replicateM 3 $
|
|
checkEnabled SPSMP 4 False =<< randomServers SPSMP defaultChatConfig
|
|
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
|
|
|
testRandomXFTPServers :: IO ()
|
|
testRandomXFTPServers = do
|
|
[srvs1, srvs2, srvs3] <-
|
|
replicateM 3 $
|
|
checkEnabled SPXFTP 6 True =<< randomServers SPXFTP defaultChatConfig
|
|
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` True
|
|
|
|
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> (L.NonEmpty (ServerCfg p), [ServerCfg p]) -> IO [ServerCfg p]
|
|
checkEnabled p n allUsed (srvs, _) = do
|
|
let def = defaultServers defaultChatConfig
|
|
cfgSrvs = L.sortWith server' $ cfgServers p def
|
|
toUse = cfgServersToUse p def
|
|
srvs == cfgSrvs `shouldBe` allUsed
|
|
L.map enable srvs `shouldBe` L.map enable cfgSrvs
|
|
let enbldSrvs = L.filter (\ServerCfg {enabled} -> enabled) srvs
|
|
toUse `shouldBe` n
|
|
length enbldSrvs `shouldBe` n
|
|
pure enbldSrvs
|
|
where
|
|
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
|
|
enable :: forall p. ServerCfg p -> ServerCfg p
|
|
enable srv = (srv :: ServerCfg p) {enabled = False}
|