diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3bc90e8c9e..bee897e46c 100644 --- a/src/Simplex/Chat.hs +++ b/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" diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 768d657e7a..9f53e4a2d9 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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 diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs index 42c28be675..cf1c91e401 100644 --- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs +++ b/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,%"; |] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 07c363eda9..1541f36b60 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/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')) ); diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 2aca5f7177..72d3f639eb 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/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 diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index d6627505f3..259d08d9ad 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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"