-- GENERATED by C->Haskell Compiler, version 0.28.8 Switcheroo, 25 November 2017 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "src/HsShellScript/Commands.chs" #-}
-- #hide
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                 -- InvalidArgument, UnsupportedOperation
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

-- | Do a call to the @realpath(3)@ system library function. This makes the path absolute, normalizes it and
-- expands all symbolic links. In case of an error, an @IOError@ is thrown.
realpath :: String    -- ^ path
         -> IO String -- ^ noramlized, absolute path, with symbolic links expanded
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

-- | Determine the target of a symbolic link. This uses the @readlink(2)@ system call. The result is a path which
-- is either absolute, or relative to the directory which the symlink is in. In case of an error, an @IOError@ is
-- thrown. The path is included and can be accessed with @IO.ioeGetFileName@. Note that, if the path to the symlink
-- ends with a slash, this path denotes the directory pointed to, /not/ the symlink. In this case the call to will
-- fail because of \"Invalid argument\".
readlink :: String    -- ^ Path of the symbolic link
         -> IO String -- ^ The link target - where the symbolic link points to
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

-- | Determine the target of a symbolic link. This uses the @readlink(2)@ system call. The target is converted,
-- such that it is relative to the current working directory, if it isn't absolute. Note that, if the path to the
-- symlink ends with a slash, this path denotes the directory pointed to, /not/ the symlink. In this case the call
-- to @readlink@ will fail with an @IOError@ because of \"Invalid argument\". In case of any error, a proper
-- @IOError@ is thrown.
readlink' :: String     -- ^ path of the symbolic link
          -> IO String  -- ^ target; where the symbolic link points to
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)))


-- | Determine whether a path is a symbolic link. The result for a dangling symlink is @True@. The path must exist
-- in the file system. In case of an error, a proper @IOError@ is thrown.
is_symlink :: String    -- ^ path
           -> IO Bool   -- ^ Whether the path is a symbolic link.
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)


-- | Return the normalised, absolute version of a specified path. The path is made absolute with the current
-- working directory, and is syntactically normalised afterwards. This is the same as what the @realpath@ program
-- reports with the @-s@ option. It's almost the same as what it reports when called from a shell. The difference
-- lies in the shell's idea of the current working directory. See 'cd' for details.
--
-- See 'cd', 'normalise_path'.
realpath_s :: String    -- ^ path
           -> IO String -- ^ noramlized, absolute path, with symbolic links not expanded
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))


-- | Make a symbolic link. This is the @symlink(2)@ function. Any error results in an @IOError@ thrown. The path of
-- the intended symlink is included in the @IOError@ and can be accessed with @ioeGetFileName@ from the Haskell
-- standard library @IO@.
symlink :: String       -- ^ contents of the symlink
        -> String       -- ^ path of the symlink
        -> 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)


-- | Call the @du@ program. See du(1).
du :: (Integral int, Read int, Show int)
   => int               -- ^ block size, this is the @--block-size@ option.
   -> String            -- ^ path of the file or directory to determine the size of
   -> IO int            -- ^ size in blocks
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



-- | Create directory. This is a shorthand to @System.Directory.createDirectory@ from the Haskell standard library.
-- In case of an error, the path is included in the @IOError@, which GHC's implementation neglects to do.
mkdir :: String         -- ^ path
      -> 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 }))


-- | Remove directory. This is @Directory.removeDirectory@ from the Haskell standard library. In case of an error,
-- the path is included in the @IOError@, which GHC's implementation neglects to do.
rmdir :: String         -- ^ path
      -> 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 }))


-- | Remove file. This is @Directory.removeFile@ from the Haskell standard library, which is a direct frontend to
-- the @unlink(2)@ system call in GHC.
rm :: String         -- ^ path
   -> IO ()
rm :: String -> IO ()
rm = String -> IO ()
removeFile


{- | Change directory. This is an alias for @Directory.setCurrentDirectory@ from the Haskell standard library. In
case of an error, the path is included in the @IOError@, which GHC's implementation neglects to do.

Note that this command is subtly different from the shell's @cd@ command. It changes the process' working
directory. This is always a realpath. Symlinks are expanded. The shell, on the other hand, keeps track of the
current working directory separately, in a different way: symlinks are /not/ expanded. The shell's idea of the
working directory is different from the working directory which a process has.

This means that the same sequence of @cd@ commands, when done in a real shell script, will lead into the same
directory. But the working directory as reported by the shell's @pwd@ command may differ from the corresponding
one, reported by @getCurrentDirectory@.

(When talking about the \"shell\", I'm talking about bash, regardless of whether started as @\/bin\/bash@ or in
compatibility mode, as @\/bin\/sh@. I presume it's the standard behavior for the POSIX standard shell.)

See 'pwd', 'with_wd'
-}
cd :: String         -- ^ path
   -> 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 }))


