macrm-1.0.0.5: src/Macrm.hs
{-# 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