mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-30 07:49:57 +00:00
d42cab8e22
* core: preset servers and operators (WIP) * usageConditionsToAdd * simplify * WIP * database entity IDs * preset operators and servers (compiles) * update (most tests pass) * remove imports * fix * update * make preset servers lists potentially empty in some operators, as long as the combined list is not empty * CLI API in progress, validateUserServers * make servers of disabled operators "unknown", consider only enabled servers when switching profile links * exclude disabled operators when receiving files * fix TH in ghc 8.10.7 * add type for ghc 8.10.7 * pattern match for ghc 8.10.7 * ghc 8.10.7 fix attempt * remove additional pattern, update servers * do not strip title from conditions * remove space --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
65 lines
2.6 KiB
Haskell
65 lines
2.6 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# 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 qualified Data.List.NonEmpty as L
|
|
import Data.Monoid (Sum (..))
|
|
import Simplex.Chat (defaultChatConfig, randomPresetServers)
|
|
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
|
import Simplex.Chat.Operators (DBEntityId' (..), NewUserServer, UserServer' (..), operatorServers, operatorServersToUse)
|
|
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 (DBEntityId' s)
|
|
|
|
deriving instance Eq (UserServer' s p)
|
|
|
|
testRandomSMPServers :: IO ()
|
|
testRandomSMPServers = do
|
|
[srvs1, srvs2, srvs3] <-
|
|
replicateM 3 $
|
|
checkEnabled SPSMP 7 False =<< randomPresetServers SPSMP (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 =<< randomPresetServers SPXFTP (presetServers defaultChatConfig)
|
|
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
|
|
|
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> NonEmpty (NewUserServer p) -> IO [NewUserServer p]
|
|
checkEnabled p n allUsed srvs = do
|
|
let srvs' = sortOn server' $ L.toList srvs
|
|
PresetServers {operators = presetOps} = presetServers defaultChatConfig
|
|
presetSrvs = sortOn server' $ concatMap (operatorServers p) presetOps
|
|
Sum toUse = foldMap' (Sum . operatorServersToUse p) presetOps
|
|
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}
|