-- |
-- Get program start working directory. This is the @PWD@ environent
-- variable, which is kept by the shell (bash, at least). It records the
-- directory path in which the program has been started. Symbolic links in
-- this path aren't expanded. In this way, it differs from
-- @getCurrentDirectory@ from the Haskell standard library.
--   
-- See 'cd', 'with_wd'
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")



-- | Change the working directory temporarily. This executes the specified IO action with a new working directory,
-- and restores it afterwards (exception-safely).
with_wd :: FilePath     -- ^ New working directory
        -> IO a         -- ^ Action to run
        -> 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)



{- | Execute @\/bin\/chmod@

>chmod = run "/bin/chmod"
-}
chmod :: [String]       -- ^ Command line arguments
      -> IO ()
chmod :: [String] -> IO ()
chmod = String -> [String] -> IO ()
run "/bin/chmod"


{- | Execute @\/bin\/chown@

>chown = run "/bin/chown"
-}
chown :: [String]       -- ^ Command line arguments
      -> IO ()
chown :: [String] -> IO ()
chown = String -> [String] -> IO ()
run "/bin/chown"


-- |
-- Execute the cp program
cp :: String    -- ^ source
   -> String    -- ^ destination
   -> IO ()
cp :: String -> String -> IO ()
cp from :: String
from to :: String
to =
   String -> [String] -> IO ()
run "cp" [String
from, String
to]


-- |
-- Execute the mv program. 
--
-- This calls the @\/bin\/mv@ to rename a file, or move it to another directory. You can move a file to another
-- file system with this. This starts a new process, which is rather slow. Consider using @rename@ instead, when
-- possible.
--
-- See 'rename'.
mv :: String    -- ^ source
   -> String    -- ^ destination
   -> 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"

-- Parser for the output of the "mt status" command.
parse_mt_status :: Parser ( Int    -- file number
                          , Int    -- block number
                          )
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)

-- |
-- Run the command @mt status@ for querying the tape drive status, and
-- parse its output.
mt_status :: IO (Int, Int)      -- ^ file and block number
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



-- | The @rename(2)@ system call to rename and\/or move a file. The @renameFile@ action from the Haskell standard
-- library doesn\'t do it, because the two paths may not refer to directories. Failure results in an @IOError@
-- thrown. The /new/ path is included in the @IOError@ and can be accessed with @IO.ioeGetFileName@.
rename :: String        -- ^ Old path
       -> String        -- ^ New path
       -> 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 a file. This first tries 'rename', which is most efficient. If it fails, because source and target path
-- point to different file systems (as indicated by the @errno@ value @EXDEV@), then @\/bin\/mv@ is called.
--
-- See 'rename', 'mv'.
rename_mv :: FilePath           -- ^ Old path
          -> FilePath           -- ^ New path
          -> 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
                                     -- Foreign.C.Error.errnoToIOError matches many errno values to
                                     -- UnsupportedOperation. In order to determine if it is the right one, the
                                     -- errno is taken again. This relies on no system calls in between.
                                     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
                 )


{- | Rename a file or directory, and manage read only issues.

This renames a file or directory, using @rename@, sets the necessary write permissions beforehand, and restores
them afterwards. This is more efficient than @force_mv@, because no external program needs to be called, but it can
rename files only inside the same file system. See @force_cmd@ for a detailed description.

The new path may be an existing directory. In this case, it is assumed that the old file is to be moved into this
directory (like with @mv@). The new path is then completed with the file name component of the old path. You won't
get an \"already exists\" error.

>force_rename = force_cmd rename

See 'force_cmd', 'rename'.
-}
force_rename :: String        -- ^ Old path
             -> String        -- ^ New path
             -> IO ()
force_rename :: String -> String -> IO ()
force_rename = (String -> String -> IO ()) -> String -> String -> IO ()
force_cmd String -> String -> IO ()
HsShellScript.Commands.rename


{- | Move a file or directory, and manage read only issues.

This moves a file or directory, using the external command @mv@, sets the necessary write permissions beforehand,
and restores them afterwards. This is less efficient than @force_rename@, because the external program @mv@ needs
to be called, but it can move files between file systems. See @force_cmd@ for a detailed description.

>force_mv src tgt = fill_in_location "force_mv" $ force_cmd (\src tgt -> run "/bin/mv" ["--", src, tgt]) src tgt

See 'force_cmd', 'force_mv'.
-}
force_mv :: String        -- ^ Old path
         -> String        -- ^ New path or target directory
         -> 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


