Evaluation job operates in the MonadUnliftIO m instead of IO

Author: Unisay

plutus-script-evaluation/lib/Database/Query.hs

@@ -1,6 +1,7 @@
 module Database.Query where
 
 import Cardano.Slotting.Slot (SlotNo)
+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
 import Data.Profunctor.Product.Default (Default)
 import Database.Orphans ()
 import Database.PostgreSQL.Simple (Connection)
@@ -92,13 +93,16 @@ selectSerialisedScriptsBatch conn count =
     pure serialised
 
 withScriptEvaluationEvents
-  :: Connection
+  :: (MonadUnliftIO m)
+  => Connection
   -> a
-  -> (a -> ScriptEvaluationRecord -> IO a)
-  -> IO a
+  -> (a -> ScriptEvaluationRecord -> m a)
+  -> m a
 withScriptEvaluationEvents conn a f = do
   let select = selectTable scriptEvaluations
-  runSelectFold conn select a f
+  withRunInIO \runInIO ->
+    runSelectFold conn select a \accum record ->
+      runInIO (f accum record)
 
 insertScriptEvaluationEvents
   :: (Default ToFields EvaluationEventRecord WriteEvaluationEventRecordFields)

plutus-script-evaluation/lib/Evaluate.hs

@@ -3,6 +3,7 @@
 module Evaluate where
 
 import Codec.Serialise (deserialise)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.ByteString qualified as BSL
@@ -35,20 +36,23 @@ data ScriptEvaluationInput = MkScriptEvaluationInput
   }
 
 evaluateScripts
-  :: Postgres.Connection
+  :: (MonadFail m, MonadUnliftIO m)
+  => Postgres.Connection
   -- ^ Database connection
   -> a
   -- ^ Initial accumulator
-  -> (ScriptEvaluationInput -> a -> IO a)
+  -> (ScriptEvaluationInput -> a -> m a)
   -- ^ Accumulation function
-  -> IO a
+  -> m a
 evaluateScripts conn initialAccum accumulate =
   Db.withScriptEvaluationEvents conn initialAccum \accum record -> do
     scriptInput <- inputFromRecord record
     accumulate scriptInput accum
 
 inputFromRecord
-  :: (MonadFail m) => Db.ScriptEvaluationRecord -> m ScriptEvaluationInput
+  :: (MonadFail m)
+  => Db.ScriptEvaluationRecord
+  -> m ScriptEvaluationInput
 inputFromRecord MkScriptEvaluationRecord'{..} = do
   let mkEvalCtx f =
         runExceptT (runWriterT f) >>= \case

plutus-script-evaluation/plutus-script-evaluation.cabal

@@ -110,6 +110,7 @@ library
     , string-interpolate                           ^>=0.3
     , text
     , transformers
+    , unliftio-core
     , vector
 
 executable dump-script-events
@@ -158,5 +159,6 @@ executable evaluate-scripts
   ghc-options:    -threaded -rtsopts
   other-modules:  Options
   build-depends:
-    , cardano-api  ^>=10.4
+    , cardano-api    ^>=10.4
     , text
+    , unliftio-core