postgres: store implementation, conditional compilation

simplexmq.cabal

@@ -154,6 +154,9 @@ library
           Simplex.Messaging.Agent.Store.Postgres.DB
           Simplex.Messaging.Agent.Store.Postgres.Migrations
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
+      if !flag(client_library)
+          exposed-modules:
+              Simplex.Messaging.Agent.Store.Postgres.Util
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -260,7 +263,6 @@ library
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , hourglass ==0.2.*
@@ -280,7 +282,6 @@ library
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
     , time ==1.12.*
@@ -301,9 +302,14 @@ library
       , hashable ==1.4.*
   if flag(client_postgres)
     build-depends:
-        postgresql-simple ==0.6.*
+        postgresql-libpq >=0.10.0.0
+      , postgresql-simple ==0.7.*
       , raw-strings-qq ==1.1.*
     cpp-options: -DdbPostgres
+  else
+    build-depends:
+        direct-sqlcipher ==2.3.*
+      , sqlcipher-simple ==0.4.*
   if impl(ghc >= 9.6.2)
     build-depends:
         bytestring ==0.11.*
@@ -406,10 +412,7 @@ test-suite simplexmq-test
       AgentTests.EqInstances
       AgentTests.FunctionalAPITests
       AgentTests.MigrationTests
-      AgentTests.NotificationTests
-      AgentTests.SchemaDump
       AgentTests.ServerChoice
-      AgentTests.SQLiteTests
       CLITests
       CoreTests.BatchingTests
       CoreTests.CryptoFileTests
@@ -423,6 +426,7 @@ test-suite simplexmq-test
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
+      Fixtures
       NtfClient
       NtfServerTests
       RemoteControl
@@ -438,6 +442,11 @@ test-suite simplexmq-test
       Static
       Static.Embedded
       Paths_simplexmq
+  if !flag(client_postgres)
+      other-modules:
+          AgentTests.NotificationTests
+          AgentTests.SchemaDump
+          AgentTests.SQLiteTests
   hs-source-dirs:
       tests
       apps/smp-server/web
@@ -478,7 +487,6 @@ test-suite simplexmq-test
     , silently ==1.2.*
     , simple-logger
     , simplexmq
-    , sqlcipher-simple
     , stm
     , text
     , time
@@ -495,6 +503,10 @@ test-suite simplexmq-test
   default-language: Haskell2010
   if flag(client_postgres)
     build-depends:
-        postgresql-simple ==0.6.*
+        postgresql-libpq >=0.10.0.0
+      , postgresql-simple ==0.7.*
       , raw-strings-qq ==1.1.*
     cpp-options: -DdbPostgres
+  else
+    build-depends:
+        sqlcipher-simple

src/Simplex/FileTransfer/Description.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -9,8 +10,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
@@ -62,17 +64,23 @@
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
 import qualified Data.Yaml as Y
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.Messaging.Agent.QueryString
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, parseAll)
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 data FileDescription (p :: FileParty) = FileDescription
   { party :: SFileParty p,
@@ -109,6 +117,9 @@
 
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
+  deriving newtype (FromField)
+
+instance ToField FileDigest where toField (FileDigest s) = toField $ Binary s
 
 instance StrEncoding FileDigest where
   strEncode (FileDigest fd) = strEncode fd
@@ -122,10 +133,6 @@
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-instance FromField FileDigest where fromField f = FileDigest <$> fromField f
-
-instance ToField FileDigest where toField (FileDigest s) = toField s
-
 data FileChunk = FileChunk
   { chunkNo :: Int,
     chunkSize :: FileSize Word32,
@@ -288,9 +295,9 @@
 instance (Integral a, Show a) => IsString (FileSize a) where
   fromString = either error id . strDecode . B.pack
 
-instance FromField a => FromField (FileSize a) where fromField f = FileSize <$> fromField f
+deriving newtype instance FromField a => FromField (FileSize a)
 
-instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s
+deriving newtype instance ToField a => ToField (FileSize a)
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [NonEmpty FileServerReplica]
 groupReplicasByServer defChunkSize =

src/Simplex/FileTransfer/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -13,8 +14,6 @@ import Data.Int (Int64)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
 import qualified Simplex.Messaging.Crypto as C
@@ -24,6 +23,13 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (XFTPServer)
 import System.FilePath ((</>))
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 type RcvFileId = ByteString -- Agent entity ID
 

src/Simplex/Messaging/Agent/Client.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
@@ -205,7 +206,6 @@
 import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Word (Word16)
-import qualified Database.SQLite.Simple as SQL
 import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
@@ -282,6 +282,9 @@
 import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
+#if !defined(dbPostgres)
+import qualified Database.SQLite.Simple as SQL
+#endif
 
 type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
 
@@ -1989,6 +1992,13 @@
   withExceptT storeError . ExceptT . liftIO . agentOperationBracket c AODatabase (\_ -> pure ()) $
     withTransaction st action `E.catches` handleDBErrors
   where
+#if defined(dbPostgres)
+    -- TODO [postgres] postgres specific error handling
+    handleDBErrors :: [E.Handler IO (Either StoreError a)]
+    handleDBErrors =
+      [ E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e
+      ]
+#else
     handleDBErrors :: [E.Handler IO (Either StoreError a)]
     handleDBErrors =
       [ E.Handler $ \(e :: SQL.SQLError) ->
@@ -1997,6 +2007,7 @@
            in pure . Left . (if busy then SEDatabaseBusy else SEInternal) $ bshow se,
         E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e
       ]
+#endif
 
 withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a))
 withStoreBatch c actions = do
