{-# LINE 1 "src/HsShellScript/Commands.chs" #-}
module HsShellScript.Commands where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
import Prelude hiding (catch)
import Control.Exception
import Data.Bits
import Foreign.C
import Foreign.C.Error
import Foreign.Ptr
import GHC.IO hiding (bracket)
import GHC.IO.Exception
import HsShellScript.Misc
import HsShellScript.Misc
import HsShellScript.Paths
import HsShellScript.ProcErr
import HsShellScript.Shell
import System.IO.Error hiding (catch)
import Data.List
import Data.Maybe
import Control.Monad
import Control.Exception
import Text.ParserCombinators.Parsec as Parsec
import System.Posix hiding (rename, createDirectory, removeDirectory)
import System.Random
import System.Directory
realpath :: String
-> IO String
realpath :: String -> IO String
realpath String
path =
String -> (Ptr CChar -> IO String) -> IO String
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
path ((Ptr CChar -> IO String) -> IO String)
-> (Ptr CChar -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cpath -> do
Ptr CChar
res <- Ptr CChar -> IO (Ptr CChar)
hsshellscript_get_realpath Ptr CChar
cpath
if Ptr CChar
res Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr
then String -> Maybe Handle -> Maybe String -> IO String
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' String
"realpath" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
path)
else Ptr CChar -> IO String
peekCString Ptr CChar
res
readlink :: String
-> IO String
readlink :: String -> IO String
readlink String
path =
String -> (Ptr CChar -> IO String) -> IO String
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
path ((Ptr CChar -> IO String) -> IO String)
-> (Ptr CChar -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cpath -> do
Ptr CChar
res <- Ptr CChar -> IO (Ptr CChar)
hsshellscript_get_readlink Ptr CChar
cpath
if Ptr CChar
res Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr
then String -> Maybe Handle -> Maybe String -> IO String
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' String
"readlink" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
path)
else Ptr CChar -> IO String
peekCString Ptr CChar
res
readlink' :: String
-> IO String
readlink' :: String -> IO String
readlink' String
symlink = do
String
target <- String -> IO String
readlink String
symlink
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> String
absolute_path' String
target ((String, String) -> String
forall a b. (a, b) -> a
fst (String -> (String, String)
split_path String
symlink)))
is_symlink :: String
-> IO Bool
is_symlink :: String -> IO Bool
is_symlink String
path =
do String -> IO String -> IO String
forall a. String -> IO a -> IO a
fill_in_location String
"is_symlink" (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readlink String
path
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
(\(IOError
ioe::IOError) -> if (IOError -> IOErrorType
ioeGetErrorType IOError
ioe IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument) then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else IOError -> IO Bool
forall a. IOError -> IO a
ioError IOError
ioe)
realpath_s :: String
-> IO String
realpath_s :: String -> IO String
realpath_s String
pfad =
do String
cwd <- IO String
getCurrentDirectory
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalise_path (String -> String -> String
absolute_path_by String
cwd String
pfad))
symlink :: String
-> String
-> IO ()
symlink :: String -> String -> IO ()
symlink String
oldpath String
newpath = do
Ptr CChar
o <- String -> IO (Ptr CChar)
newCString String
oldpath
Ptr CChar
n <- String -> IO (Ptr CChar)
newCString String
newpath
CInt
res <- Ptr CChar -> Ptr CChar -> IO CInt
foreign_symlink Ptr CChar
o Ptr CChar
n
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe Handle -> Maybe String -> IO ()
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' (String
"symlink " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
oldpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
newpath) Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
newpath)
du :: (Integral int, Read int, Show int)
=> int
-> String
-> IO int
du :: forall int.
(Integral int, Read int, Show int) =>
int -> String -> IO int
du int
block_gr String
pfad =
let par :: [String]
par = [String
"--summarize", String
"--block-size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ int -> String
forall a. Show a => a -> String
show int
block_gr, String
pfad]
parsen :: String -> IO a
parsen String
ausg =
case ReadS a
forall a. Read a => ReadS a
reads String
ausg of
[(a
groesse, String
_)] -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
groesse
[(a, String)]
_ -> String -> IO ()
errm (String
"Can't parse the output of the \"du\" program: \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote String
ausg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nShell command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
shell_command String
"du" [String]
par)
IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ausg)
in IO Any -> IO String
forall a. IO a -> IO String
pipe_from (String -> [String] -> IO Any
forall a. String -> [String] -> IO a
exec String
"/usr/bin/du" [String]
par) IO String -> (String -> IO int) -> IO int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO int
forall {a}. Read a => String -> IO a
parsen
mkdir :: String
-> IO ()
mkdir :: String -> IO ()
mkdir String
path =
String -> IO ()
createDirectory String
path
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
ioe::IOError) -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError
ioe { ioe_filename :: Maybe String
ioe_filename = String -> Maybe String
forall a. a -> Maybe a
Just String
path }))
rmdir :: String
-> IO ()
rmdir :: String -> IO ()
rmdir String
path =
String -> IO ()
removeDirectory String
path
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
ioe::IOError) -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError
ioe { ioe_filename :: Maybe String
ioe_filename = String -> Maybe String
forall a. a -> Maybe a
Just String
path }))
rm :: String
-> IO ()
rm :: String -> IO ()
rm = String -> IO ()
removeFile
cd :: String
-> IO ()
cd :: String -> IO ()
cd String
path =
String -> IO ()
setCurrentDirectory String
path
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
ioe::IOError) -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError
ioe { ioe_filename :: Maybe String
ioe_filename = String -> Maybe String
forall a. a -> Maybe a
Just String
path }))
pwd :: IO String
pwd :: IO String
pwd = (Maybe String -> String) -> IO (Maybe String) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") (String -> IO (Maybe String)
System.Posix.getEnv String
"PWD")
with_wd :: FilePath
-> IO a
-> IO a
with_wd :: forall a. String -> IO a -> IO a
with_wd String
wd IO a
io =
IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (do String
cwd <- IO String
getCurrentDirectory
String -> IO ()
setCurrentDirectory String
wd
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
cwd)
(\String
cwd -> String -> IO ()
setCurrentDirectory String
cwd)
(IO a -> String -> IO a
forall a b. a -> b -> a
const IO a
io)
chmod :: [String]
-> IO ()
chmod :: [String] -> IO ()
chmod = String -> [String] -> IO ()
run String
"/bin/chmod"
chown :: [String]
-> IO ()
chown :: [String] -> IO ()
chown = String -> [String] -> IO ()
run String
"/bin/chown"
cp :: String
-> String
-> IO ()
cp :: String -> String -> IO ()
cp String
from String
to =
String -> [String] -> IO ()
run String
"cp" [String
from, String
to]
mv :: String
-> String
-> IO ()
mv :: String -> String -> IO ()
mv String
from String
to = String -> [String] -> IO ()
runprog String
"/bin/mv" [String
"--", String
from, String
to]
number :: Parser Int
number :: Parser Int
number = do Int
sgn <- ( (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT String () Identity Char -> Parser Int -> Parser Int
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser Int
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1))
Parser Int -> Parser Int -> Parser Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Int -> Parser Int
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
)
String
ds <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
Int -> Parser Int
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
sgn Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall a. Read a => String -> a
read String
ds)
Parser Int -> String -> Parser Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"number"
parse_mt_status :: Parser ( Int
, Int
)
parse_mt_status :: Parser (Int, Int)
parse_mt_status =
do (Maybe Int
fn,Maybe Int
bn) <- (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status' (Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing)
(Int, Int) -> Parser (Int, Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
fn, Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
bn)
where
try :: GenParser tok st a -> GenParser tok st a
try = GenParser tok st a -> GenParser tok st a
forall tok st a. GenParser tok st a -> GenParser tok st a
Parsec.try
parse_mt_status' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status' (Maybe Int, Maybe Int)
st = do
(Maybe Int, Maybe Int)
st' <- (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status1' (Maybe Int, Maybe Int)
st
( (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status' (Maybe Int, Maybe Int)
st' Parser (Maybe Int, Maybe Int)
-> Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int, Maybe Int)
st' )
parse_mt_status1' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status1' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
parse_mt_status1' st :: (Maybe Int, Maybe Int)
st@(Maybe Int
fn,Maybe Int
bn) =
Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"file number = "
Int
nr <- Parser Int
number
ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
(Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
nr, Maybe Int
bn)
)
Parser (Maybe Int, Maybe Int)
-> Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"block number = "
Int
nr <- Parser Int
number
ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
(Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
fn, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
nr)
)
Parser (Maybe Int, Maybe Int)
-> Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT String () Identity String
-> Parser (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int, Maybe Int)
st)
mt_status :: IO (Int, Int)
mt_status :: IO (Int, Int)
mt_status = do
String
out <- IO Any -> IO String
forall a. IO a -> IO String
pipe_from (String -> [String] -> IO Any
forall a. String -> [String] -> IO a
exec String
"/bin/mt" [String
"status"])
case (Parser (Int, Int)
-> String -> String -> Either ParseError (Int, Int)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser (Int, Int)
parse_mt_status String
"" String
out) of
Left ParseError
err -> IOError -> IO (Int, Int)
forall a. IOError -> IO a
ioError (String -> IOError
userError (String
"parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err))
Right (Int, Int)
x -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
x
rename :: String
-> String
-> IO ()
rename :: String -> String -> IO ()
rename String
oldpath String
newpath = do
String -> (Ptr CChar -> IO ()) -> IO ()
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
oldpath ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
coldpath ->
String -> (Ptr CChar -> IO ()) -> IO ()
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
newpath ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cnewpath -> do
CInt
res <- Ptr CChar -> Ptr CChar -> IO CInt
foreign_rename Ptr CChar
coldpath Ptr CChar
cnewpath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe Handle -> Maybe String -> IO ()
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' (String
"rename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
oldpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
newpath) Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
newpath)
rename_mv :: FilePath
-> FilePath
-> IO ()
rename_mv :: String -> String -> IO ()
rename_mv String
old String
new =
String -> String -> IO ()
HsShellScript.Commands.rename String
old String
new
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
ioe::IOError) ->
if IOError -> IOErrorType
ioeGetErrorType IOError
ioe IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation
then do Errno
errno <- IO Errno
getErrno
if (Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eXDEV)
then String -> [String] -> IO ()
run String
"/bin/mv" [String
"--", String
old, String
new]
else IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
ioe
else IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
ioe
)
force_rename :: String
-> String
-> IO ()
force_rename :: String -> String -> IO ()
force_rename = (String -> String -> IO ()) -> String -> String -> IO ()
force_cmd String -> String -> IO ()
HsShellScript.Commands.rename
force_mv :: String
-> String
-> IO ()
force_mv :: String -> String -> IO ()
force_mv String
src String
tgt =
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_location String
"force_mv" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> String -> IO ()) -> String -> String -> IO ()
force_cmd (\String
src String
tgt -> String -> [String] -> IO ()
run String
"/bin/mv" [String
"--", String
src, String
tgt]) String
src String
tgt
force_rename_mv :: FilePath
-> FilePath
-> IO ()
force_rename_mv :: String -> String -> IO ()
force_rename_mv String
old String
new =
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_location String
"force_rename_mv" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> String -> IO ()) -> String -> String -> IO ()
force_cmd String -> String -> IO ()
rename_mv String
old String
new
force_cmd :: (String -> String -> IO ())
-> String
-> String
-> IO ()
force_cmd :: (String -> String -> IO ()) -> String -> String -> IO ()
force_cmd String -> String -> IO ()
cmd String
oldpath String
newpath0 =
do Bool
isdir <- String -> IO Bool
is_dir String
newpath0
let newpath :: String
newpath = if Bool
isdir then String
newpath0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a b. (a, b) -> b
snd (String -> (String, String)
split_path String
oldpath) else String
newpath0
String
old_abs <- String -> IO String
absolute_path String
oldpath
String
new_abs <- String -> IO String
absolute_path String
newpath
let (String
olddir, String
_) = String -> (String, String)
split_path String
old_abs
(String
newdir, String
_) = String -> (String, String)
split_path String
new_abs
if String
olddir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
newdir
then
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
force_writeable String
olddir (String -> String -> IO ()
cmd String
oldpath String
newpath)
else
let cmd' :: IO (String, ())
cmd' = do ()
res <- String -> String -> IO ()
cmd String
oldpath String
newpath
(String, ()) -> IO (String, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
newpath, ()
res)
in String -> IO () -> IO ()
forall a. String -> IO a -> IO a
force_writeable String
olddir (String -> IO () -> IO ()
forall a. String -> IO a -> IO a
force_writeable String
newdir (String -> IO (String, ()) -> IO ()
forall a. String -> IO (String, a) -> IO a
force_writeable2 String
oldpath IO (String, ())
cmd'))
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
(\(IOError
ioe::IOError) ->
IOError -> IO ()
forall a. IOError -> IO a
ioError (if IOError -> String
ioe_location IOError
ioe String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" Bool -> Bool -> Bool
|| IOError -> String
ioe_location IOError
ioe String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"force_writeable"
then IOError
ioe { ioe_location :: String
ioe_location = String
"force_cmd" }
else IOError
ioe))
force_writeable :: String
-> IO a
-> IO a
force_writeable :: forall a. String -> IO a -> IO a
force_writeable String
path IO a
io =
String -> IO a -> IO a
forall a. String -> IO a -> IO a
add_location String
"force_writeable" (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
String -> IO (String, a) -> IO a
forall a. String -> IO (String, a) -> IO a
force_writeable2 String
path (IO a
io IO a -> (a -> IO (String, a)) -> IO (String, a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
res -> (String, a) -> IO (String, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
path, a
res))
force_writeable2 :: String
-> IO (String, a)
-> IO a
force_writeable2 :: forall a. String -> IO (String, a) -> IO a
force_writeable2 String
path_before IO (String, a)
io =
String -> IO a -> IO a
forall a. String -> IO a -> IO a
add_location String
"force_writeable2" (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
do Bool
writeable <- String -> Bool -> Bool -> Bool -> IO Bool
fileAccess' String
path_before Bool
False Bool
True Bool
False
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
writeable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
set_user_writeable String
path_before
(String
path_after, a
res) <-
IO (String, a)
-> (SomeException -> IO (String, a)) -> IO (String, a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
IO (String, a)
io
(\(SomeException
e::SomeException) ->
do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
writeable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO ()
set_user_readonly String
path_before)
SomeException -> IO ()
ignore
SomeException -> IO (String, a)
forall e a. Exception e => e -> IO a
throwIO SomeException
e
)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
writeable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
set_user_readonly String
path_after
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
ignore :: SomeException -> IO ()
ignore :: SomeException -> IO ()
ignore SomeException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
set_user_writeable :: String -> IO ()
set_user_writeable String
path = do
FileMode
filemode <- (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileStatus -> FileMode
fileMode (String -> IO FileStatus
getFileStatus' String
path)
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_filename String
path (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> FileMode -> IO ()
setFileMode' String
path (FileMode
filemode FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.|. FileMode
ownerWriteMode)
set_user_readonly :: String -> IO ()
set_user_readonly String
path = do
FileMode
filemode <- (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileStatus -> FileMode
fileMode (String -> IO FileStatus
getFileStatus' String
path)
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_filename String
path (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> FileMode -> IO ()
setFileMode' String
path (FileMode
filemode FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.&. (FileMode -> FileMode
forall a. Bits a => a -> a
complement FileMode
ownerWriteMode))
fdupes :: [String]
-> [String]
-> IO [[[String]]]
fdupes :: [String] -> [String] -> IO [[[String]]]
fdupes [String]
opts [String]
paths = do
let paths' :: [String]
paths' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalise_path [String]
paths
paths'' :: [String]
paths'' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/") [String]
paths'
[String]
out <- (String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ IO () -> IO String
forall a. IO a -> IO String
pipe_from (String -> [String] -> IO ()
run String
"/usr/bin/fdupes" ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
paths'))
let grps :: [[String]]
grps = [String] -> [[String]]
groups [String]
out
[[[String]]] -> IO [[[String]]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String] -> [[String]]) -> [[String]] -> [[[String]]]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> [String] -> [[String]]
forall {a}. (Show a, Eq a) => [[a]] -> [[a]] -> [[[a]]]
sortgrp [String]
paths'') [[String]]
grps)
where
groups :: [String] -> [[String]]
groups [] = []
groups [String]
l =
let l' :: [String]
l' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"") [String]
l
([String]
g,[String]
rest) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") [String]
l'
in if [String]
g [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [] then [] else ([String]
g [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [String] -> [[String]]
groups [String]
rest)
split :: (a -> Bool) -> [a] -> ([a], [a])
split a -> Bool
p [] = ([], [])
split a -> Bool
p (a
x:[a]
xs) =
let ([a]
yes, [a]
no) = (a -> Bool) -> [a] -> ([a], [a])
split a -> Bool
p [a]
xs
in if a -> Bool
p a
x then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
yes, [a]
no)
else ([a]
yes, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
no)
path1 :: [[a]] -> [a] -> ([[a]], [[a]])
path1 [[a]]
grp [a]
dir = ([a] -> Bool) -> [[a]] -> ([[a]], [[a]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
split ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
dir) [[a]]
grp
sortgrp :: [[a]] -> [[a]] -> [[[a]]]
sortgrp [[a]]
dirs [] = ([a] -> [[a]]) -> [[a]] -> [[[a]]]
forall a b. (a -> b) -> [a] -> [b]
map ([[a]] -> [a] -> [[a]]
forall a b. a -> b -> a
const []) [[a]]
dirs
sortgrp [] [[a]]
grp = String -> [[[a]]]
forall a. HasCallStack => String -> a
error (String
"Bug: found paths which don't belong to any of the directories:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [[a]] -> String
forall a. Show a => a -> String
show [[a]]
grp)
sortgrp ([a]
dir:[[a]]
dirs) [[a]]
grp = let ([[a]]
paths1, [[a]]
grp_rest) = [[a]] -> [a] -> ([[a]], [[a]])
forall {a}. Eq a => [[a]] -> [a] -> ([[a]], [[a]])
path1 [[a]]
grp [a]
dir
in ([[a]]
paths1 [[a]] -> [[[a]]] -> [[[a]]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]] -> [[[a]]]
sortgrp [[a]]
dirs [[a]]
grp_rest)
replace_location :: String
-> String
-> IO a
-> IO a
replace_location :: forall a. String -> String -> IO a -> IO a
replace_location String
was String
wodurch IO a
io =
IO a -> (IOError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
io
(\(IOError
ioe::IOError) ->
if IOError -> String
ioe_location IOError
ioe String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
was
then IOError -> IO a
forall a. IOError -> IO a
ioError (IOError
ioe { ioe_location :: String
ioe_location = String
wodurch })
else IOError -> IO a
forall a. IOError -> IO a
ioError IOError
ioe
)
foreign import ccall safe "HsShellScript/Commands.chs.h hsshellscript_get_realpath"
hsshellscript_get_realpath :: ((C2HSImp.Ptr C2HSImp.CChar) -> (IO (C2HSImp.Ptr C2HSImp.CChar)))
foreign import ccall safe "HsShellScript/Commands.chs.h hsshellscript_get_readlink"
hsshellscript_get_readlink :: ((C2HSImp.Ptr C2HSImp.CChar) -> (IO (C2HSImp.Ptr C2HSImp.CChar)))
foreign import ccall safe "HsShellScript/Commands.chs.h symlink"
foreign_symlink :: ((C2HSImp.Ptr C2HSImp.CChar) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))
foreign import ccall safe "HsShellScript/Commands.chs.h rename"
foreign_rename :: ((C2HSImp.Ptr C2HSImp.CChar) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))