Add exception safety

IntersectMBO · Aug 11, 2020 · 2ff02a8 · 2ff02a8
1 parent 15d1ff7
commit 2ff02a8
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 26 deletions.
diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal
@@ -283,10 +283,12 @@ test-suite cardano-node-test
                       , hedgehog
                       , hedgehog-corpus
                       , iproute
+                      , mmorph
                       , ouroboros-consensus
                       , ouroboros-consensus-shelley
                       , ouroboros-network
                       , process
+                      , resourcet
                       , shelley-spec-ledger
                       , shelley-spec-ledger-test
                       , temporary

diff --git a/cardano-node/test/Test/Cardano/Node/Chairman.hs b/cardano-node/test/Test/Cardano/Node/Chairman.hs
@@ -12,7 +12,6 @@ import           Hedgehog (Property, discover)
 import qualified Data.Time.Clock as DTC
 import qualified Data.Time.Clock.POSIX as DTC
 import qualified Hedgehog as H
-import qualified System.IO as IO
 import qualified Test.Common.Base as H
 import qualified Test.Common.Process as H
 
@@ -42,7 +41,7 @@ prop_spawnOneNode = H.propertyOnce . H.workspace "temp/chairman" $ \tempDir -> d
     ]
 
   -- Launch cluster of three nodes
-  procResults <- forM [0..2] $ \i -> do
+  forM_ [0..2] $ \i -> do
     si <- H.noteShow $ show @Int i
     dbDir <- H.noteShow $ tempDir <> "/db/node-" <> si
     socketDir <- H.noteShow $ tempDir <> "/socket"
@@ -53,7 +52,7 @@ prop_spawnOneNode = H.propertyOnce . H.workspace "temp/chairman" $ \tempDir -> d
     H.copyFile (baseConfig <> "/topology-node-" <> si <> ".json") (tempDir <> "/topology-node-" <> si <> ".json")
     H.copyFile (baseConfig <> "/config-" <> si <> ".yaml") (tempDir <> "/config-" <> si <> ".yaml")
 
-    (Just hIn, _mOut, _mErr, hProcess) <- H.createProcess =<< H.procNode
+    (Just hIn, _mOut, _mErr, hProcess, _) <- H.createProcess =<< H.procNode
       [ "run"
       , "--database-path", dbDir
       , "--socket-path", socketDir <> "/node-" <> si <> "-socket"
@@ -69,9 +68,5 @@ prop_spawnOneNode = H.propertyOnce . H.workspace "temp/chairman" $ \tempDir -> d
 
   H.threadDelay 10000000
 
-  -- Signal for cluster to shutdown and wait for shutdown to complete
-  forM_ procResults $ \(hIn, _) -> liftIO $ IO.hClose hIn
-  forM_ procResults $ \(_, hProcess) -> void $ H.waitForProcess hProcess
-
 tests :: IO Bool
 tests = H.checkParallel $$discover
diff --git a/cardano-node/test/Test/Common/Base.hs b/cardano-node/test/Test/Common/Base.hs
@@ -15,6 +15,8 @@ module Test.Common.Base
 
 import           Control.Monad
 import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Morph
+import           Control.Monad.Trans.Resource
 import           Data.Bool
 import           Data.Either (Either (..))
 import           Data.Eq
@@ -40,10 +42,10 @@ import qualified System.Directory as IO
 import qualified System.Info as IO
 import qualified System.IO.Temp as IO
 
-propertyOnce :: H.PropertyT IO () -> H.Property
-propertyOnce = H.withTests 1 . H.property
+propertyOnce :: HasCallStack => H.PropertyT (ResourceT IO) () -> H.Property
+propertyOnce = H.withTests 1 . H.property . hoist runResourceT
 
-threadDelay :: Int -> H.PropertyT IO ()
+threadDelay :: Int -> H.PropertyT (ResourceT IO) ()
 threadDelay = H.evalM . liftIO . IO.threadDelay
 
 -- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.
@@ -58,7 +60,7 @@ failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs)
 --
 -- The directory will be deleted if the block succeeds, but left behind if
 -- the block fails.
-workspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT IO ()) -> H.PropertyT IO ()
+workspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT (ResourceT IO) ()) -> H.PropertyT (ResourceT IO) ()
 workspace prefixPath f = GHC.withFrozenCallStack $ do
   systemTemp <- H.evalM . liftIO $ IO.getCanonicalTemporaryDirectory
   let systemPrefixPath = systemTemp <> "/" <> prefixPath
@@ -76,32 +78,32 @@ workspace prefixPath f = GHC.withFrozenCallStack $ do
 --
 -- The directory will be deleted if the block succeeds, but left behind if
 -- the block fails.
-moduleWorkspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT IO ()) -> H.PropertyT IO ()
+moduleWorkspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT (ResourceT IO) ()) -> H.PropertyT (ResourceT IO) ()
 moduleWorkspace prefixPath f = GHC.withFrozenCallStack $ do
   let srcModule = maybe "UnknownModule"  (GHC.srcLocModule . snd) (listToMaybe (getCallStack callStack))
   workspace (prefixPath <> "/" <> srcModule) f
 
-createDirectoryIfMissing :: HasCallStack => FilePath -> H.PropertyT IO ()
+createDirectoryIfMissing :: HasCallStack => FilePath -> H.PropertyT (ResourceT IO) ()
 createDirectoryIfMissing filePath = H.evalM . liftIO $ IO.createDirectoryIfMissing True filePath
 
