core: refactor types for DB entity (#5945)

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: ffecd4a17af68677dedf05c95a80dc0f5c584236
+    tag: 56ea2fdd56af5f5a5da41642486aa086d7371823
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."ffecd4a17af68677dedf05c95a80dc0f5c584236" = "09c4yjn1329844f7dxw5fklxxh6jmn8d5g72mw113bs99sp9mcf7";
+  "https://github.com/simplex-chat/simplexmq.git"."56ea2fdd56af5f5a5da41642486aa086d7371823" = "1ninimiccsk0ba4wls2i9rqxj6g057m2k30zw19jvzma4xbalzg8";
   "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";

simplex-chat.cabal

@@ -256,6 +256,7 @@ library
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
     , data-default ==0.7.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -271,7 +272,6 @@ library
     , optparse-applicative >=0.15 && <0.17
     , random >=1.1 && <1.3
     , record-hasfield ==1.0.*
-    , scientific ==0.3.7.*
     , simple-logger ==0.1.*
     , simplexmq >=6.3
     , socks ==0.6.*

src/Simplex/Chat.hs

@@ -44,6 +44,7 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.Common (DBStore (dbNew))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError)
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C

src/Simplex/Chat/Library/Commands.hs

@@ -88,6 +88,7 @@ import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, m
 import Simplex.Messaging.Agent as Agent
 import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Interface (execSQL)
 import Simplex.Messaging.Agent.Store.Shared (upMigration)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -197,7 +198,7 @@ startChatController mainApp enableSndFiles = do
       startExpireCIThread user
       setExpireCIFlag user True
       where
-        shouldExpireChats = 
+        shouldExpireChats =
           fmap (fromRight False) $ runExceptT $ withStore' $ \db -> do
             ttl <- getChatItemTTL db user
             ttlCount <- getChatTTLCount db user
@@ -3683,7 +3684,7 @@ startExpireCIThread user@User {userId} = do
         liftIO $ threadDelay' interval
 
 setChatItemsExpiration :: User -> Int64 -> Int -> CM' ()
-setChatItemsExpiration user newTTL ttlCount 
+setChatItemsExpiration user newTTL ttlCount
   | newTTL > 0 || ttlCount > 0 = do
       startExpireCIThread user
       whenM chatStarted $ setExpireCIFlag user True

src/Simplex/Chat/Operators.hs

@@ -37,7 +37,6 @@ import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isNothing, mapMaybe)
-import Data.Scientific (floatingOrInteger)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -46,11 +45,11 @@ import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime, nominalDay)
 import Language.Haskell.TH.Syntax (lift)
 import Simplex.Chat.Operators.Conditions
-import Simplex.Chat.Options.DB (FromField (..), ToField (..))
 import Simplex.Chat.Types (User)
 import Simplex.Chat.Types.Util (textParseJSON)
 import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
-import Simplex.Messaging.Agent.Store.DB (fromTextField_)
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
@@ -69,32 +68,6 @@ usageConditionsText =
       in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
    )
 
