Skip to content

Commit

Permalink
Straighten out SqliteContext
Browse files Browse the repository at this point in the history
  • Loading branch information
rvl committed Feb 26, 2021
1 parent 28db8f4 commit be16292
Show file tree
Hide file tree
Showing 4 changed files with 30 additions and 43 deletions.
11 changes: 4 additions & 7 deletions lib/core/src/Cardano/DB/Sqlite.hs
Expand Up @@ -138,11 +138,9 @@ import qualified Database.Sqlite as Sqlite
-------------------------------------------------------------------------------}

-- | Context for the SQLite 'DBLayer'.
data SqliteContext = SqliteContext
newtype SqliteContext = SqliteContext
{ runQuery :: forall a. SqlPersistT IO a -> IO a
-- ^ Run a query with a connection from the pool.
, dbFile :: Maybe FilePath
-- ^ The actual database file, if any. If none, runs in-memory
}

type ConnectionPool = Pool (SqlBackend, Sqlite.Connection)
Expand Down Expand Up @@ -187,7 +185,7 @@ newInMemorySqliteContext tr manualMigrations autoMigration = do
let runQuery :: forall a. SqlPersistT IO a -> IO a
runQuery cmd = withMVarMasked lock (observe . runSqlConn cmd)

return $ SqliteContext { runQuery, dbFile = Nothing }
return $ SqliteContext { runQuery }

-- | Sets up query logging and timing, runs schema migrations if necessary and
-- provide a safe 'SqliteContext' for interacting with the database.
Expand All @@ -196,9 +194,8 @@ newSqliteContext
-> ConnectionPool
-> [ManualMigration]
-> Migration
-> FilePath
-> IO (Either MigrationError SqliteContext)
newSqliteContext tr pool manualMigrations autoMigration fp = do
newSqliteContext tr pool manualMigrations autoMigration = do
migrationResult <- withResource pool $ \(backend, conn) -> do
let executeAutoMigration = runSqlConn (runMigrationQuiet autoMigration) backend
migrationResult <- withForeignKeysDisabled tr conn $ do
Expand All @@ -224,7 +221,7 @@ newSqliteContext tr pool manualMigrations autoMigration fp = do
runQuery cmd = withResource pool $
observe . retryOnBusy tr . runSqlConn cmd . fst

in Right $ SqliteContext { runQuery, dbFile = Just fp }
in Right $ SqliteContext { runQuery }

-- | Finalize database statements and close the database connection.
--
Expand Down
2 changes: 1 addition & 1 deletion lib/core/src/Cardano/Pool/DB/Sqlite.hs
Expand Up @@ -211,7 +211,7 @@ withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do

Just fp -> handlingPersistError tr fp $
withConnectionPool tr' fp $ \pool -> do
ctx <- newSqliteContext tr' pool createViews migrateAll fp
ctx <- newSqliteContext tr' pool createViews migrateAll
ctx & either
throwIO
(action . decorateDBLayer dbDecorator . newDBLayer tr ti)
Expand Down
11 changes: 6 additions & 5 deletions lib/core/src/Cardano/Wallet/DB/Sqlite.hs
Expand Up @@ -257,16 +257,17 @@ withDBLayer
-> IO a
withDBLayer tr defaultFieldValues mDatabaseDir ti action =
case mDatabaseDir of
Nothing -> do
db <- newInMemorySqliteContext tr [] migrateAll >>= newDBLayer ti
action db
Nothing ->
newInMemorySqliteContext tr [] migrateAll
>>= newDBLayer ti
>>= action

Just fp -> do
let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues
let autoMigrations = migrateAll
withConnectionPool tr fp $ \pool -> do
ctx <- newSqliteContext tr pool manualMigrations autoMigrations fp
either throwIO (action <=< newDBLayer ti) ctx
res <- newSqliteContext tr pool manualMigrations autoMigrations
either throwIO (action <=< newDBLayer ti) res

