Make securityParam configurable and refactor

plutus-chain-index/app/Config.hs

@@ -16,6 +16,7 @@ module Config(
   dbPath,
   port,
   networkId,
+  securityParam,
   slotConfig
   ) where
 
@@ -29,11 +30,12 @@ import           Ledger.TimeSlot           (SlotConfig (..))
 import           Ouroboros.Network.Magic   (NetworkMagic (..))
 
 data ChainIndexConfig = ChainIndexConfig
-  { cicSocketPath :: String
-  , cicDbPath     :: String
-  , cicPort       :: Int
-  , cicNetworkId  :: NetworkId
-  , cicSlotConfig :: SlotConfig
+  { cicSocketPath    :: String
+  , cicDbPath        :: String
+  , cicPort          :: Int
+  , cicNetworkId     :: NetworkId
+  , cicSecurityParam :: Int
+  , cicSlotConfig    :: SlotConfig
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (FromJSON, ToJSON)
@@ -53,6 +55,7 @@ defaultConfig = ChainIndexConfig
   , cicDbPath     = "/tmp/chain-index.db"
   , cicPort       = 9083
   , cicNetworkId  = Testnet $ NetworkMagic 8
+  , cicSecurityParam = 2160
   , cicSlotConfig =
       SlotConfig
         { scSlotZeroTime = 1591566291000
@@ -61,18 +64,20 @@ defaultConfig = ChainIndexConfig
   }
 
 instance Pretty ChainIndexConfig where
-  pretty ChainIndexConfig{cicSocketPath, cicDbPath, cicPort, cicNetworkId} =
+  pretty ChainIndexConfig{cicSocketPath, cicDbPath, cicPort, cicNetworkId, cicSecurityParam} =
     vsep [ "Socket:" <+> pretty cicSocketPath
          , "Db:" <+> pretty cicDbPath
          , "Port:" <+> pretty cicPort
          , "Network Id:" <+> viaShow cicNetworkId
+         , "Security Param:" <+> pretty cicSecurityParam
          ]
 
 makeLensesFor [
   ("cicSocketPath", "socketPath"),
   ("cicDbPath", "dbPath"),
   ("cicPort", "port"),
   ("cicNetworkId", "networkId"),
+  ("cicSecurityParam", "securityParam"),
   ("cicSlotConfig", "slotConfig")
   ] 'ChainIndexConfig
 

plutus-chain-index/app/Main.hs

@@ -10,128 +10,88 @@
 
 module Main where
 
-import qualified Control.Concurrent.STM            as STM
-import           Control.Exception                 (throwIO)
-import           Control.Lens                      (unto)
-import           Control.Monad.Freer               (Eff, interpret, reinterpret, runM, send)
-import           Control.Monad.Freer.Error         (Error, handleError, runError, throwError)
-import           Control.Monad.Freer.Extras        (LogMsg (..))
-import           Control.Monad.Freer.Extras.Log    (LogLevel (..), LogMessage (..), handleLogWriter)
-import           Control.Monad.Freer.Reader        (Reader, runReader)
-import           Control.Monad.Freer.State         (State, runState)
-import           Control.Monad.Freer.Writer        (runWriter)
-import           Control.Tracer                    (nullTracer)
-import qualified Data.Aeson                        as A
-import           Data.Foldable                     (for_, traverse_)
-import           Data.Function                     ((&))
-import           Data.Functor                      (void)
-import           Data.Sequence                     (Seq, (<|))
-import           Data.Text.Prettyprint.Doc         (Pretty (..))
-import qualified Data.Yaml                         as Y
-import           Database.Beam.Migrate.Simple      (autoMigrate)
-import qualified Database.Beam.Sqlite              as Sqlite
-import qualified Database.Beam.Sqlite.Migrate      as Sqlite
-import qualified Database.SQLite.Simple            as Sqlite
-import           Options.Applicative               (execParser)
-import qualified Plutus.ChainIndex.Server          as Server
-
-import qualified Cardano.BM.Configuration.Model    as CM
-import           Cardano.BM.Setup                  (setupTrace_)
-import           Cardano.BM.Trace                  (Trace, logDebug, logError)
-
-import           Cardano.Api                       (ChainPoint)
-import           Cardano.Protocol.Socket.Client    (ChainSyncEvent (..), runChainSync)
-import           CommandLine                       (AppConfig (..), Command (..), applyOverrides, cmdWithHelpParser)
+import qualified Control.Concurrent.STM          as STM
+import           Control.Exception               (throwIO)
+import           Control.Monad.Freer             (Eff, send)
+import           Control.Monad.Freer.Extras      (LogMsg (..))
+import           Control.Monad.Freer.Extras.Beam (BeamEffect, BeamLog (..))
+import           Control.Monad.Freer.Extras.Log  (LogLevel (..), LogMessage (..))
+import           Control.Tracer                  (nullTracer)
+import qualified Data.Aeson                      as A
+import           Data.Foldable                   (for_, traverse_)
+import           Data.Function                   ((&))
+import           Data.Functor                    (void)
+import           Data.Sequence                   ((<|))
+import           Data.Text.Prettyprint.Doc       (Pretty (..))
+import qualified Data.Yaml                       as Y
+import           Database.Beam.Migrate.Simple    (autoMigrate)
+import qualified Database.Beam.Sqlite            as Sqlite
+import qualified Database.Beam.Sqlite.Migrate    as Sqlite
+import qualified Database.SQLite.Simple          as Sqlite
+import           Options.Applicative             (execParser)
+
+import qualified Cardano.BM.Configuration.Model  as CM
+import           Cardano.BM.Setup                (setupTrace_)
+import           Cardano.BM.Trace                (Trace, logDebug, logError)
+
+import           Cardano.Api                     (ChainPoint)
+import           Cardano.Protocol.Socket.Client  (ChainSyncEvent (..), runChainSync)
+import           CommandLine                     (AppConfig (..), Command (..), applyOverrides, cmdWithHelpParser)
 import qualified Config
-import           Control.Monad.Freer.Extras.Beam   (BeamEffect, BeamError (..), BeamLog (..), handleBeam)
-import           Ledger                            (Slot (..))
+import           Ledger                          (Slot (..))
 import qualified Logging
-import           Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
-import           Plutus.ChainIndex.ChainIndexLog   (ChainIndexLog (..))
-import           Plutus.ChainIndex.Compatibility   (fromCardanoBlock, fromCardanoPoint, tipFromCardanoBlock)
-import           Plutus.ChainIndex.DbSchema        (checkedSqliteDb)
-import           Plutus.ChainIndex.Effects         (ChainIndexControlEffect (..), ChainIndexQueryEffect (..),
-                                                    appendBlock, rollback)
-import           Plutus.ChainIndex.Handlers        (ChainIndexState, getResumePoints, handleControl, handleQuery,
-                                                    restoreStateFromDb)
-import           Plutus.ChainIndex.Types           (pointSlot)
-import           Plutus.Monitoring.Util            (convertLog, runLogEffects)
-
-
-type ChainIndexEffects
-  = '[ ChainIndexControlEffect
-     , ChainIndexQueryEffect
-     , BeamEffect
-     , Reader Sqlite.Connection
-     , Error BeamError
-     , State ChainIndexState
-     , Error ChainIndexError
-     , LogMsg ChainIndexLog
-     , IO
-     ]
+import           Plutus.ChainIndex               (ChainIndexLog (..), RunRequirements (..), runChainIndexEffects)
+import           Plutus.ChainIndex.Compatibility (fromCardanoBlock, fromCardanoPoint, tipFromCardanoBlock)
+import           Plutus.ChainIndex.DbSchema      (checkedSqliteDb)
+import           Plutus.ChainIndex.Effects       (ChainIndexControlEffect (..), ChainIndexQueryEffect (..), appendBlock,
+                                                  resumeSync, rollback)
+import           Plutus.ChainIndex.Handlers      (getResumePoints)
+import qualified Plutus.ChainIndex.Server        as Server
+import           Plutus.ChainIndex.Types         (pointSlot)
+import           Plutus.Monitoring.Util          (runLogEffects)
+
 
 runChainIndex
-  :: Trace IO ChainIndexLog
-  -> STM.TVar ChainIndexState
-  -> Sqlite.Connection
-  -> Eff ChainIndexEffects a
+  :: RunRequirements
+  -> Eff '[ChainIndexQueryEffect, ChainIndexControlEffect, BeamEffect] a
   -> IO (Maybe a)
-runChainIndex trace mState conn effect = do
-  -- First run the STM block capturing all log messages emited on a
-  -- successful STM transaction.
-  oldEmulatorState <- STM.atomically $ STM.readTVar mState
-  (errOrResult, logMessages') <-
-    effect
-    & interpret handleControl
-    & interpret handleQuery
-    & interpret (handleBeam (convertLog BeamLogItem trace))
-    & runReader conn
-    & flip handleError (throwError . BeamEffectError)
-    & runState oldEmulatorState
-    & runError
-    & reinterpret
-        (handleLogWriter @ChainIndexLog
-                          @(Seq (LogMessage ChainIndexLog)) $ unto pure)
-    & runWriter @(Seq (LogMessage ChainIndexLog))
-    & runM
+runChainIndex runReq effect = do
+  (errOrResult, logMessages') <- runChainIndexEffects runReq effect
   (result, logMessages) <- case errOrResult of
       Left err ->
         pure (Nothing, LogMessage Error (Err err) <| logMessages')
-      Right (result, newState) -> do
-        STM.atomically $ STM.writeTVar mState newState
+      Right result -> do
         pure (Just result, logMessages')
   -- Log all previously captured messages
   traverse_ (send . LMessage) logMessages
-    & runLogEffects trace
+    & runLogEffects (trace runReq)
   pure result
 
 chainSyncHandler
-  :: Trace IO ChainIndexLog
-  -> STM.TVar ChainIndexState
-  -> Sqlite.Connection
+  :: RunRequirements
   -> ChainSyncEvent
   -> Slot
   -> IO ()
-chainSyncHandler trace mState conn
+chainSyncHandler runReq
   (RollForward block _) _ = do
     let ciBlock = fromCardanoBlock block
     case ciBlock of
       Left err    ->
-        logError trace (ConversionFailed err)
+        logError (trace runReq) (ConversionFailed err)
       Right txs ->
-        void $ runChainIndex trace mState conn $ appendBlock (tipFromCardanoBlock block) txs
-chainSyncHandler trace mState conn
+        void $ runChainIndex runReq $ appendBlock (tipFromCardanoBlock block) txs
+chainSyncHandler runReq
   (RollBackward point _) _ = do
     putStr "Rolling back to "
     print point
     -- Do we really want to pass the tip of the new blockchain to the
     -- rollback function (rather than the point where the chains diverge)?
-    void $ runChainIndex trace mState conn $ rollback (fromCardanoPoint point)
-chainSyncHandler trace mState conn
+    void $ runChainIndex runReq $ rollback (fromCardanoPoint point)
+chainSyncHandler runReq
   (Resume point) _ = do
     putStr "Resuming from "
     print point
-    void $ runChainIndex trace mState conn $ restoreStateFromDb $ fromCardanoPoint point
+    void $ runChainIndex runReq $ resumeSync $ fromCardanoPoint point
 
 showResumePoints :: [ChainPoint] -> String
 showResumePoints = \case
@@ -186,15 +146,17 @@ main = do
         -- Automatically delete the input when an output from a matching input/output pair is deleted.
         -- See reduceOldUtxoDb in Plutus.ChainIndex.Handlers
         Sqlite.execute_ conn "DROP TRIGGER IF EXISTS delete_matching_input"
-        Sqlite.execute_ conn $
+        Sqlite.execute_ conn
           "CREATE TRIGGER delete_matching_input AFTER DELETE ON unspent_outputs \
           \BEGIN \
           \  DELETE FROM unmatched_inputs WHERE input_row_tip__row_slot = old.output_row_tip__row_slot \
           \                                 AND input_row_out_ref = old.output_row_out_ref; \
           \END"
 
-        appState <- STM.newTVarIO mempty
-        Just resumePoints <- runChainIndex trace appState conn getResumePoints
+        stateTVar <- STM.newTVarIO mempty
+        let runReq = RunRequirements trace stateTVar conn (Config.cicSecurityParam config)
+
+        Just resumePoints <- runChainIndex runReq getResumePoints
 
         putStr "\nPossible resume slots: "
         putStrLn $ showResumePoints resumePoints
@@ -205,7 +167,7 @@ main = do
                             (Config.cicSlotConfig config)
                             (Config.cicNetworkId  config)
                             resumePoints
-                            (chainSyncHandler trace appState conn)
+                            (chainSyncHandler runReq)
 
         putStrLn $ "Starting webserver on port " <> show (Config.cicPort config)
-        Server.serveChainIndexQueryServer (Config.cicPort config) trace appState conn
+        Server.serveChainIndexQueryServer (Config.cicPort config) runReq

plutus-chain-index/plutus-chain-index.cabal

@@ -146,6 +146,7 @@ test-suite plutus-chain-index-test
         lens -any,
         serialise -any,
         sqlite-simple -any,
+        stm -any,
         tasty -any,
         tasty-hedgehog -any,
 

plutus-chain-index/src/Plutus/ChainIndex.hs

@@ -1,5 +1,10 @@
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE TypeApplications #-}
 module Plutus.ChainIndex(
-    module Export
+    runChainIndexEffects
+    , RunRequirements(..)
+    , module Export
     ) where
 
 import           Control.Monad.Freer.Extras.Pagination as Export
@@ -13,3 +18,51 @@ import           Plutus.ChainIndex.TxOutBalance        as Export hiding (fromBlo
                                                                   isUnspentOutput, rollback)
 import           Plutus.ChainIndex.Types               as Export
 import           Plutus.ChainIndex.UtxoState           as Export
+
+import           Cardano.BM.Trace                      (Trace)
+import           Control.Concurrent.STM                (TVar)
+import qualified Control.Concurrent.STM                as STM
+import           Control.Lens                          (unto)
+import           Control.Monad.Freer                   (Eff, interpret, reinterpret, runM)
+import           Control.Monad.Freer.Error             (handleError, runError, throwError)
+import           Control.Monad.Freer.Extras.Beam       (BeamEffect, handleBeam)
+import           Control.Monad.Freer.Extras.Log        (LogMessage (..), handleLogWriter)
+import           Control.Monad.Freer.Extras.Modify     (raiseEnd)
+import           Control.Monad.Freer.Reader            (runReader)
+import           Control.Monad.Freer.State             (runState)
+import           Control.Monad.Freer.Writer            (runWriter)
+import           Data.Sequence                         (Seq)
+import qualified Database.SQLite.Simple                as Sqlite
+import           Plutus.Monitoring.Util                (convertLog)
+
+-- | The required arguments to run the chain-index effects.
+data RunRequirements = RunRequirements
+    { trace         :: Trace IO ChainIndexLog
+    , stateTVar     :: TVar ChainIndexState
+    , conn          :: Sqlite.Connection
+    , securityParam :: Int
+    }
+
+-- | Run the chain-index effects.
+runChainIndexEffects
+    :: RunRequirements
+    -> Eff '[ChainIndexQueryEffect, ChainIndexControlEffect, BeamEffect] a
+    -> IO (Either ChainIndexError a, Seq (LogMessage ChainIndexLog))
+runChainIndexEffects RunRequirements{trace, stateTVar, conn, securityParam} action = do
+    state <- STM.readTVarIO stateTVar
+    ((result, newState), logs) <- runM
+        $ runWriter @(Seq (LogMessage ChainIndexLog))
+        $ reinterpret
+            (handleLogWriter @ChainIndexLog
+                             @(Seq (LogMessage ChainIndexLog)) $ unto pure)
+        $ runState state
+        $ runReader conn
+        $ runReader (Depth securityParam)
+        $ runError @ChainIndexError
+        $ flip handleError (throwError . BeamEffectError)
+        $ interpret (handleBeam (convertLog BeamLogItem trace))
+        $ interpret handleControl
+        $ interpret handleQuery
+        $ raiseEnd action
+    STM.atomically $ STM.writeTVar stateTVar newState
+    pure (result, logs)

plutus-chain-index/src/Plutus/ChainIndex/ChainIndexError.hs

@@ -14,6 +14,7 @@ import           Prettyprinter                   (Pretty (..), colon, (<+>))
 data ChainIndexError =
     InsertionFailed InsertUtxoFailed
     | RollbackFailed RollbackFailed
+    | ResumeNotSupported
     | QueryFailedNoTip -- ^ Query failed because the chain index does not have a tip (not synchronised with node)
     | BeamEffectError BeamError
     deriving stock (Eq, Show, Generic)
@@ -23,6 +24,7 @@ instance Pretty ChainIndexError where
   pretty = \case
     InsertionFailed err -> "Insertion failed" <> colon <+> pretty err
     RollbackFailed err  -> "Rollback failed" <> colon <+> pretty err
+    ResumeNotSupported  -> "Resume is not supported"
     QueryFailedNoTip    -> "Query failed" <> colon <+> "No tip."
     BeamEffectError err -> "Error during Beam operation" <> colon <+> pretty err
 

plutus-chain-index/src/Plutus/ChainIndex/Effects.hs

@@ -20,6 +20,7 @@ module Plutus.ChainIndex.Effects(
     , ChainIndexControlEffect(..)
     , appendBlock
     , rollback
+    , resumeSync
     , collectGarbage
     , getDiagnostics
     ) where
@@ -76,6 +77,9 @@ data ChainIndexControlEffect r where
     -- | Roll back to a previous state (previous tip)
     Rollback    :: Point -> ChainIndexControlEffect ()
 
+    -- | Resume syncing from a certain point
+    ResumeSync  :: Point -> ChainIndexControlEffect ()
+
     -- | Delete all data that is not covered by current UTxOs.
     CollectGarbage :: ChainIndexControlEffect ()