diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b083134e2c..69b78ba9d4 100644 --- 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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 81e7a9980b..cbfa0969d4 100644 --- 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) diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 6fc5663085..5e32807ddc 100644 --- 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) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 259d08d9ad..f4f574c3d7 100644 --- 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"