core: add support for server operators (#4961)

* core: add support for server operators * migration * update schema and queries, rfc * add usage conditions tables * core: server operators new apis draft * update * conditions * update * add get conditions api * add get conditions API * WIP * compiles * fix schema * core: ui logic in types (#5139) * update --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
2024-12-17 17:20:21 +01:00 · 2024-11-04 13:28:57 +00:00
parent 9a1166f097
commit 97df069730
17 changed files with 440 additions and 36 deletions
@@ -0,0 +1,110 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Operators where
+
+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.Int (Int64)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Database.SQLite.Simple.FromField (FromField (..))
+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.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..))
+import Simplex.Messaging.Util (safeDecodeUtf8)
+
+usageConditionsCommit :: Text
+usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c"
+
+usageConditionsText :: Text
+usageConditionsText =
+  $( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
+      in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|]
+   )
+
+data OperatorTag = OTSimplex | OTXyz
+  deriving (Show)
+
+instance FromField OperatorTag where fromField = fromTextField_ textDecode
+
+instance ToField OperatorTag where toField = toField . textEncode
+
+instance FromJSON OperatorTag where
+  parseJSON = textParseJSON "OperatorTag"
+
+instance ToJSON OperatorTag where
+  toJSON = J.String . textEncode
+  toEncoding = JE.text . textEncode
+
+instance TextEncoding OperatorTag where
+  textDecode = \case
+    "simplex" -> Just OTSimplex
+    "xyz" -> Just OTXyz
+    _ -> Nothing
+  textEncode = \case
+    OTSimplex -> "simplex"
+    OTXyz -> "xyz"
+
+data UsageConditions = UsageConditions
+  { conditionsId :: Int64,
+    conditionsCommit :: Text,
+    notifiedAt :: Maybe UTCTime,
+    createdAt :: UTCTime
+  }
+  deriving (Show)
+
+data UsageConditionsAction
+  = UCAReview {operators :: [ServerOperator], deadline :: Maybe UTCTime, showNotice :: Bool}
+  | UCAAccepted {operators :: [ServerOperator]}
+  deriving (Show)
+
+-- TODO UI logic
+usageConditionsAction :: UsageConditionsAction
+usageConditionsAction = UCAAccepted []
+
+data ConditionsAcceptance
+  = CAAccepted {acceptedAt :: UTCTime}
+  | CARequired {deadline :: Maybe UTCTime}
+  deriving (Show)
+
+data ServerOperator = ServerOperator
+  { operatorId :: OperatorId,
+    operatorTag :: Maybe OperatorTag,
+    tradeName :: Text,
+    legalName :: Maybe Text,
+    serverDomains :: [Text],
+    acceptedConditions :: ConditionsAcceptance,
+    enabled :: Bool,
+    roles :: ServerRoles
+  }
+  deriving (Show)
+
+data UserServers = UserServers
+  { operator :: ServerOperator,
+    smpServers :: NonEmpty (ProtoServerWithAuth 'PSMP),
+    xftpServers :: NonEmpty (ProtoServerWithAuth 'PXFTP)
+  }
+  deriving (Show)
+
+$(JQ.deriveJSON defaultJSON ''UsageConditions)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
+
+$(JQ.deriveJSON defaultJSON ''ServerOperator)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
+
+$(JQ.deriveJSON defaultJSON ''UserServers)