Move the creation of the runtime out of Interpret.

src/Curiosity/Interpret.hs

@@ -47,37 +47,26 @@ import System.FilePath.Glob qualified as Glob
 --------------------------------------------------------------------------------
 
 -- | Interpret a script.
-run :: P.Conf -> User.UserName -> FilePath -> Bool -> IO ExitCode
-run conf user scriptPath withFinal = do
-  runtime <- Rt.bootConf conf Rt.NoThreads >>= either throwIO pure
+run :: Rt.Runtime -> User.UserName -> FilePath -> Bool -> IO ExitCode
+run runtime user scriptPath withFinal = do
   (code, output) <- interpret runtime user scriptPath
   Rt.powerdown runtime
   when withFinal $ print output
   exitWith code
 
-runNoTrace :: P.Conf -> User.UserName -> FilePath -> Bool -> IO ExitCode
-runNoTrace conf user scriptPath withFinal = do
-  runtime <- Rt.bootConf conf Rt.NoThreads >>= either throwIO pure
+runNoTrace :: Rt.Runtime -> User.UserName -> FilePath -> Bool -> IO ExitCode
+runNoTrace runtime user scriptPath withFinal = do
   output <- interpretFile' runtime user scriptPath 0
   Rt.powerdown runtime
   when withFinal $ print output
   exitSuccess
 
 -- | Similar to `run`, but capturing the output, and logging elsewhere
 -- than normally: this is used in tests and in the `/scenarios` handler.
-run' :: FilePath -> IO [Trace]
-run' scriptPath = do
-  let conf =
-        P.Conf
-          { P._confLogging = P.noLoggingConf
-          , -- P.mkLoggingConf "/tmp/cty-serve-explore.log"
-            -- TOOD Multiple concurrent calls to the same log file
-            -- end up with
-            -- RuntimeException openFile: resource busy (file is locked)
-            P._confDbFile = Nothing
-          }
-  runtime <- Rt.bootConf conf Rt.NoThreads >>= either throwIO pure
+run' :: Rt.Runtime -> FilePath -> IO [Trace]
+run' runtime scriptPath = do
   output <- interpretFile runtime "system" scriptPath 0
+  -- TODO the boot/powerdone should be done in a withRuntime or similar.
   Rt.powerdown runtime
   pure output
 

src/Curiosity/Run.hs

@@ -101,16 +101,18 @@ run (Command.CommandWithTarget (Command.Sock conf) target _) = do
       exitFailure
 run (Command.CommandWithTarget (Command.Run conf scriptPath runOutput) target (Command.User user)) =
   case target of
-    Command.MemoryTarget ->
+    Command.MemoryTarget -> do
+      runtime <- Rt.bootConf conf Rt.NoThreads >>= either throwIO pure
       let Command.RunOutput withTraces withFinal = runOutput
        in if withTraces
-            then Interpret.run conf user scriptPath withFinal
-            else Interpret.runNoTrace conf user scriptPath withFinal
-    Command.StateFileTarget path ->
+            then Interpret.run runtime user scriptPath withFinal
+            else Interpret.runNoTrace runtime user scriptPath withFinal
+    Command.StateFileTarget path -> do
+      runtime <- Rt.bootConf conf {P._confDbFile = Just path} Rt.NoThreads >>= either throwIO pure
       let Command.RunOutput withTraces withFinal = runOutput
        in if withTraces
-            then Interpret.run conf {P._confDbFile = Just path} user scriptPath withFinal
-            else Interpret.runNoTrace conf {P._confDbFile = Just path} user scriptPath withFinal
+            then Interpret.run runtime user scriptPath withFinal
+            else Interpret.runNoTrace runtime user scriptPath withFinal
     Command.UnixDomainTarget _ -> do
       putStrLn @Text "TODO"
       exitFailure

src/Curiosity/Runtime/IO.hs

