WIP

2026-04-07 17:15:52 +00:00 · 2024-11-05 16:29:30 +00:00
parent 128d031ced
commit 601ddf97ce
2 changed files with 126 additions and 43 deletions
--- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs
+++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs
@@ -37,7 +37,6 @@ CREATE TABLE operator_usage_conditions (
  server_operator_id INTEGER REFERENCES server_operators (server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
  server_operator_tag TEXT,
  conditions_commit TEXT NOT NULL,
-  conditions_accepted INTEGER NOT NULL,
  accepted_at TEXT,
  created_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
--- a/src/Simplex/Chat/Operators.hs
+++ b/src/Simplex/Chat/Operators.hs
@@ -4,21 +4,25 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}

 module Simplex.Chat.Operators where

+import Control.Monad (foldM)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
 import Data.FileEmbed
+import Data.Foldable1 (fold1)
 import Data.Int (Int64)
-import Data.List (find)
+import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Database.SQLite.Simple.FromField (FromField (..))
@@ -26,10 +30,10 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import Language.Haskell.TH.Syntax (lift)
 import Simplex.Chat.Operators.Conditions
 import Simplex.Chat.Types.Util (textParseJSON)
-import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles)
+import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerRoles)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..))
+import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI)
 import Simplex.Messaging.Util (safeDecodeUtf8)

 usageConditionsCommit :: Text
@@ -45,7 +49,7 @@ usageConditionsText =
   )

 data OperatorTag = OTSimplex | OTXyz
-  deriving (Show)
+  deriving (Eq, Show)

 instance FromField OperatorTag where fromField = fromTextField_ textDecode

@@ -90,7 +94,7 @@ data ConditionsAcceptance
  deriving (Show)

 data ServerOperator = ServerOperator
