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

2026-04-27 19:26:12 +00:00 · 2024-11-05 21:40:33 +04:00
parent 3b0205b25f
commit 2da89c2cf1
4 changed files with 181 additions and 64 deletions
@@ -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"