core: different roles for different protocols (#5185)

* core: different roles for different protocols * include current conditions in responses * fix * fix test * fix --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
2026-04-26 23:55:53 +00:00 · 2024-11-15 12:08:15 +00:00
parent ff8e29c0eb
commit feb687d3b8
8 changed files with 104 additions and 65 deletions
@@ -588,7 +588,7 @@ data ChatResponse
  | CRChatItemId User (Maybe ChatItemId)
  | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
  | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
-  | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
+  | CRServerOperatorConditions {conditions :: ServerOperatorConditions}
  | CRUserServers {user :: User, userServers :: [UserOperatorServers]}
  | CRUserServersValidation {user :: User, serverErrors :: [UserServersError]}
  | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
@@ -15,8 +15,10 @@ CREATE TABLE server_operators (
  legal_name TEXT,
  server_domains TEXT,
  enabled INTEGER NOT NULL DEFAULT 1,
-  role_storage INTEGER NOT NULL DEFAULT 1,
-  role_proxy INTEGER NOT NULL DEFAULT 1,
+  smp_role_storage INTEGER NOT NULL DEFAULT 1,
+  smp_role_proxy INTEGER NOT NULL DEFAULT 1,
+  xftp_role_storage INTEGER NOT NULL DEFAULT 1,
+  xftp_role_proxy INTEGER NOT NULL DEFAULT 1,
  created_at TEXT NOT NULL DEFAULT (datetime('now')),
  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
@@ -596,8 +596,10 @@ CREATE TABLE server_operators(
  legal_name TEXT,
  server_domains TEXT,
  enabled INTEGER NOT NULL DEFAULT 1,
-  role_storage INTEGER NOT NULL DEFAULT 1,
-  role_proxy INTEGER NOT NULL DEFAULT 1,
+  smp_role_storage INTEGER NOT NULL DEFAULT 1,
+  smp_role_proxy INTEGER NOT NULL DEFAULT 1,
+  xftp_role_storage INTEGER NOT NULL DEFAULT 1,
+  xftp_role_proxy INTEGER NOT NULL DEFAULT 1,
  created_at TEXT NOT NULL DEFAULT(datetime('now')),
  updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
@@ -134,6 +134,13 @@ data UsageConditionsAction
  | UCAAccepted {operators :: [ServerOperator]}
  deriving (Show)

+data ServerOperatorConditions = ServerOperatorConditions
+  { serverOperators :: [ServerOperator],
+    currentConditions :: UsageConditions,
+    conditionsAction :: Maybe UsageConditionsAction
+  }
+  deriving (Show)
+
 usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
 usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
  let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
@@ -178,10 +185,16 @@ data ServerOperator' s = ServerOperator
    serverDomains :: [Text],
    conditionsAcceptance :: ConditionsAcceptance,
    enabled :: Bool,
-    roles :: ServerRoles
+    smpRoles :: ServerRoles,
+    xftpRoles :: ServerRoles
  }
  deriving (Show)

+operatorRoles :: UserProtocol p => SProtocolType p -> ServerOperator -> ServerRoles
+operatorRoles p op = case p of
+  SPSMP -> smpRoles op
+  SPXFTP -> xftpRoles op
+
 conditionsAccepted :: ServerOperator -> Bool
 conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
  CAAccepted {} -> True
@@ -336,8 +349,8 @@ updatedServerOperators presetOps storedOps =
      Just presetOp -> (storedOp' :)
        where
          storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
-            Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} ->
-              ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles}
+            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.
@@ -361,8 +374,8 @@ updatedUserServers p presetOps randomSrvs srvs =
 srvHost :: UserServer' s p -> NonEmpty TransportHost
 srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv

-agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p)
-agentServerCfgs opDomains randomSrvs =
+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
  where
    fallbackSrvs = L.map (snd . agentServer) randomSrvs
@@ -372,8 +385,8 @@ agentServerCfgs opDomains randomSrvs =
    agentServer :: UserServer' s p -> (Bool, ServerCfg p)
    agentServer srv@UserServer {server, enabled} =
      case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
-        Just (_, ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles}) ->
-          (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles})
+        Just (_, op@ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled}) ->
+          (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles = operatorRoles p op})
        Nothing ->
          (True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles})