-  { operatorId :: OperatorId,
+  { operatorId :: Maybe OperatorId,
    operatorTag :: Maybe OperatorTag,
    appVendor :: Bool,
    tradeName :: Text,
@@ -103,23 +107,32 @@ data ServerOperator = ServerOperator
  deriving (Show)

 data OperatorEnabled = OperatorEnabled
-  { operatorId :: OperatorId,
-    enabled :: Bool,
-    roles :: ServerRoles
+  { operatorId' :: OperatorId,
+    enabled' :: Bool,
+    roles' :: ServerRoles
  }
  deriving (Show)

 data UserServers = UserServers
  { operator :: Maybe ServerOperator,
-    smpServers :: [ServerCfg 'PSMP],
-    xftpServers :: [ServerCfg 'PXFTP]
+    smpServers :: [UserServer 'PSMP],
+    xftpServers :: [UserServer 'PXFTP]
+  }
+  deriving (Show)
+
+data UserServer p = UserServer
+  { serverId :: Maybe Int64,
+    serverOperatorId :: Maybe OperatorId,
+    server :: ProtoServerWithAuth p,
+    tested :: Maybe Bool,
+    enabled :: Bool
  }
  deriving (Show)

 data PresetOperatorServers = PresetOperatorServers
  { operator :: ServerOperator,
-    smpServers :: NonEmpty (PresetServer 'PSMP),
-    xftpServers :: NonEmpty (PresetServer 'PXFTP),
+    presetSMPServers :: NonEmpty (PresetServer 'PSMP),
+    presetXFTPServers :: NonEmpty (PresetServer 'PXFTP),
    useSMP :: Int,
    useXFTP :: Int
  }
@@ -129,41 +142,105 @@ data PresetServer p = PresetServer
    server :: ProtoServerWithAuth p
  }

-- this function should be called inside DB transaction to update conditions in the database
-- it returns (current conditions record in the final list, conditions to add, all conditions)
-usageConditionsToAdd :: Text -> Text -> UTCTime -> [UsageConditions] -> (UsageConditions, [UsageConditions])
-usageConditionsToAdd prevCommit currCommit createdAt = \case
-  [] -> (currCond, [prevCond, currCond])
+-- This function should be used inside DB transaction to update conditions in the database
+-- it returns (conditions to mark as accepted to SimpleX operator, conditions to add)
+usageConditionsToAdd :: Bool -> Text -> Text -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, [UsageConditions])
+usageConditionsToAdd newUser prevCommit sourceCommit createdAt = \case
+  []
+    | newUser -> (Just sourceCond, [sourceCond])
+    | otherwise -> (Just prevCond, [prevCond, sourceCond])
    where
      prevCond = conditions 1 prevCommit 
-      currCond = conditions 2 currCommit
-  conds -> case find ((currCommit ==) . conditionsCommit) conds of
-    Just currCond -> (currCond, [])
-    Nothing -> (currCond, [currCond])
-      where
-        cId = maximum (map conditionsId conds) + 1
-        currCond = conditions cId currCommit
+      sourceCond = conditions 2 sourceCommit
+  conds -> (Nothing, if hasSourceCond then [] else [sourceCond])
+    where
+      hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds
+      sourceCond = conditions cId sourceCommit
+      cId = maximum (map conditionsId conds) + 1
  where
    conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}

-groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers]
-groupByOperator srvOperators smpSrvs xftpSrvs =
-  map createOperatorServers (M.toList combinedMap)
+-- This function should be used inside DB transaction to update operators.
+-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
+-- and preserves custom operators without tags for forward compatibility.
+updatedServerOperators :: NonEmpty PresetOperatorServers -> [ServerOperator] -> [ServerOperator]
+updatedServerOperators presetSrvs storedOps =
+  foldr addPreset [] presetSrvs <> filter (isNothing . operatorTag) storedOps -- TODO remove domains of preset operators from custom
  where
-    srvOperatorId ServerCfg {operator} = operator
-    opId ServerOperator {operatorId} = operatorId
-    operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
-    operatorMap = M.fromList [(Just (opId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
-    initialMap :: Map (Maybe Int64) ([ServerCfg 'PSMP], [ServerCfg 'PXFTP])
-    initialMap = M.fromList [(key, ([], [])) | key <- M.keys operatorMap]
-    smpsMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (server : smps, xftps)) (srvOperatorId server) acc) initialMap smpSrvs
-    combinedMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (smps, server : xftps)) (srvOperatorId server) acc) smpsMap xftpSrvs
-    createOperatorServers (key, (groupedSmps, groupedXftps)) =
-      UserServers
-        { operator = fromMaybe Nothing (M.lookup key operatorMap),
-          smpServers = groupedSmps,
-          xftpServers = groupedXftps
-        }
+    addPreset PresetOperatorServers {operator = presetOp} = (storedOp' :)
+      where
+        storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
+          Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} ->
+            presetOp {operatorId, conditionsAcceptance, enabled, roles}
+          Nothing -> presetOp
+
+
+data UpdatedServers p = UpdatedServers
+  { toUpsert :: [UserServer p],
+    toDelete :: [Int64]
+  }
+
+-- This function should be used inside DB transaction to update servers.
+-- It assumes that the list of operators was amended using updatedServerOperators,
+-- that [ServerOperator] has the same operators as [PresetOperatorServers],
+-- and that they all have serverOperatorId set.
+updatedUserServers :: NonEmpty PresetOperatorServers -> [ServerOperator] -> [UserServer 'PSMP] -> [UserServer 'PXFTP] -> Either String ([UserServer 'PSMP], [UserServer 'PXFTP])
+updatedUserServers presetSrvs storedOps smpSrvs xftpSrvs = do
+  smpSrvs' <- updatedSrvs useSMP smpSrvs =<< presetSrvsToStore presetSMPServers
+  xftpSrvs' <- updatedSrvs useXFTP xftpSrvs =<< presetSrvsToStore presetXFTPServers
+  pure (smpSrvs', xftpSrvs')
+  where
+    presetSrvsToStore :: forall p. (PresetOperatorServers -> NonEmpty (PresetServer p)) -> Either String (NonEmpty (Bool, UserServer p))
+    presetSrvsToStore presetSel = fold1 <$> mapM operatorSrvs presetSrvs
+      where
+        operatorSrvs :: PresetOperatorServers -> Either String (NonEmpty (Bool, UserServer p))
+        operatorSrvs op@PresetOperatorServers {operator} = case find ((operatorTag operator ==) . operatorTag) storedOps of
+          Nothing -> Left "preset operator not stored"
+          Just op' -> Right $ L.map (userSrv op') (presetSel op)
+        userSrv op PresetServer {server, useServer} =
+          let srv = UserServer {serverId = Nothing, serverOperatorId = operatorId op, server, tested = Nothing, enabled = False}
+           in (useServer, srv)
+
+    updatedSrvs :: forall p. (PresetOperatorServers -> Int) -> [UserServer p] -> NonEmpty (Bool, UserServer p) -> Either String [UserServer p]
+    updatedSrvs useSel storedSrvs presetSrvs =
+      fmap enabledSrvs . addOtherServers =<< foldM updatedSrv (storedSrvs', []) presetSrvs
+      where
+        storedSrvs' :: Map (ProtoServerWithAuth p) (UserServer p)
+        storedSrvs' = foldl' (\m us@UserServer {server} -> M.insert server us m) M.empty storedSrvs
+        updatedSrv :: (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)]) -> (Bool, UserServer p) -> Either String (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)])
+        updatedSrv srvs srv = undefined
+        addOtherServers :: (Map (ProtoServerWithAuth p) (UserServer p), [(Bool, UserServer p)]) -> Either String [(Bool, UserServer p)]
+        addOtherServers = undefined
+        enabledSrvs :: [(Bool, UserServer p)] -> [UserServer p]
+        enabledSrvs = undefined
+
+    -- addSrv srv@ServerCfg {server = ProtocolServerWithAuth ProtocolServer {host}} uss =
+    --   case find (\us -> any [\h -> any (\d -> d `T.isSuffixOf` ) serverDomains (operator us)] host) uss of
+    --     Just opId 
+    --   where
+    --     hasOperatorDomain ServerCfg {server = ProtocolServerWithAuth ProtocolServer {host}} us
+
+
+    --   addSrv srv uss = ... а тут просто найти оператора в списке и вставить ему сервер через add и как то ругнуться если его нет (но такого не должно быть). Либо вообще есть вариант сразу читать в этом формате - сначала прочитать операторов и в цикле читать серверы каждого - это вот может быть еще проще
+
+-- groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers]
+-- groupByOperator srvOperators smpSrvs xftpSrvs =
+--   map createOperatorServers (M.toList combinedMap)
+--   where
+--     srvOperatorId ServerCfg {operator} = operator
+--     opId ServerOperator {operatorId} = operatorId
+--     operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
+--     operatorMap = M.fromList [(Just (opId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
+--     initialMap :: Map (Maybe Int64) ([ServerCfg 'PSMP], [ServerCfg 'PXFTP])
+--     initialMap = M.fromList [(key, ([], [])) | key <- M.keys operatorMap]
+--     smpsMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (server : smps, xftps)) (srvOperatorId server) acc) initialMap smpSrvs
+--     combinedMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (smps, server : xftps)) (srvOperatorId server) acc) smpsMap xftpSrvs
+--     createOperatorServers (key, (groupedSmps, groupedXftps)) =
+--       UserServers
+--         { operator = fromMaybe Nothing (M.lookup key operatorMap),
+--           smpServers = groupedSmps,
+--           xftpServers = groupedXftps
+--         }

 $(JQ.deriveJSON defaultJSON ''UsageConditions)

@@ -173,4 +250,11 @@ $(JQ.deriveJSON defaultJSON ''ServerOperator)

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)

+instance ProtocolTypeI p => ToJSON (UserServer p) where
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer)
+  toJSON = $(JQ.mkToJSON defaultJSON ''UserServer)
+
+instance ProtocolTypeI p => FromJSON (UserServer p) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer)
+
 $(JQ.deriveJSON defaultJSON ''UserServers)