From bdaec30fa084e4c18964035d432abc42a55288a7 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 4 Nov 2024 21:11:03 +0400 Subject: [PATCH] core: getServerOperators, getUserServers, getUsageConditions apis wip (#5141) --- src/Simplex/Chat.hs | 31 +++++++------ src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Operators.hs | 38 ++++++++++++---- src/Simplex/Chat/Store/Profiles.hs | 73 ++++++++++++++++++++++++------ src/Simplex/Chat/Store/Shared.hs | 1 + 5 files changed, 107 insertions(+), 38 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 380f6c5d24..bd165ea5e6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1489,8 +1489,7 @@ processChatCommand' vr = \case APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do cfg@ChatConfig {defaultServers} <- asks config srvs <- withFastStore' (`getProtocolServers` user) - ts <- liftIO getCurrentTime - operators <- withFastStore' $ \db -> getServerOperators db ts + 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,27 +1507,31 @@ processChatCommand' vr = \case lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) TestProtoServer srv -> withUser $ \User {userId} -> processChatCommand $ APITestProtoServer userId srv - APIGetServerOperators -> pure $ chatCmdError Nothing "not supported" + APIGetServerOperators -> do + operators <- withFastStore $ \db -> getServerOperators db + let conditionsAction = usageConditionsAction operators + pure $ CRServerOperators operators conditionsAction APISetServerOperators _operators -> pure $ chatCmdError Nothing "not supported" - APIGetUserServers userId -> withUserId userId $ \user -> - pure $ chatCmdError (Just user) "not supported" + APIGetUserServers userId -> withUserId userId $ \user -> do + (operators, smpServers, xftpServers) <- withFastStore $ \db -> do + 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 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" APIGetUsageConditions -> do + usageConditions <- withFastStore $ \db -> getCurrentUsageConditions db -- TODO - -- get current conditions -- get latest accepted conditions (from operators) - ts <- liftIO getCurrentTime - let usageConditions = - UsageConditions - { conditionsId = 1, - conditionsCommit = "abc", - notifiedAt = Nothing, - createdAt = ts - } pure CRUsageConditions { usageConditions = usageConditions, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index bd2cee3e50..2cb8e0cd42 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -589,7 +589,7 @@ data ChatResponse | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]} | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} | CRServerOperators {operators :: [ServerOperator], conditionsAction :: UsageConditionsAction} - | CRUserServers {userServers :: [UserServers]} + | CRUserServers {user :: User, userServers :: [UserServers]} | CRUserServersValidation {serverErrors :: [UserServersError]} | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions} | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64} diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 9a2dac0b1b..ff110e2ada 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,7 +13,9 @@ 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.Text (Text) import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) @@ -20,10 +23,10 @@ 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, 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 (ProtoServerWithAuth, ProtocolType (..)) +import Simplex.Messaging.Protocol (ProtocolType (..)) import Simplex.Messaging.Util (safeDecodeUtf8) usageConditionsCommit :: Text @@ -72,8 +75,8 @@ data UsageConditionsAction deriving (Show) -- TODO UI logic -usageConditionsAction :: UsageConditionsAction -usageConditionsAction = UCAAccepted [] +usageConditionsAction :: [ServerOperator] -> UsageConditionsAction +usageConditionsAction _operators = UCAAccepted [] data ConditionsAcceptance = CAAccepted {acceptedAt :: UTCTime} @@ -93,12 +96,31 @@ data ServerOperator = ServerOperator deriving (Show) data UserServers = UserServers - { operator :: ServerOperator, - smpServers :: NonEmpty (ProtoServerWithAuth 'PSMP), - xftpServers :: NonEmpty (ProtoServerWithAuth 'PXFTP) + { operator :: Maybe ServerOperator, + smpServers :: [ServerCfg 'PSMP], + xftpServers :: [ServerCfg 'PXFTP] } deriving (Show) +groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers] +groupByOperator srvOperators smpSrvs xftpSrvs = + map createOperatorServers (M.toList combinedMap) + where + srvOperatorId :: ServerCfg p -> Maybe Int64 + srvOperatorId ServerCfg {operator} = operator + operatorMap :: Map (Maybe Int64) (Maybe ServerOperator) + operatorMap = M.fromList [(Just (operatorId 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 + combinedMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (smps, server : xftps)) (srvOperatorId server) acc) smpsMap xftpSrvs + createOperatorServers (key, (groupedSmps, groupedXftps)) = + UserServers + { operator = fromMaybe Nothing (M.lookup key operatorMap), + smpServers = groupedSmps, + xftpServers = groupedXftps + } + $(JQ.deriveJSON defaultJSON ''UsageConditions) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index fe2cc737fb..d6627505f3 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -50,6 +50,7 @@ module Simplex.Chat.Store.Profiles -- overwriteOperatorsAndServers, overwriteProtocolServers, getServerOperators, + getCurrentUsageConditions, createCall, deleteCalls, getCalls, @@ -73,7 +74,8 @@ import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Call @@ -540,7 +542,7 @@ getProtocolServers db User {userId} = -- 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 () +overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () overwriteProtocolServers db User {userId} servers = -- liftIO $ mapM_ (updateServerOperators_ db) operators_ checkConstraint SEUniqueID . ExceptT $ do @@ -556,25 +558,66 @@ overwriteProtocolServers db User {userId} servers = VALUES (?,?,?,?,?,?,?,?,?,?,?) |] ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) - pure $ Right () -- Right <$> getProtocolServers db user + pure $ Right () where protocol = decodeLatin1 $ strEncode $ protocolTypeI @p -getServerOperators :: DB.Connection -> UTCTime -> IO [ServerOperator] -getServerOperators db ts = - map toOperator - <$> DB.query_ - db - [sql| - SELECT server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy - FROM server_operators; +getServerOperators :: DB.Connection -> ExceptT StoreError IO [ServerOperator] +getServerOperators db = do + conditions <- getCurrentUsageConditions db + liftIO $ + map (toOperator conditions) + <$> 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 + 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 |] where - -- TODO get conditions state - toOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) = - let roles = ServerRoles {storage, proxy} - in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains = [domains], acceptedConditions = CAAccepted ts, enabled, roles} + toOperator :: + UsageConditions -> + ( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) + :. (Maybe Text, Maybe UTCTime) + ) -> + ServerOperator + toOperator + UsageConditions {conditionsCommit, createdAt} + ( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) + :. (operatorConditionsCommit_, acceptedAt_) + ) = + let roles = ServerRoles {storage, proxy} + acceptedConditions = case (operatorConditionsCommit_, acceptedAt_) of + (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) + +getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions +getCurrentUsageConditions db = + ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $ + DB.query_ + db + [sql| + SELECT usage_conditions_id, conditions_commit, notified_at, created_at + FROM usage_conditions + ORDER BY usage_conditions_id DESC LIMIT 1 + |] + +toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions +toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) = + UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} -- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator] -- updateServerOperators_ db operators = do diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index f9a8685ec8..083079e2ea 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -127,6 +127,7 @@ data StoreError | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} | SERemoteCtrlDuplicateCA | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId} + | SEUsageConditionsNotFound deriving (Show, Exception) $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)