mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: use random servers for each operator (#5192)
* core: use random servers for each operator (WIP, compiles with undefined stub) * compiles * fix some, break some * tests pass * cleanup * delays in tests * enable random servers test * remove new preset servers in down migration * fix migration * test
This commit is contained in:
Evgeny
GitHub
parent
3d4a47cdae
commit
619985730e
11 changed files with 319 additions and 248 deletions
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
|
@ -178,6 +179,8 @@ defaultChatConfig =
|
|||
},
|
||||
chatVRange = supportedChatVRange,
|
||||
confirmMigrations = MCConsole,
|
||||
-- this property should NOT use operator = Nothing
|
||||
-- non-operator servers can be passed via options
|
||||
presetServers =
|
||||
PresetServers
|
||||
{ operators =
|
||||
|
|
@ -310,11 +313,15 @@ newChatController
|
|||
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
|
||||
firstTime = dbNew chatStore
|
||||
currentUser <- newTVarIO user
|
||||
randomSMP <- randomPresetServers SPSMP presetServers'
|
||||
randomXFTP <- randomPresetServers SPXFTP presetServers'
|
||||
let randomServers = RandomServers {smpServers = randomSMP, xftpServers = randomXFTP}
|
||||
randomPresetServers <- chooseRandomServers presetServers'
|
||||
let rndSrvs = L.toList randomPresetServers
|
||||
operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op
|
||||
opDomains = operatorDomains $ mapMaybe operatorWithId $ zip [1..] rndSrvs
|
||||
agentSMP <- randomServerCfgs "agent SMP servers" SPSMP opDomains rndSrvs
|
||||
agentXFTP <- randomServerCfgs "agent XFTP servers" SPXFTP opDomains rndSrvs
|
||||
let randomAgentServers = RandomAgentServers {smpServers = agentSMP, xftpServers = agentXFTP}
|
||||
currentRemoteHost <- newTVarIO Nothing
|
||||
servers <- withTransaction chatStore $ \db -> agentServers db config randomServers
|
||||
servers <- withTransaction chatStore $ \db -> agentServers db config randomPresetServers randomAgentServers
|
||||
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
|
||||
agentAsync <- newTVarIO Nothing
|
||||
random <- liftIO C.newRandom
|
||||
|
|
@ -350,7 +357,8 @@ newChatController
|
|||
ChatController
|
||||
{ firstTime,
|
||||
currentUser,
|
||||
randomServers,
|
||||
randomPresetServers,
|
||||
randomAgentServers,
|
||||
currentRemoteHost,
|
||||
smpAgent,
|
||||
agentAsync,
|
||||
|
|
@ -410,19 +418,26 @@ newChatController
|
|||
xftp = map newUserServer xftpSrvs,
|
||||
useXFTP = 0
|
||||
}
|
||||
agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers
|
||||
agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} rs = do
|
||||
randomServerCfgs :: UserProtocol p => String -> SProtocolType p -> [(Text, ServerOperator)] -> [PresetOperator] -> IO (NonEmpty (ServerCfg p))
|
||||
randomServerCfgs name p opDomains rndSrvs =
|
||||
toJustOrError name $ L.nonEmpty $ agentServerCfgs p opDomains $ concatMap (pServers p) rndSrvs
|
||||
agentServers :: DB.Connection -> ChatConfig -> NonEmpty PresetOperator -> RandomAgentServers -> IO InitialAgentServers
|
||||
agentServers db ChatConfig {presetServers = PresetServers {ntf, netCfg}} presetOps as = do
|
||||
users <- getUsers db
|
||||
opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users)
|
||||
smp' <- getServers SPSMP users opDomains
|
||||
xftp' <- getServers SPXFTP users opDomains
|
||||
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
|
||||
ops <- getUpdateServerOperators db presetOps (null users)
|
||||
let opDomains = operatorDomains $ mapMaybe snd ops
|
||||
(smp', xftp') <- unzip <$> mapM (getServers ops opDomains) users
|
||||
pure InitialAgentServers {smp = M.fromList smp', xftp = M.fromList xftp', ntf, netCfg}
|
||||
where
|
||||
getServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p)))
|
||||
getServers p users opDomains = do
|
||||
let rs' = rndServers p rs
|
||||
fmap M.fromList $ forM users $ \u ->
|
||||
(aUserId u,) . agentServerCfgs p opDomains rs' <$> getUpdateUserServers db p presetOps rs' u
|
||||
getServers :: [(Maybe PresetOperator, Maybe ServerOperator)] -> [(Text, ServerOperator)] -> User -> IO ((UserId, NonEmpty (ServerCfg 'PSMP)), (UserId, NonEmpty (ServerCfg 'PXFTP)))
|
||||
getServers ops opDomains user' = do
|
||||
smpSrvs <- getProtocolServers db SPSMP user'
|
||||
xftpSrvs <- getProtocolServers db SPXFTP user'
|
||||
uss <- groupByOperator' (ops, smpSrvs, xftpSrvs)
|
||||
ts <- getCurrentTime
|
||||
uss' <- mapM (setUserServers' db user' ts . updatedUserServers) uss
|
||||
let auId = aUserId user'
|
||||
pure $ bimap (auId,) (auId,) $ useServers as opDomains uss'
|
||||
|
||||
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
|
||||
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} =
|
||||
|
|
@ -465,28 +480,31 @@ withFileLock :: String -> Int64 -> CM a -> CM a
|
|||
withFileLock name = withEntityLock name . CLFile
|
||||
{-# INLINE withFileLock #-}
|
||||
|
||||
serverCfg :: ProtoServerWithAuth p -> ServerCfg p
|
||||
serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles}
|
||||
useServers :: Foldable f => RandomAgentServers -> [(Text, ServerOperator)] -> f UserOperatorServers -> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
|
||||
useServers as opDomains uss =
|
||||
let smp' = useServerCfgs SPSMP as opDomains $ concatMap (servers' SPSMP) uss
|
||||
xftp' = useServerCfgs SPXFTP as opDomains $ concatMap (servers' SPXFTP) uss
|
||||
in (smp', xftp')
|
||||
|
||||
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
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
randomPresetServers :: forall p. UserProtocol p => SProtocolType p -> PresetServers -> IO (NonEmpty (NewUserServer p))
|
||||
randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =<< mapM opSrvs operators
|
||||
useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p)
|
||||
useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains =
|
||||
fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains
|
||||
where
|
||||
toJust = \case
|
||||
Just a -> pure a
|
||||
Nothing -> E.throwIO $ userError "no preset servers"
|
||||
opSrvs :: PresetOperator -> IO [NewUserServer p]
|
||||
opSrvs op = do
|
||||
let srvs = operatorServers p op
|
||||
rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p)
|
||||
rndAgentServers = \case
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
chooseRandomServers :: PresetServers -> IO (NonEmpty PresetOperator)
|
||||
chooseRandomServers PresetServers {operators} =
|
||||
forM operators $ \op -> do
|
||||
smp' <- opSrvs SPSMP op
|
||||
xftp' <- opSrvs SPXFTP op
|
||||
pure (op :: PresetOperator) {smp = smp', xftp = xftp'}
|
||||
where
|
||||
opSrvs :: forall p. UserProtocol p => SProtocolType p -> PresetOperator -> IO [NewUserServer p]
|
||||
opSrvs p op = do
|
||||
let srvs = pServers p op
|
||||
toUse = operatorServersToUse p op
|
||||
(enbldSrvs, dsbldSrvs) = partition (\UserServer {enabled} -> enabled) srvs
|
||||
if toUse <= 0 || toUse >= length enbldSrvs
|
||||
|
|
@ -497,6 +515,13 @@ randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =
|
|||
pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
|
||||
server' UserServer {server = ProtoServerWithAuth srv _} = srv
|
||||
|
||||
toJustOrError :: String -> Maybe a -> IO a
|
||||
toJustOrError name = \case
|
||||
Just a -> pure a
|
||||
Nothing -> do
|
||||
putStrLn $ name <> ": expected Just, exiting"
|
||||
E.throwIO $ userError name
|
||||
|
||||
-- enableSndFiles has no effect when mainApp is True
|
||||
startChatController :: Bool -> Bool -> CM' (Async ())
|
||||
startChatController mainApp enableSndFiles = do
|
||||
|
|
@ -525,7 +550,7 @@ startChatController mainApp enableSndFiles = do
|
|||
startXFTP startWorkers = do
|
||||
tmp <- readTVarIO =<< asks tempDirectory
|
||||
runExceptT (withAgent $ \a -> startWorkers a tmp) >>= \case
|
||||
Left e -> liftIO $ print $ "Error starting XFTP workers: " <> show e
|
||||
Left e -> liftIO $ putStrLn $ "Error starting XFTP workers: " <> show e
|
||||
Right _ -> pure ()
|
||||
startCleanupManager = do
|
||||
cleanupAsync <- asks cleanupManagerAsync
|
||||
|
|
@ -639,36 +664,43 @@ processChatCommand' vr = \case
|
|||
forM_ profile $ \Profile {displayName} -> checkValidName displayName
|
||||
p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile
|
||||
u <- asks currentUser
|
||||
smpServers <- chooseServers SPSMP
|
||||
xftpServers <- chooseServers SPXFTP
|
||||
users <- withFastStore' getUsers
|
||||
forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} ->
|
||||
when (n == displayName) . throwChatError $
|
||||
if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""}
|
||||
opDomains <- operatorDomains . serverOperators <$> withFastStore getServerOperators
|
||||
rs <- asks randomServers
|
||||
let smp = agentServerCfgs SPSMP opDomains (rndServers SPSMP rs) smpServers
|
||||
xftp = agentServerCfgs SPXFTP opDomains (rndServers SPXFTP rs) xftpServers
|
||||
auId <- withAgent (\a -> createUser a smp xftp)
|
||||
(uss, (smp', xftp')) <- chooseServers =<< readTVarIO u
|
||||
auId <- withAgent $ \a -> createUser a smp' xftp'
|
||||
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
|
||||
user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
|
||||
createPresetContactCards user `catchChatError` \_ -> pure ()
|
||||
withFastStore $ \db -> do
|
||||
user <- withFastStore $ \db -> do
|
||||
user <- createUserRecordAt db (AgentUserId auId) p True ts
|
||||
mapM_ (setUserServers db user ts) uss
|
||||
createPresetContactCards db user `catchStoreError` \_ -> pure ()
|
||||
createNoteFolder db user
|
||||
liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) $ useServers SPSMP rs smpServers
|
||||
liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) $ useServers SPXFTP rs xftpServers
|
||||
pure user
|
||||
atomically . writeTVar u $ Just user
|
||||
pure $ CRActiveUser user
|
||||
where
|
||||
createPresetContactCards :: User -> CM ()
|
||||
createPresetContactCards user =
|
||||
withFastStore $ \db -> do
|
||||
createContact db user simplexStatusContactProfile
|
||||
createContact db user simplexTeamContactProfile
|
||||
chooseServers :: forall p. ProtocolTypeI p => SProtocolType p -> CM [UserServer p]
|
||||
chooseServers p = do
|
||||
srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user)
|
||||
pure $ fromMaybe [] srvs
|
||||
createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO ()
|
||||
createPresetContactCards db user = do
|
||||
createContact db user simplexStatusContactProfile
|
||||
createContact db user simplexTeamContactProfile
|
||||
chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)))
|
||||
chooseServers user_ = do
|
||||
as <- asks randomAgentServers
|
||||
mapM (withFastStore . flip getUserServers >=> liftIO . groupByOperator) user_ >>= \case
|
||||
Just uss -> do
|
||||
let opDomains = operatorDomains $ mapMaybe operator' uss
|
||||
uss' = map copyServers uss
|
||||
pure $ (uss',) $ useServers as opDomains uss
|
||||
Nothing -> do
|
||||
ps <- asks randomPresetServers
|
||||
uss <- presetUserServers <$> withFastStore' (\db -> getUpdateServerOperators db ps True)
|
||||
let RandomAgentServers {smpServers = smp', xftpServers = xftp'} = as
|
||||
pure (uss, (smp', xftp'))
|
||||
copyServers :: UserOperatorServers -> UpdatedUserOperatorServers
|
||||
copyServers UserOperatorServers {operator, smpServers, xftpServers} =
|
||||
let new srv = AUS SDBNew srv {serverId = DBNewEntity}
|
||||
in UpdatedUserOperatorServers {operator, smpServers = map new smpServers, xftpServers = map new xftpServers}
|
||||
coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day)
|
||||
day = 86400
|
||||
ListUsers -> CRUsersList <$> withFastStore' getUsersInfo
|
||||
|
|
@ -1568,32 +1600,16 @@ processChatCommand' vr = \case
|
|||
pure $ CRConnNtfMessages ntfMsgs
|
||||
GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do
|
||||
srvs <- withFastStore (`getUserServers` user)
|
||||
CRUserServers user <$> liftIO (groupedServers srvs p)
|
||||
where
|
||||
groupedServers :: UserProtocol p => ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> SProtocolType p -> IO [UserOperatorServers]
|
||||
groupedServers (operators, smpServers, xftpServers) = \case
|
||||
SPSMP -> groupByOperator (operators, smpServers, [])
|
||||
SPXFTP -> groupByOperator (operators, [], xftpServers)
|
||||
liftIO $ CRUserServers user <$> groupByOperator (protocolServers p srvs)
|
||||
SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do
|
||||
srvs' <- mapM aUserServer srvs
|
||||
userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user)
|
||||
case L.nonEmpty userServers_ of
|
||||
Nothing -> throwChatError $ CECommandError "no servers"
|
||||
Just userServers -> case srvs of
|
||||
[] -> throwChatError $ CECommandError "no servers"
|
||||
_ -> processChatCommand $ APISetUserServers userId $ L.map (updatedSrvs p) userServers
|
||||
where
|
||||
-- disable preset and replace custom servers (groupByOperator always adds custom)
|
||||
updatedSrvs :: UserProtocol p => SProtocolType p -> UserOperatorServers -> UpdatedUserOperatorServers
|
||||
updatedSrvs p' UserOperatorServers {operator, smpServers, xftpServers} = case p' of
|
||||
SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers)
|
||||
SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers)
|
||||
where
|
||||
u = uncurry $ UpdatedUserOperatorServers operator
|
||||
updateSrvs :: [UserServer p] -> [AUserServer p]
|
||||
updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs' (const []) operator
|
||||
disableSrv srv@UserServer {preset} =
|
||||
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
|
||||
_ -> do
|
||||
srvs' <- mapM aUserServer srvs
|
||||
processChatCommand $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers
|
||||
where
|
||||
aUserServer :: AProtoServerWithAuth -> CM (AUserServer p)
|
||||
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
|
||||
|
|
@ -1607,20 +1623,21 @@ processChatCommand' vr = \case
|
|||
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
|
||||
liftIO $ setServerOperators db operatorsEnabled
|
||||
CRServerOperatorConditions <$> getServerOperators db
|
||||
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db ->
|
||||
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do
|
||||
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
|
||||
APISetUserServers userId userServers -> withUserId userId $ \user -> do
|
||||
errors <- validateAllUsersServers userId $ L.toList userServers
|
||||
unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
|
||||
(operators, smpServers, xftpServers) <- withFastStore $ \db -> do
|
||||
setUserServers db user userServers
|
||||
getUserServers db user
|
||||
let opDomains = operatorDomains operators
|
||||
rs <- asks randomServers
|
||||
uss <- withFastStore $ \db -> do
|
||||
ts <- liftIO getCurrentTime
|
||||
mapM (setUserServers db user ts) userServers
|
||||
as <- asks randomAgentServers
|
||||
lift $ withAgent' $ \a -> do
|
||||
let auId = aUserId user
|
||||
setProtocolServers a auId $ agentServerCfgs SPSMP opDomains (rndServers SPSMP rs) smpServers
|
||||
setProtocolServers a auId $ agentServerCfgs SPXFTP opDomains (rndServers SPXFTP rs) xftpServers
|
||||
opDomains = operatorDomains $ mapMaybe operator' $ L.toList uss
|
||||
(smp', xftp') = useServers as opDomains uss
|
||||
setProtocolServers a auId smp'
|
||||
setProtocolServers a auId xftp'
|
||||
ok_
|
||||
APIValidateServers userId userServers -> withUserId userId $ \user ->
|
||||
CRUserServersValidation user <$> validateAllUsersServers userId userServers
|
||||
|
|
@ -1897,7 +1914,7 @@ processChatCommand' vr = \case
|
|||
let ConnReqUriData {crSmpQueues = q :| _} = crData
|
||||
SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q
|
||||
newUserServers <-
|
||||
map protoServer' . filter (\ServerCfg {enabled} -> enabled)
|
||||
map protoServer' . L.filter (\ServerCfg {enabled} -> enabled)
|
||||
<$> getKnownAgentServers SPSMP newUser
|
||||
pure $ smpServer `elem` newUserServers
|
||||
updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do
|
||||
|
|
@ -3375,6 +3392,23 @@ processChatCommand' vr = \case
|
|||
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
|
||||
CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
|
||||
|
||||
protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
||||
protocolServers p (operators, smpServers, xftpServers) = case p of
|
||||
SPSMP -> (operators, smpServers, [])
|
||||
SPXFTP -> (operators, [], xftpServers)
|
||||
|
||||
-- disable preset and replace custom servers (groupByOperator always adds custom)
|
||||
updatedServers :: forall p. UserProtocol p => SProtocolType p -> [AUserServer p] -> UserOperatorServers -> UpdatedUserOperatorServers
|
||||
updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} = case p' of
|
||||
SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers)
|
||||
SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers)
|
||||
where
|
||||
u = uncurry $ UpdatedUserOperatorServers operator
|
||||
updateSrvs :: [UserServer p] -> [AUserServer p]
|
||||
updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs (const []) operator
|
||||
disableSrv srv@UserServer {preset} =
|
||||
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
|
||||
|
||||
type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom)
|
||||
|
||||
contactCITimed :: Contact -> CM (Maybe CITimed)
|
||||
|
|
@ -3761,7 +3795,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 protoServer' <$> getKnownAgentServers SPXFTP user
|
||||
knownSrvs <- L.map protoServer' <$> getKnownAgentServers SPXFTP user
|
||||
pure $ filter (`notElem` knownSrvs) srvs
|
||||
ipProtectedForSrvs :: [XFTPServer] -> CM Bool
|
||||
ipProtectedForSrvs srvs = do
|
||||
|
|
@ -3775,13 +3809,13 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
|||
toView $ CRChatItemUpdated user aci
|
||||
throwChatError $ CEFileNotApproved fileId unknownSrvs
|
||||
|
||||
getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM [ServerCfg p]
|
||||
getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p))
|
||||
getKnownAgentServers p user = do
|
||||
rs <- asks randomServers
|
||||
as <- asks randomAgentServers
|
||||
withStore $ \db -> do
|
||||
opDomains <- operatorDomains . serverOperators <$> getServerOperators db
|
||||
srvs <- liftIO $ getProtocolServers db p user
|
||||
pure $ L.toList $ agentServerCfgs p opDomains (rndServers p rs) srvs
|
||||
pure $ useServerCfgs p as opDomains srvs
|
||||
|
||||
protoServer' :: ServerCfg p -> ProtocolServer p
|
||||
protoServer' ServerCfg {server} = protoServer server
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ import Simplex.Chat.Util (liftIOEither)
|
|||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
|
||||
|
|
@ -154,9 +154,9 @@ data ChatConfig = ChatConfig
|
|||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
data RandomServers = RandomServers
|
||||
{ smpServers :: NonEmpty (NewUserServer 'PSMP),
|
||||
xftpServers :: NonEmpty (NewUserServer 'PXFTP)
|
||||
data RandomAgentServers = RandomAgentServers
|
||||
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
|
||||
xftpServers :: NonEmpty (ServerCfg 'PXFTP)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -183,6 +183,7 @@ data PresetServers = PresetServers
|
|||
ntf :: [NtfServer],
|
||||
netCfg :: NetworkConfig
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data InlineFilesConfig = InlineFilesConfig
|
||||
{ offerChunks :: Integer,
|
||||
|
|
@ -206,7 +207,8 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
|
|||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
randomServers :: RandomServers,
|
||||
randomPresetServers :: NonEmpty PresetOperator,
|
||||
randomAgentServers :: RandomAgentServers,
|
||||
currentRemoteHost :: TVar (Maybe RemoteHostId),
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
|
|
|
|||
|
|
@ -53,4 +53,6 @@ DROP INDEX idx_operator_usage_conditions_server_operator_id;
|
|||
DROP TABLE operator_usage_conditions;
|
||||
DROP TABLE usage_conditions;
|
||||
DROP TABLE server_operators;
|
||||
|
||||
DELETE FROM protocol_servers WHERE host LIKE "%.simplexonflux.com,%";
|
||||
|]
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import qualified Data.Aeson.TH as JQ
|
|||
import Data.Either (partitionEithers)
|
||||
import Data.FileEmbed
|
||||
import Data.Foldable (foldMap')
|
||||
import Data.Functor.Identity
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind
|
||||
|
|
@ -234,13 +235,13 @@ class UserServersClass u where
|
|||
type AServer u = (s :: ProtocolType -> Type) | s -> u
|
||||
operator' :: u -> Maybe ServerOperator
|
||||
partitionValid :: [AServer u p] -> ([Text], [AUserServer p])
|
||||
servers' :: UserProtocol p => u -> SProtocolType p -> [AServer u p]
|
||||
servers' :: UserProtocol p => SProtocolType p -> u -> [AServer u p]
|
||||
|
||||
instance UserServersClass UserOperatorServers where
|
||||
type AServer UserOperatorServers = UserServer_ 'DBStored ProtoServerWithAuth
|
||||
operator' UserOperatorServers {operator} = operator
|
||||
partitionValid ss = ([], map (AUS SDBStored) ss)
|
||||
servers' UserOperatorServers {smpServers, xftpServers} = \case
|
||||
servers' p UserOperatorServers {smpServers, xftpServers} = case p of
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
|
|
@ -248,7 +249,7 @@ instance UserServersClass UpdatedUserOperatorServers where
|
|||
type AServer UpdatedUserOperatorServers = AUserServer
|
||||
operator' UpdatedUserOperatorServers {operator} = operator
|
||||
partitionValid = ([],)
|
||||
servers' UpdatedUserOperatorServers {smpServers, xftpServers} = \case
|
||||
servers' p UpdatedUserOperatorServers {smpServers, xftpServers} = case p of
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
|
|
@ -259,7 +260,7 @@ instance UserServersClass ValidatedUserOperatorServers where
|
|||
where
|
||||
serverOrErr :: AValidatedServer p -> Either Text (AUserServer p)
|
||||
serverOrErr (AVS s srv@UserServer {server = server'}) = (\server -> AUS s srv {server}) <$> unVPS server'
|
||||
servers' ValidatedUserOperatorServers {smpServers, xftpServers} = \case
|
||||
servers' p ValidatedUserOperatorServers {smpServers, xftpServers} = case p of
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
|
|
@ -290,9 +291,13 @@ data PresetOperator = PresetOperator
|
|||
xftp :: [NewUserServer 'PXFTP],
|
||||
useXFTP :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
|
||||
operatorServers p PresetOperator {smp, xftp} = case p of
|
||||
pOperator :: PresetOperator -> Maybe NewServerOperator
|
||||
pOperator PresetOperator {operator} = operator
|
||||
|
||||
pServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
|
||||
pServers p PresetOperator {smp, xftp} = case p of
|
||||
SPSMP -> smp
|
||||
SPXFTP -> xftp
|
||||
|
||||
|
|
@ -335,83 +340,113 @@ usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case
|
|||
where
|
||||
conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}
|
||||
|
||||
presetUserServers :: [(Maybe PresetOperator, Maybe ServerOperator)] -> [UpdatedUserOperatorServers]
|
||||
presetUserServers = mapMaybe $ \(presetOp_, op) -> mkUS op <$> presetOp_
|
||||
where
|
||||
mkUS op PresetOperator {smp, xftp} =
|
||||
UpdatedUserOperatorServers op (map (AUS SDBNew) smp) (map (AUS SDBNew) xftp)
|
||||
|
||||
-- This function should be used inside DB transaction to update operators.
|
||||
-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
|
||||
-- and preserves custom operators without tags for forward compatibility.
|
||||
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator]
|
||||
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [(Maybe PresetOperator, Maybe AServerOperator)]
|
||||
updatedServerOperators presetOps storedOps =
|
||||
foldr addPreset [] presetOps
|
||||
<> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps)
|
||||
<> map (\op -> (Nothing, Just $ ASO SDBStored op)) (filter (isNothing . operatorTag) storedOps)
|
||||
where
|
||||
-- TODO remove domains of preset operators from custom
|
||||
addPreset PresetOperator {operator} = case operator of
|
||||
Nothing -> id
|
||||
Just presetOp -> (storedOp' :)
|
||||
where
|
||||
storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
|
||||
Just ServerOperator {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles} ->
|
||||
ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles}
|
||||
Nothing -> ASO SDBNew presetOp
|
||||
addPreset op = ((Just op, storedOp' <$> pOperator op) :)
|
||||
where
|
||||
storedOp' presetOp = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
|
||||
Just ServerOperator {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles} ->
|
||||
ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles}
|
||||
Nothing -> ASO SDBNew presetOp
|
||||
|
||||
-- This function should be used inside DB transaction to update servers.
|
||||
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 updatedSrvs)
|
||||
updatedUserServers :: (Maybe PresetOperator, UserOperatorServers) -> UpdatedUserOperatorServers
|
||||
updatedUserServers (presetOp_, UserOperatorServers {operator, smpServers, xftpServers}) =
|
||||
UpdatedUserOperatorServers {operator, smpServers = smp', xftpServers = xftp'}
|
||||
where
|
||||
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
|
||||
customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
|
||||
presetSrvs :: [NewUserServer p]
|
||||
presetSrvs = concatMap (operatorServers p) presetOps
|
||||
presetHosts :: Set TransportHost
|
||||
presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
|
||||
userServer :: NewUserServer p -> AUserServer p
|
||||
userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
|
||||
stored = map (AUS SDBStored)
|
||||
(smp', xftp') = case presetOp_ of
|
||||
Nothing -> (stored smpServers, stored xftpServers)
|
||||
Just presetOp -> (updated SPSMP smpServers, updated SPXFTP xftpServers)
|
||||
where
|
||||
updated :: forall p. UserProtocol p => SProtocolType p -> [UserServer p] -> [AUserServer p]
|
||||
updated p srvs = map userServer presetSrvs <> stored (filter customServer srvs)
|
||||
where
|
||||
storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
|
||||
storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs
|
||||
customServer :: UserServer p -> Bool
|
||||
customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
|
||||
presetSrvs :: [NewUserServer p]
|
||||
presetSrvs = pServers p presetOp
|
||||
presetHosts :: Set TransportHost
|
||||
presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
|
||||
userServer :: NewUserServer p -> AUserServer p
|
||||
userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
|
||||
|
||||
srvHost :: UserServer' s p -> NonEmpty TransportHost
|
||||
srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv
|
||||
|
||||
agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p)
|
||||
agentServerCfgs p opDomains randomSrvs =
|
||||
fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer
|
||||
agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)] -> [UserServer' s p] -> [ServerCfg p]
|
||||
agentServerCfgs p opDomains = mapMaybe agentServer
|
||||
where
|
||||
fallbackSrvs = L.map (snd . agentServer) randomSrvs
|
||||
enabledOpAgentServer srv =
|
||||
let (opEnabled, srvCfg) = agentServer srv
|
||||
in if opEnabled then Just srvCfg else Nothing
|
||||
agentServer :: UserServer' s p -> (Bool, ServerCfg p)
|
||||
agentServer :: UserServer' s p -> Maybe (ServerCfg p)
|
||||
agentServer srv@UserServer {server, enabled} =
|
||||
case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
|
||||
Just (_, op@ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled}) ->
|
||||
(opEnabled, ServerCfg {server, enabled, operator = Just opId, roles = operatorRoles p op})
|
||||
Just (_, op@ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled})
|
||||
| opEnabled -> Just ServerCfg {server, enabled, operator = Just opId, roles = operatorRoles p op}
|
||||
| otherwise -> Nothing
|
||||
Nothing ->
|
||||
(True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles})
|
||||
Just ServerCfg {server, enabled, operator = Nothing, roles = allRoles}
|
||||
|
||||
matchingHost :: Text -> TransportHost -> Bool
|
||||
matchingHost d = \case
|
||||
THDomainName h -> d `T.isSuffixOf` T.pack h
|
||||
_ -> False
|
||||
|
||||
operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)]
|
||||
operatorDomains :: [ServerOperator' s] -> [(Text, ServerOperator' s)]
|
||||
operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) []
|
||||
|
||||
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 [] []
|
||||
class Box b where
|
||||
box :: a -> b a
|
||||
unbox :: b a -> a
|
||||
|
||||
instance Box Identity where
|
||||
box = Identity
|
||||
unbox = runIdentity
|
||||
|
||||
instance Box ((,) (Maybe a)) where
|
||||
box = (Nothing,)
|
||||
unbox = snd
|
||||
|
||||
groupByOperator :: ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers]
|
||||
groupByOperator (ops, smpSrvs, xftpSrvs) = map runIdentity <$> groupByOperator_ (map Identity ops, smpSrvs, xftpSrvs)
|
||||
|
||||
-- For the initial app start this function relies on tuple being Functor/Box
|
||||
-- to preserve the information about operator being DBNew or DBStored
|
||||
groupByOperator' :: ([(Maybe PresetOperator, Maybe ServerOperator)], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [(Maybe PresetOperator, UserOperatorServers)]
|
||||
groupByOperator' = groupByOperator_
|
||||
{-# INLINE groupByOperator' #-}
|
||||
|
||||
groupByOperator_ :: forall f. (Box f, Traversable f) => ([f (Maybe ServerOperator)], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [f UserOperatorServers]
|
||||
groupByOperator_ (ops, smpSrvs, xftpSrvs) = do
|
||||
let ops' = mapMaybe sequence ops
|
||||
customOp_ = find (isNothing . unbox) ops
|
||||
ss <- mapM ((\op -> (serverDomains (unbox op),) <$> newIORef (mkUS . Just <$> op))) ops'
|
||||
custom <- newIORef $ maybe (box $ mkUS Nothing) (mkUS <$>) customOp_
|
||||
mapM_ (addServer ss custom addSMP) (reverse smpSrvs)
|
||||
mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs)
|
||||
opSrvs <- mapM (readIORef . snd) ss
|
||||
customSrvs <- readIORef custom
|
||||
pure $ opSrvs <> [customSrvs]
|
||||
where
|
||||
addServer :: [([Text], IORef UserOperatorServers)] -> IORef UserOperatorServers -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
|
||||
mkUS op = UserOperatorServers op [] []
|
||||
addServer :: [([Text], IORef (f UserOperatorServers))] -> IORef (f UserOperatorServers) -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
|
||||
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
|
||||
in atomicModifyIORef'_ v (add srv <$>)
|
||||
addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers}
|
||||
addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers}
|
||||
|
||||
|
|
@ -434,7 +469,7 @@ validateUserServers curr others = currUserErrs <> concatMap otherUserErrs others
|
|||
| otherwise = [USEStorageMissing p' user | noServers (hasRole storage)] <> [USEProxyMissing p' user | noServers (hasRole proxy)]
|
||||
where
|
||||
p' = AProtocolType p
|
||||
noServers cond = not $ any srvEnabled $ snd $ partitionValid $ concatMap (`servers'` p) $ filter cond uss
|
||||
noServers cond = not $ any srvEnabled $ snd $ partitionValid $ concatMap (servers' p) $ filter cond uss
|
||||
opEnabled = maybe True (\ServerOperator {enabled} -> enabled) . operator'
|
||||
hasRole roleSel = maybe True (\op@ServerOperator {enabled} -> enabled && roleSel (operatorRoles p op)) . operator'
|
||||
srvEnabled (AUS _ UserServer {deleted, enabled}) = enabled && not deleted
|
||||
|
|
@ -442,7 +477,7 @@ validateUserServers curr others = currUserErrs <> concatMap otherUserErrs others
|
|||
serverErrs p uss = map (USEInvalidServer p') invalidSrvs <> mapMaybe duplicateErr_ srvs
|
||||
where
|
||||
p' = AProtocolType p
|
||||
(invalidSrvs, userSrvs) = partitionValid $ concatMap (`servers'` p) uss
|
||||
(invalidSrvs, userSrvs) = partitionValid $ concatMap (servers' p) uss
|
||||
srvs = filter (\(AUS _ UserServer {deleted}) -> not deleted) userSrvs
|
||||
duplicateErr_ (AUS _ srv@UserServer {server}) =
|
||||
USEDuplicateServer p' (safeDecodeUtf8 $ strEncode server)
|
||||
|
|
|
|||
|
|
@ -50,9 +50,6 @@ module Simplex.Chat.Store.Profiles
|
|||
getContactWithoutConnViaAddress,
|
||||
updateUserAddressAutoAccept,
|
||||
getProtocolServers,
|
||||
getUpdateUserServers,
|
||||
-- overwriteOperatorsAndServers,
|
||||
overwriteProtocolServers,
|
||||
insertProtocolServer,
|
||||
getUpdateServerOperators,
|
||||
getServerOperators,
|
||||
|
|
@ -63,6 +60,7 @@ module Simplex.Chat.Store.Profiles
|
|||
setConditionsNotified,
|
||||
acceptConditions,
|
||||
setUserServers,
|
||||
setUserServers',
|
||||
createCall,
|
||||
deleteCalls,
|
||||
getCalls,
|
||||
|
|
@ -83,7 +81,7 @@ import Data.Functor (($>))
|
|||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
|
|
@ -108,7 +106,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 (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
||||
|
||||
|
|
@ -532,18 +530,6 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
|
|||
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
|
||||
_ -> (False, False, Nothing)
|
||||
|
||||
getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO [UserServer p]
|
||||
getUpdateUserServers db p presetOps randomSrvs user = do
|
||||
ts <- getCurrentTime
|
||||
srvs <- getProtocolServers db p user
|
||||
let srvs' = L.toList $ 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 _ -> updateProtocolServer db p ts s $> s
|
||||
|
||||
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
|
||||
getProtocolServers db p User {userId} =
|
||||
map toUserServer
|
||||
|
|
@ -561,26 +547,6 @@ getProtocolServers db p User {userId} =
|
|||
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]
|
||||
-- overwriteOperatorsAndServers db user@User {userId} operators_ servers = do
|
||||
overwriteProtocolServers :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> [UserServer p] -> ExceptT StoreError IO ()
|
||||
overwriteProtocolServers db p User {userId} servers =
|
||||
-- liftIO $ mapM_ (updateServerOperators_ db) operators_
|
||||
checkConstraint SEUniqueID . ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, decodeLatin1 $ strEncode p)
|
||||
forM_ servers $ \UserServer {serverId, server, preset, 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 :. (preset, tested, enabled, userId, currentTs, currentTs))
|
||||
pure $ Right ()
|
||||
|
||||
insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
|
||||
insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
|
||||
DB.execute
|
||||
|
|
@ -623,10 +589,10 @@ getServerOperators db = do
|
|||
let conditionsAction = usageConditionsAction ops currentConditions now
|
||||
pure ServerOperatorConditions {serverOperators = ops, currentConditions, conditionsAction}
|
||||
|
||||
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
||||
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
||||
getUserServers db user =
|
||||
(,,)
|
||||
<$> (serverOperators <$> getServerOperators db)
|
||||
<$> (map Just . serverOperators <$> getServerOperators db)
|
||||
<*> liftIO (getProtocolServers db SPSMP user)
|
||||
<*> liftIO (getProtocolServers db SPXFTP user)
|
||||
|
||||
|
|
@ -646,7 +612,7 @@ updateServerOperator db currentTs ServerOperator {operatorId, enabled, smpRoles,
|
|||
|]
|
||||
(enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles, currentTs, operatorId)
|
||||
|
||||
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
|
||||
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [(Maybe PresetOperator, Maybe ServerOperator)]
|
||||
getUpdateServerOperators db presetOps newUser = do
|
||||
conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
|
||||
now <- getCurrentTime
|
||||
|
|
@ -654,7 +620,7 @@ getUpdateServerOperators db presetOps newUser = do
|
|||
mapM_ insertConditions condsToAdd
|
||||
latestAcceptedConds_ <- getLatestAcceptedConditions db
|
||||
ops <- updatedServerOperators presetOps <$> getServerOperators_ db
|
||||
forM ops $ \(ASO _ op) ->
|
||||
forM ops $ traverse $ mapM $ \(ASO _ op) -> -- traverse for tuple, mapM for Maybe
|
||||
case operatorId op of
|
||||
DBNewEntity -> do
|
||||
op' <- insertOperator op
|
||||
|
|
@ -825,22 +791,24 @@ getUsageConditionsById_ db conditionsId =
|
|||
|]
|
||||
(Only conditionsId)
|
||||
|
||||
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
|
||||
setUserServers :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> ExceptT StoreError IO UserOperatorServers
|
||||
setUserServers db user ts = checkConstraint SEUniqueID . liftIO . setUserServers' db user ts
|
||||
|
||||
setUserServers' :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> IO UserOperatorServers
|
||||
setUserServers' db user@User {userId} ts UpdatedUserOperatorServers {operator, smpServers, xftpServers} = do
|
||||
mapM_ (updateServerOperator db ts) operator
|
||||
smpSrvs' <- catMaybes <$> mapM (upsertOrDelete SPSMP) smpServers
|
||||
xftpSrvs' <- catMaybes <$> mapM (upsertOrDelete SPXFTP) xftpServers
|
||||
pure UserOperatorServers {operator, smpServers = smpSrvs', xftpServers = xftpSrvs'}
|
||||
where
|
||||
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO ()
|
||||
upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of
|
||||
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
|
||||
upsertOrDelete p (AUS _ s@UserServer {serverId, deleted}) = case serverId of
|
||||
DBNewEntity
|
||||
| deleted -> pure ()
|
||||
| otherwise -> void $ insertProtocolServer db p user ts s
|
||||
| deleted -> pure Nothing
|
||||
| otherwise -> Just <$> 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
|
||||
| deleted -> Nothing <$ DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False)
|
||||
| otherwise -> Just s <$ 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
|
||||
|
|
|
|||
|
|
@ -25,10 +25,9 @@ import Data.Maybe (isNothing)
|
|||
import qualified Data.Text as T
|
||||
import Network.Socket
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), PresetServers (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Operators (PresetOperator (..), presetServer)
|
||||
import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion)
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
|
|
@ -95,8 +94,8 @@ testCoreOpts =
|
|||
{ dbFilePrefix = "./simplex_v1",
|
||||
dbKey = "",
|
||||
-- dbKey = "this is a pass-phrase to encrypt the database",
|
||||
smpServers = [],
|
||||
xftpServers = [],
|
||||
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
simpleNetCfg = defaultSimpleNetCfg,
|
||||
logLevel = CLLImportant,
|
||||
logConnections = False,
|
||||
|
|
@ -150,18 +149,6 @@ testCfg :: ChatConfig
|
|||
testCfg =
|
||||
defaultChatConfig
|
||||
{ agentConfig = testAgentCfg,
|
||||
presetServers =
|
||||
(presetServers defaultChatConfig)
|
||||
{ operators =
|
||||
[ PresetOperator
|
||||
{ operator = Nothing,
|
||||
smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
useSMP = 1,
|
||||
xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
useXFTP = 1
|
||||
}
|
||||
]
|
||||
},
|
||||
showReceipts = False,
|
||||
testView = True,
|
||||
tbqSize = 16
|
||||
|
|
|
|||
|
|
@ -240,6 +240,7 @@ testRetryConnecting tmp = testChatCfgOpts2 cfg' opts' aliceProfile bobProfile te
|
|||
bob <##. "smp agent error: BROKER"
|
||||
withSmpServer' serverCfg' $ do
|
||||
alice <## "server connected localhost ()"
|
||||
threadDelay 250000
|
||||
bob ##> ("/_connect plan 1 " <> inv)
|
||||
bob <## "invitation link: ok to connect"
|
||||
bob ##> ("/_connect 1 " <> inv)
|
||||
|
|
@ -1144,27 +1145,24 @@ testGetSetSMPServers =
|
|||
alice ##> "/_servers 1"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"
|
||||
alice #$> ("/smp smp://1234-w==@smp1.example.im", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://1234-w==@smp1.example.im"
|
||||
alice #$> ("/smp smp://1234-w==:password@smp1.example.im", id, "ok")
|
||||
-- alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://1234-w==:password@smp1.example.im"
|
||||
alice #$> ("/smp smp://2345-w==@smp2.example.im smp://3456-w==@smp3.example.im:5224", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://2345-w==@smp2.example.im"
|
||||
alice <## " smp://3456-w==@smp3.example.im:5224"
|
||||
|
||||
|
|
@ -1190,26 +1188,23 @@ testGetSetXFTPServers =
|
|||
alice ##> "/_servers 1"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"
|
||||
alice #$> ("/xftp xftp://1234-w==@xftp1.example.im", id, "ok")
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://1234-w==@xftp1.example.im"
|
||||
alice #$> ("/xftp xftp://1234-w==:password@xftp1.example.im", id, "ok")
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://1234-w==:password@xftp1.example.im"
|
||||
alice #$> ("/xftp xftp://2345-w==@xftp2.example.im xftp://3456-w==@xftp3.example.im:5224", id, "ok")
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://2345-w==@xftp2.example.im"
|
||||
alice <## " xftp://3456-w==@xftp3.example.im:5224"
|
||||
|
||||
|
|
@ -1831,13 +1826,11 @@ testCreateUserSameServers =
|
|||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://2345-w==@smp2.example.im"
|
||||
alice <## " smp://3456-w==@smp3.example.im:5224"
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://2345-w==@xftp2.example.im"
|
||||
alice <## " xftp://3456-w==@xftp3.example.im:5224"
|
||||
|
||||
|
|
|
|||
|
|
@ -1988,7 +1988,6 @@ testGroupAsync tmp = do
|
|||
(bob <## "#team: you joined the group")
|
||||
alice #> "#team hello bob"
|
||||
bob <# "#team alice> hello bob"
|
||||
print (1 :: Integer)
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
withNewTestChat tmp "cath" cathProfile $ \cath -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
|
|
@ -2008,7 +2007,6 @@ testGroupAsync tmp = do
|
|||
]
|
||||
alice #> "#team hello cath"
|
||||
cath <# "#team alice> hello cath"
|
||||
print (2 :: Integer)
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
concurrentlyN_
|
||||
|
|
@ -2024,7 +2022,6 @@ testGroupAsync tmp = do
|
|||
cath <## "#team: member bob (Bob) is connected"
|
||||
]
|
||||
threadDelay 500000
|
||||
print (3 :: Integer)
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
withNewTestChat tmp "dan" danProfile $ \dan -> do
|
||||
bob <## "2 contacts connected (use /cs for the list)"
|
||||
|
|
@ -2044,7 +2041,6 @@ testGroupAsync tmp = do
|
|||
]
|
||||
threadDelay 1000000
|
||||
threadDelay 1000000
|
||||
print (4 :: Integer)
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
withTestChat tmp "dan" $ \dan -> do
|
||||
|
|
@ -2066,7 +2062,6 @@ testGroupAsync tmp = do
|
|||
dan <## "#team: member cath (Catherine) is connected"
|
||||
]
|
||||
threadDelay 1000000
|
||||
print (5 :: Integer)
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
withTestChat tmp "cath" $ \cath -> do
|
||||
|
|
|
|||
|
|
@ -273,6 +273,7 @@ testRetryAcceptingViaContactLink tmp = testChatCfgOpts2 cfg' opts' aliceProfile
|
|||
bob <##. "smp agent error: BROKER"
|
||||
withSmpServer' serverCfg' $ do
|
||||
alice <## "server connected localhost ()"
|
||||
threadDelay 250000
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: ok to connect"
|
||||
bob ##> ("/_connect 1 " <> cLink)
|
||||
|
|
@ -1737,12 +1738,11 @@ testChangePCCUserDiffSrv tmp = do
|
|||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"
|
||||
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003"
|
||||
alice ##> "/user alice"
|
||||
showActiveUser alice "alice (Alice)"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,12 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
|
@ -8,8 +14,10 @@
|
|||
|
||||
module OperatorTests (operatorTests) where
|
||||
|
||||
import Data.Bifunctor (second)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
|
|
@ -19,10 +27,11 @@ import Test.Hspec
|
|||
|
||||
operatorTests :: Spec
|
||||
operatorTests = describe "managing server operators" $ do
|
||||
validateServers
|
||||
validateServersTest
|
||||
updatedServersTest
|
||||
|
||||
validateServers :: Spec
|
||||
validateServers = describe "validate user servers" $ do
|
||||
validateServersTest :: Spec
|
||||
validateServersTest = describe "validate user servers" $ do
|
||||
it "should pass valid user servers" $ validateUserServers [valid] [] `shouldBe` []
|
||||
it "should fail without servers" $ do
|
||||
validateUserServers [invalidNoServers] [] `shouldBe` [USENoServers aSMP Nothing]
|
||||
|
|
@ -41,6 +50,50 @@ validateServers = describe "validate user servers" $ do
|
|||
aSMP = AProtocolType SPSMP
|
||||
aXFTP = AProtocolType SPXFTP
|
||||
|
||||
updatedServersTest :: Spec
|
||||
updatedServersTest = describe "validate user servers" $ do
|
||||
it "adding preset operators on first start" $ do
|
||||
let ops' :: [(Maybe PresetOperator, Maybe AServerOperator)] =
|
||||
updatedServerOperators operators []
|
||||
length ops' `shouldBe` 2
|
||||
all addedPreset ops' `shouldBe` True
|
||||
let ops'' :: [(Maybe PresetOperator, Maybe ServerOperator)] =
|
||||
saveOps ops' -- mock getUpdateServerOperators
|
||||
uss <- groupByOperator' (ops'', [], []) -- no stored servers
|
||||
length uss `shouldBe` 3
|
||||
[op1, op2, op3] <- pure $ map updatedUserServers uss
|
||||
[p1, p2] <- pure operators -- presets
|
||||
sameServers p1 op1
|
||||
sameServers p2 op2
|
||||
null (servers' SPSMP op3) `shouldBe` True
|
||||
null (servers' SPXFTP op3) `shouldBe` True
|
||||
it "adding preset operators and assiging servers to operator for existing users" $ do
|
||||
let ops' = updatedServerOperators operators []
|
||||
ops'' = saveOps ops'
|
||||
uss <-
|
||||
groupByOperator'
|
||||
( ops'',
|
||||
saveSrvs $ take 3 simplexChatSMPServers <> [newUserServer "smp://abcd@smp.example.im"],
|
||||
saveSrvs $ map (presetServer True) $ L.take 3 defaultXFTPServers
|
||||
)
|
||||
[op1, op2, op3] <- pure $ map updatedUserServers uss
|
||||
[p1, p2] <- pure operators -- presets
|
||||
sameServers p1 op1
|
||||
sameServers p2 op2
|
||||
map srvHost' (servers' SPSMP op3) `shouldBe` [["smp.example.im"]]
|
||||
null (servers' SPXFTP op3) `shouldBe` True
|
||||
where
|
||||
addedPreset = \case
|
||||
(Just PresetOperator {operator = Just op}, Just (ASO SDBNew op')) -> operatorTag op == operatorTag op'
|
||||
_ -> False
|
||||
saveOps = zipWith (\i -> second ((\(ASO _ op) -> op {operatorId = DBEntityId i}) <$>)) [1..]
|
||||
saveSrvs = zipWith (\i srv -> srv {serverId = DBEntityId i}) [1..]
|
||||
sameServers preset op = do
|
||||
map srvHost (pServers SPSMP preset) `shouldBe` map srvHost' (servers' SPSMP op)
|
||||
map srvHost (pServers SPXFTP preset) `shouldBe` map srvHost' (servers' SPXFTP op)
|
||||
srvHost' (AUS _ s) = srvHost s
|
||||
PresetServers {operators} = presetServers defaultChatConfig
|
||||
|
||||
deriving instance Eq User
|
||||
|
||||
deriving instance Eq UserServersError
|
||||
|
|
|
|||
|
|
@ -14,9 +14,8 @@ 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 (defaultChatConfig, chooseRandomServers)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
|
||||
|
|
@ -38,22 +37,25 @@ testRandomSMPServers :: IO ()
|
|||
testRandomSMPServers = do
|
||||
[srvs1, srvs2, srvs3] <-
|
||||
replicateM 3 $
|
||||
checkEnabled SPSMP 7 False =<< randomPresetServers SPSMP (presetServers defaultChatConfig)
|
||||
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 =<< randomPresetServers SPXFTP (presetServers defaultChatConfig)
|
||||
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 (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
|
||||
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'
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue