core: setConditionsNotified, acceptConditions, setUserServers, validateServers apis wip (#5147)

2026-03-30 18:35:49 +00:00 · 2024-11-05 21:40:33 +04:00
parent 3b0205b25f
commit 2da89c2cf1
4 changed files with 181 additions and 64 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -1489,7 +1489,7 @@ processChatCommand' vr = \case
  APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
    cfg@ChatConfig {defaultServers} <- asks config
    srvs <- withFastStore' (`getProtocolServers` user)
-    operators <- withFastStore $ \db -> getServerOperators db
+    (operators, _) <- withFastStore $ \db -> getServerOperators db
    let servers = AUPS $ UserProtoServers p (useServers cfg p srvs) (cfgServers p defaultServers)
    pure $ CRUserProtoServers {user, servers, operators}
  GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
@@ -1508,44 +1508,51 @@ processChatCommand' vr = \case
  TestProtoServer srv -> withUser $ \User {userId} ->
    processChatCommand $ APITestProtoServer userId srv
  APIGetServerOperators -> do
-    operators <- withFastStore $ \db -> getServerOperators db
-    let conditionsAction = usageConditionsAction operators
+    (operators, conditionsAction) <- withFastStore $ \db -> getServerOperators db
    pure $ CRServerOperators operators conditionsAction
  APISetServerOperators operatorsEnabled -> do
-    operators <- withFastStore $ \db -> setServerOperators db operatorsEnabled
-    let conditionsAction = usageConditionsAction operators
+    (operators, conditionsAction) <- withFastStore $ \db -> setServerOperators db operatorsEnabled
    pure $ CRServerOperators operators conditionsAction
  APIGetUserServers userId -> withUserId userId $ \user -> do
    (operators, smpServers, xftpServers) <- withFastStore $ \db -> do
-      operators <- getServerOperators db
+      (operators, _) <- getServerOperators db
      smpServers <- liftIO $ getServers db user SPSMP
      xftpServers <- liftIO $ getServers db user SPXFTP
      pure (operators, smpServers, xftpServers)
    let userServers = groupByOperator operators smpServers xftpServers
    pure $ CRUserServers user userServers
    where
-      getServers :: (ProtocolTypeI p) => DB.Connection -> User -> SProtocolType p -> IO [ServerCfg p]
+      getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ServerCfg p]
      getServers db user _p = getProtocolServers db user
-  APISetUserServers userId _userServers -> withUserId userId $ \user ->
-    pure $ chatCmdError (Just user) "not supported"
-  APIValidateServers _userServers ->
-    -- response is CRUserServersValidation
-    pure $ chatCmdError Nothing "not supported"
+  APISetUserServers userId userServers -> withUserId userId $ \user -> do
+    let errors = validateUserServers userServers
+    unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
+    withFastStore $ \db -> setUserServers db user userServers
+    -- TODO set protocol servers for agent
+    ok_
+  APIValidateServers userServers -> do
+    let errors = validateUserServers userServers
+    pure $ CRUserServersValidation errors
  APIGetUsageConditions -> do
    (usageConditions, acceptedConditions) <- withFastStore $ \db -> do
      usageConditions <- getCurrentUsageConditions db
      acceptedConditions <- getLatestAcceptedConditions db
      pure (usageConditions, acceptedConditions)
+    -- TODO if db commit is different from source commit, conditionsText should be nothing in response
    pure
      CRUsageConditions
        { usageConditions,
          conditionsText = usageConditionsText,
          acceptedConditions
        }
-  APISetConditionsNotified _conditionsId -> do
-    pure $ chatCmdError Nothing "not supported"
-  APIAcceptConditions _conditionsId _opIds ->
-    pure $ chatCmdError Nothing "not supported"
+  APISetConditionsNotified conditionsId -> do
+    currentTs <- liftIO getCurrentTime
+    withFastStore' $ \db -> setConditionsNotified db conditionsId currentTs
+    ok_
+  APIAcceptConditions conditionsId operators -> do
+    currentTs <- liftIO getCurrentTime
+    (operators', conditionsAction) <- withFastStore $ \db -> acceptConditions db conditionsId operators currentTs
+    pure $ CRServerOperators operators' conditionsAction
  APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
    checkStoreNotChanged $
      withChatLock "setChatItemTTL" $ do
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -71,7 +71,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, OperatorId, ServerCfg)
+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)
@@ -360,7 +360,7 @@ data ChatCommand
  | APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation
  | APIGetUsageConditions
  | APISetConditionsNotified Int64
-  | APIAcceptConditions Int64 (NonEmpty OperatorId)
+  | APIAcceptConditions Int64 (NonEmpty ServerOperator)
  | APISetChatItemTTL UserId (Maybe Int64)
  | SetChatItemTTL (Maybe Int64)
  | APIGetChatItemTTL UserId
@@ -588,7 +588,7 @@ data ChatResponse
  | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
  | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
  | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
-  | CRServerOperators {operators :: [ServerOperator], conditionsAction :: UsageConditionsAction}
+  | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
  | CRUserServers {user :: User, userServers :: [UserServers]}
  | CRUserServersValidation {serverErrors :: [UserServersError]}
  | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
@@ -961,12 +961,6 @@ data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (

 deriving instance Show AProtoServersConfig

-data UserServersError
-  = USEStorageMissing
-  | USEProxyMissing
-  | USEDuplicate {server :: AProtoServerWithAuth}
-  deriving (Show)
-
 data UserProtoServers p = UserProtoServers
  { serverProtocol :: SProtocolType p,
    protoServers :: NonEmpty (ServerCfg p),
@@ -1545,8 +1539,6 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DB") ''DatabaseError)

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "Chat") ''ChatError)

-$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
-
 $(JQ.deriveJSON defaultJSON ''AppFilePathsConfig)

 $(JQ.deriveJSON defaultJSON ''ContactSubStatus)
--- a/src/Simplex/Chat/Operators.hs
+++ b/src/Simplex/Chat/Operators.hs
@@ -13,20 +13,22 @@ import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
 import Data.FileEmbed
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Text (Text)
-import Data.Time.Clock (UTCTime)
+import Data.Time (addUTCTime)
+import Data.Time.Clock (UTCTime, nominalDay)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Language.Haskell.TH.Syntax (lift)
 import Simplex.Chat.Operators.Conditions
 import Simplex.Chat.Types.Util (textParseJSON)
-import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles)
+import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
-import Simplex.Messaging.Protocol (ProtocolType (..))
+import Simplex.Messaging.Protocol (AProtoServerWithAuth, ProtocolType (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)

 usageConditionsCommit :: Text
@@ -74,9 +76,30 @@ data UsageConditionsAction
  | UCAAccepted {operators :: [ServerOperator]}
  deriving (Show)

-- TODO UI logic
-usageConditionsAction :: [ServerOperator] -> UsageConditionsAction
-usageConditionsAction _operators = UCAAccepted []
+usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
+usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
+  let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
+  if null enabledOperators
+    then Nothing
+    else
+      if all conditionsAccepted enabledOperators
+        then
+          let acceptedForOperators = filter conditionsAccepted operators
+           in Just $ UCAAccepted acceptedForOperators
+        else
+          let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
+              deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
+              showNotice = isNothing notifiedAt
+           in Just $ UCAReview acceptForOperators deadline showNotice
+
+conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
+conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
+  if notifiedAtOrNow < addUTCTime (14 * nominalDay) createdAt
+    then Just $ conditionsDeadline notifiedAtOrNow
+    else Nothing -- required
+  where
+    conditionsDeadline :: UTCTime -> UTCTime
+    conditionsDeadline = addUTCTime (31 * nominalDay)

 data ConditionsAcceptance
  = CAAccepted {acceptedAt :: Maybe UTCTime}
@@ -95,6 +118,11 @@ data ServerOperator = ServerOperator
  }
  deriving (Show)

+conditionsAccepted :: ServerOperator -> Bool
+conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
+  CAAccepted {} -> True
+  _ -> False
+
 data OperatorEnabled = OperatorEnabled
  { operatorId :: OperatorId,
    enabled :: Bool,
@@ -128,6 +156,27 @@ groupByOperator srvOperators smpSrvs xftpSrvs =
          xftpServers = groupedXftps
        }

+data UserServersError
+  = USEStorageMissing
+  | USEProxyMissing
+  | USEDuplicate {server :: AProtoServerWithAuth}
+  deriving (Show)
+
+validateUserServers :: NonEmpty UserServers -> [UserServersError]
+validateUserServers userServers =
+  let storageMissing_ = if any (canUseForRole storage) userServers then [] else [USEStorageMissing]
+      proxyMissing_ = if any (canUseForRole proxy) userServers then [] else [USEProxyMissing]
+      -- TODO duplicate errors
+      -- allSMPServers =
+      --   map (\ServerCfg {server} -> server) $
+      --     concatMap (\UserServers {smpServers} -> smpServers) userServers
+   in storageMissing_ <> proxyMissing_ -- <> duplicateErrors
+  where
+    canUseForRole :: (ServerRoles -> Bool) -> UserServers -> Bool
+    canUseForRole roleSel UserServers {operator, smpServers, xftpServers} = case operator of
+      Just ServerOperator {roles} -> roleSel roles
+      Nothing -> not (null smpServers) && not (null xftpServers)
+
 $(JQ.deriveJSON defaultJSON ''UsageConditions)

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
@@ -137,3 +186,5 @@ $(JQ.deriveJSON defaultJSON ''ServerOperator)
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)

 $(JQ.deriveJSON defaultJSON ''UserServers)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
--- a/src/Simplex/Chat/Store/Profiles.hs
+++ b/src/Simplex/Chat/Store/Profiles.hs
@@ -53,6 +53,9 @@ module Simplex.Chat.Store.Profiles
    setServerOperators,
    getCurrentUsageConditions,
    getLatestAcceptedConditions,
+    setConditionsNotified,
+    acceptConditions,
+    setUserServers,
    createCall,
    deleteCalls,
    getCalls,
@@ -76,8 +79,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, splitOn)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time (addUTCTime)
-import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
+import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 import Simplex.Chat.Call
@@ -542,6 +544,7 @@ getProtocolServers db User {userId} =
          roles = ServerRoles {storage = fromMaybe True storage_, proxy = fromMaybe True proxy_}
       in ServerCfg {server, operator, preset, tested, enabled, roles}

+-- 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 :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
@@ -565,27 +568,29 @@ overwriteProtocolServers db User {userId} servers =
  where
    protocol = decodeLatin1 $ strEncode $ protocolTypeI @p

-getServerOperators :: DB.Connection -> ExceptT StoreError IO [ServerOperator]
+getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
 getServerOperators db = do
  now <- liftIO getCurrentTime
  currentConditions <- getCurrentUsageConditions db
  latestAcceptedConditions <- getLatestAcceptedConditions db
-  liftIO $
-    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,
-          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
-        ) AcceptedConditions ON AcceptedConditions.server_operator_id = so.server_operator_id
-      |]
+  operators <-
+    liftIO $
+      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,
+              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
+            ) AcceptedConditions ON AcceptedConditions.server_operator_id = so.server_operator_id
+          |]
+  pure (operators, usageConditionsAction operators currentConditions now)
  where
    toOperator ::
      UTCTime ->
@@ -620,20 +625,12 @@ getServerOperators db = do
                | otherwise ->
                    if operatorCommit == latestAcceptedCommit
                      then -- new conditions available, latest accepted conditions were accepted for operator
-                        conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
+                        CARequired $ 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.Connection -> NonEmpty OperatorEnabled -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
 setServerOperators db operatorsEnabled = do
  liftIO $ forM_ operatorsEnabled $ \OperatorEnabled {operatorId, enabled, roles = ServerRoles {storage, proxy}} ->
    DB.execute
@@ -667,7 +664,6 @@ getLatestAcceptedConditions db = do
          [sql|
          SELECT conditions_commit
          FROM operator_usage_conditions
-          WHERE conditions_accepted = 1
          ORDER BY accepted_at DESC
          LIMIT 1
        |]
@@ -682,6 +678,77 @@ getLatestAcceptedConditions db = do
        |]
        (Only latestAcceptedCommit)

+setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
+setConditionsNotified db conditionsId notifiedAt =
+  DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, conditionsId)
+
+acceptConditions :: DB.Connection -> Int64 -> NonEmpty ServerOperator -> UTCTime -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
+acceptConditions db conditionsId operators acceptedAt = do
+  UsageConditions {conditionsCommit} <- getUsageConditionsById_ db conditionsId
+  liftIO $ forM_ operators $ \ServerOperator {operatorId, operatorTag} ->
+    DB.execute
+      db
+      [sql|
+        INSERT INTO operator_usage_conditions
+          (server_operator_id, server_operator_tag, conditions_commit, accepted_at)
+        VALUES (?,?,?,?)
+      |]
+      (operatorId, operatorTag, conditionsCommit, acceptedAt)
+  getServerOperators db
+
+getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
+getUsageConditionsById_ db conditionsId =
+  ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
+    DB.query
+      db
+      [sql|
+        SELECT usage_conditions_id, conditions_commit, notified_at, created_at
+        FROM usage_conditions
+        WHERE usage_conditions_id = ?
+      |]
+      (Only conditionsId)
+
+setUserServers :: DB.Connection -> User -> NonEmpty UserServers -> ExceptT StoreError IO ()
+setUserServers db User {userId} userServers = do
+  currentTs <- liftIO getCurrentTime
+  forM_ userServers $ do
+    \UserServers {operator, smpServers, xftpServers} -> do
+      forM_ operator $ \op -> liftIO $ updateOperator currentTs op
+      overwriteServers currentTs operator smpServers
+      overwriteServers currentTs operator xftpServers
+  where
+    updateOperator :: UTCTime -> ServerOperator -> IO ()
+    updateOperator currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
+      DB.execute
+        db
+        [sql|
+          UPDATE server_operators
+          SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
+          WHERE server_operator_id = ?
+        |]
+        (enabled, storage, proxy, operatorId, currentTs)
+    overwriteServers :: forall p. ProtocolTypeI p => UTCTime -> Maybe ServerOperator -> [ServerCfg p] -> ExceptT StoreError IO ()
+    overwriteServers currentTs serverOperator servers =
+      checkConstraint SEUniqueID . ExceptT $ do
+        case serverOperator of
+          Nothing ->
+            DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id IS NULL AND protocol = ?" (userId, protocol)
+          Just ServerOperator {operatorId} ->
+            DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id = ? AND protocol = ?" (userId, operatorId, protocol)
+        forM_ servers $ \ServerCfg {server, operator, preset, tested, enabled} -> do
+          let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
+          DB.execute
+            db
+            [sql|
+              INSERT INTO protocol_servers
+                (protocol, host, port, key_hash, basic_auth, operator, preset, tested, enabled, user_id, created_at, updated_at)
+              VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+            |]
+            ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, operator) :. (preset, tested, enabled, userId, currentTs, currentTs))
+        pure $ Right ()
+      where
+        protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
+
 -- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
 -- updateServerOperators_ db operators = do
 --   DB.execute_ db "DELETE FROM server_operators WHERE preset = 0"