-data DBStored = DBStored | DBNew
-
-data SDBStored (s :: DBStored) where
-  SDBStored :: SDBStored 'DBStored
-  SDBNew :: SDBStored 'DBNew
-
-deriving instance Show (SDBStored s)
-
-class DBStoredI s where sdbStored :: SDBStored s
-
-instance DBStoredI 'DBStored where sdbStored = SDBStored
-
-instance DBStoredI 'DBNew where sdbStored = SDBNew
-
-data DBEntityId' (s :: DBStored) where
-  DBEntityId :: Int64 -> DBEntityId' 'DBStored
-  DBNewEntity :: DBEntityId' 'DBNew
-
-deriving instance Show (DBEntityId' s)
-
-deriving instance Eq (DBEntityId' s)
-
-type DBEntityId = DBEntityId' 'DBStored
-
-type DBNewEntity = DBEntityId' 'DBNew
-
 data OperatorTag = OTSimplex | OTFlux
   deriving (Eq, Ord, Show)
 
@@ -118,19 +91,6 @@ instance TextEncoding OperatorTag where
     OTSimplex -> "simplex"
     OTFlux -> "flux"
 
--- this and other types only define instances of serialization for known DB IDs only,
--- entities without IDs cannot be serialized to JSON
-instance FromField DBEntityId
-#if defined(dbPostgres)
-  where
-    fromField f dat = DBEntityId <$> fromField f dat
-#else
-  where
-    fromField f = DBEntityId <$> fromField f
-#endif
-
-instance ToField DBEntityId where toField (DBEntityId i) = toField i
-
 data UsageConditions = UsageConditions
   { conditionsId :: Int64,
     conditionsCommit :: Text,
@@ -486,25 +446,6 @@ validateUserServers curr others = currUserErrs <> concatMap otherUserErrs others
     userServers :: (UserServersClass u, UserProtocol p) => SProtocolType p -> [u] -> [AUserServer p]
     userServers p = map aUserServer' . concatMap (servers' p)
 
-instance ToJSON (DBEntityId' s) where
-  toEncoding = \case
-    DBEntityId i -> toEncoding i
-    DBNewEntity -> JE.null_
-  toJSON = \case
-    DBEntityId i -> toJSON i
-    DBNewEntity -> J.Null
-
-instance DBStoredI s => FromJSON (DBEntityId' s) where
-  parseJSON v = case (v, sdbStored @s) of
-    (J.Null, SDBNew) -> pure DBNewEntity
-    (J.Number n, SDBStored) -> case floatingOrInteger n of
-      Left (_ :: Double) -> fail "bad DBEntityId"
-      Right i -> pure $ DBEntityId (fromInteger i)
-    _ -> fail "bad DBEntityId"
-  omittedField = case sdbStored @s of
-    SDBStored -> Nothing
-    SDBNew -> Just DBNewEntity
-
 $(JQ.deriveJSON defaultJSON ''UsageConditions)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)

src/Simplex/Chat/Operators/Presets.hs

@@ -9,6 +9,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Simplex.Chat.Operators
 import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..), allRoles)
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Protocol (ProtocolType (..), SMPServer)
 
 operatorSimpleXChat :: NewServerOperator

src/Simplex/Chat/Store/Profiles.hs

@@ -111,6 +111,7 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode)
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
 #if defined(dbPostgres)
@@ -500,14 +501,14 @@ toGroupLinkInfo (groupId_, mRole_) =
 
 getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
 getGroupLinkInfo db userId groupId =
-  fmap join $ maybeFirstRow toGroupLinkInfo $ 
+  fmap join $ maybeFirstRow toGroupLinkInfo $
     DB.query
       db
       [sql|
         SELECT group_id, group_link_member_role
         FROM user_contact_links
         WHERE user_id = ? AND group_id = ?
-      |]      
+      |]
       (userId, groupId)
 
 getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)

src/Simplex/Chat/Store/Remote.hs

@@ -10,6 +10,7 @@ import Control.Monad.Except
 import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeASCII, encodeUtf8)
+import qualified Data.X509 as X
 import Data.Word (Word16)
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store.Shared
@@ -66,7 +67,7 @@ remoteHostQuery =
     FROM remote_hosts
   |]
 
-toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16) -> RemoteHost
+toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject X.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16) -> RemoteHost
 toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey, ifaceName_, ifaceAddr_, bindPort_) =
   RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing, bindAddress_, bindPort_}
   where
@@ -133,7 +134,7 @@ toRemoteCtrl ::
   ( RemoteCtrlId,
     Text,
     C.APrivateSignKey,
-    C.SignedObject C.Certificate,
+    C.SignedObject X.Certificate,
     C.KeyHash,
     C.PublicKeyEd25519,
     C.PrivateKeyX25519,

src/Simplex/Chat/View.hs

@@ -60,6 +60,7 @@ import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
 import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..))
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))

tests/OperatorTests.hs

@@ -23,6 +23,7 @@ import Simplex.Chat.Operators.Presets
 import Simplex.Chat.Types
 import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
 import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..), allRoles)
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Protocol
 import Test.Hspec