SCP-3445: fix chain index blocking (#386)

* [chain-index]: replace chain index state's MVar with TVar

* [chain-index]: add sqlite connection pool

Author: Evgenii Akentev

freer-extras/freer-extras.cabal

@@ -49,6 +49,7 @@ library
         mtl -any,
         openapi3 -any,
         prettyprinter -any,
+        resource-pool -any,
         sqlite-simple -any,
         streaming -any,
         text -any,
@@ -75,5 +76,6 @@ test-suite freer-extras-test
         freer-extras -any,
         freer-simple -any,
         lens -any,
+        resource-pool -any,
         semigroups -any,
         sqlite-simple -any,

freer-extras/src/Control/Monad/Freer/Extras/Beam.hs

@@ -1,38 +1,41 @@
-{-# LANGUAGE ConstraintKinds    #-}
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE GADTs              #-}
-{-# LANGUAGE KindSignatures     #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RankNTypes         #-}
-{-# LANGUAGE StrictData         #-}
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE TypeApplications   #-}
-{-# LANGUAGE TypeOperators      #-}
-{-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE NumericUnderscores    #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE StrictData            #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
 
 module Control.Monad.Freer.Extras.Beam where
 
 import Cardano.BM.Data.Tracer (ToObject (..))
 import Cardano.BM.Trace (Trace, logDebug)
 import Control.Concurrent (threadDelay)
-import Control.Exception (try)
+import Control.Exception (Exception, throw, try)
 import Control.Monad (guard)
 import Control.Monad.Freer (Eff, LastMember, Member, type (~>))
-import Control.Monad.Freer.Error (Error, throwError)
 import Control.Monad.Freer.Extras.Pagination (Page (..), PageQuery (..), PageSize (..))
 import Control.Monad.Freer.Reader (Reader, ask)
 import Control.Monad.Freer.TH (makeEffect)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Foldable (traverse_)
 import Data.List.NonEmpty qualified as L
 import Data.Maybe (isJust, listToMaybe)
+import Data.Pool (Pool)
+import Data.Pool qualified as Pool
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Database.Beam (Beamable, DatabaseEntity, FromBackendRow, Identity, MonadIO (liftIO), Q, QBaseScope, QExpr,
@@ -58,6 +61,8 @@ newtype BeamError =
   deriving stock (Eq, Show, Generic)
   deriving anyclass (FromJSON, ToJSON, ToObject)
 
+instance Exception BeamError
+
 instance Pretty BeamError where
   pretty = \case
     SqlError s -> "SqlError (via Beam)" <> colon <+> pretty s
@@ -126,8 +131,7 @@ instance Semigroup (BeamEffect ()) where
 handleBeam ::
   forall effs.
   ( LastMember IO effs
-  , Member (Error BeamError) effs
-  , Member (Reader Sqlite.Connection) effs
+  , Member (Reader (Pool Sqlite.Connection)) effs
   )
   => Trace IO BeamLog
   -> BeamEffect
@@ -176,30 +180,28 @@ handleBeam trace eff = runBeam trace $ execute eff
 runBeam ::
   forall effs.
   ( LastMember IO effs
-  , Member (Error BeamError) effs
-  , Member (Reader Sqlite.Connection) effs
+  , Member (Reader (Pool Sqlite.Connection)) effs
   )
   => Trace IO BeamLog
   -> SqliteM
   ~> Eff effs
 runBeam trace action = do
-  conn <- ask @Sqlite.Connection
-  loop conn ( 5 :: Int )
+  pool <- ask @(Pool Sqlite.Connection)
+  liftIO $ Pool.withResource pool $ \conn -> loop conn ( 5 :: Int )
   where
     loop conn retries = do
       let traceSql = logDebug trace . SqlLog
-      resultEither <- liftIO $ try $ Sqlite.withTransaction conn $ runBeamSqliteDebug traceSql conn action
+      resultEither <- try $ Sqlite.withTransaction conn $ runBeamSqliteDebug traceSql conn action
       case resultEither of
           -- 'Database.SQLite.Simple.ErrorError' corresponds to an SQL error or
           -- missing database. When this exception is raised, we suppose it's
           -- because the another transaction was already running.
           Left (Sqlite.SQLError Sqlite.ErrorError _ _) | retries > 0 -> do
-              liftIO $ threadDelay 100_000
+              threadDelay 100_000
               loop conn (retries - 1)
           -- We handle and rethrow errors other than
           -- 'Database.SQLite.Simple.ErrorError'.
-          Left e -> do
-              throwError $ SqlError $ Text.pack $ show e
+          Left e -> throw $ SqlError $ Text.pack $ show e
           Right v -> return v
 
 makeEffect ''BeamEffect

freer-extras/test/Control/Monad/Freer/Extras/BeamSpec.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
 {-# LANGUAGE ImpredicativeTypes   #-}
+{-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -24,6 +25,8 @@ import Control.Tracer (nullTracer)
 import Data.Int (Int16)
 import Data.Kind (Constraint)
 import Data.List (sort)
+import Data.Pool (Pool)
+import Data.Pool qualified as Pool
 import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
 import Data.Set qualified as Set
 import Database.Beam (Beamable, Columnar, Database, DatabaseSettings, FromBackendRow, Generic, MonadIO (liftIO), Q,
@@ -182,27 +185,28 @@ selectAllPages pq q = do
 
 runBeamEffectInGenTestDb
     :: Set Int
-    -> Eff '[BeamEffect, Error BeamError, Reader Sqlite.Connection, IO] a
+    -> Eff '[BeamEffect, Error BeamError, Reader (Pool Sqlite.Connection), IO] a
     -> (a -> PropertyT IO ())
     -> PropertyT IO ()
 runBeamEffectInGenTestDb items effect runTest = do
-  result <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do
-    Sqlite.runBeamSqlite conn $ do
+  pool <- liftIO $ Pool.createPool (Sqlite.open ":memory:") Sqlite.close 1 1_000_000 1
+  result <- liftIO $ do
+    Pool.withResource pool $ \conn -> Sqlite.runBeamSqlite conn $ do
       autoMigrate Sqlite.migrationBackend checkedSqliteDb
       runInsert $ insertOnConflict (testRows db) (insertValues $ IntegerRow . fromIntegral <$> Set.toList items) anyConflict onConflictDoNothing
-      liftIO $ runBeamEffect conn effect
+    runBeamEffect pool effect
 
   case result of
     Left _  -> Hedgehog.assert False
     Right r -> runTest r
 
 runBeamEffect
-    :: Sqlite.Connection
-    -> Eff '[BeamEffect, Error BeamError, Reader Sqlite.Connection, IO] a
+    :: Pool Sqlite.Connection
+    -> Eff '[BeamEffect, Error BeamError, Reader (Pool Sqlite.Connection), IO] a
     -> IO (Either BeamError a)
-runBeamEffect conn effect = do
+runBeamEffect pool effect = do
   effect
     & interpret (handleBeam nullTracer)
     & runError
-    & runReader conn
+    & runReader pool
     & runM