{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}moduleSystem.Unix.Directory(find,removeRecursiveSafely,unmountRecursiveSafely,renameFileWithBackup,withWorkingDirectory,withTemporaryDirectory,mkdtemp)whereimportControl.ExceptionimportData.List(isSuffixOf)importSystem.CmdimportSystem.DirectoryimportSystem.ExitimportSystem.FilePathimportSystem.IOimportSystem.Posix.FilesimportSystem.Posix.TypesimportForeign.C-- | Traverse a directory and return a list of all the (path,-- fileStatus) pairs.find::FilePath->IO[(FilePath,FileStatus)]findpath=dostatus<-getSymbolicLinkStatuspathcaseisDirectorystatusofTrue->dosubs<-getDirectoryContentspath>>=return.map(path</>).filter(not.flipelem[".",".."])>>=mapMfind>>=return.concatreturn$(path,status):subsFalse->return[(path,status)]traverse::FilePath->(FilePath->IO())->(FilePath->IO())->(FilePath->IO())->IO()-- ^ Traverse a file system directory applying D to every directory, F-- to every non-directory file, and M to every mount point.-- NOTE: It is tempting to use the "find" function to returns a list-- of the elements of the directory and then map that list over an-- "unmount and remove" function. However, because we are unmounting-- as we traverse, the contents of the file list may change in ways-- that could confuse the find function.traversepathfdm=doresult<-try$getSymbolicLinkStatuspatheither(\(_::SomeException)->return())(doPathpath)resultwheredoPathpathstatus=ifisDirectorystatusthendogetDirectoryContentspath>>=mapM(doDirectoryFile1statuspath)dpathelsefpathdoDirectoryFile::Int->FileStatus->FilePath->String->IO()doDirectoryFile___"."=return()doDirectoryFile___".."=return()doDirectoryFiletries___|tries>=5=error("Couldn't unmount file system on "++path)doDirectoryFiletriesstatuspathname=doletchild=path</>namechildStatus<-getSymbolicLinkStatuschildifdeviceIDstatus==deviceIDchildStatusthendoPathchildchildStatuselsedoiftries>1thenhPutStrLnstderr("try "++showtries++":")elsereturn()mchilddoDirectoryFile(tries+1)statuspathname-- |Recursively remove a directory contents on a single file system.-- The adjective \"Safely\" refers to these features:-- 1. It will not follow symlinks-- 2. If it finds a directory that seems to be a mount point,-- it will attempt to unmount it up to five times. If it-- still seems to be a mount point it gives up-- 3. It doesn't use /proc/mounts, which is ambiguous or wrong-- when you are inside a chroot.removeRecursiveSafely::FilePath->IO()removeRecursiveSafelypath=traversepathremoveFileremoveDirectoryumountwhereumountpath=dohPutStrLnstderr("-- removeRecursiveSafely: unmounting "++path)-- This is less likely to hang and more likely to succeed-- than regular umount.letcmd="umount -l "++pathresult<-systemcmdcaseresultofExitSuccess->return()ExitFailuren->error("Failure: "++cmd++" -> "++shown)unmountRecursiveSafely::FilePath->IO()-- ^ Like removeRecursiveSafely but doesn't remove any files, just-- unmounts anything it finds mounted. Note that this can be much-- slower than Mount.umountBelow, use that instead.unmountRecursiveSafelypath=traversepathnoOpnoOpumountwherenoOp_=return()umountpath=dohPutStrLnstderr("-- unmountRecursiveSafely: unmounting "++path)-- This is less likely to hang and more likely to succeed-- than regular umount.letcmd="umount -l "++pathcode<-systemcmdcasecodeofExitSuccess->return()ExitFailuren->error("Failure: "++cmd++" -> "++shown)-- |Rename src to dst, and if dst already exists move it to dst~.-- If dst~ exists it is removed.renameFileWithBackup::FilePath->FilePath->IO()renameFileWithBackupsrcdst=doremoveIfExists(dst++"~")renameIfExistsdst(dst++"~")System.Directory.renameFilesrcdstwhereremoveIfExistspath=doexists<-doesFileExistpathifexiststhenremoveFilepathelsereturn()renameIfExistssrcdst=doexists<-doesFileExistsrcifexiststhenSystem.Directory.renameFilesrcdstelsereturn()-- |temporarily change the working directory to |dir| while running |action|withWorkingDirectory::FilePath->IOa->IOawithWorkingDirectorydiraction=bracketgetCurrentDirectorysetCurrentDirectory(\_->setCurrentDirectorydir>>action)-- |create a temporary directory, run the action, remove the temporary directory-- the first argument is a template for the temporary directory name-- the directory will be created as a subdirectory of the directory returned by getTemporaryDirectory-- the temporary directory will be automatically removed afterwards.-- your working directory is not alteredwithTemporaryDirectory::FilePath->(FilePath->IOa)->IOawithTemporaryDirectoryfpf=dosysTmpDir<-getTemporaryDirectorybracket(mkdtemp(sysTmpDir</>fp))removeRecursiveSafelyfforeignimportccallunsafe"stdlib.h mkdtemp"c_mkdtemp::CString->IOCStringmkdtemp::FilePath->IOFilePathmkdtemptemplate=withCString(if"XXXXXX"`isSuffixOf`templatethentemplateelse(template++"XXXXXX"))$\ptr->docname<-throwErrnoIfNull"mkdtemp"(c_mkdtempptr)name<-peekCStringcnamereturnname