diff --git a/cabal.project b/cabal.project index fab9495dc..96cf5badd 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,17 @@ packages: . +-- packages: . ../direct-sqlcipher ../sqlcipher-simple source-repository-package type: git location: https://github.com/simplex-chat/aeson.git tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7 + +source-repository-package + type: git + location: https://github.com/simplex-chat/direct-sqlcipher.git + tag: 34309410eb2069b029b8fc1872deb1e0db123294 + +source-repository-package + type: git + location: https://github.com/simplex-chat/sqlcipher-simple.git + tag: 5e154a2aeccc33ead6c243ec07195ab673137221 diff --git a/package.yaml b/package.yaml index f6999668c..e1aa08780 100644 --- a/package.yaml +++ b/package.yaml @@ -38,7 +38,7 @@ dependencies: - cryptonite >= 0.27 && < 0.30 - cryptostore == 0.2.* - data-default == 0.7.* - - direct-sqlite == 2.3.* + - direct-sqlcipher == 2.3.* - directory == 1.3.* - filepath == 1.4.* - http-types == 0.12.* @@ -56,7 +56,7 @@ dependencies: - random >= 1.1 && < 1.3 - simple-logger == 0.1.* - socks == 0.6.* - - sqlite-simple == 0.4.* + - sqlcipher-simple == 0.4.* - stm == 2.5.* - template-haskell == 2.16.* - text == 1.2.* diff --git a/simplexmq.cabal b/simplexmq.cabal index 88a1e1d02..52f0ee469 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -116,7 +116,7 @@ library , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* - , direct-sqlite ==2.3.* + , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , generic-random >=1.3 && <1.5 @@ -133,7 +133,7 @@ library , random >=1.1 && <1.3 , simple-logger ==0.1.* , socks ==0.6.* - , sqlite-simple ==0.4.* + , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* , text ==1.2.* @@ -177,7 +177,7 @@ executable ntf-server , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* - , direct-sqlite ==2.3.* + , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , generic-random >=1.3 && <1.5 @@ -195,7 +195,7 @@ executable ntf-server , simple-logger ==0.1.* , simplexmq , socks ==0.6.* - , sqlite-simple ==0.4.* + , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* , text ==1.2.* @@ -239,7 +239,7 @@ executable smp-agent , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* - , direct-sqlite ==2.3.* + , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , generic-random >=1.3 && <1.5 @@ -257,7 +257,7 @@ executable smp-agent , simple-logger ==0.1.* , simplexmq , socks ==0.6.* - , sqlite-simple ==0.4.* + , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* , text ==1.2.* @@ -301,7 +301,7 @@ executable smp-server , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* - , direct-sqlite ==2.3.* + , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , generic-random >=1.3 && <1.5 @@ -319,7 +319,7 @@ executable smp-server , simple-logger ==0.1.* , simplexmq , socks ==0.6.* - , sqlite-simple ==0.4.* + , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* , text ==1.2.* @@ -380,7 +380,7 @@ test-suite smp-server-test , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* - , direct-sqlite ==2.3.* + , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , generic-random >=1.3 && <1.5 @@ -400,7 +400,7 @@ test-suite smp-server-test , simple-logger ==0.1.* , simplexmq , socks ==0.6.* - , sqlite-simple ==0.4.* + , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* , text ==1.2.* diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index c540c30b2..9a9b0e1c0 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -52,7 +52,7 @@ module Simplex.Messaging.Agent.Client logServer, removeSubscription, hasActiveSubscription, - agentDbPath, + agentStore, AgentOperation (..), AgentOpState (..), AgentState (..), @@ -232,8 +232,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do lock <- newTMVar () return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrConns, activeSubs, pendingSubs, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, connCmdsQueued, asyncCmdQueues, asyncCmdProcesses, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock} -agentDbPath :: AgentClient -> FilePath -agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath +agentStore :: AgentClient -> SQLiteStore +agentStore AgentClient {agentEnv = Env {store}} = store class ProtocolServerClient msg where getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 5e85097d9..9004a2bd9 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -18,6 +18,7 @@ module Simplex.Messaging.Agent.Env.SQLite defaultReconnectInterval, Env (..), newSMPAgentEnv, + createAgentStore, NtfSupervisor (..), NtfSupervisorCommand (..), ) @@ -65,6 +66,7 @@ data AgentConfig = AgentConfig connIdBytes :: Int, tbqSize :: Natural, dbFile :: FilePath, + dbKey :: String, yesToMigrations :: Bool, smpCfg :: ProtocolClientConfig, ntfCfg :: ProtocolClientConfig, @@ -108,6 +110,7 @@ defaultAgentConfig = connIdBytes = 12, tbqSize = 64, dbFile = "smp-agent.db", + dbKey = "", yesToMigrations = False, smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)}, ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)}, @@ -139,14 +142,17 @@ data Env = Env } newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env -newSMPAgentEnv config@AgentConfig {dbFile, yesToMigrations} = do +newSMPAgentEnv config@AgentConfig {dbFile, dbKey, yesToMigrations} = do idsDrg <- newTVarIO =<< drgNew - store <- liftIO $ createSQLiteStore dbFile Migrations.app yesToMigrations + store <- liftIO $ createAgentStore dbFile dbKey yesToMigrations clientCounter <- newTVarIO 0 randomServer <- newTVarIO =<< liftIO newStdGen ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor} +createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore +createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app + data NtfSupervisor = NtfSupervisor { ntfTkn :: TVar (Maybe NtfToken), ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand), diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 50e752c57..3def1d5a2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -22,6 +22,8 @@ module Simplex.Messaging.Agent.Store.SQLite ( SQLiteStore (..), createSQLiteStore, connectSQLiteStore, + closeSQLiteStore, + sqlString, -- * Queues and connections createNewConn, @@ -150,7 +152,7 @@ import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist) import System.Exit (exitFailure) import System.FilePath (takeDirectory) import System.IO (hFlush, stdout) -import UnliftIO.Exception (bracket) +import UnliftIO.Exception (bracket, onException) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -158,28 +160,19 @@ import UnliftIO.STM data SQLiteStore = SQLiteStore { dbFilePath :: FilePath, + dbEncrypted :: TVar Bool, dbConnection :: TMVar DB.Connection, dbNew :: Bool } -createSQLiteStore :: FilePath -> [Migration] -> Bool -> IO SQLiteStore -createSQLiteStore dbFilePath migrations yesToMigrations = do +createSQLiteStore :: FilePath -> String -> [Migration] -> Bool -> IO SQLiteStore +createSQLiteStore dbFilePath dbKey migrations yesToMigrations = do let dbDir = takeDirectory dbFilePath createDirectoryIfMissing False dbDir - st <- connectSQLiteStore dbFilePath - checkThreadsafe st - migrateSchema st migrations yesToMigrations + st <- connectSQLiteStore dbFilePath dbKey + migrateSchema st migrations yesToMigrations `onException` closeSQLiteStore st pure st -checkThreadsafe :: SQLiteStore -> IO () -checkThreadsafe st = withConnection st $ \db -> do - compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[Text]] - let threadsafeOption = find (T.isPrefixOf "THREADSAFE=") (concat compileOptions) - case threadsafeOption of - Just "THREADSAFE=0" -> confirmOrExit "SQLite compiled with non-threadsafe code." - Nothing -> putStrLn "Warning: SQLite THREADSAFE compile option not found" - _ -> return () - migrateSchema :: SQLiteStore -> [Migration] -> Bool -> IO () migrateSchema st migrations yesToMigrations = withConnection st $ \db -> do Migrations.initialize db @@ -202,24 +195,38 @@ confirmOrExit s = do ok <- getLine when (map toLower ok /= "y") exitFailure -connectSQLiteStore :: FilePath -> IO SQLiteStore -connectSQLiteStore dbFilePath = do +connectSQLiteStore :: FilePath -> String -> IO SQLiteStore +connectSQLiteStore dbFilePath dbKey = do dbNew <- not <$> doesFileExist dbFilePath - dbConnection <- newTMVarIO =<< connectDB dbFilePath - pure SQLiteStore {dbFilePath, dbConnection, dbNew} + dbConnection <- newTMVarIO =<< connectDB dbFilePath dbKey + dbEncrypted <- newTVarIO . not $ null dbKey + pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew} -connectDB :: FilePath -> IO DB.Connection -connectDB path = do - dbConn <- DB.open path - SQLite3.exec (DB.connectionHandle dbConn) . fromQuery $ - [sql| - PRAGMA foreign_keys = ON; - -- PRAGMA trusted_schema = OFF; - PRAGMA secure_delete = ON; - PRAGMA auto_vacuum = FULL; - |] - -- _printPragmas dbConn path - pure dbConn +connectDB :: FilePath -> String -> IO DB.Connection +connectDB path key = do + db <- DB.open path + prepare db `onException` DB.close db + -- _printPragmas db path + pure db + where + prepare db = do + let exec = SQLite3.exec $ DB.connectionHandle db + unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";" + exec . fromQuery $ + [sql| + PRAGMA foreign_keys = ON; + -- PRAGMA trusted_schema = OFF; + PRAGMA secure_delete = ON; + PRAGMA auto_vacuum = FULL; + |] + +closeSQLiteStore :: SQLiteStore -> IO () +closeSQLiteStore st = atomically (takeTMVar $ dbConnection st) >>= DB.close + +sqlString :: String -> Text +sqlString s = quote <> T.replace quote "''" (T.pack s) <> quote + where + quote = "'" -- _printPragmas :: DB.Connection -> FilePath -> IO () -- _printPragmas db path = do diff --git a/stack.yaml b/stack.yaml index 29af9bcdb..0cc68455c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,6 +48,12 @@ extra-deps: - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033 - github: simplex-chat/aeson commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7 + # - ../direct-sqlcipher + - github: simplex-chat/direct-sqlcipher + commit: 34309410eb2069b029b8fc1872deb1e0db123294 + # - ../sqlcipher-simple + - github: simplex-chat/sqlcipher-simple + commit: 5e154a2aeccc33ead6c243ec07195ab673137221 # - ../hs-tls/core # - github: simplex-chat/hs-tls # commit: f6cc753611f80af300401cfae63846e9d7c40d9e diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6a79fdea2..84ae3e1aa 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -43,7 +43,7 @@ withStore2 = before connect2 . after (removeStore . fst) connect2 :: IO (SQLiteStore, SQLiteStore) connect2 = do s1 <- createStore - s2 <- connectSQLiteStore (dbFilePath s1) + s2 <- connectSQLiteStore (dbFilePath s1) "" pure (s1, s2) createStore :: IO SQLiteStore @@ -51,7 +51,7 @@ createStore = do -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous -- IO operations on multiple similarly named files; error seems to be environment specific r <- randomIO :: IO Word32 - createSQLiteStore (testDB <> show r) Migrations.app True + createSQLiteStore (testDB <> show r) "" Migrations.app True removeStore :: SQLiteStore -> IO () removeStore db = do diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 03baa28b2..43c67a332 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -20,7 +20,7 @@ schemaDumpTest = testVerifySchemaDump :: IO () testVerifySchemaDump = do - void $ createSQLiteStore testDB Migrations.app False + void $ createSQLiteStore testDB "" Migrations.app False void $ readCreateProcess (shell $ "touch " <> schema) "" savedSchema <- readFile schema savedSchema `seq` pure ()