core: getServerOperators, getUserServers, getUsageConditions apis wip (#5141)

src/Simplex/Chat.hs

@@ -1489,8 +1489,7 @@ processChatCommand' vr = \case
   APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
     cfg@ChatConfig {defaultServers} <- asks config
     srvs <- withFastStore' (`getProtocolServers` user)
-    ts <- liftIO getCurrentTime
-    operators <- withFastStore' $ \db -> getServerOperators db ts
+    operators <- withFastStore $ \db -> getServerOperators db
     let servers = AUPS $ UserProtoServers p (useServers cfg p srvs) (cfgServers p defaultServers)
     pure $ CRUserProtoServers {user, servers, operators}
   GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
@@ -1508,27 +1507,31 @@ processChatCommand' vr = \case
     lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
   TestProtoServer srv -> withUser $ \User {userId} ->
     processChatCommand $ APITestProtoServer userId srv
-  APIGetServerOperators -> pure $ chatCmdError Nothing "not supported"
+  APIGetServerOperators -> do
+    operators <- withFastStore $ \db -> getServerOperators db
+    let conditionsAction = usageConditionsAction operators
+    pure $ CRServerOperators operators conditionsAction
   APISetServerOperators _operators -> pure $ chatCmdError Nothing "not supported"
-  APIGetUserServers userId -> withUserId userId $ \user ->
-    pure $ chatCmdError (Just user) "not supported"
+  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
+    where
+      getServers :: (ProtocolTypeI p) => DB.Connection -> User -> SProtocolType p -> IO [ServerCfg p]
+      getServers db user _p = getProtocolServers db user
   APISetUserServers userId _userServers -> withUserId userId $ \user ->
     pure $ chatCmdError (Just user) "not supported"
   APIValidateServers _userServers ->
     -- response is CRUserServersValidation
     pure $ chatCmdError Nothing "not supported"
   APIGetUsageConditions -> do
+    usageConditions <- withFastStore $ \db -> getCurrentUsageConditions db
     -- TODO
-    -- get current conditions
     -- get latest accepted conditions (from operators)
-    ts <- liftIO getCurrentTime
-    let usageConditions =
-          UsageConditions
-            { conditionsId = 1,
-              conditionsCommit = "abc",
-              notifiedAt = Nothing,
-              createdAt = ts
-            }
     pure
       CRUsageConditions
         { usageConditions = usageConditions,

src/Simplex/Chat/Controller.hs

@@ -589,7 +589,7 @@ data ChatResponse
   | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
   | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
   | CRServerOperators {operators :: [ServerOperator], conditionsAction :: UsageConditionsAction}
-  | CRUserServers {userServers :: [UserServers]}
+  | CRUserServers {user :: User, userServers :: [UserServers]}
   | CRUserServersValidation {serverErrors :: [UserServersError]}
   | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
   | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}

src/Simplex/Chat/Operators.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -12,7 +13,9 @@ import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
 import Data.FileEmbed
 import Data.Int (Int64)
-import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Database.SQLite.Simple.FromField (FromField (..))
@@ -20,10 +23,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, ServerRoles)
+import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..))
+import Simplex.Messaging.Protocol (ProtocolType (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
 
 usageConditionsCommit :: Text
@@ -72,8 +75,8 @@ data UsageConditionsAction
   deriving (Show)
 
 -- TODO UI logic
-usageConditionsAction :: UsageConditionsAction
-usageConditionsAction = UCAAccepted []
+usageConditionsAction :: [ServerOperator] -> UsageConditionsAction
+usageConditionsAction _operators = UCAAccepted []
 
 data ConditionsAcceptance
   = CAAccepted {acceptedAt :: UTCTime}
@@ -93,12 +96,31 @@ data ServerOperator = ServerOperator
   deriving (Show)
 
 data UserServers = UserServers
-  { operator :: ServerOperator,
-    smpServers :: NonEmpty (ProtoServerWithAuth 'PSMP),
-    xftpServers :: NonEmpty (ProtoServerWithAuth 'PXFTP)
+  { operator :: Maybe ServerOperator,
+    smpServers :: [ServerCfg 'PSMP],
+    xftpServers :: [ServerCfg 'PXFTP]
   }
   deriving (Show)
 
+groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers]
+groupByOperator srvOperators smpSrvs xftpSrvs =
+  map createOperatorServers (M.toList combinedMap)
+  where
+    srvOperatorId :: ServerCfg p -> Maybe Int64
+    srvOperatorId ServerCfg {operator} = operator
+    operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
+    operatorMap = M.fromList [(Just (operatorId 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)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)

src/Simplex/Chat/Store/Profiles.hs

@@ -50,6 +50,7 @@ module Simplex.Chat.Store.Profiles
     -- overwriteOperatorsAndServers,
     overwriteProtocolServers,
     getServerOperators,
+    getCurrentUsageConditions,
     createCall,
     deleteCalls,
     getCalls,
@@ -73,7 +74,8 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock (UTCTime (..), getCurrentTime)
+import Data.Time (addUTCTime)
+import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
 import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 import Simplex.Chat.Call
@@ -540,7 +542,7 @@ getProtocolServers db User {userId} =
 
 -- 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 -> [ServerCfg p] -> ExceptT StoreError IO ()
 overwriteProtocolServers db User {userId} servers =
   -- liftIO $ mapM_ (updateServerOperators_ db) operators_
   checkConstraint SEUniqueID . ExceptT $ do
@@ -556,25 +558,66 @@ overwriteProtocolServers db User {userId} servers =
           VALUES (?,?,?,?,?,?,?,?,?,?,?)
         |]
         ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
-    pure $ Right ()
     -- Right <$> getProtocolServers db user
+    pure $ Right ()
   where
     protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
 
-getServerOperators :: DB.Connection -> UTCTime -> IO [ServerOperator]
-getServerOperators db ts =
-  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;
+getServerOperators :: DB.Connection -> ExceptT StoreError IO [ServerOperator]
+getServerOperators db = do
+  conditions <- getCurrentUsageConditions db
+  liftIO $
+    map (toOperator conditions)
+      <$> 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,
+          LastOperatorConditions.conditions_commit, LastOperatorConditions.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
+        ) LastOperatorConditions ON LastOperatorConditions.server_operator_id = so.server_operator_id
       |]
   where
-    -- TODO get conditions state
-    toOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
-      let roles = ServerRoles {storage, proxy}
-       in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains = [domains], acceptedConditions = CAAccepted ts, enabled, roles}
+    toOperator ::
+      UsageConditions ->
+      ( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool)
+          :. (Maybe Text, Maybe UTCTime)
+      ) ->
+      ServerOperator
+    toOperator
+      UsageConditions {conditionsCommit, createdAt}
+      ( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy)
+          :. (operatorConditionsCommit_, acceptedAt_)
+        ) =
+        let roles = ServerRoles {storage, proxy}
+            acceptedConditions = case (operatorConditionsCommit_, acceptedAt_) of
+              (Nothing, _) -> CARequired Nothing
+              (Just operatorConditionsCommit, Just acceptedAt)
+                | conditionsCommit == operatorConditionsCommit -> CAAccepted acceptedAt
+              _ -> CARequired (Just $ conditionsDeadline createdAt)
+         in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains = [domains], acceptedConditions, enabled, roles}
+    conditionsDeadline :: UTCTime -> UTCTime
+    conditionsDeadline = addUTCTime (31 * nominalDay)
+
+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
+      |]
+
+toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
+toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
+  UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
 
 -- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
 -- updateServerOperators_ db operators = do

src/Simplex/Chat/Store/Shared.hs

@@ -127,6 +127,7 @@ data StoreError
   | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
   | SERemoteCtrlDuplicateCA
   | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
+  | SEUsageConditionsNotFound
   deriving (Show, Exception)
 
 $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)