mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-11 06:17:08 +00:00
CLI API in progress, validateUserServers
This commit is contained in:
Evgeny Poberezkin
@@ -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.*
|
||||
|
||||
@@ -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
|
||||
|
||||
+48
-49
@@ -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),
|
||||
|
||||
@@ -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]}
|
||||
|
||||
+112
-47
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+39
-31
@@ -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}
|
||||
|
||||
Reference in New Issue
Block a user