db-synthesizer: relax check whether a dir "looks like a ChainDB" (#1221)

db-synthesizer has a sanity check when (over)writing a directory to
check whether it actually plausibly contains a ChainDB. Previously, this
check was only succeeding when the directory would contain exactly three
entries named `immutable`/`ledger`/`volatile`. This is somewhat
annoying, as ChainDBs usually contain the folder `gsm` as well as files
like `clean`/`lock`/`protocolMagicId` in addition.

This PR relaxes the check, as discussed with @mgmeier: We now only check
whether the subdirectories are a subset of
`immutable`/`ledger`/`volatile`/`gsm`, and fail if any other
subdirectories are present.

Follow-up to #1206

Author: amesgen

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs

@@ -12,6 +12,7 @@ import           Cardano.Node.Types
 import           Cardano.Tools.DBSynthesizer.Forging
 import           Cardano.Tools.DBSynthesizer.Orphans ()
 import           Cardano.Tools.DBSynthesizer.Types
+import           Control.Monad (filterM)
 import           Control.Monad.Trans.Except (ExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT,
                      handleIOExceptT, hoistEither, runExceptT)
@@ -20,6 +21,7 @@ import           Data.Aeson as Aeson (FromJSON, Result (..), Value,
                      eitherDecodeFileStrict', eitherDecodeStrict', fromJSON)
 import           Data.Bool (bool)
 import           Data.ByteString as BS (ByteString, readFile)
+import qualified Data.Set as Set
 import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Cardano.Node
 import           Ouroboros.Consensus.Config (TopLevelConfig, configStorage)
@@ -170,11 +172,12 @@ preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO ()
 preOpenChainDB mode db =
     doesDirectoryExist db >>= bool create checkMode
   where
-    checkIsDB ls    = length ls <= 3 && all (`elem` ["immutable", "ledger", "volatile"]) ls
+    checkIsDB ls    = Set.fromList ls `Set.isSubsetOf` chainDBDirs
+    chainDBDirs     = Set.fromList ["immutable", "ledger", "volatile", "gsm"]
     loc             = "preOpenChainDB: '" ++ db ++ "'"
     create          = createDirectoryIfMissing True db
     checkMode = do
-        isChainDB <- checkIsDB <$> listDirectory db
+        isChainDB <- checkIsDB <$> listSubdirectories db
         case mode of
             OpenCreate ->
                 fail $ loc ++ " already exists. Use -f to overwrite or -a to append."
@@ -184,5 +187,9 @@ preOpenChainDB mode db =
                 removePathForcibly db >> create
             _ ->
                 fail $ loc ++ " is non-empty and does not look like a ChainDB"
-                    <> " (i.e. its entries are not exactly 'immutable'/'ledger'/'volatile')."
-                    <> " Aborting."
+                    <> " (i.e. it contains directories other than"
+                    <> " 'immutable'/'ledger'/'volatile'/'gsm'). Aborting."
+
+    listSubdirectories path = filterM isDir =<< listDirectory path
+      where
+        isDir p = doesDirectoryExist (path </> p)