@@ -423,7 +436,7 @@ validateUserServers curr others = currUserErrs <> concatMap otherUserErrs others
        p' = AProtocolType p
        noServers cond = not $ any srvEnabled $ snd $ partitionValid $ concatMap (`servers'` p) $ filter cond uss
        opEnabled = maybe True (\ServerOperator {enabled} -> enabled) . operator'
-        hasRole roleSel = maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) . operator'
+        hasRole roleSel = maybe True (\op@ServerOperator {enabled} -> enabled && roleSel (operatorRoles p op)) . operator'
        srvEnabled (AUS _ UserServer {deleted, enabled}) = enabled && not deleted
    serverErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [u] -> [UserServersError]
    serverErrs p uss = map (USEInvalidServer p') invalidSrvs <> mapMaybe duplicateErr_ srvs
@@ -472,6 +485,8 @@ instance DBStoredI s => FromJSON (ServerOperator' s) where

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)

+$(JQ.deriveJSON defaultJSON ''ServerOperatorConditions)
+
 instance ProtocolTypeI p => ToJSON (UserServer' s p) where
  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer_)
  toJSON = $(JQ.mkToJSON defaultJSON ''UserServer_)
@@ -612,20 +612,21 @@ serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_)
      auth = safeDecodeUtf8 . unBasicAuth <$> auth_
   in (protocol, host, port, keyHash, auth)

-getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
+getServerOperators :: DB.Connection -> ExceptT StoreError IO ServerOperatorConditions
 getServerOperators db = do
-  currentConds <- getCurrentUsageConditions db
+  currentConditions <- getCurrentUsageConditions db
  liftIO $ do
    now <- getCurrentTime
    latestAcceptedConds_ <- getLatestAcceptedConditions db
-    let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now
-    operators <- mapM getConds =<< getServerOperators_ db
-    pure (operators, usageConditionsAction operators currentConds now)
+    let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConditions latestAcceptedConds_ now
+    ops <- mapM getConds =<< getServerOperators_ db
+    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 user =
  (,,)
-    <$> (fst <$> getServerOperators db)
+    <$> (serverOperators <$> getServerOperators db)
    <*> liftIO (getProtocolServers db SPSMP user)
    <*> liftIO (getProtocolServers db SPXFTP user)

@@ -635,15 +636,15 @@ setServerOperators db ops = do
  mapM_ (updateServerOperator db currentTs) ops

 updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
-updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
+updateServerOperator db currentTs ServerOperator {operatorId, enabled, smpRoles, xftpRoles} =
  DB.execute
    db
    [sql|
      UPDATE server_operators
-      SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
+      SET enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?, updated_at = ?
      WHERE server_operator_id = ?
    |]
-    (enabled, storage, proxy, operatorId, currentTs)
+    (enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles, currentTs, operatorId)

 getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
 getUpdateServerOperators db presetOps newUser = do
@@ -677,25 +678,25 @@ getUpdateServerOperators db presetOps newUser = do
        |]
        (conditionsId, conditionsCommit, notifiedAt, createdAt)
    updateOperator :: ServerOperator -> IO ()
-    updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} =
+    updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} =
      DB.execute
        db
        [sql|
          UPDATE server_operators
-          SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ?
+          SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?
          WHERE server_operator_id = ?
        |]
-        (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId)
+        (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles, operatorId)
    insertOperator :: NewServerOperator -> IO ServerOperator
-    insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do
+    insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} = do
      DB.execute
        db
        [sql|
          INSERT INTO server_operators
-            (server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy)
-          VALUES (?,?,?,?,?,?,?)
+            (server_operator_tag, trade_name, legal_name, server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy)
+          VALUES (?,?,?,?,?,?,?,?,?)
        |]
-        (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy)
+        (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles)
      opId <- insertedRowId db
      pure op {operatorId = DBEntityId opId}
    autoAcceptConditions op UsageConditions {conditionsCommit} =
@@ -706,15 +707,15 @@ serverOperatorQuery :: Query
 serverOperatorQuery =
  [sql|
    SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
-      server_domains, enabled, role_storage, role_proxy
+      server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy
    FROM server_operators
  |]

 getServerOperators_ :: DB.Connection -> IO [ServerOperator]
 getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery

-toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) -> ServerOperator
-toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
+toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool) :. (Bool, Bool) :. (Bool, Bool) -> ServerOperator
+toServerOperator ((operatorId, operatorTag, tradeName, legalName, domains, enabled) :. smpRoles' :. xftpRoles') =
  ServerOperator
    { operatorId,
      operatorTag,
@@ -723,8 +724,11 @@ toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enable
      serverDomains = T.splitOn "," domains,
      conditionsAcceptance = CARequired Nothing,
      enabled,
-      roles = ServerRoles {storage, proxy}
+      smpRoles = serverRoles smpRoles',
+      xftpRoles = serverRoles xftpRoles'
    }
+  where
+    serverRoles (storage, proxy) = ServerRoles {storage, proxy}

 getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
 getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do
@@ -65,7 +65,7 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
-import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..))
+import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
@@ -98,7 +98,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
  CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
  CRApiParsedMarkdown ft -> [viewJSON ft]
  CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
-  CRServerOperators ops ca -> viewServerOperators ops ca 
+  CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca
  CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
  CRUserServersValidation {} -> []
  CRUsageConditions {} -> []
@@ -1221,15 +1221,27 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
    <> viewServers SPSMP smpServers
    <> viewServers SPXFTP xftpServers
  where
-    viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString]
+    viewServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServer p] -> [StyledString]
    viewServers _ [] = []
-    viewServers p srvs = ["  " <> protocolName p <> " servers"] <> map (plain . ("    " <> ) . viewServer) srvs
+    viewServers p srvs
+      | maybe True (\ServerOperator {enabled} -> enabled) operator =
+          ["  " <> protocolName p <> " servers" <> maybe "" ((" " <>) . viewRoles) operator]
+            <> map (plain . ("    " <> ) . viewServer) srvs
+      | otherwise = []
      where
        viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo
          where
            serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_
            serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled]
            testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
+        viewRoles op@ServerOperator {enabled}
+          | not enabled = "disabled"
+          | storage rs && proxy rs = "enabled"
+          | storage rs = "enabled storage"
+          | proxy rs = "enabled proxy"
+          | otherwise = "disabled (servers known)"
+          where
+            rs = operatorRoles p op

 serversUserHelp :: [StyledString]
 serversUserHelp =
@@ -1272,8 +1284,8 @@ viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsA
    <> (", " <> viewOpEnabled op)

 shortViewOperator :: ServerOperator -> Text
-shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} =
-  tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op)
+shortViewOperator ServerOperator {operatorId = DBEntityId opId, tradeName, enabled} =
+  tshow opId <> ". " <> tradeName <> parens (if enabled then "enabled" else "disabled")

 viewOpIdTag :: ServerOperator' s -> Text
 viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
@@ -1290,11 +1302,19 @@ viewOpConditions = \case
    viewCond w ts = w <> maybe "" (parens . tshow) ts

 viewOpEnabled :: ServerOperator' s -> Text
-viewOpEnabled ServerOperator {enabled, roles = ServerRoles {storage, proxy}}
-  | enabled && storage && proxy = "enabled"
-  | enabled && storage = "enabled storage"
-  | enabled && proxy = "enabled proxy"
-  | otherwise = "disabled"
+viewOpEnabled ServerOperator {enabled, smpRoles, xftpRoles}
+  | not enabled = "disabled"
+  | no smpRoles && no xftpRoles = "disabled (servers known)"
+  | both smpRoles && both xftpRoles = "enabled"
+  | otherwise = "SMP " <> viewRoles smpRoles <> ", XFTP" <> viewRoles xftpRoles
+  where
+    no rs = not $ storage rs || proxy rs
+    both rs = storage rs && proxy rs
+    viewRoles rs
+      | both rs = "enabled"
+      | storage rs = "enabled storage"
+      | proxy rs = "enabled proxy"
+      | otherwise = "disabled (servers known)"

 viewConditionsAction :: UsageConditionsAction -> [StyledString]
 viewConditionsAction = \case
@@ -1382,12 +1402,6 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
  ["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
    <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]

-- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
-- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
--   where
--     ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
--     viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
-
 viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
 viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
  where