diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index dae57a6..97135ab 100644 --- a/fs-api/src/System/FS/API.hs +++ b/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 () diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 866580d..9bf73f5 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/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 $ diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index ce2f009..e523e69 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/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 }) diff --git a/fs-sim/src/System/FS/Sim/FsTree.hs b/fs-sim/src/System/FS/Sim/FsTree.hs index bdc5882..bbba101 100644 --- a/fs-sim/src/System/FS/Sim/FsTree.hs +++ b/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 -------------------------------------------------------------------------------} diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 00ef060..86972b5 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/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 diff --git a/fs-sim/src/System/FS/Sim/Pure.hs b/fs-sim/src/System/FS/Sim/Pure.hs index 14642c6..8d9cfd9 100644 --- a/fs-sim/src/System/FS/Sim/Pure.hs +++ b/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 diff --git a/fs-sim/src/System/FS/Sim/STM.hs b/fs-sim/src/System/FS/Sim/STM.hs index 71c0ddc..e16f08d 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/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 diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index dd12442..64a3e6c 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/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]