From 6128a248693d55518819290fc2d7cfbb701684a0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 6 Nov 2024 08:09:02 +0000 Subject: [PATCH] database entity IDs --- src/Simplex/Chat.hs | 2 +- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Operators.hs | 211 +++++++++++++++++++++-------- src/Simplex/Chat/Store/Profiles.hs | 17 ++- 4 files changed, 165 insertions(+), 67 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 60feda2a66..83649712a7 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -191,7 +191,7 @@ defaultChatConfig = smpServers = xyzSMPServers, useSMP = 3, xftpServers = xyzXFTPServers, - useXFTP = 3, + useXFTP = 3 } ], ntf = _defaultNtfServers, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8fe5de6a9b..2597a685dd 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -85,7 +85,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol) +import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol) import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Transport (TLS, simplexMQVersion) import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost) diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 8126a91de4..b8a97c00ea 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -1,10 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Chat.Operators where @@ -17,12 +22,15 @@ import qualified Data.Aeson.TH as JQ import Data.FileEmbed import Data.Foldable1 (fold1) import Data.Int (Int64) +import Data.Kind (Type) 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, isNothing) +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime, nominalDay) @@ -49,8 +57,32 @@ usageConditionsText = in [| stripFrontMatter (safeDecodeUtf8 $(lift s)) |] ) +data EntityStored = ESStored | ESNew + +data SEntityStored (s :: EntityStored) where + SESStored :: SEntityStored 'ESStored + SESNew :: SEntityStored 'ESNew + +data DBEntityId' (s :: EntityStored) where + DBEntityId :: Int64 -> DBEntityId' 'ESStored + NewDBEntity :: DBEntityId' 'ESNew + +deriving instance Show (DBEntityId' s) + +type DBEntityId = DBEntityId' 'ESStored + +type NewDBEntity = DBEntityId' 'ESNew + +data ADBEntityId = forall s. AEI (SEntityStored s) (DBEntityId' s) + +pattern ADBEntityId :: Int64 -> ADBEntityId +pattern ADBEntityId i = AEI SESStored (DBEntityId i) + +pattern ANewDBEntity :: ADBEntityId +pattern ANewDBEntity = AEI SESNew NewDBEntity + data OperatorTag = OTSimplex | OTXyz - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance FromField OperatorTag where fromField = fromTextField_ textDecode @@ -72,6 +104,12 @@ instance TextEncoding OperatorTag where OTSimplex -> "simplex" OTXyz -> "xyz" +-- this and other types only define instances of serialization for known DB IDs only, +-- entities without IDs cannot be serialized to JSON +instance FromField DBEntityId where fromField f = DBEntityId <$> fromField f + +instance ToField DBEntityId where toField (DBEntityId i) = toField i + data UsageConditions = UsageConditions { conditionsId :: Int64, conditionsCommit :: Text, @@ -115,8 +153,14 @@ data ConditionsAcceptance | CARequired {deadline :: Maybe UTCTime} deriving (Show) -data ServerOperator = ServerOperator - { operatorId :: Maybe OperatorId, +type ServerOperator = ServerOperator' DBEntityId + +type NewServerOperator = ServerOperator' NewDBEntity + +type AServerOperator = ServerOperator' ADBEntityId + +data ServerOperator' s = ServerOperator + { operatorId :: s, operatorTag :: Maybe OperatorTag, appVendor :: Bool, tradeName :: Text, @@ -128,6 +172,9 @@ data ServerOperator = ServerOperator } deriving (Show) +aServerOperator :: ServerOperator -> AServerOperator +aServerOperator op@ServerOperator {operatorId = DBEntityId opId} = op {operatorId = ADBEntityId opId} + conditionsAccepted :: ServerOperator -> Bool conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of CAAccepted {} -> True @@ -140,15 +187,25 @@ data OperatorEnabled = OperatorEnabled } deriving (Show) -data UserServers = UserServers - { operator :: Maybe ServerOperator, - smpServers :: [UserServer 'PSMP], - xftpServers :: [UserServer 'PXFTP] +type UserServers = UserServers' DBEntityId + +type AUserServers = UserServers' ADBEntityId + +data UserServers' s = UserServers + { operator :: Maybe (ServerOperator' s), + smpServers :: [UserServer' s 'PSMP], + xftpServers :: [UserServer' s 'PXFTP] } deriving (Show) -data UserServer p = UserServer - { serverId :: Maybe Int64, +type UserServer p = UserServer' DBEntityId p + +type NewUserServer p = UserServer' NewDBEntity p + +type AUserServer p = UserServer' ADBEntityId p + +data UserServer' s p = UserServer + { serverId :: s, serverOperatorId :: Maybe OperatorId, server :: ProtoServerWithAuth p, tested :: Maybe Bool, @@ -157,7 +214,7 @@ data UserServer p = UserServer deriving (Show) data PresetOperatorServers = PresetOperatorServers - { operator :: ServerOperator, + { operator :: NewServerOperator, presetSMPServers :: NonEmpty (PresetServer 'PSMP), presetXFTPServers :: NonEmpty (PresetServer 'PXFTP), useSMP :: Int, @@ -190,56 +247,78 @@ usageConditionsToAdd newUser prevCommit sourceCommit createdAt = \case -- 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 :: NonEmpty PresetOperatorServers -> [ServerOperator] -> [AServerOperator] updatedServerOperators presetSrvs storedOps = - foldr addPreset [] presetSrvs <> filter (isNothing . operatorTag) storedOps -- TODO remove domains of preset operators from custom + foldr addPreset [] presetSrvs + <> map aServerOperator (filter (isNothing . operatorTag) storedOps) -- TODO remove domains of preset operators from custom where 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] - } + Just ServerOperator {operatorId = DBEntityId opId, conditionsAcceptance, enabled, roles} -> + presetOp {operatorId = ADBEntityId opId, conditionsAcceptance, enabled, roles} + Nothing -> presetOp {operatorId = ANewDBEntity} -- 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') +-- +-- presets -> stored or user-supplied servers, possibly with incorrect operators +updatedUserServers' :: NonEmpty PresetOperatorServers -> [UserServers] -> ([AUserServers], NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)) +updatedUserServers' presetSrvs storedSrvs = (userServers, agentSMPServers, agentXFTPServers) 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) + userServers = undefined + agentSMPServers = undefined + agentXFTPServers = undefined + -- make set of known tags of preset operators + knownPresetOps :: Set (Maybe OperatorTag) + knownPresetOps = foldl' (\s PresetOperatorServers {operator} -> S.insert (operatorTag operator) s) S.empty presetSrvs - 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 + -- make map domain -> operator + -- storedSrvs: + -- - remove preset operators with tags not present in presets) + -- - flatten + -- - set correct operators based on domains + -- - split servers to with/without preset operators + -- - make Map (protoserver, stored server record) from servers with preset operators + -- presetSrvs: flatten, update using map above, prepare agent servers, reassemble to userServers + -- add other operators and servers without operator + -- + -- (storedPresets, storedOthers) = partition (isJust . operatorTag . operator) storedSrvs + -- (storedOthersKeep, storeOthersPresets) + -- userServers = foldr addOther (foldr addPreset [] presetSrvs) storedOthers + + +-- 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 @@ -254,11 +333,10 @@ updatedUserServers presetSrvs storedOps smpSrvs xftpSrvs = do -- 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]) +-- srvOperatorId ServerCfg {operator} = DBEntityId <$> operator +-- operatorMap :: Map (Maybe DBEntityId) (Maybe ServerOperator) +-- operatorMap = M.fromList [(Just (operatorId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing +-- initialMap :: Map (Maybe DBEntityId) ([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 @@ -290,21 +368,38 @@ validateUserServers userServers = Just ServerOperator {roles} -> roleSel roles Nothing -> not (null smpServers) && not (null xftpServers) +instance ToJSON DBEntityId where + toEncoding (DBEntityId i) = toEncoding i + toJSON (DBEntityId i) = toJSON i + +instance FromJSON DBEntityId where + parseJSON v = DBEntityId <$> parseJSON v + $(JQ.deriveJSON defaultJSON ''UsageConditions) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance) -$(JQ.deriveJSON defaultJSON ''ServerOperator) +instance ToJSON ServerOperator where + toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator') + toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator') + +instance FromJSON ServerOperator where + parseJSON = $(JQ.mkParseJSON 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) + toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer') + toJSON = $(JQ.mkToJSON defaultJSON ''UserServer') instance ProtocolTypeI p => FromJSON (UserServer p) where - parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer) + parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer') -$(JQ.deriveJSON defaultJSON ''UserServers) +instance ToJSON UserServers where + toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServers') + toJSON = $(JQ.mkToJSON defaultJSON ''UserServers') + +instance FromJSON UserServers where + parseJSON = $(JQ.mkParseJSON 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 f4f574c3d7..567f294d32 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -596,7 +597,7 @@ getServerOperators db = do UTCTime -> UsageConditions -> Maybe UsageConditions -> - ( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) + ( (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) :. (Maybe Text, Maybe UTCTime) ) -> ServerOperator @@ -628,15 +629,16 @@ getServerOperators db = do 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} + in ServerOperator {operatorId, operatorTag, appVendor = False, tradeName, legalName, serverDomains, conditionsAcceptance, enabled, roles} + -- TODO appVendor 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}} -> + 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) + (enabled', storage, proxy, operatorId') getServerOperators db getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions @@ -727,7 +729,7 @@ setUserServers db User {userId} userServers = do WHERE server_operator_id = ? |] (enabled, storage, proxy, operatorId, currentTs) - overwriteServers :: forall p. ProtocolTypeI p => UTCTime -> Maybe ServerOperator -> [ServerCfg p] -> ExceptT StoreError IO () + overwriteServers :: forall p. ProtocolTypeI p => UTCTime -> Maybe ServerOperator -> [UserServer p] -> ExceptT StoreError IO () overwriteServers currentTs serverOperator servers = checkConstraint SEUniqueID . ExceptT $ do case serverOperator of @@ -735,7 +737,7 @@ setUserServers db User {userId} userServers = do 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 + forM_ servers $ \UserServer {server, serverOperatorId, tested, enabled} -> do let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server DB.execute db @@ -744,7 +746,8 @@ setUserServers db User {userId} userServers = do (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)) + ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, serverOperatorId) :. (False, tested, enabled, userId, currentTs, currentTs)) + -- take preset from operator pure $ Right () where protocol = decodeLatin1 $ strEncode $ protocolTypeI @p