Add removeDirectoryRecursive to the API and simulator implementation.

These changes are taken from the `feature/utxo-hd-cleanup` branch in the
`ouroboros-network` repo:
IntersectMBO/ouroboros-network#4352

Co-authored-by: Javier Sagredo <javier.sagredo@iohk.io>
Co-authored-by: Nick Frisby <nick.frisby@iohk.io>
Co-authored-by: Damian Nadales <damian.nadales@iohk.io>
Co-authored-by: Joris Dral <joris@well-typed.com>

fs-api/src/System/FS/API.hs

@@ -132,6 +132,9 @@ data HasFS m h = HasFS {
     -- | Check if the path exists and is a file
   , doesFileExist            :: HasCallStack => FsPath -> m Bool
 
+    -- | Remove the directory (which must exist) and its contents
+  , removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
+
     -- | Remove the file (which must exist)
   , removeFile               :: HasCallStack => FsPath -> m ()
 

fs-api/src/System/FS/IO.hs

@@ -64,6 +64,8 @@ ioHasFS mount = HasFS {
         Dir.doesFileExist (root fp)
     , createDirectoryIfMissing = \createParent fp -> rethrowFsError fp $
         Dir.createDirectoryIfMissing createParent (root fp)
+    , removeDirectoryRecursive = \fp -> rethrowFsError fp $
+        Dir.removeDirectoryRecursive (root fp)
     , removeFile = \fp -> rethrowFsError fp $
         Dir.removeFile (root fp)
     , renameFile = \fp1 fp2 -> rethrowFsError fp1 $

fs-sim/src/System/FS/Sim/Error.hs

@@ -281,6 +281,7 @@ data Errors = Errors
   , listDirectoryE            :: ErrorStream
   , doesDirectoryExistE       :: ErrorStream
   , doesFileExistE            :: ErrorStream
+  , removeDirectoryRecursiveE :: ErrorStream
   , removeFileE               :: ErrorStream
   , renameFileE               :: ErrorStream
   }
@@ -352,6 +353,7 @@ instance Semigroup Errors where
       , listDirectoryE            = combine listDirectoryE
       , doesDirectoryExistE       = combine doesDirectoryExistE
       , doesFileExistE            = combine doesFileExistE
+      , removeDirectoryRecursiveE = combine removeDirectoryRecursiveE
       , removeFileE               = combine removeFileE
       , renameFileE               = combine renameFileE
       }
@@ -381,6 +383,7 @@ simpleErrors es = Errors
     , listDirectoryE            = es
     , doesDirectoryExistE       = es
     , doesFileExistE            = es
+    , removeDirectoryRecursiveE = es
     , removeFileE               = es
     , renameFileE               = es
     }
@@ -432,6 +435,9 @@ genErrors genPartialWrites genSubstituteWithJunk = do
     listDirectoryE <- streamGen 3
       [ FsInsufficientPermissions, FsResourceInappropriateType
       , FsResourceDoesNotExist ]
+    removeDirectoryRecursiveE <- streamGen 3
+      [ FsInsufficientPermissions, FsResourceAlreadyInUse
+      , FsResourceDoesNotExist, FsResourceInappropriateType ]
     removeFileE    <- streamGen 3
       [ FsInsufficientPermissions, FsResourceAlreadyInUse
       , FsResourceDoesNotExist, FsResourceInappropriateType ]
@@ -518,6 +524,9 @@ mkSimErrorHasFS fsVar errorsVar =
         , doesFileExist            = \p ->
             withErr errorsVar p (doesFileExist p) "doesFileExist"
             doesFileExistE (\e es -> es { doesFileExistE = e })
+        , removeDirectoryRecursive = \p ->
+            withErr errorsVar p (removeDirectoryRecursive p) "removeFile"
+            removeDirectoryRecursiveE (\e es -> es { removeDirectoryRecursiveE = e })
         , removeFile               = \p ->
             withErr errorsVar p (removeFile p) "removeFile"
             removeFileE (\e es -> es { removeFileE = e })

fs-sim/src/System/FS/Sim/FsTree.hs

