From 49d1b26bba44bf417b56bf6a0345bac98e1827ce Mon Sep 17 00:00:00 2001
From: Evgeny <evgeny@poberezkin.com>
Date: Fri, 22 Nov 2024 10:38:00 +0000
Subject: [PATCH] core: tests for operators api, CLI command to update
 operators (#5226)

---
 src/Simplex/Chat.hs            | 25 ++++++++++++++++++
 src/Simplex/Chat/Controller.hs |  1 +
 src/Simplex/Chat/Operators.hs  |  8 ++++++
 src/Simplex/Chat/View.hs       | 21 ++++++++++-----
 tests/ChatClient.hs            | 10 +++++++
 tests/ChatTests/Direct.hs      | 48 ++++++++++++++++++++++++++++------
 6 files changed, 98 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs
index 0daf9fa394..5906da57de 100644
--- a/src/Simplex/Chat.hs
+++ b/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
diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs
index e44ea2ac18..23aa632478 100644
--- a/src/Simplex/Chat/Controller.hs
+++ b/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
diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs
index ebe1da8176..e14e95211a 100644
--- a/src/Simplex/Chat/Operators.hs
+++ b/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
diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs
index e4c0fd5606..f9ec3f936c 100644
--- a/src/Simplex/Chat/View.hs
+++ b/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"]
diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs
index 7bf7804472..8b7e8fcd32 100644
--- a/tests/ChatClient.hs
+++ b/tests/ChatClient.hs
@@ -376,6 +376,16 @@ userName :: TestCC -> IO [Char]
 userName (TestCC ChatController {currentUser} _ _ _ _ _) =
   maybe "no current user" (\User {localDisplayName} -> T.unpack localDisplayName) <$> readTVarIO currentUser
 
+testChat :: HasCallStack => Profile -> (HasCallStack => TestCC -> IO ()) -> FilePath -> IO ()
+testChat = testChatCfgOpts testCfg testOpts
+
+testChatCfgOpts :: HasCallStack => ChatConfig -> ChatOpts -> Profile -> (HasCallStack => TestCC -> IO ()) -> FilePath -> IO ()
+testChatCfgOpts cfg opts p test = testChatN cfg opts [p] test_
+  where
+    test_ :: HasCallStack => [TestCC] -> IO ()
+    test_ [tc] = test tc
+    test_ _ = error "expected 1 chat client"
+
 testChat2 :: HasCallStack => Profile -> Profile -> (HasCallStack => TestCC -> TestCC -> IO ()) -> FilePath -> IO ()
 testChat2 = testChatCfgOpts2 testCfg testOpts
 
diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs
index 6bbf72171e..d305055d94 100644
--- a/tests/ChatTests/Direct.hs
+++ b/tests/ChatTests/Direct.hs
@@ -85,6 +85,8 @@ chatDirectTests = do
   describe "XFTP servers" $ do
     it "get and set XFTP servers" testGetSetXFTPServers
     it "test XFTP server connection" testTestXFTPServer
+  describe "operators and usage conditions" $ do
+    it "get and enable operators, accept conditions" testOperators
   describe "async connection handshake" $ do
     describe "connect when initiating client goes offline" $ do
       it "curr" $ testAsyncInitiatingOffline testCfg testCfg
@@ -1140,8 +1142,8 @@ testSendMultiManyBatches =
 
 testGetSetSMPServers :: HasCallStack => FilePath -> IO ()
 testGetSetSMPServers =
-  testChat2 aliceProfile bobProfile $
-    \alice _ -> do
+  testChat aliceProfile $
+    \alice -> do
       alice ##> "/_servers 1"
       alice <## "Your servers"
       alice <## "  SMP servers"
@@ -1168,8 +1170,8 @@ testGetSetSMPServers =
 
 testTestSMPServerConnection :: HasCallStack => FilePath -> IO ()
 testTestSMPServerConnection =
-  testChat2 aliceProfile bobProfile $
-    \alice _ -> do
+  testChat aliceProfile $
+    \alice -> do
       alice ##> "/smp test smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"
       alice <## "SMP server test passed"
       -- to test with password:
@@ -1183,8 +1185,8 @@ testTestSMPServerConnection =
 
 testGetSetXFTPServers :: HasCallStack => FilePath -> IO ()
 testGetSetXFTPServers =
-  testChat2 aliceProfile bobProfile $
-    \alice _ -> withXFTPServer $ do
+  testChat aliceProfile $
+    \alice -> withXFTPServer $ do
       alice ##> "/_servers 1"
       alice <## "Your servers"
       alice <## "  SMP servers"
@@ -1210,8 +1212,8 @@ testGetSetXFTPServers =
 
 testTestXFTPServer :: HasCallStack => FilePath -> IO ()
 testTestXFTPServer =
-  testChat2 aliceProfile bobProfile $
-    \alice _ -> withXFTPServer $ do
+  testChat aliceProfile $
+    \alice -> withXFTPServer $ do
       alice ##> "/xftp test xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7002"
       alice <## "XFTP server test passed"
       -- to test with password:
@@ -1223,6 +1225,36 @@ testTestXFTPServer =
       alice <## "XFTP server test failed at Connect, error: BROKER {brokerAddress = \"xftp://LcJU@localhost:7002\", brokerErr = NETWORK}"
       alice <## "Possibly, certificate fingerprint in XFTP server address is incorrect"
 
+testOperators  :: HasCallStack => FilePath -> IO ()
+testOperators =
+  testChatCfgOpts testCfg opts' aliceProfile $
+    \alice -> do
+      -- initial load
+      alice ##> "/_conditions"
+      alice <##. "Current conditions: 2."
+      alice ##> "/_operators"
+      alice <##. "1 (simplex). SimpleX Chat (SimpleX Chat Ltd), domains: simplex.im, servers: enabled, conditions: required ("
+      alice <## "2 (flux). Flux (InFlux Technologies Limited), domains: simplexonflux.com, servers: disabled, conditions: required"
+      alice <##. "The new conditions will be accepted for SimpleX Chat Ltd at "
+      -- set conditions notified 
+      alice ##> "/_conditions_notified 2"
+      alice <## "ok"
+      alice ##> "/_operators"
+      alice <##. "1 (simplex). SimpleX Chat (SimpleX Chat Ltd), domains: simplex.im, servers: enabled, conditions: required ("
+      alice <## "2 (flux). Flux (InFlux Technologies Limited), domains: simplexonflux.com, servers: disabled, conditions: required"
+      alice ##> "/_conditions"
+      alice <##. "Current conditions: 2 (notified)."
+      -- accept conditions
+      alice ##> "/_accept_conditions 2 1,2"
+      alice <##. "1 (simplex). SimpleX Chat (SimpleX Chat Ltd), domains: simplex.im, servers: enabled, conditions: accepted ("
+      alice <##. "2 (flux). Flux (InFlux Technologies Limited), domains: simplexonflux.com, servers: disabled, conditions: accepted ("
+      -- update operators
+      alice ##> "/operators 2:on:smp=proxy"
+      alice <##. "1 (simplex). SimpleX Chat (SimpleX Chat Ltd), domains: simplex.im, servers: enabled, conditions: accepted ("
+      alice <##. "2 (flux). Flux (InFlux Technologies Limited), domains: simplexonflux.com, servers: SMP enabled proxy, XFTP enabled, conditions: accepted ("
+  where
+    opts' = testOpts {coreOptions = testCoreOpts {smpServers = [], xftpServers = []}}
+
 testAsyncInitiatingOffline :: HasCallStack => ChatConfig -> ChatConfig -> FilePath -> IO ()
 testAsyncInitiatingOffline aliceCfg bobCfg tmp = do
   inv <- withNewTestChatCfg tmp aliceCfg "alice" aliceProfile $ \alice -> do