{-# 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 path :: String
path =
String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \cpath :: CString
cpath -> do
CString
res <- CString -> IO CString
hsshellscript_get_realpath CString
cpath
if CString
res CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
then String -> Maybe Handle -> Maybe String -> IO String
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' "realpath" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
path)
else CString -> IO String
peekCString CString
res
readlink :: String
-> IO String
readlink :: String -> IO String
readlink path :: String
path =
String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \cpath :: CString
cpath -> do
CString
res <- CString -> IO CString
hsshellscript_get_readlink CString
cpath
if CString
res CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
then String -> Maybe Handle -> Maybe String -> IO String
forall a. String -> Maybe Handle -> Maybe String -> IO a
throwErrno' "readlink" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
path)
else CString -> IO String
peekCString CString
res
readlink' :: String
-> IO String
readlink' :: String -> IO String
readlink' symlink :: String
symlink = do
String
target <- String -> IO String
readlink String
symlink
String -> IO String
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 path :: String
path =
do String -> IO String -> IO String
forall a. String -> IO a -> IO a
fill_in_location "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 (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 (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 pfad :: String
pfad =
do String
cwd <- IO String
getCurrentDirectory
String -> IO String
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 oldpath :: String
oldpath newpath :: String
newpath = do
CString
o <- String -> IO CString
newCString String
oldpath
CString
n <- String -> IO CString
newCString String
newpath
CInt
res <- CString -> CString -> IO CInt
foreign_symlink CString
o CString
n
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -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' ("symlink " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
oldpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 :: int -> String -> IO int
du block_gr :: int
block_gr pfad :: String
pfad =
let par :: [String]
par = ["--summarize", "--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 ausg :: String
ausg =
case ReadS a
forall a. Read a => ReadS a
reads String
ausg of
[(groesse :: a
groesse, _)] -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
groesse
_ -> String -> IO ()
errm ("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]
++ "\nShell command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
shell_command "du" [String]
par)
IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 "/usr/bin/du" [String]
par) IO String -> (String -> IO int) -> IO int
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 path :: 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 path :: 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 path :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "") (String -> IO (Maybe String)
System.Posix.getEnv "PWD")
with_wd :: FilePath
-> IO a
-> IO a
with_wd :: String -> IO a -> IO a
with_wd wd :: String
wd io :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
cwd)
(\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 "/bin/chmod"
chown :: [String]
-> IO ()
chown :: [String] -> IO ()
chown = String -> [String] -> IO ()
run "/bin/chown"
cp :: String
-> String
-> IO ()
cp :: String -> String -> IO ()
cp from :: String
from to :: String
to =
String -> [String] -> IO ()
run "cp" [String
from, String
to]
mv :: String
-> String
-> IO ()
mv :: String -> String -> IO ()
mv from :: String
from to :: String
to = String -> [String] -> IO ()
runprog "/bin/mv" ["--", 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 '-' ParsecT String () Identity Char -> Parser Int -> Parser Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (-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 (m :: * -> *) a. Monad m => a -> m a
return 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 (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
<?> "number"
parse_mt_status :: Parser ( Int
, Int
)
parse_mt_status :: Parser (Int, Int)
parse_mt_status =
do (fn :: Maybe Int
fn,bn :: 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 (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' st :: (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 (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@(fn :: Maybe Int
fn,bn :: 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 "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 (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 "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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int)
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 "/bin/mt" ["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
out) of
Left err :: ParseError
err -> IOError -> IO (Int, Int)
forall a. IOError -> IO a
ioError (String -> IOError
userError ("parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err))
Right x :: (Int, Int)
x -> (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
x
rename :: String
-> String
-> IO ()
rename :: String -> String -> IO ()
rename oldpath :: String
oldpath newpath :: String
newpath = do
String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
oldpath ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \coldpath :: CString
coldpath ->
String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
newpath ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cnewpath :: CString
cnewpath -> do
CInt
res <- CString -> CString -> IO CInt
foreign_rename CString
coldpath CString
cnewpath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -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' ("rename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shell_quote String
oldpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 old :: String
old new :: 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 "/bin/mv" ["--", 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 src :: String
src tgt :: String
tgt =
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_location "force_mv" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> String -> IO ()) -> String -> String -> IO ()
force_cmd (\src :: String
src tgt :: String
tgt -> String -> [String] -> IO ()
run "/bin/mv" ["--", String
src, String
tgt]) String
src String
tgt
force_rename_mv :: FilePath
-> FilePath
-> IO ()
force_rename_mv :: String -> String -> IO ()
force_rename_mv old :: String
old new :: String
new =
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
fill_in_location "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 cmd :: String -> String -> IO ()
cmd oldpath :: String
oldpath newpath0 :: 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
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 (olddir :: String
olddir, _) = String -> (String, String)
split_path String
old_abs
(newdir :: String
newdir, _) = 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 (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
== "" Bool -> Bool -> Bool
|| IOError -> String
ioe_location IOError
ioe String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "force_writeable"
then IOError
ioe { ioe_location :: String
ioe_location = "force_cmd" }
else IOError
ioe))
force_writeable :: String
-> IO a
-> IO a
force_writeable :: String -> IO a -> IO a
force_writeable path :: String
path io :: IO a
io =
String -> IO a -> IO a
forall a. String -> IO a -> IO a
add_location "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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \res :: a
res -> (String, a) -> IO (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
path, a
res))
force_writeable2 :: String
-> IO (String, a)
-> IO a
force_writeable2 :: String -> IO (String, a) -> IO a
force_writeable2 path_before :: String
path_before io :: IO (String, a)
io =
String -> IO a -> IO a
forall a. String -> IO a -> IO a
add_location "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
(path_after :: String
path_after, res :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
res
where
ignore :: SomeException -> IO ()
ignore :: SomeException -> IO ()
ignore _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
set_user_writeable :: String -> IO ()
set_user_writeable path :: String
path = do
FileMode
filemode <- (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
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 path :: String
path = do
FileMode
filemode <- (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
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 opts :: [String]
opts paths :: [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]
paths'
[String]
out <- (String -> [String]) -> IO String -> IO [String]
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 "/usr/bin/fdupes" ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
paths'))
let grps :: [[String]]
grps = [String] -> [[String]]
groups [String]
out
[[[String]]] -> IO [[[String]]]
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 l :: [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]
l
(g :: [String]
g,rest :: [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]
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 p :: a -> Bool
p [] = ([], [])
split p :: a -> Bool
p (x :: a
x:xs :: [a]
xs) =
let (yes :: [a]
yes, no :: [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 grp :: [[a]]
grp dir :: [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 dirs :: [[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 [] grp :: [[a]]
grp = String -> [[[a]]]
forall a. HasCallStack => String -> a
error ("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 (dir :: [a]
dir:dirs :: [[a]]
dirs) grp :: [[a]]
grp = let (paths1 :: [[a]]
paths1, grp_rest :: [[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 :: String -> String -> IO a -> IO a
replace_location was :: String
was wodurch :: String
wodurch io :: 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)))