-copyFile :: HasCallStack => FilePath -> FilePath -> H.PropertyT IO ()
+copyFile :: HasCallStack => FilePath -> FilePath -> H.PropertyT (ResourceT IO) ()
 copyFile src dst = GHC.withFrozenCallStack $ do
   H.annotate $ "Copy from " <> show src <> " to " <> show dst
   H.evalM . liftIO $ IO.copyFile src dst
 
-noteShow :: (HasCallStack, Show a) => a -> H.PropertyT IO a
+noteShow :: (HasCallStack, Show a) => a -> H.PropertyT (ResourceT IO) a
 noteShow a = GHC.withFrozenCallStack $ do
   !b <- H.eval a
   H.annotateShow b
   return b
 
-noteShowM :: (HasCallStack, Show a) => H.PropertyT IO a -> H.PropertyT IO a
+noteShowM :: (HasCallStack, Show a) => H.PropertyT (ResourceT IO) a -> H.PropertyT (ResourceT IO) a
 noteShowM a = GHC.withFrozenCallStack $ do
   !b <- H.evalM a
   H.annotateShow b
   return b
 
-noteShowIO :: (HasCallStack, Show a) => IO a -> H.PropertyT IO a
+noteShowIO :: (HasCallStack, Show a) => IO a -> H.PropertyT (ResourceT IO) a
 noteShowIO a = GHC.withFrozenCallStack $ do
   !b <- H.evalM . liftIO $ a
   H.annotateShow b

diff --git a/cardano-node/test/Test/Common/Process.hs b/cardano-node/test/Test/Common/Process.hs
@@ -15,6 +15,7 @@ import           Control.Concurrent.Async
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Resource
 import           Data.Bool
 import           Data.Either
 import           Data.Function
@@ -62,12 +63,16 @@ argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg
 -- | Create a process returning handles to stdin, stdout, and stderr as well as the process handle.
 createProcess :: HasCallStack
   => CreateProcess
-  -> H.PropertyT IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+  -> H.PropertyT (ResourceT IO) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, ReleaseKey)
 createProcess cp = GHC.withFrozenCallStack $ do
   case IO.cmdspec cp of
     RawCommand cmd args -> H.annotate $ "Command line: " <> cmd <> " " <> L.unwords args
     ShellCommand cmd -> H.annotate $ "Command line: " <> cmd
-  H.evalM . liftIO $ IO.createProcess cp
+  (mhStdin, mhStdout, mhStderr, hProcess) <- H.evalM . liftIO $ IO.createProcess cp
+  releaseKey <- register $ IO.cleanupProcess (mhStdin, mhStdout, mhStderr, hProcess)
+  return (mhStdin, mhStdout, mhStderr, hProcess, releaseKey)
+
+
 
 -- | Create a process returning its stdout.
 --
@@ -82,7 +87,7 @@ execFlex :: HasCallStack
   => String
   -> String
   -> [String]
-  -> H.PropertyT IO String
+  -> H.PropertyT (ResourceT IO) String
 execFlex pkgBin envBin arguments = GHC.withFrozenCallStack $ do
   maybeEnvBin <- liftIO $ IO.lookupEnv envBin
   (actualBin, actualArguments) <- case maybeEnvBin of
@@ -105,12 +110,12 @@ execFlex pkgBin envBin arguments = GHC.withFrozenCallStack $ do
     IO.ExitSuccess -> return stdout
 
 -- | Run cardano-cli, returning the stdout
-execCli :: HasCallStack => [String] -> H.PropertyT IO String
+execCli :: HasCallStack => [String] -> H.PropertyT (ResourceT IO) String
 execCli = GHC.withFrozenCallStack $ execFlex "cardano-cli" "CARDANO_CLI"
 
 waitForProcess :: HasCallStack
   => ProcessHandle
-  -> H.PropertyT IO (Maybe ExitCode)
+  -> H.PropertyT (ResourceT IO) (Maybe ExitCode)
 waitForProcess hProcess = GHC.withFrozenCallStack $ do
   H.evalM . liftIO $ catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> return Nothing
 
@@ -122,7 +127,7 @@ procFlex
   -- ^ Environment variable pointing to the binary to run
   -> [String]
   -- ^ Arguments to the CLI command
-  -> H.PropertyT IO CreateProcess
+  -> H.PropertyT (ResourceT IO) CreateProcess
   -- ^ Captured stdout
 procFlex pkg binaryEnv arguments = GHC.withFrozenCallStack . H.evalM $ do
   maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv
@@ -138,19 +143,19 @@ procCli
   :: HasCallStack
   => [String]
   -- ^ Arguments to the CLI command
-  -> H.PropertyT IO CreateProcess
+  -> H.PropertyT (ResourceT IO) CreateProcess
   -- ^ Captured stdout
 procCli = procFlex "cardano-cli" "CARDANO_CLI"
 
 procNode
   :: HasCallStack
   => [String]
   -- ^ Arguments to the CLI command
-  -> H.PropertyT IO CreateProcess
+  -> H.PropertyT (ResourceT IO) CreateProcess
   -- ^ Captured stdout
 procNode = procFlex "cardano-node" "CARDANO_NODE"
 
-getProjectBase :: H.PropertyT IO String
+getProjectBase :: H.PropertyT (ResourceT IO) String
 getProjectBase = do
   maybeNodeSrc <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC"
   case maybeNodeSrc of