diff --git a/cabal.project b/cabal.project index 61ce04a569..74f944c37d 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: ff05a465ee15ac7ae2c14a9fb703a18564950631 + tag: 93f30c8edf9243ad2291dd6427d87328e282560a source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 3e0f103641..bd2602c1b6 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."ff05a465ee15ac7ae2c14a9fb703a18564950631" = "1gv4nwqzbqkj7y3ffkiwkr4qwv52vdzppsds5vsfqaayl14rzmgp"; + "https://github.com/simplex-chat/simplexmq.git"."93f30c8edf9243ad2291dd6427d87328e282560a" = "1zf0sp9dy6kz4zvyz6mdgmhydps7khcq84n30irp983w1xh7gzs7"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 72653ef4ad..e899a73eeb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -98,7 +99,7 @@ import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, getFastNetworkConfig, ipAddressProtected, withLockMap) -import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), OperatorId, ServerCfg (..), allRoles, createAgentStore, defaultAgentConfig, enabledServerCfg, presetServerCfg) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), OperatorId, ServerCfg (..), ServerRoles (..), allRoles, createAgentStore, defaultAgentConfig, presetServerCfg) import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) @@ -138,30 +139,28 @@ import qualified UnliftIO.Exception as E import UnliftIO.IO (hClose, hSeek, hTell, openFile) import UnliftIO.STM -operatorSimpleXChat :: ServerOperator +operatorSimpleXChat :: NewServerOperator operatorSimpleXChat = ServerOperator - { operatorId = Nothing, + { operatorId = DBNewEntity, operatorTag = Just OTSimplex, - appVendor = True, tradeName = "SimpleX Chat", legalName = Just "SimpleX Chat Ltd", serverDomains = ["simplex.im"], - acceptedConditions = CARequired Nothing, + conditionsAcceptance = CARequired Nothing, enabled = True, roles = allRoles } -operatorXYZ :: ServerOperator +operatorXYZ :: NewServerOperator operatorXYZ = ServerOperator - { operatorId = Nothing, + { operatorId = DBNewEntity, operatorTag = Just OTXyz, - appVendor = False, tradeName = "XYZ", legalName = Just "XYZ Ltd", serverDomains = ["xyz.com"], - acceptedConditions = CARequired Nothing, + conditionsAcceptance = CARequired Nothing, enabled = False, roles = ServerRoles {storage = False, proxy = True} } @@ -179,18 +178,18 @@ defaultChatConfig = presetServers = PresetServers { operators = - [ PresetOperatorServers + [ PresetOperator { operator = operatorSimpleXChat, - smpServers = simplexChatSMPServers, + smp = simplexChatSMPServers, useSMP = 4, - xftpServers = L.map (PresetServer True) defaultXFTPServers, + xftp = L.map (presetServer True) defaultXFTPServers, useXFTP = 3 }, - PresetOperatorServers + PresetOperator { operator = operatorXYZ, - smpServers = xyzSMPServers, + smp = xyzSMPServers, useSMP = 3, - xftpServers = xyzXFTPServers, + xftp = xyzXFTPServers, useXFTP = 3 } ], @@ -218,10 +217,10 @@ defaultChatConfig = chatHooks = defaultChatHooks } -simplexChatSMPServers :: NonEmpty (PresetServer 'PSMP) -simplexChatSMPServers = +simplexChatSMPServers :: NonEmpty (NewUserServer 'PSMP) +simplexChatSMPServers = L.map - (PresetServer True) + (presetServer True) [ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion", "smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion", "smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion", @@ -235,16 +234,16 @@ simplexChatSMPServers = "smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion" ] <> L.map - (PresetServer False) + (presetServer False) [ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion", "smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion", "smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion" ] -xyzSMPServers :: NonEmpty (PresetServer 'PSMP) +xyzSMPServers :: NonEmpty (NewUserServer 'PSMP) xyzSMPServers = L.map - (PresetServer True) + (presetServer True) [ "smp://abcd@smp1.xyz.com", "smp://abcd@smp2.xyz.com", "smp://abcd@smp3.xyz.com", @@ -253,10 +252,10 @@ xyzSMPServers = "smp://abcd@smp6.xyz.com" ] -xyzXFTPServers :: NonEmpty (PresetServer 'PXFTP) +xyzXFTPServers :: NonEmpty (NewUserServer 'PXFTP) xyzXFTPServers = L.map - (PresetServer True) + (presetServer True) [ "xftp://abcd@xftp1.xyz.com", "xftp://abcd@xftp2.xyz.com", "xftp://abcd@xftp3.xyz.com", @@ -300,16 +299,16 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo newChatController ChatDatabase {chatStore, agentStore} user - cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote, confirmMigrations} + cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize} backgroundMode = do let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations - config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'} + config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'} firstTime = dbNew chatStore currentUser <- newTVarIO user currentRemoteHost <- newTVarIO Nothing - servers <- agentServers config + servers <- withTransaction chatStore agentServers smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode agentAsync <- newTVarIO Nothing random <- liftIO C.newRandom @@ -382,28 +381,24 @@ newChatController contactMergeEnabled } where - configServers :: DefaultAgentServers - configServers = - let DefaultAgentServers {smp = defSmp, xftp = defXftp, netCfg} = defaultServers - smp' = maybe defSmp (L.map enabledServerCfg) (nonEmpty smpServers) - xftp' = maybe defXftp (L.map enabledServerCfg) (nonEmpty xftpServers) - in defaultServers {smp = smp', xftp = xftp', netCfg = updateNetworkConfig netCfg simpleNetCfg} - agentServers :: ChatConfig -> IO InitialAgentServers - agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do - users <- withTransaction chatStore getUsers - smp' <- getUserServers users SPSMP - xftp' <- getUserServers users SPXFTP + PresetServers {operators = presetOps, ntf, netCfg} = presetServers + agentServers :: DB.Connection -> IO InitialAgentServers + agentServers db = do + users <- getUsers db + opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users) + smp' <- getUserServers SPSMP users opDomains smpServers + xftp' <- getUserServers SPXFTP users opDomains xftpServers pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg} where - getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ServerCfg p))) - getUserServers users protocol = case users of - [] -> pure $ M.fromList [(1, cfgServers protocol defServers)] - _ -> M.fromList <$> initialServers + getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> [ProtoServerWithAuth p] -> IO (Map UserId (NonEmpty (ServerCfg p))) + getUserServers protocol users opDomains = maybe get srvCfgs . L.nonEmpty where - initialServers :: IO [(UserId, NonEmpty (ServerCfg p))] - initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users - userServers :: User -> IO (NonEmpty (ServerCfg p)) - userServers user' = useServers config protocol <$> withTransaction chatStore (`getProtocolServers` user') + get = do + randomSrvs <- randomPresetServers presetOps + fmap M.fromList $ forM users $ \u -> + (aUserId u,) . useServers opDomains <$> getUpdateUserServers db presetOps randomSrvs u + srvCfgs ss = pure $ M.fromList $ map (\u -> (aUserId u, L.map srvCfg ss)) users + srvCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles} updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} = @@ -446,34 +441,6 @@ withFileLock :: String -> Int64 -> CM a -> CM a withFileLock name = withEntityLock name . CLFile {-# INLINE withFileLock #-} -useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ServerCfg p) -useServers ChatConfig {defaultServers} p = fromMaybe (cfgServers p defaultServers) . nonEmpty - -randomServers :: forall p. UserProtocol p => SProtocolType p -> ChatConfig -> IO (NonEmpty (ServerCfg p), [ServerCfg p]) -randomServers p ChatConfig {defaultServers} = do - let srvs = cfgServers p defaultServers - (enbldSrvs, dsbldSrvs) = L.partition (\ServerCfg {enabled} -> enabled) srvs - toUse = cfgServersToUse p defaultServers - if length enbldSrvs <= toUse - then pure (srvs, []) - else do - (enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs - let dsbldSrvs' = map (\srv -> (srv :: ServerCfg p) {enabled = False}) srvsToDisable - srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs - pure (fromMaybe srvs $ L.nonEmpty srvs', srvs') - where - server' ServerCfg {server = ProtoServerWithAuth srv _} = srv - -cfgServers :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> NonEmpty (ServerCfg p) -cfgServers p DefaultAgentServers {smp, xftp} = case p of - SPSMP -> smp - SPXFTP -> xftp - -cfgServersToUse :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> Int -cfgServersToUse p DefaultAgentServers {useSMP, useXFTP} = case p of - SPSMP -> useSMP - SPXFTP -> useXFTP - -- enableSndFiles has no effect when mainApp is True startChatController :: Bool -> Bool -> CM' (Async ()) startChatController mainApp enableSndFiles = do @@ -616,8 +583,9 @@ processChatCommand' vr = \case forM_ profile $ \Profile {displayName} -> checkValidName displayName p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile u <- asks currentUser - (smp, smpServers) <- chooseServers SPSMP - (xftp, xftpServers) <- chooseServers SPXFTP + opDomains <- operatorDomains . fst <$> withFastStore getServerOperators + (smp, smpServers_) <- chooseServers SPSMP opDomains + (xftp, xftpServers_) <- chooseServers SPXFTP opDomains users <- withFastStore' getUsers forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> when (n == displayName) . throwChatError $ @@ -626,9 +594,10 @@ processChatCommand' vr = \case ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts createPresetContactCards user `catchChatError` \_ -> pure () - withFastStore $ \db -> createNoteFolder db user - storeServers user smpServers - storeServers user xftpServers + withFastStore $ \db -> do + createNoteFolder db user + liftIO $ mapM_ (mapM_ (insertProtocolServer db user ts)) smpServers_ + liftIO $ mapM_ (mapM_ (insertProtocolServer db user ts)) xftpServers_ atomically . writeTVar u $ Just user pure $ CRActiveUser user where @@ -637,18 +606,15 @@ processChatCommand' vr = \case withFastStore $ \db -> do createContact db user simplexStatusContactProfile createContact db user simplexTeamContactProfile - chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (ServerCfg p), [ServerCfg p]) - chooseServers protocol = - asks currentUser >>= readTVarIO >>= \case - Nothing -> asks config >>= liftIO . randomServers protocol - Just user -> chosenServers =<< withFastStore' (`getProtocolServers` user) - where - chosenServers servers = do - cfg <- asks config - pure (useServers cfg protocol servers, servers) - storeServers user servers = - unless (null servers) . withFastStore $ - \db -> overwriteProtocolServers db user servers + chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [(Text, ServerOperator)] -> CM (NonEmpty (ServerCfg p), Maybe (NonEmpty (NewUserServer p))) + chooseServers protocol opDomains = do + PresetServers {operators = presetOps} <- asks $ presetServers . config + randomSrvs <- liftIO $ randomPresetServers presetOps + chatReadVar currentUser >>= \case + Nothing -> pure (useServers opDomains randomSrvs, Just randomSrvs) + Just user -> do + srvs <- withFastStore' $ \db -> getUpdateUserServers db presetOps randomSrvs user + pure (useServers opDomains srvs, Nothing) coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withFastStore' getUsersInfo @@ -1546,43 +1512,39 @@ processChatCommand' vr = \case msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs pure $ CRConnNtfMessages ntfMsgs - APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do - cfg@ChatConfig {defaultServers} <- asks config - srvs <- withFastStore' (`getProtocolServers` user) - (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} -> - processChatCommand $ APIGetUserProtoServers userId aProtocol - APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) - | null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do - withFastStore $ \db -> overwriteProtocolServers db user servers - cfg <- asks config - lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers - ok user - | otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled" - SetUserProtoServers serversConfig -> withUser $ \User {userId} -> - processChatCommand $ APISetUserProtoServers userId serversConfig + -- APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do + -- cfg@ChatConfig {defaultServers} <- asks config + -- srvs <- withFastStore' (`getProtocolServers` user) + -- (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} -> + -- processChatCommand $ APIGetUserProtoServers userId aProtocol + -- APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) + -- | null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do + -- withFastStore $ \db -> overwriteProtocolServers db user servers + -- cfg <- asks config + -- lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers + -- ok user + -- | otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled" + -- SetUserProtoServers serversConfig -> withUser $ \User {userId} -> + -- processChatCommand $ APISetUserProtoServers userId serversConfig APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) TestProtoServer srv -> withUser $ \User {userId} -> processChatCommand $ APITestProtoServer userId srv - APIGetServerOperators -> do - (operators, conditionsAction) <- withFastStore $ \db -> getServerOperators db - pure $ CRServerOperators operators conditionsAction - APISetServerOperators operatorsEnabled -> do - (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 - 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 + APIGetServerOperators -> uncurry CRServerOperators <$> withFastStore getServerOperators + APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do + liftIO $ setServerOperators db operatorsEnabled + uncurry CRServerOperators <$> getServerOperators db + APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do + (operators, _) <- getServerOperators db + liftIO $ do + smpServers <- getServers db user SPSMP + xftpServers <- getServers db user SPXFTP + CRUserServers user <$> groupByOperator operators smpServers xftpServers where - getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ServerCfg p] + getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [UserServer p] getServers db user _p = getProtocolServers db user APISetUserServers userId userServers -> withUserId userId $ \user -> do let errors = validateUserServers userServers @@ -1596,7 +1558,7 @@ processChatCommand' vr = \case APIGetUsageConditions -> do (usageConditions, acceptedConditions) <- withFastStore $ \db -> do usageConditions <- getCurrentUsageConditions db - acceptedConditions <- getLatestAcceptedConditions db + acceptedConditions <- liftIO $ getLatestAcceptedConditions db pure (usageConditions, acceptedConditions) -- TODO if db commit is different from source commit, conditionsText should be nothing in response pure @@ -1609,10 +1571,12 @@ processChatCommand' vr = \case currentTs <- liftIO getCurrentTime withFastStore' $ \db -> setConditionsNotified db conditionsId currentTs ok_ - APIAcceptConditions conditionsId operators -> do + -- TODO switch to IDs + APIAcceptConditions conditionsId operators -> withFastStore $ \db -> do currentTs <- liftIO getCurrentTime - (operators', conditionsAction) <- withFastStore $ \db -> acceptConditions db conditionsId operators currentTs - pure $ CRServerOperators operators' conditionsAction + operators' <- L.toList <$> acceptConditions db conditionsId operators currentTs + currentConds <- getCurrentUsageConditions db + pure $ CRServerOperators operators' $ usageConditionsAction operators' currentConds currentTs APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user -> checkStoreNotChanged $ withChatLock "setChatItemTTL" $ do @@ -1866,7 +1830,7 @@ processChatCommand' vr = \case let ConnReqUriData {crSmpQueues = q :| _} = crData SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q cfg <- asks config - newUserServers <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPSMP <$> withFastStore' (`getProtocolServers` newUser) + newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (`getProtocolServers` newUser) pure $ smpServer `elem` newUserServers updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) @@ -2200,7 +2164,7 @@ processChatCommand' vr = \case where changeMemberRole user gInfo members m gEvent = do let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m - assertUserGroupRole gInfo $ maximum [GRAdmin, mRole, memRole] + assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole]) withGroupLock "memberRole" groupId . procCmd $ do unless (mRole == memRole) $ do withFastStore' $ \db -> updateGroupMemberRole db user m memRole @@ -2600,12 +2564,12 @@ processChatCommand' vr = \case agentServersSummary <- lift $ withAgent' getAgentServersSummary cfg <- asks config (users, smpServers, xftpServers) <- - withStore' $ \db -> (,,) <$> getUsers db <*> getServers db cfg user SPSMP <*> getServers db cfg user SPXFTP + withStore' $ \db -> (,,) <$> getUsers db <*> getServers db user SPSMP <*> getServers db user SPXFTP let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers pure $ CRAgentServersSummary user presentedServersSummary where - getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> ChatConfig -> User -> SProtocolType p -> IO (NonEmpty (ProtocolServer p)) - getServers db cfg user p = L.map (\ServerCfg {server} -> protoServer server) . useServers cfg p <$> getProtocolServers db user + getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] + getServers db user _p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db user ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails @@ -3723,8 +3687,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] getUnknownSrvs srvs = do - cfg <- asks config - knownSrvs <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPXFTP <$> withStore' (`getProtocolServers` user) + knownSrvs <- map (\UserServer {server} -> protoServer server) <$> withStore' (`getProtocolServers` user) pure $ filter (`notElem` knownSrvs) srvs ipProtectedForSrvs :: [XFTPServer] -> CM Bool ipProtectedForSrvs srvs = do @@ -3936,7 +3899,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do (sftConns, sfts) <- getSndFileTransferConns (rftConns, rfts) <- getRcvFileTransferConns (pcConns, pcs) <- getPendingContactConns - let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns] + let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]]) pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs) -- subscribe using batched commands rs <- withAgent $ \a -> agentBatchSubscribe a conns @@ -4744,7 +4707,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) SWITCH qd phase cStats -> do toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats) - when (phase `elem` [SPStarted, SPCompleted]) $ case qd of + when (phase == SPStarted || phase == SPCompleted) $ case qd of QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing RSYNC rss cryptoErr_ cStats -> @@ -5155,7 +5118,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when continued $ sendPendingGroupMessages user m conn SWITCH qd phase cStats -> do toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) - when (phase `elem` [SPStarted, SPCompleted]) $ case qd of + when (phase == SPStarted || phase == SPCompleted) $ case qd of QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing RSYNC rss cryptoErr_ cStats -> @@ -6719,15 +6682,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = messageWarning "x.grp.mem.con: neither member is invitee" where inviteeXGrpMemCon :: GroupMemberIntro -> CM () - inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} - | introStatus == GMIntroReConnected = updateStatus introId GMIntroConnected - | introStatus `elem` [GMIntroToConnected, GMIntroConnected] = pure () - | otherwise = updateStatus introId GMIntroToConnected + inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of + GMIntroReConnected -> updateStatus introId GMIntroConnected + GMIntroToConnected -> pure () + GMIntroConnected -> pure () + _ -> updateStatus introId GMIntroToConnected forwardMemberXGrpMemCon :: GroupMemberIntro -> CM () - forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} - | introStatus == GMIntroToConnected = updateStatus introId GMIntroConnected - | introStatus `elem` [GMIntroReConnected, GMIntroConnected] = pure () - | otherwise = updateStatus introId GMIntroReConnected + forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of + GMIntroToConnected -> updateStatus introId GMIntroConnected + GMIntroReConnected -> pure () + GMIntroConnected -> pure () + _ -> updateStatus introId GMIntroReConnected updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM () @@ -8192,14 +8157,14 @@ chatCommandP = "/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP), "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), - "/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP), - "/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), - "/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []), - "/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), - "/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []), - "/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP), - "/smp" $> GetUserProtoServers (AProtocolType SPSMP), - "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), + -- "/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP), + -- "/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), + -- "/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []), + -- "/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP), + -- "/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []), + -- "/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP), + -- "/smp" $> GetUserProtoServers (AProtocolType SPSMP), + -- "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), "/_operators" $> APIGetServerOperators, "/_operators " *> (APISetServerOperators <$> jsonP), "/_user_servers " *> (APIGetUserServers <$> A.decimal), @@ -8549,7 +8514,7 @@ chatCommandP = onOffP (Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP))) (pure Nothing) - srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP) + -- srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP) rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P)) text1P = safeDecodeUtf8 <$> A.takeTill (== ' ') char_ = optional . A.char diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 2597a685dd..d974881753 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -35,7 +35,6 @@ import qualified Data.ByteArray as BA import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (ord) -import Data.Constraint (Dict (..)) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) @@ -71,7 +70,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, ServerCfg) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority) @@ -85,7 +84,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, ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol) +import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer) import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Transport (TLS, simplexMQVersion) import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost) @@ -174,7 +173,7 @@ defaultChatHooks = } data PresetServers = PresetServers - { operators :: NonEmpty PresetOperatorServers, + { operators :: NonEmpty PresetOperator, ntf :: [NtfServer], netCfg :: NetworkConfig } @@ -344,20 +343,20 @@ data ChatCommand | APIGetGroupLink GroupId | APICreateMemberContact GroupId GroupMemberId | APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent} - | APIGetUserProtoServers UserId AProtocolType - | GetUserProtoServers AProtocolType - | APISetUserProtoServers UserId AProtoServersConfig - | SetUserProtoServers AProtoServersConfig - | APITestProtoServer UserId AProtoServerWithAuth + | -- | APIGetUserProtoServers UserId AProtocolType + -- | GetUserProtoServers AProtocolType + -- | APISetUserProtoServers UserId AProtoServersConfig + -- | SetUserProtoServers AProtoServersConfig + APITestProtoServer UserId AProtoServerWithAuth | TestProtoServer AProtoServerWithAuth | APIGetServerOperators | APISetServerOperators (NonEmpty OperatorEnabled) | APIGetUserServers UserId - | APISetUserServers UserId (NonEmpty UserServers) - | APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation + | APISetUserServers UserId (NonEmpty UserOperatorServers) + | APIValidateServers (NonEmpty UserOperatorServers) -- response is CRUserServersValidation | APIGetUsageConditions | APISetConditionsNotified Int64 - | APIAcceptConditions Int64 (NonEmpty ServerOperator) + | APIAcceptConditions Int64 (NonEmpty ServerOperator) -- TODO replace with IDs | APISetChatItemTTL UserId (Maybe Int64) | SetChatItemTTL (Maybe Int64) | APIGetChatItemTTL UserId @@ -583,10 +582,10 @@ data ChatResponse | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo} | CRChatItemId User (Maybe ChatItemId) | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} - | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]} - | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} + | -- | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]} + CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction} - | CRUserServers {user :: User, userServers :: [UserServers]} + | CRUserServers {user :: User, userServers :: [UserOperatorServers]} | CRUserServersValidation {serverErrors :: [UserServersError]} | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions} | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64} @@ -951,23 +950,23 @@ instance ToJSON AgentQueueId where toJSON = strToJSON toEncoding = strToJEncoding -data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]} - deriving (Show) +-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]} +-- deriving (Show) -data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p) +-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p) -deriving instance Show AProtoServersConfig +-- deriving instance Show AProtoServersConfig -data UserProtoServers p = UserProtoServers - { serverProtocol :: SProtocolType p, - protoServers :: NonEmpty (ServerCfg p), - presetServers :: NonEmpty (ServerCfg p) - } - deriving (Show) +-- data UserProtoServers p = UserProtoServers +-- { serverProtocol :: SProtocolType p, +-- protoServers :: NonEmpty (ServerCfg p), +-- presetServers :: NonEmpty (ServerCfg p) +-- } +-- deriving (Show) -data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p) +-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p) -deriving instance Show AUserProtoServers +-- deriving instance Show AUserProtoServers data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath} deriving (Show) @@ -1570,28 +1569,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo) $(JQ.deriveJSON defaultJSON ''SlowSQLQuery) -instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where - parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig) +-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where +-- parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig) -instance ProtocolTypeI p => FromJSON (UserProtoServers p) where - parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers) +-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where +-- parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers) -instance ProtocolTypeI p => ToJSON (UserProtoServers p) where - toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers) - toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) +-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where +-- toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers) +-- toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) -instance FromJSON AUserProtoServers where - parseJSON v = J.withObject "AUserProtoServers" parse v - where - parse o = do - AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol" - case userProtocol p of - Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v - Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p +-- instance FromJSON AUserProtoServers where +-- parseJSON v = J.withObject "AUserProtoServers" parse v +-- where +-- parse o = do +-- AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol" +-- case userProtocol p of +-- Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v +-- Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p -instance ToJSON AUserProtoServers where - toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s - toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s +-- instance ToJSON AUserProtoServers where +-- toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s +-- toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState) diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs index fc0ca21e54..d84cc5aa73 100644 --- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs +++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs @@ -11,7 +11,6 @@ m20241027_server_operators = 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, @@ -22,8 +21,6 @@ CREATE TABLE server_operators ( updated_at TEXT NOT NULL DEFAULT (datetime('now')) ); -ALTER TABLE protocol_servers ADD COLUMN server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL; - CREATE TABLE usage_conditions ( usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT, conditions_commit TEXT NOT NULL UNIQUE, @@ -41,18 +38,8 @@ CREATE TABLE operator_usage_conditions ( created_at TEXT NOT NULL DEFAULT (datetime('now')) ); -CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(server_operator_id); CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id); -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, 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, 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,%"; +CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id); |] down_m20241027_server_operators :: Query @@ -60,9 +47,6 @@ down_m20241027_server_operators = [sql| DROP INDEX idx_operator_usage_conditions_conditions_commit; DROP INDEX idx_operator_usage_conditions_server_operator_id; -DROP INDEX idx_protocol_servers_server_operator_id; - -ALTER TABLE protocol_servers DROP COLUMN server_operator_id; DROP TABLE operator_usage_conditions; DROP TABLE usage_conditions; diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index c46505a6a6..ad962d1fdd 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,10 +21,9 @@ 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.IORef import Data.Int (Int64) -import Data.Kind (Type) -import Data.List (find, foldl') +import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -32,6 +32,7 @@ import Data.Maybe (fromMaybe, isNothing) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) +import qualified Data.Text as T import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime, nominalDay) import Database.SQLite.Simple.FromField (FromField (..)) @@ -39,10 +40,11 @@ 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 (..), allRoles) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..)) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol) +import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (safeDecodeUtf8) usageConditionsCommit :: Text @@ -57,29 +59,29 @@ usageConditionsText = in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|] ) -data EntityStored = ESStored | ESNew +data DBStored = DBStored | DBNew -data SEntityStored (s :: EntityStored) where - SESStored :: SEntityStored 'ESStored - SESNew :: SEntityStored 'ESNew +data SDBStored (s :: DBStored) where + SDBStored :: SDBStored 'DBStored + SDBNew :: SDBStored 'DBNew -data DBEntityId' (s :: EntityStored) where - DBEntityId :: Int64 -> DBEntityId' 'ESStored - NewDBEntity :: DBEntityId' 'ESNew +data DBEntityId' (s :: DBStored) where + DBEntityId :: Int64 -> DBEntityId' 'DBStored + DBNewEntity :: DBEntityId' 'DBNew deriving instance Show (DBEntityId' s) -type DBEntityId = DBEntityId' 'ESStored +type DBEntityId = DBEntityId' 'DBStored -type NewDBEntity = DBEntityId' 'ESNew +type DBNewEntity = DBEntityId' 'DBNew -data ADBEntityId = forall s. AEI (SEntityStored s) (DBEntityId' s) +data ADBEntityId = forall s. AEI (SDBStored s) (DBEntityId' s) pattern ADBEntityId :: Int64 -> ADBEntityId -pattern ADBEntityId i = AEI SESStored (DBEntityId i) +pattern ADBEntityId i = AEI SDBStored (DBEntityId i) -pattern ANewDBEntity :: ADBEntityId -pattern ANewDBEntity = AEI SESNew NewDBEntity +pattern ADBNewEntity :: ADBEntityId +pattern ADBNewEntity = AEI SDBNew DBNewEntity data OperatorTag = OTSimplex | OTXyz deriving (Eq, Ord, Show) @@ -126,18 +128,16 @@ data UsageConditionsAction 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 + if + | null enabledOperators -> Nothing + | all conditionsAccepted enabledOperators -> + let acceptedForOperators = filter conditionsAccepted operators + in Just $ UCAAccepted acceptedForOperators + | otherwise -> + 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 = @@ -153,16 +153,15 @@ data ConditionsAcceptance | CARequired {deadline :: Maybe UTCTime} deriving (Show) -type ServerOperator = ServerOperator' DBEntityId +type ServerOperator = ServerOperator' 'DBStored -type NewServerOperator = ServerOperator' NewDBEntity +type NewServerOperator = ServerOperator' 'DBNew -type AServerOperator = ServerOperator' ADBEntityId +data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s) data ServerOperator' s = ServerOperator - { operatorId :: s, + { operatorId :: DBEntityId' s, operatorTag :: Maybe OperatorTag, - appVendor :: Bool, tradeName :: Text, legalName :: Maybe Text, serverDomains :: [Text], @@ -172,9 +171,6 @@ data ServerOperator' s = 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 @@ -187,56 +183,67 @@ data OperatorEnabled = OperatorEnabled } deriving (Show) -type UserServers = UserServers' DBEntityId - -type AUserServers = UserServers' ADBEntityId - -data UserServers' s = UserServers - { operator :: Maybe (ServerOperator' s), - smpServers :: [UserServer' s 'PSMP], - xftpServers :: [UserServer' s 'PXFTP] +data UserOperatorServers = UserOperatorServers + { operator :: Maybe ServerOperator, + smpServers :: [UserServer 'PSMP], + xftpServers :: [UserServer 'PXFTP] } deriving (Show) -type UserServer p = UserServer' DBEntityId p +type UserServer p = UserServer' 'DBStored p -type NewUserServer p = UserServer' NewDBEntity p +type NewUserServer p = UserServer' 'DBNew p -type AUserServer p = UserServer' ADBEntityId p +data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p) data UserServer' s p = UserServer - { serverId :: s, - serverOperatorId :: Maybe OperatorId, + { serverId :: DBEntityId' s, server :: ProtoServerWithAuth p, + preset :: Bool, tested :: Maybe Bool, enabled :: Bool } deriving (Show) -data PresetOperatorServers = PresetOperatorServers +data PresetOperator = PresetOperator { operator :: NewServerOperator, - presetSMPServers :: NonEmpty (PresetServer 'PSMP), - presetXFTPServers :: NonEmpty (PresetServer 'PXFTP), + smp :: NonEmpty (NewUserServer 'PSMP), useSMP :: Int, + xftp :: NonEmpty (NewUserServer 'PXFTP), useXFTP :: Int } -data PresetServer p = PresetServer - { useServer :: Bool, - server :: ProtoServerWithAuth p - } +operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> NonEmpty (NewUserServer p) +operatorServers p PresetOperator {smp, xftp} = case p of + SPSMP -> smp + SPXFTP -> xftp + +operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int +operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of + SPSMP -> useSMP + SPXFTP -> useXFTP + +presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p +presetServer enabled server = + UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled} -- 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 +usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions]) +usageConditionsToAdd = usageConditionsToAdd' previousConditionsCommit usageConditionsCommit + +-- This function is used in unit tests +usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions]) +usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case [] - | newUser -> (Just sourceCond, [sourceCond]) - | otherwise -> (Just prevCond, [prevCond, sourceCond]) + | newUser -> (Just sourceCond, sourceCond, [sourceCond]) + | otherwise -> (Just prevCond, sourceCond, [prevCond, sourceCond]) where prevCond = conditions 1 prevCommit sourceCond = conditions 2 sourceCommit - conds -> (Nothing, if hasSourceCond then [] else [sourceCond]) + conds + | hasSourceCond -> (Nothing, last conds, []) + | otherwise -> (Nothing, sourceCond, [sourceCond]) where hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds sourceCond = conditions cId sourceCommit @@ -247,103 +254,88 @@ 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] -> [AServerOperator] -updatedServerOperators presetSrvs storedOps = - foldr addPreset [] presetSrvs - <> map aServerOperator (filter (isNothing . operatorTag) storedOps) -- TODO remove domains of preset operators from custom +updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator] +updatedServerOperators presetOps storedOps = + foldr addPreset [] presetOps + <> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps) where - addPreset PresetOperatorServers {operator = presetOp} = (storedOp' :) + -- TODO remove domains of preset operators from custom + addPreset PresetOperator {operator = presetOp} = (storedOp' :) where storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of - Just ServerOperator {operatorId = DBEntityId opId, conditionsAcceptance, enabled, roles} -> - presetOp {operatorId = ADBEntityId opId, conditionsAcceptance, enabled, roles} - Nothing -> presetOp {operatorId = ANewDBEntity} + Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} -> + ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles} + Nothing -> ASO SDBNew presetOp -- 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. --- --- 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) +updatedUserServers :: forall p. NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p) +updatedUserServers _presetOps randomSrvs = \case + [] -> L.map (AUS SDBNew) randomSrvs + srvs -> + L.map userChanges allPresetServers + `L.appendList` map (AUS SDBStored) (filter customServer srvs) where - 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 + customServer UserServer {preset, server = ProtoServerWithAuth srv _} = + not preset && all (`S.notMember` allPresetHosts) (host srv) + allPresetServers :: NonEmpty (NewUserServer p) + allPresetServers = undefined + allPresetHosts :: Set TransportHost + allPresetHosts = undefined + userChanges :: NewUserServer p -> AUserServer p -- apply changes from stored servers + userChanges = 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 +randomPresetServers :: NonEmpty PresetOperator -> IO (NonEmpty (NewUserServer p)) +randomPresetServers = undefined --- 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') +-- randomServers :: forall p. UserProtocol p => SProtocolType p -> ChatConfig -> IO (NonEmpty (ServerCfg p), [ServerCfg p]) +-- randomServers p ChatConfig {defaultServers} = do +-- let srvs = operatorServers p defaultServers +-- (enbldSrvs, dsbldSrvs) = L.partition (\ServerCfg {enabled} -> enabled) srvs +-- toUse = cfgServersToUse p defaultServers +-- if length enbldSrvs <= toUse +-- then pure (srvs, []) +-- else do +-- (enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs +-- let dsbldSrvs' = map (\srv -> (srv :: ServerCfg p) {enabled = False}) srvsToDisable +-- srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs +-- pure (fromMaybe srvs $ L.nonEmpty srvs', srvs') -- 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) +-- server' ServerCfg {server = ProtoServerWithAuth srv _} = 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 +useServers :: [(Text, ServerOperator)] -> NonEmpty (UserServer' s p) -> NonEmpty (ServerCfg p) +useServers opDomains = L.map agentServer + where + agentServer :: UserServer' s p -> ServerCfg p + agentServer UserServer {server = server@(ProtoServerWithAuth ProtocolServer {host} _), enabled} = + case snd <$> find (\(d, _) -> any (matchingHost d) host) opDomains of + Just ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles} -> + ServerCfg {server, operator = Just opId, enabled = opEnabled && enabled, roles} + Nothing -> + ServerCfg {server, operator = Nothing, enabled, roles = allRoles} + where + matchingHost d = \case + THDomainName h -> d `T.isSuffixOf` T.pack h + _ -> False --- 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 +operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)] +operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) [] --- addSrv srv uss = ... а тут просто найти оператора в списке и вставить ему сервер через add и как то ругнуться если его нет (но такого не должно быть). Либо вообще есть вариант сразу читать в этом формате - сначала прочитать операторов и в цикле читать серверы каждого - это вот может быть еще проще - --- groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers] --- groupByOperator srvOperators smpSrvs xftpSrvs = --- map createOperatorServers (M.toList combinedMap) --- where --- 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 --- createOperatorServers (key, (groupedSmps, groupedXftps)) = --- UserServers --- { operator = fromMaybe Nothing (M.lookup key operatorMap), --- smpServers = groupedSmps, --- xftpServers = groupedXftps --- } +groupByOperator :: [ServerOperator] -> [UserServer 'PSMP] -> [UserServer 'PXFTP] -> IO [UserOperatorServers] +groupByOperator ops smpSrvs xftpSrvs = do + ss <- mapM (\op -> newIORef $ UserOperatorServers (Just op) [] []) ops + custom <- newIORef $ UserOperatorServers Nothing [] [] + domains <- foldM addOpDomains M.empty ss + mapM_ (addServer ss custom domains) smpSrvs + mapM_ (addServer ss custom domains) xftpSrvs + mapM readIORef ss + where + addOpDomains :: Map Text (IORef UserOperatorServers) -> IORef UserOperatorServers -> IO (Map Text (IORef UserOperatorServers)) + addOpDomains _domains _s = undefined + addServer :: [IORef UserOperatorServers] -> IORef UserOperatorServers -> Map Text (IORef UserOperatorServers) -> UserServer p -> IO () + addServer _ss _custom _domains = undefined data UserServersError = USEStorageMissing @@ -352,22 +344,21 @@ data UserServersError | USEDuplicateXFTP {server :: AProtoServerWithAuth} deriving (Show) -validateUserServers :: NonEmpty UserServers -> [UserServersError] +validateUserServers :: NonEmpty UserOperatorServers -> [UserServersError] validateUserServers userServers = let storageMissing_ = if any (canUseForRole storage) userServers then [] else [USEStorageMissing] proxyMissing_ = if any (canUseForRole proxy) userServers then [] else [USEProxyMissing] - - allSMPServers = map (\UserServer {server} -> server) $ concatMap (\UserServers {smpServers} -> smpServers) userServers + allSMPServers = map (\UserServer {server} -> server) $ concatMap (\UserOperatorServers {smpServers} -> smpServers) userServers duplicateSMPServers = findDuplicatesByHost allSMPServers duplicateSMPErrors = map (USEDuplicateSMP . AProtoServerWithAuth SPSMP) duplicateSMPServers - allXFTPServers = map (\UserServer {server} -> server) $ concatMap (\UserServers {xftpServers} -> xftpServers) userServers + allXFTPServers = map (\UserServer {server} -> server) $ concatMap (\UserOperatorServers {xftpServers} -> xftpServers) userServers duplicateXFTPServers = findDuplicatesByHost allXFTPServers duplicateXFTPErrors = map (USEDuplicateXFTP . AProtoServerWithAuth SPXFTP) duplicateXFTPServers in storageMissing_ <> proxyMissing_ <> duplicateSMPErrors <> duplicateXFTPErrors where - canUseForRole :: (ServerRoles -> Bool) -> UserServers -> Bool - canUseForRole roleSel UserServers {operator, smpServers, xftpServers} = case operator of + canUseForRole :: (ServerRoles -> Bool) -> UserOperatorServers -> Bool + canUseForRole roleSel UserOperatorServers {operator, smpServers, xftpServers} = case operator of Just ServerOperator {roles} -> roleSel roles Nothing -> not (null smpServers) && not (null xftpServers) findDuplicatesByHost :: [ProtoServerWithAuth p] -> [ProtoServerWithAuth p] @@ -406,11 +397,6 @@ instance ProtocolTypeI p => ToJSON (UserServer p) where instance ProtocolTypeI p => FromJSON (UserServer p) where parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer') -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 defaultJSON ''UserOperatorServers) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError) diff --git a/src/Simplex/Chat/Stats.hs b/src/Simplex/Chat/Stats.hs index 6dd5c79ab1..21ad25b311 100644 --- a/src/Simplex/Chat/Stats.hs +++ b/src/Simplex/Chat/Stats.hs @@ -7,7 +7,6 @@ module Simplex.Chat.Stats where import qualified Data.Aeson.TH as J import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) @@ -131,7 +130,7 @@ data NtfServerSummary = NtfServerSummary -- - users are passed to exclude hidden users from totalServersSummary; -- - if currentUser is hidden, it should be accounted in totalServersSummary; -- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs -toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary +toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries (userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 567f294d32..d1eb6bf8ed 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -48,8 +49,11 @@ module Simplex.Chat.Store.Profiles getContactWithoutConnViaAddress, updateUserAddressAutoAccept, getProtocolServers, + getUpdateUserServers, -- overwriteOperatorsAndServers, overwriteProtocolServers, + insertProtocolServer, + getUpdateServerOperators, getServerOperators, setServerOperators, getCurrentUsageConditions, @@ -78,10 +82,11 @@ import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) -import Data.Text (Text, splitOn) +import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime (..), getCurrentTime) -import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..)) import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Call import Simplex.Chat.Messages @@ -93,7 +98,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme -import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..)) +import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..)) import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -525,178 +530,264 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) _ -> (False, False, Nothing) -getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p] +getUpdateUserServers :: forall p. ProtocolTypeI p => DB.Connection -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO (NonEmpty (UserServer p)) +getUpdateUserServers db presetOps randomSrvs user = do + ts <- getCurrentTime + srvs <- getProtocolServers db user + let srvs' = updatedUserServers presetOps randomSrvs srvs + mapM (upsertServer ts) srvs' + where + upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p) + upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of + DBNewEntity -> insertProtocolServer db user ts s + DBEntityId _ -> updateServer s ts $> s + updateServer :: UserServer p -> UTCTime -> IO () + updateServer UserServer {serverId, server, preset, tested, enabled} ts = + DB.execute + db + [sql| + UPDATE protocol_servers + SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?, + preset = ?, tested = ?, enabled = ?, updated_at + WHERE smp_server_id = ? + |] + (serverColumns server :. (preset, tested, enabled, ts, serverId)) + +getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [UserServer p] getProtocolServers db User {userId} = - map toServerCfg + map toUserServer <$> DB.query db [sql| - SELECT s.host, s.port, s.key_hash, s.basic_auth, s.server_operator_id, s.preset, s.tested, s.enabled, o.role_storage, o.role_proxy - FROM protocol_servers s - LEFT JOIN server_operators o USING (server_operator_id) - WHERE s.user_id = ? AND s.protocol = ? + SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled + FROM protocol_servers + WHERE user_id = ? AND protocol = ? |] (userId, decodeLatin1 $ strEncode protocol) where protocol = protocolTypeI @p - toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Maybe OperatorId, Bool, Maybe Bool, Bool, Maybe Bool, Maybe Bool) -> ServerCfg p - toServerCfg (host, port, keyHash, auth_, operator, preset, tested, enabled, storage_, proxy_) = + toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p + toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) = let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) - roles = ServerRoles {storage = fromMaybe True storage_, proxy = fromMaybe True proxy_} - in ServerCfg {server, operator, preset, tested, enabled, roles} + in UserServer {serverId, server, preset, tested, enabled} -- 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 () +overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [UserServer p] -> ExceptT StoreError IO () overwriteProtocolServers db User {userId} servers = -- liftIO $ mapM_ (updateServerOperators_ db) operators_ checkConstraint SEUniqueID . ExceptT $ do currentTs <- getCurrentTime DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol) - forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do - let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server + forM_ servers $ \UserServer {serverId, server, preset, tested, enabled} -> do DB.execute db [sql| INSERT INTO protocol_servers - (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?) + (server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) |] - ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) - -- Right <$> getProtocolServers db user + (Only serverId :. serverColumns server :. (preset, tested, enabled, userId, currentTs, currentTs)) pure $ Right () where protocol = decodeLatin1 $ strEncode $ protocolTypeI @p +insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> User -> UTCTime -> NewUserServer p -> IO (UserServer p) +insertProtocolServer db User {userId} ts srv@UserServer {server, preset, tested, enabled} = do + DB.execute + db + [sql| + INSERT INTO protocol_servers + (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + (serverColumns server :. (preset, tested, enabled, userId, ts, ts)) + sId <- insertedRowId db + pure (srv :: NewUserServer p) {serverId = DBEntityId sId} + +serverColumns :: forall p. ProtocolTypeI p => ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text) +serverColumns (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) = + let protocol = decodeLatin1 $ strEncode $ protocolTypeI @p + auth = safeDecodeUtf8 . unBasicAuth <$> auth_ + in (protocol, host, port, keyHash, auth) + getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction) getServerOperators db = do - now <- liftIO getCurrentTime - currentConditions <- getCurrentUsageConditions db - latestAcceptedConditions <- getLatestAcceptedConditions db - 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 -> - UsageConditions -> - Maybe UsageConditions -> - ( (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) - :. (Maybe Text, Maybe UTCTime) - ) -> - ServerOperator - toOperator - now - UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} - latestAcceptedConditions_ - ( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) - :. (operatorCommit_, acceptedAt_) - ) = - let roles = ServerRoles {storage, proxy} - 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 - -- 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 - 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, appVendor = False, tradeName, legalName, serverDomains, conditionsAcceptance, enabled, roles} - -- TODO appVendor + currentConds <- getCurrentUsageConditions db + liftIO $ do + now <- getCurrentTime + latestAcceptedConds_ <- getLatestAcceptedConditions db + let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now + operators <- mapM getConds =<< getServerOperators_ db + pure (operators, usageConditionsAction operators currentConds now) -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}} -> +setServerOperators :: DB.Connection -> NonEmpty OperatorEnabled -> IO () +setServerOperators db = + mapM_ $ \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 + +getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator] +getUpdateServerOperators db presetOps newUser = do + conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery + now <- getCurrentTime + let (acceptForSimplex_, currentConds, condsToAdd) = usageConditionsToAdd newUser now conds + mapM_ insertConditions condsToAdd + latestAcceptedConds_ <- getLatestAcceptedConditions db + ops <- updatedServerOperators presetOps <$> getServerOperators_ db + forM ops $ \(ASO _ op) -> + case operatorId op of + DBNewEntity -> do + op' <- insertOperator op + case (operatorTag op', acceptForSimplex_) of + (Just OTSimplex, Just cond) -> autoAcceptConditions op' cond + _ -> pure op' + DBEntityId _ -> do + updateOperator op + getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case + CARequired Nothing | operatorTag op == Just OTSimplex -> autoAcceptConditions op currentConds + CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds + ca -> pure op {conditionsAcceptance = ca} + where + insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} = + DB.execute + db + [sql| + INSERT INTO usage_conditions + (usage_conditions_id, conditions_commit, notified_at, created_at) + VALUES (?,?,?,?) + |] + (conditionsId, conditionsCommit, notifiedAt, createdAt) + updateOperator :: ServerOperator -> IO () + updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = + DB.execute + db + [sql| + UPDATE server_operators + SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ? + WHERE server_operator_id = ? + |] + (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId) + insertOperator :: NewServerOperator -> IO ServerOperator + insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do + DB.execute + db + [sql| + INSERT INTO server_operators + (server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy) + VALUES (?,?,?,?,?,?,?) + |] + (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy) + opId <- insertedRowId db + pure op {operatorId = DBEntityId opId} + autoAcceptConditions op UsageConditions {conditionsCommit} = + acceptConditions_ db op conditionsCommit Nothing + $> op {conditionsAcceptance = CAAccepted Nothing} + +getServerOperators_ :: DB.Connection -> IO [ServerOperator] +getServerOperators_ db = + 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 + |] + where + toOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) = + ServerOperator + { operatorId, + operatorTag, + tradeName, + legalName, + serverDomains = T.splitOn "," domains, + conditionsAcceptance = CARequired Nothing, + enabled, + roles = ServerRoles {storage, proxy} + } + +getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance +getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do + case latestAcceptedConds_ of + Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator + Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do + operatorAcceptedConds_ <- + maybeFirstRow id $ + DB.query + db + [sql| + SELECT conditions_commit, accepted_at + FROM operator_usage_conditions + WHERE server_operator_id = ? + ORDER BY operator_usage_conditions_id DESC + LIMIT 1 + |] + (Only operatorId) + pure $ case operatorAcceptedConds_ of + Just (operatorCommit, acceptedAt_) + | operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled? + | currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt) + | otherwise -> CAAccepted acceptedAt_ + _ -> CARequired Nothing -- no conditions were accepted for this operator 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 - |] + DB.query_ db (usageCondsQuery <> " DESC LIMIT 1") + +usageCondsQuery :: Query +usageCondsQuery = + [sql| + SELECT usage_conditions_id, conditions_commit, notified_at, created_at + FROM usage_conditions + ORDER BY usage_conditions_id + |] 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| +getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions) +getLatestAcceptedConditions db = + maybeFirstRow toUsageConditions $ + DB.query_ + db + [sql| + SELECT usage_conditions_id, conditions_commit, notified_at, created_at + FROM usage_conditions + WHERE conditions_commit = ( SELECT conditions_commit FROM operator_usage_conditions 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) + ) + |] 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.Connection -> Int64 -> NonEmpty ServerOperator -> UTCTime -> ExceptT StoreError IO (NonEmpty ServerOperator) 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 + let ts = Just acceptedAt + liftIO $ forM operators $ \op -> + acceptConditions_ db op conditionsCommit ts $> op {conditionsAcceptance = CAAccepted ts} + +acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> Maybe UTCTime -> IO () +acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt = + DB.execute + db + [sql| + INSERT INTO operator_usage_conditions + (server_operator_id, server_operator_tag, conditions_commit, accepted_at) + VALUES (?,?,?,?) + |] + (operatorId, operatorTag, conditionsCommit, acceptedAt) getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions getUsageConditionsById_ db conditionsId = @@ -710,11 +801,11 @@ getUsageConditionsById_ db conditionsId = |] (Only conditionsId) -setUserServers :: DB.Connection -> User -> NonEmpty UserServers -> ExceptT StoreError IO () +setUserServers :: DB.Connection -> User -> NonEmpty UserOperatorServers -> ExceptT StoreError IO () setUserServers db User {userId} userServers = do currentTs <- liftIO getCurrentTime forM_ userServers $ do - \UserServers {operator, smpServers, xftpServers} -> do + \UserOperatorServers {operator, smpServers, xftpServers} -> do forM_ operator $ \op -> liftIO $ updateOperator currentTs op overwriteServers currentTs operator smpServers overwriteServers currentTs operator xftpServers @@ -737,58 +828,20 @@ 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 $ \UserServer {server, serverOperatorId, tested, enabled} -> do - let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server + forM_ servers $ \UserServer {serverId, server, tested, enabled} -> do 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 (?,?,?,?,?,?,?,?,?,?,?,?) + (server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, serverOperatorId) :. (False, tested, enabled, userId, currentTs, currentTs)) - -- take preset from operator + (Only serverId :. serverColumns server :. (tested, enabled, userId, currentTs, currentTs)) + -- take preset from operator 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" --- let (existing, new) = partition (isJust . operatorId) operators --- existing' <- mapM (\op -> upsertExisting op $> op) existing --- new' <- mapM insertNew new --- pure $ existing' <> new' --- where --- upsertExisting ServerOperator {operatorId, name, preset, enabled, roles = ServerRoles {storage, proxy}} --- | preset = --- DB.execute --- db --- [sql| --- UPDATE server_operators --- SET enabled = ?, role_storage = ?, role_proxy = ? --- WHERE server_operator_id = ? --- |] --- (enabled, storage, proxy, operatorId) --- | otherwise = --- DB.execute --- db --- [sql| --- INSERT INTO server_operators (server_operator_id, name, preset, enabled, role_storage, role_proxy) --- VALUES (?,?,?,?,?,?) --- |] --- (operatorId, name, preset, enabled, storage, proxy) --- insertNew op@ServerOperator {name, preset, enabled, roles = ServerRoles {storage, proxy}} = do --- DB.execute --- db --- [sql| --- INSERT INTO server_operators (name, preset, enabled, role_storage, role_proxy) --- VALUES (?,?,?,?,?) --- |] --- (name, preset, enabled, storage, proxy) --- opId <- insertedRowId db --- pure op {operatorId = Just opId} - createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do currentTs <- getCurrentTime diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index e38a34d45f..361e61b953 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Simplex.Chat.Terminal where @@ -13,15 +14,15 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Database.SQLite.Simple (SQLError (..)) import qualified Database.SQLite.Simple as DB -import Simplex.Chat (defaultChatConfig, operatorSimpleXChat) +import Simplex.Chat (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat) import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Help (chatWelcome) +import Simplex.Chat.Operators import Simplex.Chat.Options import Simplex.Chat.Terminal.Input import Simplex.Chat.Terminal.Output import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) -import Simplex.Messaging.Agent.Env.SQLite (allRoles, presetServerCfg) import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig) import Simplex.Messaging.Util (raceAny_) import System.IO (hFlush, hSetEcho, stdin, stdout) @@ -29,20 +30,24 @@ import System.IO (hFlush, hSetEcho, stdin, stdout) terminalChatConfig :: ChatConfig terminalChatConfig = defaultChatConfig - { defaultServers = - DefaultAgentServers - { smp = - L.fromList $ - map - (presetServerCfg True allRoles operatorSimpleXChat) - [ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion", - "smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion", - "smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion" - ], - useSMP = 3, - ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"], - xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) defaultXFTPServers, - useXFTP = L.length defaultXFTPServers, + { presetServers = + PresetServers + { operators = + [ PresetOperator + { operator = operatorSimpleXChat, + smp = + L.map + (presetServer True) + [ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion", + "smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion", + "smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion" + ], + useSMP = 3, + xftp = L.map (presetServer True) defaultXFTPServers, + useXFTP = 3 + } + ], + ntf = _defaultNtfServers, netCfg = defaultNetworkConfig { smpProxyMode = SPMUnknown, diff --git a/src/Simplex/Chat/Terminal/Main.hs b/src/Simplex/Chat/Terminal/Main.hs index 64703a3a92..b0eb4dac88 100644 --- a/src/Simplex/Chat/Terminal/Main.hs +++ b/src/Simplex/Chat/Terminal/Main.hs @@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe) import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Network.Socket -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString) import Simplex.Chat.Core import Simplex.Chat.Options import Simplex.Chat.Terminal @@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r welcome :: ChatConfig -> ChatOpts -> IO () -welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} = +welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} = mapM_ putStrLn [ versionString versionNumber, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index c53e5a2749..a14ba1317a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace, toUpper) import Data.Function (on) import Data.Int (Int64) -import Data.List (foldl', groupBy, intercalate, intersperse, partition, sortOn) +import Data.List (groupBy, intercalate, intersperse, partition, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -42,7 +42,6 @@ import Simplex.Chat.Help import Simplex.Chat.Markdown import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages.CIContent -import Simplex.Chat.Operators import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange) import Simplex.Chat.Remote.Types @@ -54,7 +53,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..)) -import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerCfg (..)) +import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..)) @@ -96,7 +95,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRChats chats -> viewChats ts tz chats CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat] CRApiParsedMarkdown ft -> [viewJSON ft] - CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView + -- CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure CRServerOperators {} -> [] CRUserServers {} -> [] @@ -1214,27 +1213,27 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho "profile is " <> if isJust viewPwdHash then "hidden" else "visible" ] -viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString] -viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView = - customServers - <> if testView - then [] - else - [ "", - "use " <> highlight (srvCmd <> " test ") <> " to test " <> pName <> " server connection", - "use " <> highlight (srvCmd <> " ") <> " to configure " <> pName <> " servers", - "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets" - ] - <> case p of - SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] - SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] - where - srvCmd = "/" <> strEncode p - pName = protocolName p - customServers = - if null protoServers - then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers - else viewServers operators protoServers +-- viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString] +-- viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView = +-- customServers +-- <> if testView +-- then [] +-- else +-- [ "", +-- "use " <> highlight (srvCmd <> " test ") <> " to test " <> pName <> " server connection", +-- "use " <> highlight (srvCmd <> " ") <> " to configure " <> pName <> " servers", +-- "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets" +-- ] +-- <> case p of +-- SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] +-- SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] +-- where +-- srvCmd = "/" <> strEncode p +-- pName = protocolName p +-- customServers = +-- if null protoServers +-- then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers +-- else viewServers operators protoServers protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode @@ -1331,11 +1330,11 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} = ["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo] <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo] -viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString] -viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList - where - ops :: Map (Maybe Int64) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators - viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")" +-- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString] +-- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList +-- where +-- ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators +-- viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")" viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo