macrm (empty) → 1.0.0.5
raw patch · 12 files changed
+1590/−0 lines, 12 filesdep +MissingHdep +basedep +bytestringsetup-changed
Dependencies added: MissingH, base, bytestring, cmdargs, cond, directory, exceptions, filepath, githash, hspec, inline-c, macrm, main-tester, process, text, time, unix, uuid
Files
- .editorconfig +23/−0
- .gitignore +7/−0
- ChangeLog.md +64/−0
- LICENSE +30/−0
- Makefile +74/−0
- README.md +42/−0
- Setup.hs +4/−0
- app/Main.hs +6/−0
- hie.yaml +13/−0
- macrm.cabal +88/−0
- src/Macrm.hs +498/−0
- test/Spec.hs +741/−0
+ .editorconfig view
@@ -0,0 +1,23 @@+root = true++[*]+charset = utf-8+end_of_line = lf+indent_style = space+indent_size = 8+insert_final_newline = true+trim_trailing_whitespace = true++[*.hs]+indent_size = 2++[*.md]+indent_size = 2+trim_trailing_whitespace = false++[*.{yml,yaml}]+indent_size = 2++[Makefile]+indent_size = 4+indent_style = tab
+ .gitignore view
@@ -0,0 +1,7 @@+*~+.stack-work/+.test/+dist-newstyle/+macrm.cabal+macrm.tix+stack.yaml.lock
+ ChangeLog.md view
@@ -0,0 +1,64 @@+# Changelog for macrm++All notable changes to this project will be documented in this file.++## Unreleased changes++#### Added++- add man manual++#### Changed++## 1.0.0.5++#### Changed++- fix for `stack sdist`++## 1.0.0.4++#### Added++- add tests++#### Changed++- fix some bugs+- add Makefile+- add .editorconfig+- add hie.yaml+- update .travis.yml+- refactor a bit++## 1.0.0.3++#### Changed++- update LTS to 16.17+- update README.md++## 1.0.0.2++#### Changed++- update LTS to 15.15+- improve version string+- refactor a bit++## 1.0.0.1++#### Changed++- add .travis.yml+- format source code+- fix some warning of hlint+- update LTS to 14.27+- update .gitignore+- add hie.yaml for Haskell IDE Engine++## 1.0.0.0++#### Added++- implement first version
+ LICENSE view
@@ -0,0 +1,30 @@+(c) 2018 Satoshi Ogata++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Satoshi Ogata nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,74 @@+MAKEFILE := $(lastword $(MAKEFILE_LIST))+MAKEFILE_DIR := $(dir $(MAKEFILE))+SRCS := app/Main.hs $(wildcard src/*.hs) $(wildcard test/*.hs)++.PHONY: all+all: hie.yaml+ cd $(MAKEFILE_DIR) && stack build --fast --pedantic++.PHONY: build+build:+ cd $(MAKEFILE_DIR) && stack build --pedantic++.PHONY: clean+clean:+ cd $(MAKEFILE_DIR) && stack clean++.PHONY: rebuild+rebuild: clean build++.PHONY: install+install: rebuild installdirs+ stack install++.PHONY: uninstall+uninstall:+ rm -f $${HOME}/.local/bin/macrm++.PHONY: distclean+distclean:+ cd $(MAKEFILE_DIR) && rm -rf .stack-work macrm.cabal stack.yaml.lock++.PHONY: check+check:+ stack test --coverage++.PHONY: test+test: check++.PHONY: lint+lint:+ hlint src app test++.PHONY: installdirs+installdirs:+ mkdir -p $(HOME)/.local/bin++.PHONY: pre-dist+pre-dist: /usr/local/Homebrew/Library/Taps/satosystems/homebrew-tap/macrm.rb+ @if [ -f "$^" ]; then \+ $(eval CURRENT_VERSION := $(shell (cat $^ | grep url | awk -F'/' '{print $$8}'))) \+ $(eval NEW_VERSION := $(shell git tag | tail -n 1)) \+ if [ "$(CURRENT_VERSION)" != "$(NEW_VERSION)" ]; then \+ $(eval URL := $(shell echo "https://github.com/satosystems/macrm/releases/download/$(NEW_VERSION)/macrm")) \+ if [ "`curl -I $(URL) | head -n 1 | awk -F' ' '{print $$2}'`" != "404" ]; then \+ $(eval ESCAPED_URL := $(shell echo "$(URL)" | sed -E 's/\//\\\//g')) \+ curl -L -o "$(TMPDIR)macrm" "$(URL)"; \+ export __MACRM_HASH=`openssl sha256 "$(TMPDIR)macrm" | awk -F' ' '{print $$2}'`; \+ sed -E "/^ url /s/\"[^\"]+\"/\"$(ESCAPED_URL)\"/; /^ sha256 /s/\"[^\"]+\"/\"$${__MACRM_HASH}\"/" "$^" > "$(TMPDIR)macrm.rb" && mv "$(TMPDIR)macrm.rb" "$^"; \+ export -n __MACRM_HASH; \+ rm $(TMPDIR)macrm; \+ fi \+ fi \+ fi++hie.yaml: $(SRCS)+ cd $(MAKEFILE_DIR) && type gen-hie 2> /dev/null && gen-hie > $@ || stack install implicit-hie && make -f $(MAKEFILE_DIR)$(MAKEFILE) $@++/usr/local/Homebrew/Library/Taps/satosystems/homebrew-tap/macrm.rb: /usr/local/Homebrew/Library/Taps/satosystems/homebrew-tap++/usr/local/Homebrew/Library/Taps/satosystems/homebrew-tap:+ brew tap satosystems/tap++help:+ @cat $(MAKEFILE) | grep -E '^[^ :]+ *:([^=]|$$)' | grep -v '^.PHONY *:' | awk -F':' '{print $$1}'
+ README.md view
@@ -0,0 +1,42 @@+# macrm++[](https://travis-ci.org/satosystems/macrm)++This program is a replacement of macOS's `rm` command.+Unlike `rm` command, this `macrm` command moves deleted files to trash.+That is not just a move, of cause it is possible to undo.++## How to install++### Install via self build++```shell-session+$ git clone https://github.com/satosystems/macrm.git+...+$ cd macrm+...+$ make install+...+$+```++### Install via Homebrew++```shell-session+$ brew install satosystems/tap/macrm+...+$+```++### Install via Hackage++```shell-session+$ stack install macrm+...+$+```++## How to use++It is same as `rm` command.+Please see `macrm --help` for details.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple ( defaultMain )++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Macrm ( run )++main :: IO ()+main = run
+ hie.yaml view
@@ -0,0 +1,13 @@+cradle:+ stack:+ - path: "./src"+ component: "macrm:lib"++ - path: "./app/Main.hs"+ component: "macrm:exe:macrm"++ - path: "./app/Paths_macrm.hs"+ component: "macrm:exe:macrm"++ - path: "./test"+ component: "macrm:test:test"
+ macrm.cabal view
@@ -0,0 +1,88 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8c4cb58ceda2b19569334cea7c787535aad04b26e6bc6c1da0585cea2a6beabd++name: macrm+version: 1.0.0.5+synopsis: Alternative rm command for macOS that remove files/dirs to the system trash+description: Please see the README on GitHub at <https://github.com/satosystems/macrm#readme>+category: Program+homepage: https://github.com/satosystems/macrm#readme+bug-reports: https://github.com/satosystems/macrm/issues+author: Satoshi Ogata+maintainer: satosystems@gmail.com+copyright: (c) 2018-2020 Satoshi Ogata+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ .editorconfig+ .gitignore+ ChangeLog.md+ Makefile+ README.md+ hie.yaml++source-repository head+ type: git+ location: https://github.com/satosystems/macrm++library+ exposed-modules:+ Macrm+ other-modules:+ Paths_macrm+ hs-source-dirs:+ src+ build-depends:+ MissingH >=1.4.3 && <1.5+ , base >=4.7 && <5+ , cmdargs >=0.10.20 && <0.11+ , cond >=0.4.1 && <0.5+ , directory >=1.3.6 && <1.4+ , exceptions >=0.10.4 && <0.11+ , githash >=0.1.4 && <0.2+ , inline-c >=0.9.1 && <0.10+ , process >=1.6.9 && <1.7+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unix >=2.7.2 && <2.8+ default-language: Haskell2010++executable macrm+ main-is: Main.hs+ other-modules:+ Paths_macrm+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -optP-Wno-nonportable-include-path+ build-depends:+ base >=4.7 && <5+ , macrm+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_macrm+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ MissingH >=1.4.3 && <1.5+ , base >=4.7 && <5+ , bytestring >=0.10.10 && <0.11+ , directory >=1.3.6 && <1.4+ , filepath >=1.4.2 && <1.5+ , hspec >=2.7.4 && <2.8+ , macrm+ , main-tester >=0.2.0 && <0.3+ , process >=1.6.9 && <1.7+ , unix >=2.7.2 && <2.8+ , uuid >=1.3.13 && <1.4+ default-language: Haskell2010
+ src/Macrm.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Macrm where++import Control.Conditional ( ifM )+import Control.Monad ( foldM+ , unless+ , when+ )+import Data.Char ( toUpper )+import Data.Fixed ( Fixed+ , HasResolution+ , Uni+ , showFixed+ )+import Data.Int ( Int32 )+import Data.Maybe ( fromJust+ , isNothing+ )+import qualified Data.Text as T+import Data.Time.LocalTime ( TimeOfDay(TimeOfDay)+ , ZonedTime+ ( zonedTimeToLocalTime+ )+ , getZonedTime+ , localTimeOfDay+ )+import Data.Tuple.Utils ( fst3+ , snd3+ , thd3+ )+import Data.Version ( showVersion )+import Foreign.C.String ( withCString )+import GitHash ( GitInfo+ , giDirty+ , giHash+ , tGitInfoCwd+ )+import qualified Language.C.Inline as C+import Paths_macrm ( version )+import System.Console.CmdArgs ( (&=)+ , Data+ , Typeable+ , args+ , cmdArgs+ , explicit+ , help+ , name+ , noAtExpand+ , program+ , summary+ , typ+ )+import System.Exit ( ExitCode+ ( ExitFailure+ , ExitSuccess+ )+ , exitWith+ )+import System.Directory ( doesDirectoryExist+ , getHomeDirectory+ , listDirectory+ , renameDirectory+ , renameFile+ )+import System.IO ( hClose+ , hFlush+ , hGetContents+ , hPutStr+ , hPutStrLn+ , stderr+ , stdout+ )+import System.Path.NameManip ( absolute_path+ , guess_dotdot+ )+import System.Posix.Files ( FileStatus+ , fileGroup+ , fileMode+ , fileOwner+ , getSymbolicLinkStatus+ , groupExecuteMode+ , groupReadMode+ , groupWriteMode+ , intersectFileModes+ , isBlockDevice+ , isCharacterDevice+ , isDirectory+ , isNamedPipe+ , isSocket+ , isSymbolicLink+ , ownerExecuteMode+ , ownerReadMode+ , ownerWriteMode+ , otherExecuteMode+ , otherReadMode+ , otherWriteMode+ , setGroupIDMode+ , setUserIDMode+ )+import System.Posix.Types ( FileMode+ , GroupID+ , UserID+ )+import System.Posix.User ( getRealUserID )+import System.Process ( CreateProcess+ ( std_err+ , std_in+ , std_out+ )+ , StdStream(CreatePipe)+ , createProcess+ , proc+ , waitForProcess+ )++C.include "<fcntl.h>"+C.include "<unistd.h>"+C.include "<sys/stat.h>"++data FileExists = NotExists | DeadLink | Exists deriving (Eq, Show)++type FileInfo = (FilePath, FileExists, Maybe FileStatus)++data Options = Options+ { directory :: Bool+ , force :: Bool+ , interactive :: Bool+ , plaster :: Bool+ , recursive :: Bool+ , recursive' :: Bool+ , verbose :: Bool+ , whiteouts :: Bool+ , files :: [FilePath]+ } deriving (Data, Show, Typeable)++getOptions :: Options+getOptions =+ Options+ { directory = False+ &= help "Attempt to remove directories as well as other types of files."+ , force = False &= help+ ( "Attempt to remove the files without prompting for confirmation, "+ ++ "regardless of the file's permissions. If the file does not exist, "+ ++ "do not display a diagnostic message or modify the exit status to reflect an error. "+ ++ "The -f option overrides any previous -i options."+ )+ , interactive = False &= help+ ( "Request confirmation before attempting to remove each file, "+ ++ "regardless of the file's permissions, "+ ++ "or whether or not the standard input device is a terminal. "+ ++ "The -i option overrides any previous -f options."+ )+ , plaster = False &= name "P" &= help+ ( "Overwrite regular files before deleting them. "+ ++ "Files are overwritten three times, first with the byte pattern 0xff, "+ ++ "then 0x00, and then 0xff again, before they are deleted. "+ ++ "This flag is ignored under macrm."+ )+ , recursive = False &= name "R" &= help+ ("Attempt to remove the file hierarchy rooted in each file argument. "+ ++ "The -R option implies the -d option. If the -i option is specified, "+ ++ "the user is prompted for confirmation before each directory's "+ ++ "contents are processed (as well as before the attempt is made to remove the directory). "+ ++ "If the user does not respond affirmatively, "+ ++ "the file hierarchy rooted in that directory is skipped."+ )+ , recursive' = False &= name "r" &= explicit &= help "Equivalent to -R."+ , verbose = False &= help+ "Be verbose when deleting files, showing them as they are removed."+ , whiteouts = False &= name "W" &= help+ ("Attempt to undelete the named files. "+ ++ "Currently, this option can only be used to recover files covered by whiteouts. "+ ++ "This flag is ignored under macrm."+ )+ , files = [] &= args &= typ "FILES/DIRS"+ }+ &= summary versionString+ &= program "macrm"+ &= noAtExpand++absolutize :: FilePath -> IO FilePath+absolutize path = fromJust . guess_dotdot <$> absolute_path path++moveToTrash :: [FileInfo] -> IO ()+moveToTrash [] = return ()+moveToTrash (fileInfo : fis) = do+ pair <- makePair fileInfo+ move pair+ moveToTrash fis+ where+ makePair :: FileInfo -> IO (FilePath, FilePath)+ makePair (path, _, _) = do+ let fileOrDirName = T.unpack . last . T.splitOn "/" . T.pack $ path+ removedPath <- getRemovedPath fileOrDirName+ return (path, removedPath)+ move :: (FilePath, FilePath) -> IO ()+ move (from, to) = ifM (doesDirectoryExist from)+ (renameDirectory from to)+ (renameFile from to)++getRemovedPath :: FilePath -> IO FilePath+getRemovedPath fileOrDirName = do+ dayOfTime <- getCurrentDayOfTime+ searchRemovedPath fileOrDirName $ ' ' : dayOfTime++searchRemovedPath :: FilePath -> String -> IO FilePath+searchRemovedPath fileOrDirName suffix = do+ homePath <- getHomeDirectory+ let trashPath = homePath ++ "/.Trash/"+ removed <- listDirectory trashPath+ if fileOrDirName `elem` removed+ then searchRemovedPath (fileOrDirName ++ suffix) suffix+ else return $ trashPath ++ fileOrDirName++getCurrentDayOfTime :: IO String+getCurrentDayOfTime = do+ zonedTime <- getZonedTime+ let (TimeOfDay hour minute second) =+ (localTimeOfDay . zonedTimeToLocalTime) zonedTime+ sHour = if hour >= 10 then show hour else '0' : show hour+ sMinute = if minute >= 10 then show minute else '0' : show minute+ uSecond = changeResolution second :: Uni+ sSecond' = showFixed True uSecond+ sSecond = if uSecond >= 10 then sSecond' else '0' : sSecond'+ suffix = sHour ++ "." ++ sMinute ++ "." ++ sSecond+ return suffix++changeResolution :: (HasResolution a, HasResolution b) => Fixed a -> Fixed b+changeResolution = fromRational . toRational++rm :: Options -> ExitCode -> UserID -> [FileInfo] -> [FilePath] -> IO ExitCode+rm (Options False False False False False False False False []) ExitSuccess _ [] []+ = do+ hPutStrLn stderr+ "usage: macrm [-f | -i] [-dPRrvW] file ...\n unlink file"+ return $ ExitFailure 1+rm _ exitCode _ [] [] = return exitCode+rm _ exitCode _ removables [] = do+ ec <- remove removables+ case ec of+ ExitSuccess -> return exitCode+ _ -> return $ ExitFailure 1+rm options exitCode uid removables (path : paths) = do+ fileInfo <- getFileInfo path+ if snd3 fileInfo == NotExists+ then if force options+ then rm options exitCode uid removables paths+ else do+ hPutStrLn stderr $ "macrm: " ++ path ++ ": No such file or directory"+ rm options (ExitFailure 1) uid removables paths+ else do+ let status = fromJust . thd3 $ fileInfo+ let isDir = snd3 fileInfo == Exists && isDirectory status+ let withRecursive = recursive options || recursive' options+ let withDirectory = directory options+ isNotEmpty <- if isDir+ then not . null <$> listDirectory path+ else return False+ if isDir+ && not withRecursive+ && (not withDirectory || withDirectory && isNotEmpty)+ then if withDirectory && isNotEmpty+ then do+ hPutStrLn stderr $ "macrm: " ++ path ++ ": Directory not empty"+ rm options (ExitFailure 1) uid removables paths+ else do+ hPutStrLn stderr $ "macrm: " ++ path ++ ": is a directory"+ rm options (ExitFailure 1) uid removables paths+ else if interactive options+ then do+ let message = case (isDir, withRecursive) of+ (True, True) -> "examine files in directory "+ _ -> "remove "+ agreement <- getAgreement message path+ if agreement+ then do+ when (verbose options) $ putStrLn path+ rm options exitCode uid (fileInfo : removables) paths+ else rm options exitCode uid removables paths+ else do+ let fileUid = fileOwner status+ fileGid = fileGroup status+ mMessage <- if uid == fileUid+ then return Nothing+ else Just <$> makeMessage fileInfo fileUid fileGid+ needRemove <- if isNothing mMessage+ then return True+ else getAgreement (fromJust mMessage) path+ if needRemove+ then do+ when (verbose options) $ putStrLn path+ rm options exitCode uid (fileInfo : removables) paths+ else rm options exitCode uid removables paths++remove :: [FileInfo] -> IO ExitCode+remove fileInfos = do+ let (paths, isDeadLinks, mStatuses) = foldl+ (\(paths', isDeadLinks', mStatuses') (path, isDeadLink, mStatus) ->+ (path : paths', isDeadLink : isDeadLinks', mStatus : mStatuses')+ )+ ([], [], [])+ fileInfos+ absolutePaths <- mapM absolutize paths+ (normals, specials) <- foldM filterSpecialFiles ([], [])+ $ zip3 absolutePaths isDeadLinks mStatuses+ unless (null specials) $ moveToTrash . reverse $ specials+ if null normals+ then return ExitSuccess+ else executeScript . createScript . map fst3 . reverse $ normals++executeScript :: String -> IO ExitCode+executeScript script = do+ (Just stdIn, _, _, ph) <- createProcess (proc "osascript" [])+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ hPutStr stdIn script+ hFlush stdIn+ hClose stdIn+ waitForProcess ph++createScript :: [FilePath] -> String+createScript paths = concat+ [ "set l to {}\n"+ , concatMap+ (\path -> "set end of l to posix file \"" ++ path ++ "\" as alias\n")+ paths+ , "tell application \"Finder\"\n"+ , "delete l\n"+ , "end tell\n"+ , "return"+ ]++getAgreement :: String -> FilePath -> IO Bool+getAgreement message path = do+ putStr $ message ++ path ++ "? "+ hFlush stdout+ input <- getLine+ return $ not (null input) && toUpper (head input) == 'Y'++filterSpecialFiles+ :: ([FileInfo], [FileInfo]) -> FileInfo -> IO ([FileInfo], [FileInfo])+filterSpecialFiles (normals, specials) fileInfo = if isSpecialFile fileInfo+ then return (normals, fileInfo : specials)+ else return (fileInfo : normals, specials)++getFileFlags :: FilePath -> IO (Maybe String)+getFileFlags path = do+ (_, Just stdOut, _, ph) <- createProcess (proc "/bin/ls" ["-lO", path])+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ _ <- waitForProcess ph+ output <- hGetContents stdOut+ if null output+ then return Nothing+ else+ let flags = T.unpack $ (T.splitOn " " . T.pack $ output) !! 7+ in return $ Just flags++makeMessage :: FileInfo -> UserID -> GroupID -> IO String+makeMessage (path, _, Just status) uid gid = do+ userAndGroup <- makeUserAndGroupString uid gid+ mFlags <- getFileFlags path+ return+ $ "override "+ ++ makePermissionString status+ ++ " "+ ++ userAndGroup+ ++ maybe "" (" " ++) mFlags+ ++ " for "+makeMessage _ _ _ = undefined -- never happen++makePermissionString :: FileStatus -> String+makePermissionString status =+ [ ifm permission ownerReadMode 'r'+ , ifm permission ownerWriteMode 'w'+ , ifm permission ownerExecuteMode 'x'+ , ifm permission groupReadMode 'r'+ , ifm permission groupWriteMode 'w'+ , ifm permission groupExecuteMode 'x'+ , ifm permission otherReadMode 'r'+ , ifm permission otherWriteMode 'w'+ , ifm permission otherExecuteMode 'x'+ ]+ where+ permission :: FileMode+ permission = fileMode status+ ifm :: FileMode -> FileMode -> Char -> Char+ ifm p m a =+ let+ stickyBit = 0o1000+ isU =+ m+ == ownerExecuteMode+ && intersectFileModes p setUserIDMode+ == setUserIDMode+ isG =+ m+ == groupExecuteMode+ && intersectFileModes p setGroupIDMode+ == setGroupIDMode+ isO =+ m == otherExecuteMode && intersectFileModes p stickyBit == stickyBit+ in+ if intersectFileModes p m == m+ then if isU || isG then 's' else if isO then 't' else a+ else if isU || isG then 'S' else if isO then 'T' else '-'++makeUserAndGroupString :: UserID -> GroupID -> IO String+makeUserAndGroupString uid gid = do+ passwdContents <- readFile "/etc/passwd"+ let user =+ searchIdName (show (fromIntegral uid :: Int32)) $ lines passwdContents+ groupContents <- readFile "/etc/group"+ let group =+ searchIdName (show (fromIntegral gid :: Int32)) $ lines groupContents+ return $ user ++ "/" ++ group+ where+ searchIdName :: String -> [String] -> String+ searchIdName uidOrGid [] = uidOrGid+ searchIdName uidOrGid (('#' : _) : ss) = searchIdName uidOrGid ss+ searchIdName uidOrGid (s : ss) = if id' == uidOrGid+ then name'+ else searchIdName uidOrGid ss+ where+ splitted :: [T.Text]+ splitted = T.splitOn ":" . T.pack $ s+ id' :: String+ id' = T.unpack $ splitted !! 2+ name' :: String+ name' = T.unpack . head $ splitted++getFileInfo :: FilePath -> IO FileInfo+getFileInfo path = do+ fileExists <- isPathExists path+ if fileExists == NotExists+ then return (path, fileExists, Nothing)+ else do+ status <- getSymbolicLinkStatus path+ return (path, fileExists, Just status)++isSpecialFile :: FileInfo -> Bool+isSpecialFile (_, NotExists, _ ) = False+isSpecialFile (_, DeadLink , _ ) = True+isSpecialFile (_, Exists , Nothing) = undefined -- never happen+isSpecialFile (_, Exists, Just status) =+ isSymbolicLink status+ || isNamedPipe status+ || isSocket status+ || isCharacterDevice status+ || isBlockDevice status++isPathExists :: FilePath -> IO FileExists+isPathExists path = do+ rc <- withCString path $ \cpath -> [C.block| int {+ struct stat lstat_info;+ int fd;+ if (lstat($(char *cpath), &lstat_info) == -1) {+ return 0; // not exists+ }+ fd = open($(char *cpath), O_RDONLY);+ if (fd == -1) {+ return 1; // dead link+ }+ close(fd);+ return 2; // exists+ } |]+ return $ case rc of+ 0 -> NotExists+ 1 -> DeadLink+ 2 -> Exists+ _ -> undefined -- never happen++gitInfo :: GitInfo+gitInfo = $$(tGitInfoCwd)++versionString :: String+versionString = concat+ [ "macrm ver "+ , showVersion version+ , " based on Git commit "+ , giHash gitInfo+ , if giDirty gitInfo then " Dirty" else " Clean"+ ]++run :: IO ()+run = do+ options <- cmdArgs getOptions+ uid <- getRealUserID+ ec <- rm options ExitSuccess uid [] . files $ options+ exitWith ec
+ test/Spec.hs view
@@ -0,0 +1,741 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString.Char8 as BS8+import Data.List.Utils ( startswith )+import Data.Maybe ( isNothing )+import Data.UUID ( toString )+import Data.UUID.V4 ( nextRandom )+import Data.Version ( showVersion )+import Test.Hspec ( hspec+ , describe+ , it+ , shouldBe+ , shouldContain+ , shouldReturn+ , shouldSatisfy+ , Spec+ )+import Test.Main ( withArgs+ , ExitCode+ ( ExitSuccess+ , ExitFailure+ )+ , captureProcessResult+ , withStdin+ , ProcessResult+ ( prStdout+ , prStderr+ , prExitCode+ , prException+ )+ )+import System.Directory ( createDirectory+ , createDirectoryIfMissing+ , doesPathExist+ , listDirectory+ , removeDirectoryRecursive+ , removeFile+ , renameFile+ )+import System.Environment ( getEnv )+import System.FilePath ( addTrailingPathSeparator )+import System.IO ( hGetContents )+import System.Posix.Files ( createSymbolicLink )+import System.Process ( createProcess+ , proc+ , CreateProcess(std_out)+ , StdStream(CreatePipe)+ )++import Macrm ( absolutize+ , run+ )+import Paths_macrm ( version )++data Path = Path+ { fileOrDirName :: String+ , relativePath :: FilePath+ , absolutePath :: FilePath+ }++data TestFiles = TestFiles+ { parentDir :: Path+ , normalFiles :: [Path]+ , notExistPaths :: [Path]+ , emptyDirs :: [Path]+ , notEmptyDirs :: [Path]+ , symbolicLinkFiles :: [Path]+ , symbolicLinkDirs :: [Path]+ , deadSymbolicLinks :: [Path]+ }++createTestFile :: String -> IO Path+createTestFile baseDir = do+ uuid <- nextRandom+ let name = toString uuid+ let path = addTrailingPathSeparator baseDir ++ name+ writeFile path ""+ Path name path <$> absolutize path++createNotExistTestFile :: String -> IO Path+createNotExistTestFile baseDir = do+ uuid <- nextRandom+ let name = toString uuid+ let path = addTrailingPathSeparator baseDir ++ name+ Path name path <$> absolutize path++createTestDir :: String -> IO Path+createTestDir baseDir = do+ uuid <- nextRandom+ let name = toString uuid+ let path = addTrailingPathSeparator baseDir ++ name+ createDirectoryIfMissing True path+ Path name path <$> absolutize path++createTestSymbolicLink :: FilePath -> String -> IO Path+createTestSymbolicLink baseDir source = do+ uuid <- nextRandom+ let name = toString uuid+ let path = addTrailingPathSeparator baseDir ++ name+ createSymbolicLink source path+ Path name path <$> absolutize path++createTestFiles :: IO TestFiles+createTestFiles = do+ baseDir <- createTestDir ".test"+ let baseDirPath = relativePath baseDir+ let baseDirs = replicate 3 baseDirPath+ normalFiles' <- mapM createTestFile baseDirs+ notExistPaths' <- mapM createNotExistTestFile baseDirs+ emptyDirs' <- mapM createTestDir baseDirs+ notEmptyDirs' <- mapM createTestDir baseDirs+ mapM_ (createTestFile . relativePath) notEmptyDirs'+ let createTestSymbolicLink' =+ mapM (\(Path fn _ _) -> createTestSymbolicLink baseDirPath fn)+ symbolicLinkFiles' <- createTestSymbolicLink' normalFiles'+ symbolicLinkDirs' <- createTestSymbolicLink' emptyDirs'+ normalFiles'' <- mapM createTestFile baseDirs+ deadSymbolicLinks' <- createTestSymbolicLink' normalFiles''+ mapM_ (\(Path _ _ ap) -> removeFile ap) normalFiles''+ return $ TestFiles { parentDir = baseDir+ , normalFiles = normalFiles'+ , notExistPaths = notExistPaths'+ , emptyDirs = emptyDirs'+ , notEmptyDirs = notEmptyDirs'+ , symbolicLinkFiles = symbolicLinkFiles'+ , symbolicLinkDirs = symbolicLinkDirs'+ , deadSymbolicLinks = deadSymbolicLinks'+ }++removeTestFiles :: TestFiles -> IO ()+removeTestFiles = removeDirectoryRecursive . relativePath . parentDir++spec_run :: FilePath -> Spec+spec_run trashPath = describe "run" $ do+ it "shows usage with no options" $ do+ pr <- withArgs [] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` BS8.unlines+ ["usage: macrm [-f | -i] [-dPRrvW] file ...", " unlink file"]+ prExitCode pr `shouldBe` ExitFailure 1+ (isNothing . prException) pr `shouldBe` True+ it "shows version with `--version' option" $ do+ (_, Just hout, _, _) <- createProcess (proc "git" ["rev-parse", "HEAD"])+ { std_out = CreatePipe+ }+ output <- hGetContents hout+ pr <- withArgs ["--version"] $ captureProcessResult run+ prStdout pr `shouldBe` BS8.pack+ ( "macrm ver "+ ++ showVersion version+ ++ " based on Git commit "+ ++ (head . lines) output+ ++ " Clean\n"+ )+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ pr' <- withArgs ["-V"] $ captureProcessResult run+ pr `shouldBe` pr'+ it "shows numeric version with `--numeric-version' option" $ do+ pr <- withArgs ["--numeric-version"] $ captureProcessResult run+ prStdout pr `shouldBe` BS8.pack (showVersion version ++ "\n")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ it "shows help with `--help' option" $ do+ let+ help = BS8.unlines+ [ "macrm [OPTIONS] [FILES/DIRS]"+ , ""+ , "Common flags:"+ , " -d --directory Attempt to remove directories as well as other types"+ , " of files."+ , " -f --force Attempt to remove the files without prompting for"+ , " confirmation, regardless of the file's permissions. If"+ , " the file does not exist, do not display a diagnostic"+ , " message or modify the exit status to reflect an error."+ , " The -f option overrides any previous -i options."+ , " -i --interactive Request confirmation before attempting to remove each"+ , " file, regardless of the file's permissions, or whether"+ , " or not the standard input device is a terminal. The -i"+ , " option overrides any previous -f options."+ , " -P --plaster Overwrite regular files before deleting them. Files"+ , " are overwritten three times, first with the byte"+ , " pattern 0xff, then 0x00, and then 0xff again, before"+ , " they are deleted. This flag is ignored under macrm."+ , " -R --recursive Attempt to remove the file hierarchy rooted in each"+ , " file argument. The -R option implies the -d option. If"+ , " the -i option is specified, the user is prompted for"+ , " confirmation before each directory's contents are"+ , " processed (as well as before the attempt is made to"+ , " remove the directory). If the user does not respond"+ , " affirmatively, the file hierarchy rooted in that"+ , " directory is skipped."+ , " -r Equivalent to -R."+ , " -v --verbose Be verbose when deleting files, showing them as they"+ , " are removed."+ , " -W --whiteouts Attempt to undelete the named files. Currently, this"+ , " option can only be used to recover files covered by"+ , " whiteouts. This flag is ignored under macrm."+ , " -? --help Display help message"+ , " -V --version Print version information"+ , " --numeric-version Print just the version number"+ ]+ pr <- withArgs ["--help"] $ captureProcessResult run+ prStdout pr `shouldSatisfy` (help `BS8.isSuffixOf`)+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ pr' <- withArgs ["-?"] $ captureProcessResult run+ pr `shouldBe` pr'+ it "will get an error if it tries to remove a file that does not exist" $ do+ testFiles <- createTestFiles+ let filePath = (relativePath . head . notExistPaths) testFiles+ pr <- withArgs [filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` BS8.pack+ ("macrm: " ++ filePath ++ ": No such file or directory\n")+ prExitCode pr `shouldBe` ExitFailure 1+ (isNothing . prException) pr `shouldBe` True+ removeTestFiles testFiles+ it "removes a normal file" $ do+ testFiles <- createTestFiles+ let path = head . normalFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath = relativePath path+ pr <- withArgs [filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath = addTrailingPathSeparator trashPath ++ fileName+ doesPathExist removedFilePath `shouldReturn` True+ doesPathExist filePath `shouldReturn` False+ removeFile removedFilePath+ removeTestFiles testFiles+ it "removes normal files" $ do+ testFiles <- createTestFiles+ let paths = normalFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <- withArgs filePaths $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ mapM_ (\path -> doesPathExist path `shouldReturn` True) removedFilePaths+ mapM_ (\path -> doesPathExist path `shouldReturn` False) filePaths+ mapM_ removeFile removedFilePaths+ removeTestFiles testFiles+ it "removes same name files" $ do+ testFiles <- createTestFiles+ let basePath = head . normalFiles $ testFiles+ let filePath0 = relativePath basePath+ let baseDir = relativePath . head . notEmptyDirs $ testFiles+ let sameFileName = fileOrDirName basePath+ let filePath1 = addTrailingPathSeparator baseDir ++ sameFileName+ renameFile (relativePath . last . normalFiles $ testFiles) filePath1+ pr <- withArgs [filePath0, filePath1] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath0 = addTrailingPathSeparator trashPath ++ sameFileName+ removed <- listDirectory trashPath+ let filtered = filter (startswith $ sameFileName ++ " ") removed+ length filtered `shouldBe` 1+ doesPathExist removedFilePath0 `shouldReturn` True+ doesPathExist filePath0 `shouldReturn` False+ doesPathExist filePath1 `shouldReturn` False+ removeFile removedFilePath0+ removeFile . (addTrailingPathSeparator trashPath ++) . head $ filtered+ removeTestFiles testFiles+ it "removes same name special files" $ do+ testFiles <- createTestFiles+ let path = head . symbolicLinkFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath0 = relativePath path+ let baseDir = relativePath . head . notEmptyDirs $ testFiles+ let filePath1 = addTrailingPathSeparator baseDir ++ fileName+ renameFile (relativePath . last . symbolicLinkFiles $ testFiles) filePath1+ pr <- withArgs [filePath0, filePath1] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath0 = addTrailingPathSeparator trashPath ++ fileName+ removed <- listDirectory trashPath+ let filtered = filter (startswith $ fileName ++ " ") removed+ length filtered `shouldBe` 1+ (fileName `elem` removed) `shouldBe` True+ doesPathExist filePath0 `shouldReturn` False+ doesPathExist filePath1 `shouldReturn` False+ removeFile removedFilePath0+ removeFile . (addTrailingPathSeparator trashPath ++) . head $ filtered+ removeTestFiles testFiles+ it "removes same name directries" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath0 = relativePath path+ let baseDir = relativePath . head . notEmptyDirs $ testFiles+ let dirPath1 = addTrailingPathSeparator baseDir ++ dirName+ createDirectory dirPath1+ pr <- withArgs ["-d", dirPath0, dirPath1] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath0 = addTrailingPathSeparator trashPath ++ dirName+ removed <- listDirectory trashPath+ let filtered = filter (startswith $ dirName ++ " ") removed+ length filtered `shouldBe` 1+ doesPathExist removedDirPath0 `shouldReturn` True+ doesPathExist dirPath0 `shouldReturn` False+ doesPathExist dirPath1 `shouldReturn` False+ removeDirectoryRecursive removedDirPath0+ removeDirectoryRecursive+ . (addTrailingPathSeparator trashPath ++)+ . head+ $ filtered+ removeTestFiles testFiles+ it "fails to remove directory" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs [dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr+ `shouldBe` BS8.pack ("macrm: " ++ dirPath ++ ": is a directory\n")+ prExitCode pr `shouldBe` ExitFailure 1+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` False+ doesPathExist dirPath `shouldReturn` True+ removeTestFiles testFiles+ it "removes empty directory with `--directory' option" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["--directory", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes empty directory with `-d' option" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["-d", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "fails to remove non empty directory with `--directory' option" $ do+ testFiles <- createTestFiles+ let path = head . notEmptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["--directory", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr+ `shouldBe` BS8.pack ("macrm: " ++ dirPath ++ ": Directory not empty\n")+ prExitCode pr `shouldBe` ExitFailure 1+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` False+ doesPathExist dirPath `shouldReturn` True+ removeTestFiles testFiles+ it "fails to remove non empty directory with `-d' option" $ do+ testFiles <- createTestFiles+ let path = head . notEmptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["-d", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr+ `shouldBe` BS8.pack ("macrm: " ++ dirPath ++ ": Directory not empty\n")+ prExitCode pr `shouldBe` ExitFailure 1+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` False+ doesPathExist dirPath `shouldReturn` True+ removeTestFiles testFiles+ it "does nothing when specified non-existance file with `--force' option" $ do+ testFiles <- createTestFiles+ let path = head . notExistPaths $ testFiles+ let filePath = relativePath path+ pr <- withArgs ["--force", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ removeTestFiles testFiles+ it "does nothing when specified non-existance file with `-f' option" $ do+ testFiles <- createTestFiles+ let path = head . notExistPaths $ testFiles+ let filePath = relativePath path+ pr <- withArgs ["-f", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ removeTestFiles testFiles+ it "removes or not with `--interactive' option" $ do+ testFiles <- createTestFiles+ let paths = normalFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <-+ withStdin "Y\nn\nyes\n"+ . withArgs ("--interactive" : filePaths)+ $ captureProcessResult run+ let prompt =+ foldl (\acc cur -> acc ++ "remove " ++ cur ++ "? ") "" filePaths+ prStdout pr `shouldBe` BS8.pack prompt+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ doesPathExist (head removedFilePaths) `shouldReturn` True+ doesPathExist (removedFilePaths !! 1) `shouldReturn` False+ doesPathExist (last removedFilePaths) `shouldReturn` True+ doesPathExist (head filePaths) `shouldReturn` False+ doesPathExist (filePaths !! 1) `shouldReturn` True+ doesPathExist (last filePaths) `shouldReturn` False+ removeFile $ head removedFilePaths+ removeFile $ last removedFilePaths+ removeTestFiles testFiles+ it "removes or not with `-i' option" $ do+ testFiles <- createTestFiles+ let paths = normalFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <-+ withStdin "Y\nn\nyes\n"+ . withArgs ("-i" : filePaths)+ $ captureProcessResult run+ let prompt =+ foldl (\acc cur -> acc ++ "remove " ++ cur ++ "? ") "" filePaths+ prStdout pr `shouldBe` BS8.pack prompt+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ doesPathExist (head removedFilePaths) `shouldReturn` True+ doesPathExist (removedFilePaths !! 1) `shouldReturn` False+ doesPathExist (last removedFilePaths) `shouldReturn` True+ doesPathExist (head filePaths) `shouldReturn` False+ doesPathExist (filePaths !! 1) `shouldReturn` True+ doesPathExist (last filePaths) `shouldReturn` False+ removeFile $ head removedFilePaths+ removeFile $ last removedFilePaths+ removeTestFiles testFiles+ it "ignores `--plaster' option" $ do+ testFiles <- createTestFiles+ let path = head . normalFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath = relativePath path+ pr <- withArgs ["--plaster", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath = addTrailingPathSeparator trashPath ++ fileName+ doesPathExist removedFilePath `shouldReturn` True+ doesPathExist filePath `shouldReturn` False+ removeFile removedFilePath+ removeTestFiles testFiles+ it "ignores `-P' option" $ do+ testFiles <- createTestFiles+ let path = head . normalFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath = relativePath path+ pr <- withArgs ["-P", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath = addTrailingPathSeparator trashPath ++ fileName+ doesPathExist removedFilePath `shouldReturn` True+ doesPathExist filePath `shouldReturn` False+ removeFile removedFilePath+ removeTestFiles testFiles+ it "removes non empty directory with `--recursive' option" $ do+ testFiles <- createTestFiles+ let path = head . notEmptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["--recursive", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes non empty directory with `-R' option" $ do+ testFiles <- createTestFiles+ let path = head . notEmptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["-R", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes non empty directory with `-r' option" $ do+ testFiles <- createTestFiles+ let path = head . notEmptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withArgs ["-r", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes specified files and shows verbose with `--verbose' option" $ do+ testFiles <- createTestFiles+ let paths = normalFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <- withArgs ("--verbose" : filePaths) $ captureProcessResult run+ prStdout pr `shouldBe` (BS8.pack . unlines) filePaths+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ mapM_ (\path -> doesPathExist path `shouldReturn` True) removedFilePaths+ mapM_ (\path -> doesPathExist path `shouldReturn` False) filePaths+ mapM_ removeFile removedFilePaths+ removeTestFiles testFiles+ it "removes specified files and shows verbose with `-v' option" $ do+ testFiles <- createTestFiles+ let paths = normalFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <- withArgs ("-v" : filePaths) $ captureProcessResult run+ prStdout pr `shouldBe` (BS8.pack . unlines) filePaths+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ mapM_ (\path -> doesPathExist path `shouldReturn` True) removedFilePaths+ mapM_ (\path -> doesPathExist path `shouldReturn` False) filePaths+ mapM_ removeFile removedFilePaths+ removeTestFiles testFiles+ it "ignores `--whiteouts' option" $ do+ testFiles <- createTestFiles+ let path = head . normalFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath = relativePath path+ pr <- withArgs ["--whiteouts", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath = addTrailingPathSeparator trashPath ++ fileName+ doesPathExist removedFilePath `shouldReturn` True+ doesPathExist filePath `shouldReturn` False+ removeFile removedFilePath+ removeTestFiles testFiles+ it "ignores `-W' option" $ do+ testFiles <- createTestFiles+ let path = head . normalFiles $ testFiles+ let fileName = fileOrDirName path+ let filePath = relativePath path+ pr <- withArgs ["-W", filePath] $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedFilePath = addTrailingPathSeparator trashPath ++ fileName+ doesPathExist removedFilePath `shouldReturn` True+ doesPathExist filePath `shouldReturn` False+ removeFile removedFilePath+ removeTestFiles testFiles+ it "removes symbolic files" $ do+ testFiles <- createTestFiles+ let paths = symbolicLinkFiles testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <- withArgs filePaths $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ removed <- listDirectory trashPath+ mapM_ (\fileName -> removed `shouldContain` [fileName]) fileNames -- cannot use doesPathExist for simbolic link+ mapM_ (\path -> doesPathExist path `shouldReturn` False) filePaths+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ mapM_ removeFile removedFilePaths+ removeTestFiles testFiles+ it "removes dead link files" $ do+ testFiles <- createTestFiles+ let paths = deadSymbolicLinks testFiles+ let fileNames = map fileOrDirName paths+ let filePaths = map relativePath paths+ pr <- withArgs filePaths $ captureProcessResult run+ prStdout pr `shouldBe` ""+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ removed <- listDirectory trashPath+ mapM_ (\fileName -> removed `shouldContain` [fileName]) fileNames -- cannot use doesPathExist for simbolic link+ mapM_ (\path -> doesPathExist path `shouldReturn` False) filePaths+ let removedFilePaths =+ map (addTrailingPathSeparator trashPath ++) fileNames+ mapM_ removeFile removedFilePaths+ removeTestFiles testFiles+ it "removes an empty directory with `--interactive --directory' options" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <-+ withStdin "y\n"+ $ withArgs ["--interactive", "--directory", dirPath]+ $ captureProcessResult run+ prStdout pr `shouldBe` BS8.pack ("remove " ++ dirPath ++ "? ")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes empty directory with `-id' options" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withStdin "y\n" $ withArgs ["-id", dirPath] $ captureProcessResult run+ prStdout pr `shouldBe` BS8.pack ("remove " ++ dirPath ++ "? ")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes empty directory with `--interactive --recursive' options" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <-+ withStdin "y\n"+ $ withArgs ["--interactive", "--recursive", dirPath]+ $ captureProcessResult run+ prStdout pr+ `shouldBe` BS8.pack ("examine files in directory " ++ dirPath ++ "? ")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes empty directory with `-iR' options" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withStdin "y\n" $ withArgs ["-iR", dirPath] $ captureProcessResult run+ prStdout pr+ `shouldBe` BS8.pack ("examine files in directory " ++ dirPath ++ "? ")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "removes empty directory with `-ir' options" $ do+ testFiles <- createTestFiles+ let path = head . emptyDirs $ testFiles+ let dirName = fileOrDirName path+ let dirPath = relativePath path+ pr <- withStdin "y\n" $ withArgs ["-ir", dirPath] $ captureProcessResult run+ prStdout pr+ `shouldBe` BS8.pack ("examine files in directory " ++ dirPath ++ "? ")+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True+ let removedDirPath = addTrailingPathSeparator trashPath ++ dirName+ doesPathExist removedDirPath `shouldReturn` True+ doesPathExist dirPath `shouldReturn` False+ removeDirectoryRecursive removedDirPath+ removeTestFiles testFiles+ it "tries to remove /bin/rm" $ do+ pr <- withStdin "n\n" $ withArgs ["/bin/rm"] $ captureProcessResult run+ prStdout pr `shouldBe` BS8.pack+ "override rwxr-xr-x root/wheel restricted,compressed for /bin/rm? "+ prStderr pr `shouldBe` ""+ prExitCode pr `shouldBe` ExitSuccess+ (isNothing . prException) pr `shouldBe` True++main :: IO ()+main = do+ homePath <- getEnv "HOME"+ let trashPath = homePath ++ "/.Trash"+ hspec $ spec_run trashPath