@@ -2028,7 +2039,7 @@
   SEDatabaseBusy e -> CRITICAL True $ B.unpack e
   e -> INTERNAL $ show e
 
 userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (UserServers p)
 userServers c = case protocolTypeI @p of
   SPSMP -> smpServers c
   SPXFTP -> xftpServers c
@@ -2061,7 +2072,7 @@
     hasUsedHost (ProtoServerWithAuth srv _) = any (`S.member` usedHosts) $ serverHosts srv
 
 getNextServer_ ::
   (ProtocolTypeI p, UserProtocol p) =>
   NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) ->
   (Set (Maybe OperatorId), Set TransportHost) ->
   AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p), ProtoServerWithAuth p)

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -88,6 +88,7 @@ import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
 #if defined(dbPostgres)
+import Database.PostgreSQL.Simple (ConnectInfo (..))
 #else
 import Data.ByteArray (ScrubbedBytes)
 #endif
@@ -277,8 +278,7 @@ newSMPAgentEnv config store = do
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
 #if defined(dbPostgres)
--- TODO [postgres] pass db name / ConnectInfo?
-createAgentStore :: MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 #else
 createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore)

src/Simplex/Messaging/Agent/Protocol.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -167,13 +168,12 @@ import Data.Time.Clock.System (SystemTime)
 import Data.Type.Equality
 import Data.Typeable ()
 import Data.Word (Word16, Word32)
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.ToField
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Transport (XFTPErrorType)
 import Simplex.FileTransfer.Types (FileErrorType)
 import Simplex.Messaging.Agent.QueryString
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import Simplex.Messaging.Client (ProxyClientError)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
@@ -224,6 +224,13 @@ import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
 import Simplex.RemoteControl.Types
 import UnliftIO.Exception (Exception)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- SMP agent protocol version history:
 -- 1 - binary protocol encoding (1/1/2022)
@@ -644,7 +651,7 @@ instance ToJSON NotificationsMode where
 instance FromJSON NotificationsMode where
   parseJSON = strParseJSON "NotificationsMode"
 
-instance ToField NotificationsMode where toField = toField . strEncode
+instance ToField NotificationsMode where toField = toField . Binary . strEncode
 
 instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP
 

src/Simplex/Messaging/Agent/Stats.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -10,13 +11,18 @@ import qualified Data.Aeson.TH as J
 import Data.Int (Int64)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
-import Simplex.Messaging.Protocol (SMPServer, XFTPServer, NtfServer)
+import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer)
 import Simplex.Messaging.Util (decodeJSON, encodeJSON)
 import UnliftIO.STM
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 data AgentSMPServerStats = AgentSMPServerStats
   { sentDirect :: TVar Int, -- successfully sent messages

src/Simplex/Messaging/Agent/Store.hs

@@ -55,15 +55,16 @@ import Simplex.Messaging.Protocol
   )
 import qualified Simplex.Messaging.Protocol as SMP
 #if defined(dbPostgres)
+import Database.PostgreSQL.Simple (ConnectInfo (..))
 import qualified Simplex.Messaging.Agent.Store.Postgres as StoreFunctions
 #else
-import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions
 import Data.ByteArray (ScrubbedBytes)
+import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions
 #endif
 
 #if defined(dbPostgres)
-createStore :: MigrationConfirmation -> IO (Either MigrationError DBStore)
-createStore = StoreFunctions.createDBStore Migrations.app
+createStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore connectInfo schema = StoreFunctions.createDBStore connectInfo schema Migrations.app
 #else
 createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createStore dbFilePath dbKey keepKey = StoreFunctions.createDBStore dbFilePath dbKey keepKey Migrations.app