-- | Instantiate a 'DBFactory' from a given directory
newDBFactory
Expand Down
49 changes: 19 additions & 30 deletions lib/core/test/bench/db/Main.hs
Expand Up @@ -4,7 +4,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
Expand Down Expand Up @@ -196,11 +195,9 @@ import Data.Word
import Fmt
( build, padLeftF, padRightF, pretty, (+|), (|+) )
import System.Directory
( doesFileExist, getFileSize, removeFile )
( doesFileExist, getFileSize )
import System.FilePath
( takeFileName )
import System.IO.Temp
( emptySystemTempFile )
import System.IO.Unsafe
( unsafePerformIO )
import System.Random
Expand All @@ -209,6 +206,8 @@ import Test.Utils.Resource
( unBracket )
import UnliftIO.Exception
( bracket, throwIO )
import UnliftIO.Temporary
( withSystemTempFile )

import qualified Cardano.BM.Configuration.Model as CM
import qualified Cardano.BM.Data.BackendKind as CM
Expand Down Expand Up @@ -659,20 +658,19 @@ withDB
=> Tracer IO DBLog
-> (DBLayer IO s k -> Benchmark)
-> Benchmark
withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ _ db) -> bm db)
withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ db) -> bm db)

data BenchEnv s k = BenchEnv
{ _connectionPool :: !ConnectionPool
, _destroyPool :: IO ()
, _ctx :: !SqliteContext
{ cleanupDB :: IO ()
, _dbFile :: FilePath
, _dbLayer :: !(DBLayer IO s k)
}

instance NFData (BenchEnv s k) where
rnf (BenchEnv p _ ctx db) =
deepseq (rnf p) $
deepseq (rnf ctx) $
deepseq (rnf db) ()
rnf (BenchEnv _ fp db) = deepseq (rnf fp) $ deepseq (rnf db) ()

withTempSqliteFile :: (FilePath -> IO a) -> IO a
withTempSqliteFile action = withSystemTempFile "bench.db" $ \fp _ -> action fp

setupDB
:: forall s k.
Expand All @@ -683,12 +681,14 @@ setupDB
=> Tracer IO DBLog
-> IO (BenchEnv s k)
setupDB tr = do
f <- emptySystemTempFile "bench.db"
(createPool, destroyPool) <- unBracket (withConnectionPool tr f)
pool <- createPool
ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll f
db <- newDBLayerWith NoCache singleEraInterpreter ctx
pure $ BenchEnv pool destroyPool ctx db
(createPool, destroyPool) <- unBracket withSetup
uncurry (BenchEnv destroyPool) <$> createPool
where
withSetup action = withTempSqliteFile $ \fp ->
withConnectionPool tr fp $ \pool -> do
ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll
db <- newDBLayerWith NoCache singleEraInterpreter ctx
action (fp, db)

singleEraInterpreter :: TimeInterpreter IO
singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $
Expand All @@ -701,16 +701,6 @@ singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $
, getSecurityParameter = Quantity 2160
})

cleanupDB :: BenchEnv s k -> IO ()
cleanupDB (BenchEnv _ destroyPool SqliteContext{dbFile} _) = do
destroyPool
let f = fromMaybe ":memory:" dbFile
mapM_ remove [f, f <> "-shm", f <> "-wal"]
where
remove f = doesFileExist f >>= \case
True -> removeFile f
False -> pure ()

-- | Cleans the database before running the benchmark.
-- It also cleans the database after running the benchmark. That is just to
-- exercise the delete functions.
Expand Down Expand Up @@ -789,8 +779,7 @@ txHistoryDiskSpaceTests tr = do

benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO ()
benchDiskSize tr action = bracket (setupDB tr) cleanupDB
$ \(BenchEnv _ destroyPool SqliteContext{dbFile} db) -> do
let f = fromMaybe ":memory:" dbFile
$ \(BenchEnv destroyPool f db) -> do
action db
mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"]
destroyPool
Expand Down

0 comments on commit be16292

Please sign in to comment.