Merge branch 'server-operators' into ep/operators-preset-servers

src/Simplex/Chat.hs

@@ -1571,7 +1571,10 @@ processChatCommand' vr = \case
     operators <- withFastStore $ \db -> getServerOperators db
     let conditionsAction = usageConditionsAction operators
     pure $ CRServerOperators operators conditionsAction
-  APISetServerOperators _operators -> pure $ chatCmdError Nothing "not supported"
+  APISetServerOperators operatorsEnabled -> do
+    operators <- withFastStore $ \db -> setServerOperators db operatorsEnabled
+    let conditionsAction = usageConditionsAction operators
+    pure $ CRServerOperators operators conditionsAction
   APIGetUserServers userId -> withUserId userId $ \user -> do
     (operators, smpServers, xftpServers) <- withFastStore $ \db -> do
       operators <- getServerOperators db
@@ -1589,14 +1592,15 @@ processChatCommand' vr = \case
     -- response is CRUserServersValidation
     pure $ chatCmdError Nothing "not supported"
   APIGetUsageConditions -> do
-    usageConditions <- withFastStore $ \db -> getCurrentUsageConditions db
-    -- TODO
-    -- get latest accepted conditions (from operators)
+    (usageConditions, acceptedConditions) <- withFastStore $ \db -> do
+      usageConditions <- getCurrentUsageConditions db
+      acceptedConditions <- getLatestAcceptedConditions db
+      pure (usageConditions, acceptedConditions)
     pure
       CRUsageConditions
-        { usageConditions = usageConditions,
+        { usageConditions,
           conditionsText = usageConditionsText,
-          acceptedConditions = Nothing
+          acceptedConditions
         }
   APISetConditionsNotified _conditionsId -> do
     pure $ chatCmdError Nothing "not supported"

src/Simplex/Chat/Controller.hs

@@ -351,7 +351,7 @@ data ChatCommand
   | APITestProtoServer UserId AProtoServerWithAuth
   | TestProtoServer AProtoServerWithAuth
   | APIGetServerOperators
-  | APISetServerOperators (NonEmpty (OperatorId, Bool))
+  | APISetServerOperators (NonEmpty OperatorEnabled)
   | APIGetUserServers UserId
   | APISetUserServers UserId (NonEmpty UserServers)
   | APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation

src/Simplex/Chat/Migrations/M20241027_server_operators.hs

@@ -47,11 +47,11 @@ CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_
 CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(server_operator_id, conditions_commit);
 
 INSERT INTO server_operators
-  (server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled)
-  VALUES (1, 'simplex', 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
+  (server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
+  VALUES (1, 'simplex', 1, 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
 INSERT INTO server_operators
-  (server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled)
-  VALUES (2, 'xyz', 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
+  (server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
+  VALUES (2, 'xyz', 0, 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
 
 -- UPDATE protocol_servers SET server_operator_id = 1 WHERE host LIKE "%.simplex.im" OR host LIKE "%.simplex.im,%";
 |]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -593,13 +593,13 @@ CREATE TABLE app_settings(app_settings TEXT NOT NULL);
 CREATE TABLE server_operators(
   server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
   server_operator_tag TEXT,
+  app_vendor INTEGER NOT NULL,
   trade_name TEXT NOT NULL,
   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,
-  accepted_conditions_commit TEXT,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );

src/Simplex/Chat/Operators.hs

@@ -85,7 +85,7 @@ usageConditionsAction :: [ServerOperator] -> UsageConditionsAction
 usageConditionsAction _operators = UCAAccepted []
 
 data ConditionsAcceptance
-  = CAAccepted {acceptedAt :: UTCTime}
+  = CAAccepted {acceptedAt :: Maybe UTCTime}
   | CARequired {deadline :: Maybe UTCTime}
   deriving (Show)
 
@@ -96,7 +96,14 @@ data ServerOperator = ServerOperator
     tradeName :: Text,
     legalName :: Maybe Text,
     serverDomains :: [Text],
-    acceptedConditions :: ConditionsAcceptance,
+    conditionsAcceptance :: ConditionsAcceptance,
+    enabled :: Bool,
+    roles :: ServerRoles
+  }
+  deriving (Show)
+
+data OperatorEnabled = OperatorEnabled
+  { operatorId :: OperatorId,
     enabled :: Bool,
     roles :: ServerRoles
   }
@@ -143,10 +150,10 @@ groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -
 groupByOperator srvOperators smpSrvs xftpSrvs =
   map createOperatorServers (M.toList combinedMap)
   where
-    srvOperatorId :: ServerCfg p -> Maybe Int64
     srvOperatorId ServerCfg {operator} = operator
+    opId ServerOperator {operatorId} = operatorId
     operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
-    operatorMap = M.fromList [(Just (operatorId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
+    operatorMap = M.fromList [(Just (opId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
     initialMap :: Map (Maybe Int64) ([ServerCfg 'PSMP], [ServerCfg 'PXFTP])
     initialMap = M.fromList [(key, ([], [])) | key <- M.keys operatorMap]
     smpsMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (server : smps, xftps)) (srvOperatorId server) acc) initialMap smpSrvs

src/Simplex/Chat/Store/Profiles.hs

@@ -50,7 +50,9 @@ module Simplex.Chat.Store.Profiles
     -- overwriteOperatorsAndServers,
     overwriteProtocolServers,
     getServerOperators,
+    setServerOperators,
     getCurrentUsageConditions,
+    getLatestAcceptedConditions,
     createCall,
     deleteCalls,
     getCalls,
@@ -72,7 +74,7 @@ import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
+import Data.Text (Text, splitOn)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
@@ -565,44 +567,80 @@ overwriteProtocolServers db User {userId} servers =
 
 getServerOperators :: DB.Connection -> ExceptT StoreError IO [ServerOperator]
 getServerOperators db = do
-  conditions <- getCurrentUsageConditions db
+  now <- liftIO getCurrentTime
+  currentConditions <- getCurrentUsageConditions db
+  latestAcceptedConditions <- getLatestAcceptedConditions db
   liftIO $
-    map (toOperator conditions)
+    map (toOperator now currentConditions latestAcceptedConditions)
       <$> DB.query_
         db
         [sql|
         SELECT
           so.server_operator_id, so.server_operator_tag, so.trade_name, so.legal_name,
           so.server_domains, so.enabled, so.role_storage, so.role_proxy,
-          LastOperatorConditions.conditions_commit, LastOperatorConditions.accepted_at
+          AcceptedConditions.conditions_commit, AcceptedConditions.accepted_at
         FROM server_operators so
         LEFT JOIN (
           SELECT server_operator_id, conditions_commit, accepted_at, MAX(operator_usage_conditions_id)
           FROM operator_usage_conditions
           GROUP BY server_operator_id
-        ) LastOperatorConditions ON LastOperatorConditions.server_operator_id = so.server_operator_id
+        ) AcceptedConditions ON AcceptedConditions.server_operator_id = so.server_operator_id
       |]
   where
     toOperator ::
+      UTCTime ->
       UsageConditions ->
+      Maybe UsageConditions ->
       ( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool)
           :. (Maybe Text, Maybe UTCTime)
       ) ->
       ServerOperator
     toOperator
-      UsageConditions {conditionsCommit, createdAt}
+      now
+      UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt}
+      latestAcceptedConditions_
       ( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy)
-          :. (operatorConditionsCommit_, acceptedAt_)
+          :. (operatorCommit_, acceptedAt_)
         ) =
         let roles = ServerRoles {storage, proxy}
-            acceptedConditions = case (operatorConditionsCommit_, acceptedAt_) of
+            serverDomains = splitOn "," domains
+            conditionsAcceptance = case (latestAcceptedConditions_, operatorCommit_) of
+              -- no conditions were ever accepted for any operator(s)
+              -- (shouldn't happen as there should always be record for SimpleX Chat)
               (Nothing, _) -> CARequired Nothing
-              (Just operatorConditionsCommit, Just acceptedAt)
-                | conditionsCommit == operatorConditionsCommit -> CAAccepted acceptedAt
-              _ -> CARequired (Just $ conditionsDeadline createdAt)
-         in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains = [domains], acceptedConditions, enabled, roles}
-    conditionsDeadline :: UTCTime -> UTCTime
-    conditionsDeadline = addUTCTime (31 * nominalDay)
+              -- no conditions were ever accepted for this operator
+              (_, Nothing) -> CARequired Nothing
+              (Just UsageConditions {conditionsCommit = latestAcceptedCommit}, Just operatorCommit)
+                | latestAcceptedCommit == currentCommit ->
+                    if operatorCommit == latestAcceptedCommit
+                      then -- current conditions were accepted for operator
+                        CAAccepted acceptedAt_
+                      else -- current conditions were NOT accepted for operator, but were accepted for other operator(s)
+                        CARequired Nothing
+                | otherwise ->
+                    if operatorCommit == latestAcceptedCommit
+                      then -- new conditions available, latest accepted conditions were accepted for operator
+                        conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
+                      else -- new conditions available, latest accepted conditions were NOT accepted for operator (were accepted for other operator(s))
+                        CARequired Nothing
+         in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains, conditionsAcceptance, enabled, roles}
+    conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> ConditionsAcceptance
+    conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
+      if notifiedAtOrNow < addUTCTime (14 * nominalDay) createdAt
+        then CARequired (Just $ conditionsDeadline notifiedAtOrNow)
+        else CARequired Nothing
+      where
+        conditionsDeadline :: UTCTime -> UTCTime
+        conditionsDeadline = addUTCTime (31 * nominalDay)
+
+setServerOperators :: DB.Connection -> NonEmpty OperatorEnabled -> ExceptT StoreError IO [ServerOperator]
+setServerOperators db operatorsEnabled = do
+  liftIO $ forM_ operatorsEnabled $ \OperatorEnabled {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)
+  getServerOperators db
 
 getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
 getCurrentUsageConditions db =
@@ -619,6 +657,31 @@ toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
 toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
   UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
 
+getLatestAcceptedConditions :: DB.Connection -> ExceptT StoreError IO (Maybe UsageConditions)
+getLatestAcceptedConditions db = do
+  (latestAcceptedCommit_ :: Maybe Text) <-
+    liftIO $
+      maybeFirstRow fromOnly $
+        DB.query_
+          db
+          [sql|
+          SELECT conditions_commit
+          FROM operator_usage_conditions
+          WHERE conditions_accepted = 1
+          ORDER BY accepted_at DESC
+          LIMIT 1
+        |]
+  forM latestAcceptedCommit_ $ \latestAcceptedCommit ->
+    ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
+      DB.query
+        db
+        [sql|
+          SELECT usage_conditions_id, conditions_commit, notified_at, created_at
+          FROM usage_conditions
+          WHERE conditions_commit = ?
+        |]
+        (Only latestAcceptedCommit)
+
 -- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
 -- updateServerOperators_ db operators = do
 --   DB.execute_ db "DELETE FROM server_operators WHERE preset = 0"