diff --git a/package.yaml b/package.yaml index 2fc50a3532..7cf20c46e5 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ dependencies: - optparse-applicative >= 0.15 && < 0.17 - random >= 1.1 && < 1.3 - record-hasfield == 1.0.* + - scientific ==0.3.7.* - simple-logger == 0.1.* - simplexmq >= 5.0 - socks == 0.6.* diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c7d603457c..9f50bf7bd5 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -227,6 +227,7 @@ library , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplexmq >=5.0 , socks ==0.6.* @@ -291,6 +292,7 @@ executable simplex-bot , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=5.0 @@ -356,6 +358,7 @@ executable simplex-bot-advanced , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=5.0 @@ -424,6 +427,7 @@ executable simplex-broadcast-bot , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=5.0 @@ -490,6 +494,7 @@ executable simplex-chat , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=5.0 @@ -562,6 +567,7 @@ executable simplex-directory-service , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=5.0 @@ -663,6 +669,7 @@ test-suite simplex-chat-test , optparse-applicative >=0.15 && <0.17 , random >=1.1 && <1.3 , record-hasfield ==1.0.* + , scientific ==0.3.7.* , silently ==1.2.* , simple-logger ==0.1.* , simplex-chat diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index bcdef12fe2..cc9aa4431c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -463,10 +463,10 @@ withFileLock name = withEntityLock name . CLFile serverCfg :: ProtoServerWithAuth p -> ServerCfg p serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles} --- useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [UserServer p] -> [ProtocolServer p] --- useServers cfg p = \case --- [] -> map protoServer $ optsServers cfg p --- srvs -> map (\UserServer {server} -> protoServer server) srvs +useServers :: forall p. UserProtocol p => SProtocolType p -> RandomServers -> [UserServer p] -> NonEmpty (NewUserServer p) +useServers p rs servers = case L.nonEmpty servers of + Nothing -> rndServers p rs + Just srvs -> L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs rndServers :: UserProtocol p => SProtocolType p -> RandomServers -> NonEmpty (NewUserServer p) rndServers p RandomServers {smpServers, xftpServers} = case p of @@ -660,12 +660,10 @@ processChatCommand' vr = \case createContact db user simplexStatusContactProfile createContact db user simplexTeamContactProfile chooseServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (NewUserServer p)) - chooseServers p = - chatReadVar currentUser - $>>= (fmap L.nonEmpty . withFastStore' . flip getProtocolServers) - >>= \case - Nothing -> rndServers p <$> asks randomServers - Just srvs -> pure $ L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs + chooseServers p = do + rs <- asks randomServers + srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user) + pure $ useServers p rs $ fromMaybe [] srvs coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withFastStore' getUsersInfo @@ -1563,23 +1561,25 @@ processChatCommand' vr = \case msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs pure $ CRConnNtfMessages ntfMsgs - -- APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do - -- cfg@ChatConfig {defaultServers} <- asks config - -- srvs <- withFastStore' (`getProtocolServers` user) - -- (operators, _) <- withFastStore $ \db -> getServerOperators db - -- let servers = AUPS $ UserProtoServers p (useServers cfg p srvs) (cfgServers p defaultServers) - -- pure $ CRUserProtoServers {user, servers, operators} - -- GetUserProtoServers aProtocol -> withUser $ \User {userId} -> - -- processChatCommand $ APIGetUserProtoServers userId aProtocol - -- APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) - -- | null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do - -- withFastStore $ \db -> overwriteProtocolServers db user servers - -- cfg <- asks config - -- lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers - -- ok user - -- | otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled" - -- SetUserProtoServers serversConfig -> withUser $ \User {userId} -> - -- processChatCommand $ APISetUserProtoServers userId serversConfig + GetUserProtoServers (AProtocolType p) -> withUser $ \user@User {userId} -> withServerProtocol p $ do + (operators, smpServers, xftpServers) <- withFastStore (`getUserServers` user) + userServers <- liftIO $ groupByOperator $ case p of + SPSMP -> (operators, smpServers, []) + SPXFTP -> (operators, [], xftpServers) + pure $ CRUserServers user userServers + SetUserProtoServers (AProtocolType p) servers -> withUser $ \user@User {userId} -> withServerProtocol p $ do + userServers <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) + -- disable operators servers and repace (or add) custom servers, or restore random defaults if empty list + case L.nonEmpty userServers of + Just srvs -> processChatCommand $ APISetUserServers userId $ L.map updated srvs + where + updated UserOperatorServers {operator, smpServers, xftpServers} = + UpdatedUserOperatorServers + { operator, + smpServers = map (AUS SDBStored) smpServers, + xftpServers = map (AUS SDBStored) xftpServers + } + Nothing -> throwChatError $ CECommandError "no servers" APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) TestProtoServer srv -> withUser $ \User {userId} -> @@ -1588,21 +1588,22 @@ processChatCommand' vr = \case APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do liftIO $ setServerOperators db operatorsEnabled uncurry CRServerOperators <$> getServerOperators db - APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do - (operators, _) <- getServerOperators db - liftIO $ do - smpServers <- getProtocolServers @'PSMP db user - xftpServers <- getProtocolServers @'PXFTP db user - CRUserServers user <$> groupByOperator operators smpServers xftpServers + APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> + CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user) APISetUserServers userId userServers -> withUserId userId $ \user -> do let errors = validateUserServers userServers unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors) - withFastStore $ \db -> setUserServers db user userServers - -- TODO set protocol servers for agent + (operators, smpServers, xftpServers) <- withFastStore $ \db -> do + setUserServers db user userServers + getUserServers db user + let opDomains = operatorDomains operators + rs <- asks randomServers + lift $ withAgent' $ \a -> do + let auId = aUserId user + setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPSMP rs smpServers + setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPXFTP rs xftpServers ok_ - APIValidateServers userServers -> do - let errors = validateUserServers userServers - pure $ CRUserServersValidation errors + APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers userServers APIGetUsageConditions -> do (usageConditions, acceptedConditions) <- withFastStore $ \db -> do usageConditions <- getCurrentUsageConditions db @@ -1875,7 +1876,7 @@ processChatCommand' vr = \case canKeepLink (CRInvitationUri crData _) newUser = do let ConnReqUriData {crSmpQueues = q :| _} = crData SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q - newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (`getProtocolServers` newUser) + newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (\db -> getProtocolServers db SPSMP newUser) pure $ smpServer `elem` newUserServers updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) @@ -2615,7 +2616,7 @@ processChatCommand' vr = \case pure $ CRAgentServersSummary user presentedServersSummary where getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] - getServers db user _p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db user + getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails @@ -3733,7 +3734,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] getUnknownSrvs srvs = do - knownSrvs <- map (\UserServer {server} -> protoServer server) <$> withStore' (`getProtocolServers` user) + knownSrvs <- map (\UserServer {server} -> protoServer server) <$> withStore' (\db -> getProtocolServers db SPXFTP user) pure $ filter (`notElem` knownSrvs) srvs ipProtectedForSrvs :: [XFTPServer] -> CM Bool ipProtectedForSrvs srvs = do @@ -8203,14 +8204,12 @@ chatCommandP = "/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP), "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), - -- "/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP), - -- "/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), - -- "/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []), - -- "/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), - -- "/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []), - -- "/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP), - -- "/smp" $> GetUserProtoServers (AProtocolType SPSMP), - -- "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), + "/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP), + "/smp default" $> SetUserProtoServers (AProtocolType SPSMP) [], + "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP), + "/xftp default" $> SetUserProtoServers (AProtocolType SPXFTP) [], + "/smp" $> GetUserProtoServers (AProtocolType SPSMP), + "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), "/_operators" $> APIGetServerOperators, "/_operators " *> (APISetServerOperators <$> jsonP), "/_servers " *> (APIGetUserServers <$> A.decimal), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 2c062f757d..92462c173a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -349,17 +349,15 @@ data ChatCommand | APIGetGroupLink GroupId | APICreateMemberContact GroupId GroupMemberId | APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent} - | -- | APIGetUserProtoServers UserId AProtocolType - -- | GetUserProtoServers AProtocolType - -- | APISetUserProtoServers UserId AProtoServersConfig - -- | SetUserProtoServers AProtoServersConfig - APITestProtoServer UserId AProtoServerWithAuth + | GetUserProtoServers AProtocolType + | SetUserProtoServers AProtocolType [AProtoServerWithAuth] + | APITestProtoServer UserId AProtoServerWithAuth | TestProtoServer AProtoServerWithAuth | APIGetServerOperators | APISetServerOperators (NonEmpty ServerOperator) | APIGetUserServers UserId - | APISetUserServers UserId (NonEmpty UserOperatorServers) - | APIValidateServers (NonEmpty UserOperatorServers) -- response is CRUserServersValidation + | APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers) + | APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation | APIGetUsageConditions | APISetConditionsNotified Int64 | APIAcceptConditions Int64 (NonEmpty Int64) @@ -588,8 +586,7 @@ data ChatResponse | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo} | CRChatItemId User (Maybe ChatItemId) | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} - | -- | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]} - CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} + | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction} | CRUserServers {user :: User, userServers :: [UserOperatorServers]} | CRUserServersValidation {serverErrors :: [UserServersError]} diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 59b079bcfc..bad6c250b4 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -13,10 +13,12 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Operators where +import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE @@ -30,13 +32,15 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Scientific (floatingOrInteger) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime, nominalDay) +import Data.Type.Equality import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import Language.Haskell.TH.Syntax (lift) @@ -45,9 +49,9 @@ import Simplex.Chat.Types.Util (textParseJSON) import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8) +import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8, (<$?>)) usageConditionsCommit :: Text usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c" @@ -67,6 +71,19 @@ data SDBStored (s :: DBStored) where SDBStored :: SDBStored 'DBStored SDBNew :: SDBStored 'DBNew +deriving instance Show (SDBStored s) + +class DBStoredI s where sdbStored :: SDBStored s + +instance DBStoredI 'DBStored where sdbStored = SDBStored + +instance DBStoredI 'DBNew where sdbStored = SDBNew + +instance TestEquality SDBStored where + testEquality SDBStored SDBStored = Just Refl + testEquality SDBNew SDBNew = Just Refl + testEquality _ _ = Nothing + data DBEntityId' (s :: DBStored) where DBEntityId :: Int64 -> DBEntityId' 'DBStored DBNewEntity :: DBEntityId' 'DBNew @@ -77,7 +94,7 @@ type DBEntityId = DBEntityId' 'DBStored type DBNewEntity = DBEntityId' 'DBNew -data ADBEntityId = forall s. AEI (SDBStored s) (DBEntityId' s) +data ADBEntityId = forall s. DBStoredI s => AEI (SDBStored s) (DBEntityId' s) pattern ADBEntityId :: Int64 -> ADBEntityId pattern ADBEntityId i = AEI SDBStored (DBEntityId i) @@ -161,6 +178,8 @@ type NewServerOperator = ServerOperator' 'DBNew data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s) +deriving instance Show AServerOperator + data ServerOperator' s = ServerOperator { operatorId :: DBEntityId' s, operatorTag :: Maybe OperatorTag, @@ -185,18 +204,33 @@ data UserOperatorServers = UserOperatorServers } deriving (Show) +data UpdatedUserOperatorServers = UpdatedUserOperatorServers + { operator :: Maybe ServerOperator, + smpServers :: [AUserServer 'PSMP], + xftpServers :: [AUserServer 'PXFTP] + } + deriving (Show) + +updatedServers :: UserProtocol p => UpdatedUserOperatorServers -> SProtocolType p -> [AUserServer p] +updatedServers UpdatedUserOperatorServers {smpServers, xftpServers} = \case + SPSMP -> smpServers + SPXFTP -> xftpServers + type UserServer p = UserServer' 'DBStored p type NewUserServer p = UserServer' 'DBNew p data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p) +deriving instance Show (AUserServer p) + data UserServer' s p = UserServer { serverId :: DBEntityId' s, server :: ProtoServerWithAuth p, preset :: Bool, tested :: Maybe Bool, - enabled :: Bool + enabled :: Bool, + deleted :: Bool } deriving (Show) @@ -220,7 +254,7 @@ operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p presetServer enabled server = - UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled} + UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled, deleted = False} -- This function should be used inside DB transaction to update conditions in the database -- it evaluates to (conditions to mark as accepted to SimpleX operator, current conditions, and conditions to add) @@ -268,9 +302,9 @@ updatedServerOperators presetOps storedOps = updatedUserServers :: forall p. UserProtocol p => SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p) updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs updatedUserServers p presetOps randomSrvs srvs = - fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedServers) + fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedSrvs) where - updatedServers = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs) + updatedSrvs = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs) storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p) storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs customServer :: UserServer p -> Bool @@ -304,8 +338,8 @@ matchingHost d = \case operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)] operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) [] -groupByOperator :: [ServerOperator] -> [UserServer 'PSMP] -> [UserServer 'PXFTP] -> IO [UserOperatorServers] -groupByOperator ops smpSrvs xftpSrvs = do +groupByOperator :: ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers] +groupByOperator (ops, smpSrvs, xftpSrvs) = do ss <- mapM (\op -> (serverDomains op,) <$> newIORef (UserOperatorServers (Just op) [] [])) ops custom <- newIORef $ UserOperatorServers Nothing [] [] mapM_ (addServer ss custom addSMP) (reverse smpSrvs) @@ -316,67 +350,98 @@ groupByOperator ops smpSrvs xftpSrvs = do addServer ss custom add srv = let v = maybe custom snd $ find (\(ds, _) -> any (\d -> any (matchingHost d) (srvHost srv)) ds) ss in atomicModifyIORef'_ v $ add srv - addSMP srv s@UserOperatorServers {smpServers} = s {smpServers = srv : smpServers} - addXFTP srv s@UserOperatorServers {xftpServers} = s {xftpServers = srv : xftpServers} + addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers} + addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers} data UserServersError - = USEStorageMissing - | USEProxyMissing - | USEDuplicateSMP {server :: AProtoServerWithAuth} - | USEDuplicateXFTP {server :: AProtoServerWithAuth} + = USEStorageMissing {protocol :: AProtocolType} + | USEProxyMissing {protocol :: AProtocolType} + | USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost} deriving (Show) -validateUserServers :: NonEmpty UserOperatorServers -> [UserServersError] -validateUserServers userServers = - let storageMissing_ = if any (canUseForRole storage) userServers then [] else [USEStorageMissing] - proxyMissing_ = if any (canUseForRole proxy) userServers then [] else [USEProxyMissing] - allSMPServers = map (\UserServer {server} -> server) $ concatMap (\UserOperatorServers {smpServers} -> smpServers) userServers - duplicateSMPServers = findDuplicatesByHost allSMPServers - duplicateSMPErrors = map (USEDuplicateSMP . AProtoServerWithAuth SPSMP) duplicateSMPServers - - allXFTPServers = map (\UserServer {server} -> server) $ concatMap (\UserOperatorServers {xftpServers} -> xftpServers) userServers - duplicateXFTPServers = findDuplicatesByHost allXFTPServers - duplicateXFTPErrors = map (USEDuplicateXFTP . AProtoServerWithAuth SPXFTP) duplicateXFTPServers - in storageMissing_ <> proxyMissing_ <> duplicateSMPErrors <> duplicateXFTPErrors +validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError] +validateUserServers uss = + missingRolesErr SPSMP storage USEStorageMissing + <> missingRolesErr SPSMP proxy USEProxyMissing + <> missingRolesErr SPXFTP storage USEStorageMissing + <> duplicatServerErrs SPSMP + <> duplicatServerErrs SPXFTP where - canUseForRole :: (ServerRoles -> Bool) -> UserOperatorServers -> Bool - canUseForRole roleSel UserOperatorServers {operator, smpServers, xftpServers} = case operator of - Just ServerOperator {roles} -> roleSel roles - Nothing -> not (null smpServers) && not (null xftpServers) - findDuplicatesByHost :: [ProtoServerWithAuth p] -> [ProtoServerWithAuth p] - findDuplicatesByHost servers = - let allHosts = concatMap (L.toList . host . protoServer) servers - hostCounts = M.fromListWith (+) [(host, 1 :: Int) | host <- allHosts] - duplicateHosts = M.keys $ M.filter (> 1) hostCounts - in filter (\srv -> any (`elem` duplicateHosts) (L.toList $ host . protoServer $ srv)) servers + missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError] + missingRolesErr p roleSel err = [err (AProtocolType p) | hasRole] + where + hasRole = + any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $ + concatMap (`updatedServers` p) $ filter roleEnabled (L.toList uss) + roleEnabled UpdatedUserOperatorServers {operator} = + maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) operator + duplicatServerErrs :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServersError] + duplicatServerErrs p = mapMaybe duplicateErr_ srvs + where + srvs = + filter (\(AUS _ UserServer {deleted}) -> not deleted) $ + concatMap (`updatedServers` p) (L.toList uss) + duplicateErr_ (AUS _ srv@UserServer {server}) = + USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server) + <$> find (`S.member` duplicateHosts) (srvHost srv) + duplicateHosts = snd $ foldl' (\acc (AUS _ srv) -> foldl' addHost acc $ srvHost srv) (S.empty, S.empty) srvs + addHost (hs, dups) h + | h `S.member` hs = (hs, S.insert h dups) + | otherwise = (S.insert h hs, dups) -instance ToJSON DBEntityId where - toEncoding (DBEntityId i) = toEncoding i - toJSON (DBEntityId i) = toJSON i +instance ToJSON ADBEntityId where + toEncoding (AEI _ dbId) = toEncoding dbId + toJSON (AEI _ dbId) = toJSON dbId -instance FromJSON DBEntityId where - parseJSON v = DBEntityId <$> parseJSON v +instance ToJSON (DBEntityId' s) where + toEncoding = \case + DBEntityId i -> toEncoding i + DBNewEntity -> JE.null_ + toJSON = \case + DBEntityId i -> toJSON i + DBNewEntity -> J.Null + +instance FromJSON ADBEntityId where + parseJSON (J.Null) = pure $ AEI SDBNew DBNewEntity + parseJSON (J.Number n) = case floatingOrInteger n of + Left (_ :: Double) -> fail "bad ADBEntityId" + Right i -> pure $ AEI SDBStored (DBEntityId $ fromInteger i) + parseJSON _ = fail "bad ADBEntityId" + +instance DBStoredI s => FromJSON (DBEntityId' s) where + parseJSON v = (\(AEI _ dbId) -> checkDBStored dbId) <$?> parseJSON v + +checkDBStored :: forall t s s'. (DBStoredI s, DBStoredI s') => t s' -> Either String (t s) +checkDBStored x = case testEquality (sdbStored @s) (sdbStored @s') of + Just Refl -> Right x + Nothing -> Left "bad DBStored" $(JQ.deriveJSON defaultJSON ''UsageConditions) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance) -instance ToJSON ServerOperator where +instance ToJSON (ServerOperator' s) where toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator') toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator') -instance FromJSON ServerOperator where +instance DBStoredI s => FromJSON (ServerOperator' s) where parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator') $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction) -instance ProtocolTypeI p => ToJSON (UserServer p) where +instance ProtocolTypeI p => ToJSON (UserServer' s p) where toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer') toJSON = $(JQ.mkToJSON defaultJSON ''UserServer') -instance ProtocolTypeI p => FromJSON (UserServer p) where +instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer') +instance ProtocolTypeI p => FromJSON (AUserServer p) where + parseJSON v = (AUS SDBStored <$> parseJSON v) <|> (AUS SDBNew <$> parseJSON v) + $(JQ.deriveJSON defaultJSON ''UserOperatorServers) +instance FromJSON UpdatedUserOperatorServers where + parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 434a247e1e..23cb391ecb 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -55,6 +56,7 @@ module Simplex.Chat.Store.Profiles insertProtocolServer, getUpdateServerOperators, getServerOperators, + getUserServers, setServerOperators, getCurrentUsageConditions, getLatestAcceptedConditions, @@ -106,7 +108,7 @@ import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) -import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol) +import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) @@ -533,28 +535,17 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO (NonEmpty (UserServer p)) getUpdateUserServers db p presetOps randomSrvs user = do ts <- getCurrentTime - srvs <- getProtocolServers db user + srvs <- getProtocolServers db p user let srvs' = updatedUserServers p presetOps randomSrvs srvs mapM (upsertServer ts) srvs' where upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p) upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of DBNewEntity -> insertProtocolServer db p user ts s - DBEntityId _ -> updateServer ts s $> s - updateServer :: UTCTime -> UserServer p -> IO () - updateServer ts UserServer {serverId, server, preset, tested, enabled} = - DB.execute - db - [sql| - UPDATE protocol_servers - SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?, - preset = ?, tested = ?, enabled = ?, updated_at = ? - WHERE smp_server_id = ? - |] - (serverColumns p server :. (preset, tested, enabled, ts, serverId)) + DBEntityId _ -> updateProtocolServer db p ts s $> s -getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [UserServer p] -getProtocolServers db User {userId} = +getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p] +getProtocolServers db p User {userId} = map toUserServer <$> DB.query db @@ -563,13 +554,12 @@ getProtocolServers db User {userId} = FROM protocol_servers WHERE user_id = ? AND protocol = ? |] - (userId, decodeLatin1 $ strEncode protocol) + (userId, decodeLatin1 $ strEncode p) where - protocol = protocolTypeI @p toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) = - let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) - in UserServer {serverId, server, preset, tested, enabled} + let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) + in UserServer {serverId, server, preset, tested, enabled, deleted = False} -- TODO remove -- overwriteOperatorsAndServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> Maybe [ServerOperator] -> [ServerCfg p] -> ExceptT StoreError IO [ServerCfg p] @@ -604,6 +594,18 @@ insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, teste sId <- insertedRowId db pure (srv :: NewUserServer p) {serverId = DBEntityId sId} +updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO () +updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} = + DB.execute + db + [sql| + UPDATE protocol_servers + SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?, + preset = ?, tested = ?, enabled = ?, updated_at = ? + WHERE smp_server_id = ? + |] + (serverColumns p server :. (preset, tested, enabled, ts, serverId)) + serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text) serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) = let protocol = decodeLatin1 $ strEncode p @@ -620,13 +622,28 @@ getServerOperators db = do operators <- mapM getConds =<< getServerOperators_ db pure (operators, usageConditionsAction operators currentConds now) +getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) +getUserServers db user = + (,,) + <$> (fst <$> getServerOperators db) + <*> liftIO (getProtocolServers db SPSMP user) + <*> liftIO (getProtocolServers db SPXFTP user) + setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO () -setServerOperators db = - mapM_ $ \ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} -> - DB.execute - db - "UPDATE server_operators SET enabled = ?, role_storage = ?, role_proxy = ? WHERE server_operator_id = ?" - (enabled, storage, proxy, operatorId) +setServerOperators db ops = do + currentTs <- getCurrentTime + mapM_ (updateServerOperator db currentTs) ops + +updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO () +updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} = + DB.execute + db + [sql| + UPDATE server_operators + SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ? + WHERE server_operator_id = ? + |] + (enabled, storage, proxy, operatorId, currentTs) getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator] getUpdateServerOperators db presetOps newUser = do @@ -804,46 +821,20 @@ getUsageConditionsById_ db conditionsId = |] (Only conditionsId) -setUserServers :: DB.Connection -> User -> NonEmpty UserOperatorServers -> ExceptT StoreError IO () -setUserServers db User {userId} userServers = do - currentTs <- liftIO getCurrentTime - forM_ userServers $ do - \UserOperatorServers {operator, smpServers, xftpServers} -> do - forM_ operator $ \op -> liftIO $ updateOperator currentTs op - overwriteServers SPSMP currentTs operator smpServers - overwriteServers SPXFTP currentTs operator xftpServers +setUserServers :: DB.Connection -> User -> NonEmpty UpdatedUserOperatorServers -> ExceptT StoreError IO () +setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ liftIO $ do + ts <- getCurrentTime + forM_ userServers $ \UpdatedUserOperatorServers {operator, smpServers, xftpServers} -> do + mapM_ (updateServerOperator db ts) operator + mapM_ (upsertOrDelete SPSMP ts) smpServers + mapM_ (upsertOrDelete SPXFTP ts) xftpServers where - updateOperator :: UTCTime -> ServerOperator -> IO () - updateOperator currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} = - DB.execute - db - [sql| - UPDATE server_operators - SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ? - WHERE server_operator_id = ? - |] - (enabled, storage, proxy, operatorId, currentTs) - overwriteServers :: ProtocolTypeI p => SProtocolType p -> UTCTime -> Maybe ServerOperator -> [UserServer p] -> ExceptT StoreError IO () - overwriteServers p currentTs serverOperator servers = - checkConstraint SEUniqueID . ExceptT $ do - case serverOperator of - Nothing -> - DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id IS NULL AND protocol = ?" (userId, protocol) - Just ServerOperator {operatorId} -> - DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id = ? AND protocol = ?" (userId, operatorId, protocol) - forM_ servers $ \UserServer {serverId, server, tested, enabled} -> do - DB.execute - db - [sql| - INSERT INTO protocol_servers - (server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - (Only serverId :. serverColumns p server :. (tested, enabled, userId, currentTs, currentTs)) - -- take preset from operator - pure $ Right () - where - protocol = decodeLatin1 $ strEncode p + upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO () + upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of + DBNewEntity -> void $ insertProtocolServer db p user ts s + DBEntityId srvId + | deleted -> DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False) + | otherwise -> updateProtocolServer db p ts s createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 39e0599150..7d5dc67d24 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -79,10 +79,10 @@ chatDirectTests = do it "own invitation link" testPlanInvitationLinkOwn it "connecting via invitation link" testPlanInvitationLinkConnecting describe "SMP servers" $ do - xit "get and set SMP servers" testGetSetSMPServers + it "get and set SMP servers" testGetSetSMPServers it "test SMP server connection" testTestSMPServerConnection describe "XFTP servers" $ do - xit "get and set XFTP servers" testGetSetXFTPServers + it "get and set XFTP servers" testGetSetXFTPServers it "test XFTP server connection" testTestXFTPServer describe "async connection handshake" $ do describe "connect when initiating client goes offline" $ do @@ -116,7 +116,7 @@ chatDirectTests = do it "create second user" testCreateSecondUser it "multiple users subscribe and receive messages after restart" testUsersSubscribeAfterRestart it "both users have contact link" testMultipleUserAddresses - xit "create user with same servers" testCreateUserSameServers + it "create user with same servers" testCreateUserSameServers it "delete user" testDeleteUser it "users have different chat item TTL configuration, chat items expire" testUsersDifferentCIExpirationTTL it "chat items expire after restart for all users according to per user configuration" testUsersRestartCIExpiration diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index d98a818db4..d5dff9fde6 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -76,7 +76,7 @@ chatProfileTests = do it "change user for pending connection" testChangePCCUser it "change from incognito profile connects as new user" testChangePCCUserFromIncognito it "change user for pending connection and later set incognito connects as incognito in changed profile" testChangePCCUserAndThenIncognito - xit "change user for user without matching servers creates new connection" testChangePCCUserDiffSrv + it "change user for user without matching servers creates new connection" testChangePCCUserDiffSrv describe "preferences" $ do it "set contact preferences" testSetContactPrefs it "feature offers" testFeatureOffers diff --git a/tests/RandomServers.hs b/tests/RandomServers.hs index 63e46ea88c..8b0b94dbd5 100644 --- a/tests/RandomServers.hs +++ b/tests/RandomServers.hs @@ -1,56 +1,64 @@ +{-# 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 (..)) -import Simplex.Chat.Operators (operatorServers, operatorServersToUse) -import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..)) +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 random SMP servers and keep the rest disabled" testRandomSMPServers - it "should keep all 6 XFTP servers" testRandomXFTPServers + 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 (ServerCfg p) +deriving instance Eq (DBEntityId' s) + +deriving instance Eq (UserServer' s p) testRandomSMPServers :: IO () testRandomSMPServers = do - pure () - -- [srvs1, srvs2, srvs3] <- - -- replicateM 3 $ - -- checkEnabled SPSMP 4 False =<< randomServers SPSMP defaultChatConfig - -- (srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures + [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 - pure () - -- [srvs1, srvs2, srvs3] <- - -- replicateM 3 $ - -- checkEnabled SPXFTP 6 True =<< randomServers SPXFTP defaultChatConfig - -- (srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` True + [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 -> (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} +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}