From 601ddf97ce1faaab88668d4e6292c68d188c6901 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Tue, 5 Nov 2024 16:29:30 +0000 Subject: [PATCH] WIP --- .../Migrations/M20241027_server_operators.hs | 1 - src/Simplex/Chat/Operators.hs | 168 +++++++++++++----- 2 files changed, 126 insertions(+), 43 deletions(-) diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs index cf1c91e401..fc0ca21e54 100644 --- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs +++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs @@ -37,7 +37,6 @@ CREATE TABLE operator_usage_conditions ( server_operator_id INTEGER REFERENCES server_operators (server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE, server_operator_tag TEXT, conditions_commit TEXT NOT NULL, - conditions_accepted INTEGER NOT NULL, accepted_at TEXT, created_at TEXT NOT NULL DEFAULT (datetime('now')) ); diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 72d3f639eb..cb8bbfe1d5 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -4,21 +4,25 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Chat.Operators where +import Control.Monad (foldM) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ import Data.FileEmbed +import Data.Foldable1 (fold1) import Data.Int (Int64) -import Data.List (find) +import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L 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 Database.SQLite.Simple.FromField (FromField (..)) @@ -26,10 +30,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, ServerCfg (..), ServerRoles) +import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerRoles) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) -import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..)) +import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI) import Simplex.Messaging.Util (safeDecodeUtf8) usageConditionsCommit :: Text @@ -45,7 +49,7 @@ usageConditionsText = ) data OperatorTag = OTSimplex | OTXyz - deriving (Show) + deriving (Eq, Show) instance FromField OperatorTag where fromField = fromTextField_ textDecode @@ -90,7 +94,7 @@ data ConditionsAcceptance deriving (Show) data ServerOperator = ServerOperator - { operatorId :: OperatorId, + { operatorId :: Maybe OperatorId, operatorTag :: Maybe OperatorTag, appVendor :: Bool, tradeName :: Text, @@ -103,23 +107,32 @@ data ServerOperator = ServerOperator deriving (Show) data OperatorEnabled = OperatorEnabled - { operatorId :: OperatorId, - enabled :: Bool, - roles :: ServerRoles + { operatorId' :: OperatorId, + enabled' :: Bool, + roles' :: ServerRoles } deriving (Show) data UserServers = UserServers { operator :: Maybe ServerOperator, - smpServers :: [ServerCfg 'PSMP], - xftpServers :: [ServerCfg 'PXFTP] + smpServers :: [UserServer 'PSMP], + xftpServers :: [UserServer 'PXFTP] + } + deriving (Show) + +data UserServer p = UserServer + { serverId :: Maybe Int64, + serverOperatorId :: Maybe OperatorId, + server :: ProtoServerWithAuth p, + tested :: Maybe Bool, + enabled :: Bool } deriving (Show) data PresetOperatorServers = PresetOperatorServers { operator :: ServerOperator, - smpServers :: NonEmpty (PresetServer 'PSMP), - xftpServers :: NonEmpty (PresetServer 'PXFTP), + presetSMPServers :: NonEmpty (PresetServer 'PSMP), + presetXFTPServers :: NonEmpty (PresetServer 'PXFTP), useSMP :: Int, useXFTP :: Int } @@ -129,41 +142,105 @@ data PresetServer p = PresetServer server :: ProtoServerWithAuth p } --- this function should be called inside DB transaction to update conditions in the database --- it returns (current conditions record in the final list, conditions to add, all conditions) -usageConditionsToAdd :: Text -> Text -> UTCTime -> [UsageConditions] -> (UsageConditions, [UsageConditions]) -usageConditionsToAdd prevCommit currCommit createdAt = \case - [] -> (currCond, [prevCond, currCond]) +-- This function should be used inside DB transaction to update conditions in the database +-- it returns (conditions to mark as accepted to SimpleX operator, conditions to add) +usageConditionsToAdd :: Bool -> Text -> Text -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, [UsageConditions]) +usageConditionsToAdd newUser prevCommit sourceCommit createdAt = \case + [] + | newUser -> (Just sourceCond, [sourceCond]) + | otherwise -> (Just prevCond, [prevCond, sourceCond]) where prevCond = conditions 1 prevCommit - currCond = conditions 2 currCommit - conds -> case find ((currCommit ==) . conditionsCommit) conds of - Just currCond -> (currCond, []) - Nothing -> (currCond, [currCond]) - where - cId = maximum (map conditionsId conds) + 1 - currCond = conditions cId currCommit + sourceCond = conditions 2 sourceCommit + conds -> (Nothing, if hasSourceCond then [] else [sourceCond]) + where + hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds + sourceCond = conditions cId sourceCommit + cId = maximum (map conditionsId conds) + 1 where conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt} -groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers] -groupByOperator srvOperators smpSrvs xftpSrvs = - map createOperatorServers (M.toList combinedMap) +-- This function should be used inside DB transaction to update operators. +-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings, +-- and preserves custom operators without tags for forward compatibility. +updatedServerOperators :: NonEmpty PresetOperatorServers -> [ServerOperator] -> [ServerOperator] +updatedServerOperators presetSrvs storedOps = + foldr addPreset [] presetSrvs <> filter (isNothing . operatorTag) storedOps -- TODO remove domains of preset operators from custom where - srvOperatorId ServerCfg {operator} = operator - opId ServerOperator {operatorId} = operatorId - operatorMap :: Map (Maybe Int64) (Maybe ServerOperator) - 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 - 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 - } + addPreset PresetOperatorServers {operator = presetOp} = (storedOp' :) + where + storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of + Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} -> + presetOp {operatorId, conditionsAcceptance, enabled, roles} + Nothing -> presetOp + + +data UpdatedServers p = UpdatedServers + { toUpsert :: [UserServer p], + toDelete :: [Int64] + } + +-- This function should be used inside DB transaction to update servers. +-- It assumes that the list of operators was amended using updatedServerOperators, +-- that [ServerOperator] has the same operators as [PresetOperatorServers], +-- and that they all have serverOperatorId set. +updatedUserServers :: NonEmpty PresetOperatorServers -> [ServerOperator] -> [UserServer 'PSMP] -> [UserServer 'PXFTP] -> Either String ([UserServer 'PSMP], [UserServer 'PXFTP]) +updatedUserServers presetSrvs storedOps smpSrvs xftpSrvs = do + smpSrvs' <- updatedSrvs useSMP smpSrvs =<< presetSrvsToStore presetSMPServers + xftpSrvs' <- updatedSrvs useXFTP xftpSrvs =<< presetSrvsToStore presetXFTPServers + pure (smpSrvs', xftpSrvs') + where + presetSrvsToStore :: forall p. (PresetOperatorServers -> NonEmpty (PresetServer p)) -> Either String (NonEmpty (Bool, UserServer p)) + presetSrvsToStore presetSel = fold1 <$> mapM operatorSrvs presetSrvs + where + operatorSrvs :: PresetOperatorServers -> Either String (NonEmpty (Bool, UserServer p)) + operatorSrvs op@PresetOperatorServers {operator} = case find ((operatorTag operator ==) . operatorTag) storedOps of + Nothing -> Left "preset operator not stored" + Just op' -> Right $ L.map (userSrv op') (presetSel op) + userSrv op PresetServer {server, useServer} = + let srv = UserServer {serverId = Nothing, serverOperatorId = operatorId op, server, tested = Nothing, enabled = False} + in (useServer, srv) + + updatedSrvs :: forall p. (PresetOperatorServers -> Int) -> [UserServer p] -> NonEmpty (Bool, UserServer p) -> Either String [UserServer p] + updatedSrvs useSel storedSrvs presetSrvs = + fmap enabledSrvs . addOtherServers =<< foldM updatedSrv (storedSrvs', []) presetSrvs + where + storedSrvs' :: Map (ProtoServerWithAuth p) (UserServer p) + storedSrvs' = foldl' (\m us@UserServer {server} -> M.insert server us m) M.empty storedSrvs + updatedSrv :: (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)]) -> (Bool, UserServer p) -> Either String (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)]) + updatedSrv srvs srv = undefined + addOtherServers :: (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)]) -> Either String [(Bool, UserServer p)] + addOtherServers = undefined + enabledSrvs :: [(Bool, UserServer p)] -> [UserServer p] + enabledSrvs = undefined + + -- addSrv srv@ServerCfg {server = ProtocolServerWithAuth ProtocolServer {host}} uss = + -- case find (\us -> any [\h -> any (\d -> d `T.isSuffixOf` ) serverDomains (operator us)] host) uss of + -- Just opId + -- where + -- hasOperatorDomain ServerCfg {server = ProtocolServerWithAuth ProtocolServer {host}} us + + + -- addSrv srv uss = ... а тут просто найти оператора в списке и вставить ему сервер через add и как то ругнуться если его нет (но такого не должно быть). Либо вообще есть вариант сразу читать в этом формате - сначала прочитать операторов и в цикле читать серверы каждого - это вот может быть еще проще + +-- groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers] +-- groupByOperator srvOperators smpSrvs xftpSrvs = +-- map createOperatorServers (M.toList combinedMap) +-- where +-- srvOperatorId ServerCfg {operator} = operator +-- opId ServerOperator {operatorId} = operatorId +-- operatorMap :: Map (Maybe Int64) (Maybe ServerOperator) +-- 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 +-- 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) @@ -173,4 +250,11 @@ $(JQ.deriveJSON defaultJSON ''ServerOperator) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction) +instance ProtocolTypeI p => ToJSON (UserServer p) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer) + toJSON = $(JQ.mkToJSON defaultJSON ''UserServer) + +instance ProtocolTypeI p => FromJSON (UserServer p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer) + $(JQ.deriveJSON defaultJSON ''UserServers)