mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
fcae5e9925
* core: fix validation of operator servers for non current users * style * refactor --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
66 lines
2.7 KiB
Haskell
66 lines
2.7 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module RandomServers where
|
|
|
|
import Control.Monad (replicateM)
|
|
import Data.Foldable (foldMap')
|
|
import Data.List (sortOn)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.Monoid (Sum (..))
|
|
import Simplex.Chat (defaultChatConfig, chooseRandomServers)
|
|
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
|
import Simplex.Chat.Operators
|
|
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
|
|
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
|
|
import Test.Hspec
|
|
|
|
randomServersTests :: Spec
|
|
randomServersTests = describe "choosig random servers" $ do
|
|
it "should choose 4 + 3 random SMP servers and keep the rest disabled" testRandomSMPServers
|
|
it "should choose 3 + 3 random XFTP servers and keep the rest disabled" testRandomXFTPServers
|
|
|
|
deriving instance Eq ServerRoles
|
|
|
|
deriving instance Eq (UserServer' s p)
|
|
|
|
testRandomSMPServers :: IO ()
|
|
testRandomSMPServers = do
|
|
[srvs1, srvs2, srvs3] <-
|
|
replicateM 3 $
|
|
checkEnabled SPSMP 7 False =<< chooseRandomServers (presetServers defaultChatConfig)
|
|
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
|
|
|
testRandomXFTPServers :: IO ()
|
|
testRandomXFTPServers = do
|
|
[srvs1, srvs2, srvs3] <-
|
|
replicateM 3 $
|
|
checkEnabled SPXFTP 6 False =<< chooseRandomServers (presetServers defaultChatConfig)
|
|
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
|
|
|
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> NonEmpty (PresetOperator) -> IO [NewUserServer p]
|
|
checkEnabled p n allUsed presetOps' = do
|
|
let PresetServers {operators = presetOps} = presetServers defaultChatConfig
|
|
presetSrvs = sortOn server' $ concatMap (pServers p) presetOps
|
|
srvs' = sortOn server' $ concatMap (pServers p) presetOps'
|
|
Sum toUse = foldMap' (Sum . operatorServersToUse p) presetOps
|
|
Sum toUse' = foldMap' (Sum . operatorServersToUse p) presetOps'
|
|
length presetOps `shouldBe` length presetOps'
|
|
toUse `shouldBe` toUse'
|
|
srvs' == presetSrvs `shouldBe` allUsed
|
|
map enable srvs' `shouldBe` map enable presetSrvs
|
|
let enbldSrvs = filter (\UserServer {enabled} -> enabled) srvs'
|
|
toUse `shouldBe` n
|
|
length enbldSrvs `shouldBe` n
|
|
pure enbldSrvs
|
|
where
|
|
server' UserServer {server = ProtoServerWithAuth srv _} = srv
|
|
enable :: forall p. NewUserServer p -> NewUserServer p
|
|
enable srv = (srv :: NewUserServer p) {enabled = False}
|