simplex-chat/tests/RandomServers.hs
spaced4ndy fcae5e9925
core: fix validation of operator servers for non current users (#5205)
* core: fix validation of operator servers for non current users

* style

* refactor

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-11-18 20:22:35 +00:00

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}