Merge pull request #1962 from input-output-hk/int-index/csl-1758-bracket

[CSL-1758] Localize DB use in launcher

tools/src/launcher/Main.hs

@@ -235,8 +235,10 @@ instance HasConfiguration => MonadDB LauncherMode where
     dbWriteBatch = dbWriteBatchDefault
     dbDelete = dbDeleteDefault
 
-bracketNodeDBs :: FilePath -> (NodeDBs -> IO a) -> IO a
-bracketNodeDBs dbPath = bracket (openNodeDBs False dbPath) closeNodeDBs
+newtype NodeDbPath = NodeDbPath FilePath
+
+bracketNodeDBs :: NodeDbPath -> (NodeDBs -> IO a) -> IO a
+bracketNodeDBs (NodeDbPath dbPath) = bracket (openNodeDBs False dbPath) closeNodeDBs
 
 main :: IO ()
 main =
@@ -262,16 +264,14 @@ main =
                   Just _  ->
                       set Log.ltFiles [Log.HandlerWrap "launcher" Nothing] .
                       set Log.ltSeverity (Just Log.Debug)
-    bracketNodeDBs loNodeDbPath $ \lmcNodeDBs ->
-        Log.usingLoggerName "launcher" $
+    Log.usingLoggerName "launcher" $
         withConfigurations loConfiguration $
-        let lmc = LauncherModeContext{..} in
         case loWalletPath of
             Nothing -> do
                 logNotice "LAUNCHER STARTED"
                 logInfo "Running in the server scenario"
                 serverScenario
-                    lmc
+                    (NodeDbPath loNodeDbPath)
                     loNodeLogConfig
                     (loNodePath, realNodeArgs, loNodeLogPath)
                     ( loUpdaterPath
@@ -283,7 +283,7 @@ main =
                 logNotice "LAUNCHER STARTED"
                 logInfo "Running in the client scenario"
                 clientScenario
-                    lmc
+                    (NodeDbPath loNodeDbPath)
                     loNodeLogConfig
                     (loNodePath, realNodeArgs, loNodeLogPath)
                     (wpath, loWalletArgs)
@@ -325,21 +325,21 @@ main =
 -- * Launch the node.
 -- * If it exits with code 20, then update and restart, else quit.
 serverScenario
-    :: LauncherModeContext
+    :: NodeDbPath
     -> Maybe FilePath                      -- ^ Logger config
     -> (FilePath, [Text], Maybe FilePath)  -- ^ Node, its args, node log
     -> (FilePath, [Text], Maybe FilePath, Maybe FilePath)
     -- ^ Updater, args, updater runner, the update .tar
     -> Maybe String                        -- ^ Report server
     -> M ()
-serverScenario lmc logConf node updater report = do
-    runUpdater lmc updater
+serverScenario ndbp logConf node updater report = do
+    runUpdater ndbp updater
     -- TODO: the updater, too, should create a log if it fails
     (_, nodeAsync, nodeLog) <- spawnNode node
     exitCode <- wait nodeAsync
     if exitCode == ExitFailure 20 then do
         logNotice $ sformat ("The node has exited with "%shown) exitCode
-        serverScenario lmc logConf node updater report
+        serverScenario ndbp logConf node updater report
     else do
         logWarning $ sformat ("The node has exited with "%shown) exitCode
         whenJust report $ \repServ -> do
@@ -352,7 +352,7 @@ serverScenario lmc logConf node updater report = do
 -- * Launch the node and the wallet.
 -- * If the wallet exits with code 20, then update and restart, else quit.
 clientScenario
-    :: LauncherModeContext
+    :: NodeDbPath
     -> Maybe FilePath                      -- ^ Logger config
     -> (FilePath, [Text], Maybe FilePath)  -- ^ Node, its args, node log
     -> (FilePath, [Text])                  -- ^ Wallet, args
@@ -361,8 +361,8 @@ clientScenario
     -> Int                                 -- ^ Node timeout, in seconds
     -> Maybe String                        -- ^ Report server
     -> M ()
-clientScenario lmc logConf node wallet updater nodeTimeout report = do
-    runUpdater lmc updater
+clientScenario ndbp logConf node wallet updater nodeTimeout report = do
+    runUpdater ndbp updater
     (nodeHandle, nodeAsync, nodeLog) <- spawnNode node
     walletAsync <- async (runWallet wallet)
     (someAsync, exitCode) <- waitAny [nodeAsync, walletAsync]
@@ -378,7 +378,7 @@ clientScenario lmc logConf node wallet updater nodeTimeout report = do
              logInfo $ sformat ("Killing the node in "%int%" seconds") nodeTimeout
              sleep (fromIntegral nodeTimeout)
              killNode nodeHandle nodeAsync
-             clientScenario lmc logConf node wallet updater nodeTimeout report
+             clientScenario ndbp logConf node wallet updater nodeTimeout report
        | otherwise -> do
              logWarning $ sformat ("The wallet has exited with "%shown) exitCode
              -- TODO: does the wallet have some kind of log?
@@ -400,8 +400,8 @@ clientScenario lmc logConf node wallet updater nodeTimeout report = do
 
 -- | We run the updater and delete the update file if the update was
 -- successful.
-runUpdater :: LauncherModeContext -> (FilePath, [Text], Maybe FilePath, Maybe FilePath) -> M ()
-runUpdater lmc (path, args, runnerPath, mUpdateArchivePath) = do
+runUpdater :: NodeDbPath -> (FilePath, [Text], Maybe FilePath, Maybe FilePath) -> M ()
+runUpdater ndbp (path, args, runnerPath, mUpdateArchivePath) = do
     whenM (liftIO (doesFileExist path)) $ do
         logNotice "Running the updater"
         let args' = args ++ maybe [] (one . toText) mUpdateArchivePath
@@ -419,7 +419,9 @@ runUpdater lmc (path, args, runnerPath, mUpdateArchivePath) = do
                 -- hopefully if the updater has succeeded it *does* exist
                 whenJust mUpdateArchivePath $ \updateArchivePath -> liftIO $ do
                     updateArchive <- BS.L.readFile updateArchivePath
-                    usingReaderT lmc $ affirmUpdateInstalled (installerHash updateArchive)
+                    bracketNodeDBs ndbp $ \lmcNodeDBs ->
+                        usingReaderT LauncherModeContext{..} $
+                        affirmUpdateInstalled (installerHash updateArchive)
                     removeFile updateArchivePath
             ExitFailure code ->
                 logWarning $ sformat ("The updater has failed (exit code "%int%")") code