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
2024-12-17 17:20:21 +01:00 · 2024-11-18 18:44:28 +00:00
parent 3d4a47cdae
commit 619985730e
11 changed files with 319 additions and 248 deletions
@@ -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