core: tests for operators api, CLI command to update operators (#5226)

src/Simplex/Chat.hs

@@ -1640,6 +1640,16 @@ processChatCommand' vr = \case
         xftpSrvs <- getProtocolServers db SPXFTP user
         uss <- groupByOperator (ops, smpSrvs, xftpSrvs)
         pure $ (aUserId user,) $ useServers as opDomains uss
+  SetServerOperators operatorsRoles -> do
+    ops <- serverOperators <$> withFastStore getServerOperators
+    ops' <- mapM (updateOp ops) operatorsRoles
+    processChatCommand $ APISetServerOperators ops'
+    where
+      updateOp :: [ServerOperator] -> ServerOperatorRoles -> CM ServerOperator
+      updateOp ops r =
+        case find (\ServerOperator {operatorId = DBEntityId opId} -> operatorId' r == opId) ops of
+          Just op -> pure op {enabled = enabled' r, smpRoles = smpRoles' r, xftpRoles = xftpRoles' r}
+          Nothing -> throwError $ ChatErrorStore $ SEOperatorNotFound $ operatorId' r
   APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do
     CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
   APISetUserServers userId userServers -> withUserId userId $ \user -> do
@@ -8308,6 +8318,7 @@ chatCommandP =
       "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP),
       "/_operators" $> APIGetServerOperators,
       "/_operators " *> (APISetServerOperators <$> jsonP),
+      "/operators " *> (SetServerOperators . L.fromList <$> operatorRolesP `A.sepBy1` A.char ','),
       "/_servers " *> (APIGetUserServers <$> A.decimal),
       "/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP),
       "/_validate_servers " *> (APIValidateServers <$> A.decimal <* A.space <*> jsonP),
@@ -8637,6 +8648,20 @@ chatCommandP =
       optional ("yes" *> A.space) *> (TMEEnableSetTTL <$> timedTTLP)
         <|> ("yes" $> TMEEnableKeepTTL)
         <|> ("no" $> TMEDisableKeepTTL)
+    operatorRolesP = do
+      operatorId' <- A.decimal
+      enabled' <- A.char ':' *> onOffP
+      smpRoles' <- (":smp=" *> srvRolesP) <|> pure allRoles
+      xftpRoles' <- (":xftp=" *> srvRolesP) <|> pure allRoles
+      pure ServerOperatorRoles {operatorId', enabled', smpRoles', xftpRoles'}
+    srvRolesP = srvRoles <$?> A.takeTill (\c -> c == ':' || c == ',')
+      where
+        srvRoles = \case
+          "off" -> Right $ ServerRoles False False
+          "proxy" -> Right ServerRoles {storage = False, proxy = True}
+          "storage" -> Right ServerRoles {storage = True, proxy = False}
+          "on" -> Right allRoles
+          _ -> Left "bad ServerRoles"
     netCfgP = do
       socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxyWithAuth <|> Just <$> strP)
       socksMode <- " socks-mode=" *> strP <|> pure SMAlways

src/Simplex/Chat/Controller.hs

@@ -358,6 +358,7 @@ data ChatCommand
   | TestProtoServer AProtoServerWithAuth
   | APIGetServerOperators
   | APISetServerOperators (NonEmpty ServerOperator)
+  | SetServerOperators (NonEmpty ServerOperatorRoles)
   | APIGetUserServers UserId
   | APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
   | APIValidateServers UserId [UpdatedUserOperatorServers] -- response is CRUserServersValidation

src/Simplex/Chat/Operators.hs

@@ -192,6 +192,14 @@ data ServerOperator' s = ServerOperator
   }
   deriving (Show)
 
+data ServerOperatorRoles = ServerOperatorRoles
+  { operatorId' :: Int64,
+    enabled' :: Bool,
+    smpRoles' :: ServerRoles,
+    xftpRoles' :: ServerRoles
+  }
+  deriving (Show)
+
 operatorRoles :: UserProtocol p => SProtocolType p -> ServerOperator -> ServerRoles
 operatorRoles p op = case p of
   SPSMP -> smpRoles op

src/Simplex/Chat/View.hs

@@ -101,7 +101,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
   CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca
   CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
   CRUserServersValidation {} -> []
-  CRUsageConditions {} -> []
+  CRUsageConditions current _ accepted_ -> viewUsageConditions current accepted_
   CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
   CRNetworkConfig cfg -> viewNetworkConfig cfg
   CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
@@ -1280,8 +1280,8 @@ viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsA
     <> tradeName
     <> maybe "" parens legalName
     <> (", domains: "  <> T.intercalate ", " serverDomains)
+    <> (", servers: " <> viewOpEnabled op)
     <> (", conditions: " <> viewOpConditions conditionsAcceptance)
-    <> (", " <> viewOpEnabled op)
 
 shortViewOperator :: ServerOperator -> Text
 shortViewOperator ServerOperator {operatorId = DBEntityId opId, tradeName, enabled} =
@@ -1289,10 +1289,10 @@ shortViewOperator ServerOperator {operatorId = DBEntityId opId, tradeName, enabl
 
 viewOpIdTag :: ServerOperator' s -> Text
 viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
-  DBEntityId i -> tshow i <> " - " <> tag
+  DBEntityId i -> tshow i <> tag
   DBNewEntity -> tag
   where
-    tag = maybe "" textEncode operatorTag <> ". "
+    tag = maybe "" (parens . textEncode) operatorTag <> ". "
 
 viewOpConditions :: ConditionsAcceptance -> Text
 viewOpConditions = \case
@@ -1306,7 +1306,7 @@ 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
+  | otherwise = "SMP " <> viewRoles smpRoles <> ", XFTP " <> viewRoles xftpRoles
   where
     no rs = not $ storage rs || proxy rs
     both rs = storage rs && proxy rs
@@ -1319,13 +1319,20 @@ viewOpEnabled ServerOperator {enabled, smpRoles, xftpRoles}
 viewConditionsAction :: UsageConditionsAction -> [StyledString]
 viewConditionsAction = \case
   UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of
-    Just ts -> [plain $ "New conditions will be accepted at " <> tshow ts <> " for " <> ops]
-    Nothing -> [plain $ "New conditions have to be accepted for " <> ops]
+    Just ts -> [plain $ "The new conditions will be accepted for " <> ops <> " at " <> tshow ts]
+    Nothing -> [plain $ "The new conditions have to be accepted for " <> ops]
     where
       ops = T.intercalate ", " $ map legalName_ operators
       legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName
   _ -> []
 
+viewUsageConditions :: UsageConditions -> Maybe UsageConditions -> [StyledString]
+viewUsageConditions current accepted_ =
+  [plain $ "Current conditions: " <> viewConds current <> maybe "" (\ac -> ", accepted conditions: " <> viewConds ac) accepted_]
+  where
+    viewConds UsageConditions {conditionsId, conditionsCommit, notifiedAt} =
+      tshow conditionsId <> maybe "" (const " (notified)") notifiedAt <> ". " <> conditionsCommit
+
 viewChatItemTTL :: Maybe Int64 -> [StyledString]
 viewChatItemTTL = \case
   Nothing -> ["old messages are not being deleted"]