{- | Rename a file with 'rename', or when necessary with 'mv', and manage read only issues.

The necessary write permissions are set, then the file is renamed, then the permissions are restored.

First, the 'rename' system call is tried, which is most efficient. If it fails, because source and target path
point to different file systems (as indicated by the @errno@ value @EXDEV@), then @\/bin\/mv@ is called.

>force_rename_mv old new = fill_in_location "force_rename_mv" $ force_cmd rename_mv old new

See 'rename_mv', 'rename', 'mv', 'force_cmd'.
-}
force_rename_mv :: FilePath           -- ^ Old path
                -> FilePath           -- ^ New path
                -> 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


{- | Call a command which moves a file or directory, and manage read only issues.

This function is for calling a command, which renames files. Beforehand, write permissions are set in order to
enable the operation, and afterwards the permissions are restored. The command is meant to be something like
@rename@ or @run \"\/bin\/mv\"@.

In order to change the name of a file or dirctory, but leave it in the super directory it is in, the super
directory must be writeable. In order to move a file or directory to a different super directory, both super
directories and the file\/directory to be moved must be writeable. I don't know what this behaviour is supposed to
be good for.

This function concerns itself with the case that the file\/directory to be moved or renamed, or the super
directories are read only. It makes the necessary places writeable, calls the command, and makes them read only
again, if they were before. The user needs the necessary permissions for changing the corresponding write
permissions. If an error occurs (such as file not found, or insufficient permissions), then the write permissions
are restored to the state before, before the exception is passed through to the caller.

The command must take two arguments, the old path and the new path. It is expected to create the new path in the
file system, such that the correct write permissions of the new path can be set by @force_cmd@ after executing it.

The new path may be an existing directory. In this case, it is assumed that the old file is to be moved into this
directory (like with @mv@). The new path is completed with the file name component of the old path, before it is
passed to the command, such that the command is supplied the complete new path.

Examples:

>force_cmd rename from to
>force_cmd (\from to -> run "/bin/mv" ["-i", "-v", "--", from, to]) from to

See 'force_rename', 'force_mv', 'rename'.
-}
force_cmd :: (String -> String -> IO ())        -- ^ Command to execute after preparing the permissions
          -> String                             -- ^ Old path
          -> String                             -- ^ New path or target directory
          -> 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 -- Don't need to make the file/directory writeable.
              String -> IO () -> IO ()
forall a. String -> IO a -> IO a
force_writeable String
olddir (String -> String -> IO ()
cmd String
oldpath String
newpath)
         else -- Need to make both the file/dirctory and both super directories writeable.
              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))



{- | Make a file or directory writeable for the user, perform an action, and restore its writeable status. An
IOError is raised when the user doesn't have permission to make the file or directory writeable.

>force_writeable path io = force_writeable2 path (io >>= \res -> return (path, res))

Example:

>-- Need to create a new directory in /foo/bar, even if that's write protected
>force_writeable "/foo/bar" $ mkdir "/foo/bar/baz"

See 'force_cmd', 'force_writeable2'.
-}
force_writeable :: String    -- ^ File or directory to make writeable
                -> IO a      -- ^ Action to perform
                -> IO a      -- ^ Returns the return value of the action
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))


{- | Make a file or directory writeable for the user, perform an action, and restore its writeable status. The
action may change the name of the file or directory. Therefore it returns the new name, along with another return
value, which is passed to the caller.

The writeable status is only changed back if it has been changed by @force_writeable2@ before. An IOError is
raised when the user doesn'h have permission to make the file or directory writeable, or when the new path
doesn't exist.

See 'force_cmd', 'force_writeable'.
-}
force_writeable2 :: String          -- ^ File or directory to make writeable
                 -> IO (String, a)  -- ^ Action to perform
                 -> 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                        -- Don't let failure to restore the status make
                                                                -- us loose the actual exception.
                         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))


-- | Call the @fdupes@ program in order to find identical files. It outputs a list of groups of file names, such
-- that the files in each group are identical. Each of these groups is further analysed by the @fdupes@ action.
-- It is split to a list of lists of paths, such that each list of paths corresponds to one of the directories
-- which have been searched by the @fdupes@ program. If you just want groups of identical files, then apply @map
-- concat@ to the result.
--
-- /The/ @fdupes@ /program doesn\'t handle multiple occurences of the same directory, or in recursive mode one
-- specified directory containing another, properly. The same file may get reported multiple times, and identical
-- files may not get reported./
--
-- The paths are normalised (using 'normalise_path').
fdupes :: [String]              -- ^ Options for the fdupes program
       -> [String]              -- ^ Directories with files to compare
       -> IO [[[String]]]       -- ^ For each set of identical files, and each of the specified directories,
                                -- the paths of the identical files in this directory.
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)

      -- result: ( <paths within the directory>, <rest of paths> )
      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

      -- super directories -> Group of identical files -> list of lists of files in each directory
      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)))