@@ -27,9 +27,12 @@ module System.FS.Sim.FsTree (
   , createDirIfMissing
   , createDirWithParents
   , openFile
+  , removeDirRecursive
   , removeFile
   , renameFile
   , replace
+    -- * Path-listing
+  , find
     -- * Pretty-printing
   , pretty
   ) where
@@ -132,14 +135,26 @@ alterDir :: forall f a. Functor f
          -> (Folder a -> f (Folder a))    -- ^ If directory exists
          -> (FsTree a -> f (FsTree a))
 alterDir p onErr onNotExists onExists =
-    alterF p (fmap Just . onErr') (fmap Just . f)
+    alterDirMaybe p
+      (fmap Just . onErr)
+      (fmap Just onNotExists)
+      (fmap Just . onExists)
+
+-- | alterDirMaybe might remove a directory
+alterDirMaybe :: forall f a. Functor f
+              => FsPath
+              -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error
+              -> f (Maybe (Folder a))                  -- ^ If directory does not exist
+              -> (Folder a -> f (Maybe (Folder a)))    -- ^ If directory exists
+              -> (FsTree a -> f (FsTree a))
+alterDirMaybe p onErr onNotExists onExists = alterF p onErr' f
   where
-    onErr' :: FsTreeError -> f (FsTree a)
-    onErr' (FsMissing _ (_ :| [])) = Folder <$> onNotExists
+    onErr' :: FsTreeError -> f (Maybe (FsTree a))
+    onErr' (FsMissing _ (_ :| [])) = fmap Folder <$> onNotExists
     onErr' err                     = onErr err
 
-    f :: FsTree a -> f (FsTree a)
-    f (Folder m) = Folder <$> onExists m
+    f :: FsTree a -> f (Maybe (FsTree a))
+    f (Folder m) = fmap Folder <$> onExists m
     f (File   _) = onErr $ FsExpectedDir p (pathLast p :| [])
 
 alterFileMaybe :: forall f a. Functor f
@@ -254,6 +269,13 @@ createDirWithParents fp =
         go !acc []     = return acc
         go !acc (x:xs) = f acc x >>= \acc' -> go acc' xs
 
+-- | Remove a directory (which must exist) and its contents
+removeDirRecursive :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
+removeDirRecursive fp =
+    alterDirMaybe fp Left errNotExist (const (Right Nothing))
+  where
+    errNotExist = Left (FsMissing fp (pathLast fp :| []))
+
 -- | Remove a file (which must exist)
 removeFile :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
 removeFile fp =
@@ -272,6 +294,55 @@ renameFile fpOld fpNew tree = do
     -- Overwrite the new file with the old one
     alterFile fpNew Left (Right oldF) (const (Right oldF)) tree'
 
+{-------------------------------------------------------------------------------
+  Path-listing
+-------------------------------------------------------------------------------}
+
+-- Find all the file paths reachable from fp. Similar to Unix's @find@.
+--
+-- The initial path will be prepended to the each item in the resulting list of
+-- paths.
+--
+-- For instance, given the following file system, say @fs@:
+--
+-- > usr
+-- >  |-- local
+-- >        |-- bin
+--
+-- find ["usr"] fs will return:
+--
+-- > [usr, usr/local, usr/local/bin]
+--
+-- find ["usr", "local"] fs will return:
+--
+-- > [usr/local, usr/local/bin]
+--
+-- See the unit tests in @Test.Ouroboros.Storage.FsTree@ for additional
+-- examples.
+--
+-- If the given file system path does not exist, a (Left FsMissing{}) is
+-- returned.
+find :: forall a . FsPath -> FsTree a -> Either FsTreeError [FsPath]
+find fp fs = fmap (appendStartingDir . findTree) $ getDir fp fs
+  where
+    appendStartingDir :: [[Text]] -> [FsPath]
+    appendStartingDir fps = fmap fsPathFromList
+                          $ fmap (fsPathToList fp <>)
+                          $ []: fps
+
+    findTree :: Folder a -> [[Text]]
+    findTree folder = concat
+                    $ fmap appendFileNameAndFind
+                    $ M.toList folder
+      where
+        appendFileNameAndFind :: (Text, FsTree a) -> [[Text]]
+        appendFileNameAndFind (fileName, t) =
+            [fileName] : (fmap ([fileName] <>) $ findFsTree t)
+
+        findFsTree :: FsTree a -> [[Text]]
+        findFsTree (File   _      ) = []
+        findFsTree (Folder folder') = findTree folder'
+
 {-------------------------------------------------------------------------------
   Pretty-printing
 -------------------------------------------------------------------------------}

fs-sim/src/System/FS/Sim/MockFS.hs

@@ -41,6 +41,7 @@ module System.FS.Sim.MockFS (
   , doesDirectoryExist
   , doesFileExist
   , listDirectory
+  , removeDirectoryRecursive
   , removeFile
   , renameFile
     -- * Exported for the benefit of tests only
@@ -749,6 +750,41 @@ doesFileExist fp = readMockFS $ \fs ->
                Left  _ -> False
                Right _ -> True
 
+-- | Remove a directory and its contents
+--
+-- Same limitations as 'removeFile'.
+removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()
+removeDirectoryRecursive fp = do
+    modifyMockFS $ \fs -> do
+      reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs)
+      let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs
+      case fsPathToList fp of
+        []
+          -> throwError FsError {
+                 fsErrorType   = FsIllegalOperation
+               , fsErrorPath   = fsToFsErrorPathUnmounted fp
+               , fsErrorString = "cannot remove the root directory"
+               , fsErrorNo     = Nothing
+               , fsErrorStack  = prettyCallStack
+               , fsLimitation  = True
+               }
+        _ | openReachablePaths /= mempty
+          -> throwError FsError {
+                 fsErrorType   = FsIllegalOperation
+               , fsErrorPath   = fsToFsErrorPathUnmounted fp
+               , fsErrorString =  "cannot remove an open file. "
+                               ++ "The following files are reachable from "
+                               ++ show fp
+                               ++ "and are still open: "
+                               ++ show openReachablePaths
+               , fsErrorNo     = Nothing
+               , fsErrorStack  = prettyCallStack
+               , fsLimitation  = True
+               }
+        _ -> do
+          files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs)
+          return ((), fs { mockFiles = files' })
+
 -- | Remove a file
 --
 -- The behaviour of @unlink@ is to remove the file after all open file handles

fs-sim/src/System/FS/Sim/Pure.hs

@@ -40,6 +40,7 @@ pureHasFS = HasFS {
     , listDirectory            = Mock.listDirectory
     , doesDirectoryExist       = Mock.doesDirectoryExist
     , doesFileExist            = Mock.doesFileExist
+    , removeDirectoryRecursive = Mock.removeDirectoryRecursive
     , removeFile               = Mock.removeFile
     , renameFile               = Mock.renameFile
     , mkFsErrorPath            = fsToFsErrorPathUnmounted

fs-sim/src/System/FS/Sim/STM.hs

@@ -54,6 +54,7 @@ simHasFS var = HasFS {
     , listDirectory            = sim  .  Mock.listDirectory
     , doesDirectoryExist       = sim  .  Mock.doesDirectoryExist
     , doesFileExist            = sim  .  Mock.doesFileExist
+    , removeDirectoryRecursive = sim  .  Mock.removeDirectoryRecursive
     , removeFile               = sim  .  Mock.removeFile
     , renameFile               = sim  .: Mock.renameFile
     , mkFsErrorPath            = fsToFsErrorPathUnmounted

fs-sim/test/Test/System/FS/StateMachine.hs

@@ -154,6 +154,7 @@ data Cmd fp h =
   | ListDirectory      (PathExpr fp)
   | DoesDirectoryExist (PathExpr fp)
   | DoesFileExist      (PathExpr fp)
+  | RemoveDirRecursive (PathExpr fp)
   | RemoveFile         (PathExpr fp)
   | RenameFile         (PathExpr fp) (PathExpr fp)
   deriving (Generic, Show, Functor, Foldable, Traversable)
@@ -202,6 +203,7 @@ run hasFS@HasFS{..} = go
     go (ListDirectory      pe  ) = withPE  pe      (const Strings) $ listDirectory
     go (DoesDirectoryExist pe  ) = withPE  pe      (const Bool)    $ doesDirectoryExist
     go (DoesFileExist      pe  ) = withPE  pe      (const Bool)    $ doesFileExist
+    go (RemoveDirRecursive pe  ) = withPE  pe      (const Unit)    $ removeDirectoryRecursive
     go (RemoveFile         pe  ) = withPE  pe      (const Unit)    $ removeFile
     go (RenameFile     pe1 pe2 ) = withPEs pe1 pe2 (\_ _ -> Unit)  $ renameFile
 
@@ -489,6 +491,7 @@ generator Model{..} = oneof $ concat [
         , fmap At $ ListDirectory      <$> genPathExpr
         , fmap At $ DoesDirectoryExist <$> genPathExpr
         , fmap At $ DoesFileExist      <$> genPathExpr
+        , fmap At $ RemoveDirRecursive <$> genPathExpr
         , fmap At $ RemoveFile         <$> genPathExpr
         , fmap At $ RenameFile         <$> genPathExpr <*> genPathExpr
         ]
@@ -831,6 +834,12 @@ data Tag =
   -- | DoesDirectoryExistOK returns False
   | TagDoesDirectoryExistKO
 
+  -- | Remove a directory recursively
+  --
+  -- > RemoveDirRecursively fe
+  -- > DoesFileExist fe
+  | TagRemoveDirectoryRecursive
+
   -- | Remove a file
   --
   -- > RemoveFile fe
@@ -957,6 +966,7 @@ tag = C.classify [
     , tagDoesFileExistKO
     , tagDoesDirectoryExistOK
     , tagDoesDirectoryExistKO
+    , tagRemoveDirectoryRecursive Set.empty
     , tagRemoveFile Set.empty
     , tagRenameFile
     , tagPutTruncateGet Map.empty Set.empty
@@ -1213,6 +1223,19 @@ tag = C.classify [
         (DoesDirectoryExist _, Bool False) -> Left TagDoesDirectoryExistKO
         _otherwise                         -> Right tagDoesDirectoryExistKO
 
+    tagRemoveDirectoryRecursive :: Set FsPath -> EventPred
+    tagRemoveDirectoryRecursive removed = successful $ \ev _suc ->
+      case eventMockCmd ev of
+        RemoveDirRecursive fe -> Right $ tagRemoveDirectoryRecursive $ Set.insert fp removed
+          where
+            fp = evalPathExpr fe
+        DoesFileExist fe -> if Set.member fp removed
+          then Left TagRemoveDirectoryRecursive
+          else Right $ tagRemoveDirectoryRecursive removed
+            where
+              fp = evalPathExpr fe
+        _otherwise -> Right $ tagRemoveDirectoryRecursive removed
+
     tagRemoveFile :: Set FsPath -> EventPred
     tagRemoveFile removed = successful $ \ev _suc ->
       case eventMockCmd ev of
@@ -1416,7 +1439,7 @@ showLabelledExamples :: IO ()
 showLabelledExamples = showLabelledExamples' Nothing 1000 (const True)
 
 prop_sequential :: FilePath -> Property
-prop_sequential tmpDir =
+prop_sequential tmpDir = withMaxSuccess 10000 $
     QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do
       (tstTmpDir, hist, res) <- QC.run $
         withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do
@@ -1501,6 +1524,7 @@ instance (Condense fp, Condense h) => Condense (Cmd fp h) where
       go (ListDirectory fp)        = ["listDirectory", condense fp]
       go (DoesDirectoryExist fp)   = ["doesDirectoryExist", condense fp]
       go (DoesFileExist fp)        = ["doesFileExist", condense fp]
+      go (RemoveDirRecursive fp)   = ["removeDirectoryRecursive", condense fp]
       go (RemoveFile fp)           = ["removeFile", condense fp]
       go (RenameFile fp1 fp2)      = ["renameFile", condense fp1, condense fp2]