@@ -1,6 +1,7 @@
 module Curiosity.Runtime.IO
   ( -- * managing runtimes: boot, shutdown etc.
     bootConf
+  , bootForTests
   , bootDbAndLogFile
   , instantiateDb
   , readDb
@@ -16,7 +17,7 @@ import Commence.Runtime.Errors qualified as Errs
 import Control.Concurrent.STM qualified as STM
 import Control.Lens
 import Curiosity.Core qualified as Core
-import Curiosity.Parse qualified as Command
+import Curiosity.Parse qualified as Parse
 import Curiosity.Runtime.Error qualified as RErr
 import Curiosity.Runtime.Type
 import Curiosity.Types.Store qualified as Store
@@ -31,7 +32,7 @@ import System.Directory (doesFileExist)
 -- | Boot up a runtime.
 bootConf
   :: MonadIO m
-  => Command.Conf
+  => Parse.Conf
   -- ^ configuration to bootConf with.
   -> Threads
   -> m (Either Errs.RuntimeErr Runtime)
@@ -40,7 +41,7 @@ bootConf _rConf _rThreads =
     ( try @SomeException
         . ML.makeDefaultLoggersWithConf
         $ _rConf
-          ^. Command.confLogging
+          ^. Parse.confLogging
     )
     >>= \case
       Left loggerErrs ->
@@ -55,11 +56,28 @@ bootConf _rConf _rThreads =
           Left err -> Left err
           Right _rDb -> Right Runtime {..}
 
+-- | Create a specific runtime with capturing the output, and logging elsewhere
+-- than normally: this is used in tests and in the `/scenarios` handler.
+bootForTests
+  :: MonadIO m
+  => m (Either Errs.RuntimeErr Runtime)
+bootForTests = do
+  let conf =
+        Parse.Conf
+          { Parse._confLogging = Parse.noLoggingConf
+          , -- P.mkLoggingConf "/tmp/cty-serve-explore.log"
+            -- TOOD Multiple concurrent calls to the same log file
+            -- end up with
+            -- RuntimeException openFile: resource busy (file is locked)
+            Parse._confDbFile = Nothing
+          }
+  bootConf conf NoThreads
+
 -- | Create a runtime from a given state.
 bootDbAndLogFile :: MonadIO m => Store.HaskDb -> FilePath -> m Runtime
 bootDbAndLogFile db logsPath = do
-  let loggingConf = Command.mkLoggingConf logsPath
-      _rConf = Command.defaultConf {Command._confLogging = loggingConf}
+  let loggingConf = Parse.mkLoggingConf logsPath
+      _rConf = Parse.defaultConf {Parse._confLogging = loggingConf}
   _rDb <- liftIO . STM.atomically $ Core.instantiateStmDb db
   _rLoggers <- ML.makeDefaultLoggersWithConf loggingConf
   let _rThreads = NoThreads
@@ -75,9 +93,9 @@ bootDbAndLogFile db logsPath = do
 instantiateDb
   :: forall m
    . MonadIO m
-  => Command.Conf
+  => Parse.Conf
   -> m (Either Errs.RuntimeErr Core.StmDb)
-instantiateDb Command.Conf {..} = readDbSafe _confDbFile
+instantiateDb Parse.Conf {..} = readDbSafe _confDbFile
 
 readDb
   :: forall m
@@ -157,7 +175,7 @@ powerdown runtime@Runtime {..} = do
 
 saveDb :: MonadIO m => Runtime -> m (Maybe Errs.RuntimeErr)
 saveDb runtime =
-  maybe (pure Nothing) (saveDbAs runtime) $ _rConf runtime ^. Command.confDbFile
+  maybe (pure Nothing) (saveDbAs runtime) $ _rConf runtime ^. Parse.confDbFile
 
 saveDbAs :: MonadIO m => Runtime -> FilePath -> m (Maybe Errs.RuntimeErr)
 saveDbAs runtime fpath = do

src/Curiosity/Server.hs

@@ -2991,7 +2991,9 @@ handleRun path authResult (Data.Command cmd) =
 partialScenarioState :: ServerC m => FilePath -> FilePath -> Int -> m Html
 partialScenarioState scenariosDir name nbr = do
   let path = scenariosDir </> name <> ".txt"
-  ts <- liftIO $ Interpret.run' path
+  ts <- liftIO $ do
+    runtime <- Rt.bootForTests >>= either throwIO pure
+    Interpret.run' runtime path
   let ts' = Interpret.flatten ts
       db = Interpret.traceState $ ts' !! nbr -- TODO Proper input validation
   pure . H.code . H.pre . H.text $ show db
@@ -3004,7 +3006,9 @@ partialScenarioStateAsJson
   -> m (JP.PrettyJSON '[ 'JP.DropNulls] HaskDb)
 partialScenarioStateAsJson scenariosDir name nbr = do
   let path = scenariosDir </> name <> ".txt"
-  ts <- liftIO $ Interpret.run' path
+  ts <- liftIO $ do
+    runtime <- Rt.bootForTests >>= either throwIO pure
+    Interpret.run' runtime path
   let ts' = Interpret.flatten ts
       db = Interpret.traceState $ ts' !! nbr -- TODO Proper input validation
   pure $ JP.PrettyJSON db
@@ -3017,7 +3021,9 @@ partialScenarioStateAsSvg
   -> m Text
 partialScenarioStateAsSvg scenariosDir name nbr = do
   let path = scenariosDir </> name <> ".txt"
-  ts <- liftIO $ Interpret.run' path
+  ts <- liftIO $ do
+    runtime <- Rt.bootForTests >>= either throwIO pure
+    Interpret.run' runtime path
   let ts' = Interpret.flatten ts
       db = Interpret.traceState $ ts' !! nbr -- TODO Proper input validation
   liftIO $ Graph.graphSvg db
@@ -3039,7 +3045,9 @@ partialScenariosAsJson = listScenarioNames
 partialScenario :: ServerC m => FilePath -> FilePath -> m Html
 partialScenario scenariosDir name = do
   let path = scenariosDir </> name <> ".txt"
-  ts <- liftIO $ Interpret.run' path
+  ts <- liftIO $ do
+    runtime <- Rt.bootForTests >>= either throwIO pure
+    Interpret.run' runtime path
   let ts' = Interpret.flatten ts
   pure $ do
     H.style

tests/Curiosity/Runner.hs

@@ -12,6 +12,7 @@ import Curiosity.DataSpec qualified
 import Curiosity.DslSpec qualified
 import Curiosity.Interpret qualified as Interpret
 import Curiosity.RunSpec qualified
+import Curiosity.Runtime qualified as Runtime
 import Curiosity.RuntimeSpec qualified
 import CuriositySpec qualified
 import Data.Text qualified as T
@@ -49,6 +50,8 @@ mkGoldenTest path = do
   pure $ Silver.goldenVsAction testName goldenPath action convert
  where
   action :: IO [Text]
-  action = snd . Interpret.formatOutput <$> Interpret.run' path
+  action = do
+    runtime <- Runtime.bootForTests >>= either throwIO pure
+    snd . Interpret.formatOutput <$> Interpret.run' runtime path
 
   convert = T.unlines