module Darcs.Util.File
    ( -- * Files and directories
      getFileStatus
    , doesDirectoryReallyExist
    , removeFileMayNotExist
    , getRecursiveContents
    , getRecursiveContentsFullPath
    , copyTree
      -- * Fetching files
    , fetchFilePS
    , fetchFileLazyPS
    , gzFetchFilePS
    , speculateFileOrUrl
    , copyFileOrUrl
    , Cachable(..)
      -- * Backup
    , backupByRenaming
    , backupByCopying
      -- * Temporary files
    , withTemp
    , withOpenTemp
    ) where

import Darcs.Prelude
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Exception ( catchall, ifDoesNotExistError )
import Darcs.Util.Global ( defaultRemoteDarcsCmd )
import Darcs.Util.HTTP ( Cachable(..) )
import qualified Darcs.Util.HTTP as HTTP
import Darcs.Util.Path ( FilePathLike, toFilePath )
import Darcs.Util.Ssh ( copySSH )
import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath, splitSshUrl )

import Control.Exception ( IOException, bracket, catch )
import Control.Monad ( forM, unless, when, zipWithM_ )
import qualified Data.ByteString as B ( ByteString, readFile )
import qualified Data.ByteString.Lazy as BL
import Network.URI ( parseURI, uriScheme )
import System.Directory
    ( copyFile
    , createDirectory
    , doesDirectoryExist
    , doesFileExist
    , listDirectory
    , removeFile
    , renameDirectory
    , renameFile
    )
import System.FilePath.Posix ( normalise, (</>) )
import System.IO ( Handle, hClose, openBinaryTempFile )
import System.IO.Error ( catchIOError, isDoesNotExistError )
import System.Posix.Files
    ( FileStatus
    , createLink
    , getSymbolicLinkStatus
    , isDirectory
    , isRegularFile
    )

-- | Badly named, since it is actually 'getSymbolicLinkStatus', with all
-- 'IOError's turned into 'Nothing'.
getFileStatus :: FilePath -> IO (Maybe FileStatus)
getFileStatus :: String -> IO (Maybe FileStatus)
getFileStatus String
f =
  FileStatus -> Maybe FileStatus
forall a. a -> Maybe a
Just (FileStatus -> Maybe FileStatus)
-> IO FileStatus -> IO (Maybe FileStatus)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getSymbolicLinkStatus String
f IO (Maybe FileStatus)
-> (IOError -> IO (Maybe FileStatus)) -> IO (Maybe FileStatus)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
_-> Maybe FileStatus -> IO (Maybe FileStatus)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FileStatus
forall a. Maybe a
Nothing)

-- | Whether a path is an existing directory, but not a symlink to one.
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist :: String -> IO Bool
doesDirectoryReallyExist String
f =
    Bool -> IO Bool -> IO Bool
forall a. a -> IO a -> IO a
ifDoesNotExistError Bool
False (FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getSymbolicLinkStatus String
f)

-- | Variant of 'removeFile' that doesn't throw exception when file does not exist.
removeFileMayNotExist :: FilePathLike p => p -> IO ()
removeFileMayNotExist :: forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist p
f = () -> IO () -> IO ()
forall a. a -> IO a -> IO a
ifDoesNotExistError () (String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)

-- | Return all files under given directory that aren't directories.
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents :: String -> IO [String]
getRecursiveContents String
topdir = do
  entries <- String -> IO [String]
listDirectory String
topdir
  paths <- forM entries $ \String
name -> do
    let path :: String
path = String
topdir String -> String -> String
</> String
name
    isDir <- String -> IO Bool
doesDirectoryExist String
path
    if isDir
      then getRecursiveContents path
      else return [name]
  return (concat paths)

-- | Return all files under given directory that aren't directories.
-- Unlike 'getRecursiveContents' this function returns the full path.
getRecursiveContentsFullPath :: FilePath -> IO [FilePath]
getRecursiveContentsFullPath :: String -> IO [String]
getRecursiveContentsFullPath String
topdir = do
  entries <- String -> IO [String]
listDirectory String
topdir
  paths <- forM entries $ \String
name -> do
    let path :: String
path = String
topdir String -> String -> String
</> String
name
    isDir <- String -> IO Bool
doesDirectoryExist String
path
    if isDir
      then getRecursiveContentsFullPath path
      else return [path]
  return (concat paths)

-- | Very much darcs-specific copying procedure. For local files it tries
-- to hard-link, falling back to normal copy if it fails. Remote URLs are
-- downloaded using either HTTP or SSH. For SSH, this tries to use the
-- given remote darcs command to invoke it's transfer-mode command.
copyFileOrUrl :: String    -- ^ remote darcs executable
              -> String    -- ^ path representing the origin file or URL
              -> FilePath  -- ^ destination path
              -> Cachable  -- ^ tell whether file to copy is cachable
              -> IO ()
copyFileOrUrl :: String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
_    String
fou String
out Cachable
_     | String -> Bool
isValidLocalPath String
fou = String -> String -> IO ()
copyLocal String
fou String
out
copyFileOrUrl String
_    String
fou String
out Cachable
cache | String -> Bool
isHttpUrl String
fou = String -> String -> Cachable -> IO ()
HTTP.copyRemote String
fou String
out Cachable
cache
copyFileOrUrl String
rd   String
fou String
out Cachable
_     | String -> Bool
isSshUrl String
fou = String -> SshFilePath -> String -> IO ()
copySSH String
rd (String -> SshFilePath
splitSshUrl String
fou) String
out
copyFileOrUrl String
_    String
fou String
_   Cachable
_     = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"unknown transport protocol: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fou

-- | Hard-link file, falling back to normal copying it that fails.
copyLocal  :: String -> FilePath -> IO ()
copyLocal :: String -> String -> IO ()
copyLocal String
fou String
out = String -> String -> IO ()
createLink String
fou String
out IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` String -> String -> IO ()
copyFile String
fou String
out

-- | Recursively copy a directory, where the target directory is supposed to
-- already exist.
copyTree :: FilePath -> FilePath -> IO ()
copyTree :: String -> String -> IO ()
copyTree String
source String
dest =
 do fs <- String -> IO FileStatus
getSymbolicLinkStatus String
source
    if isDirectory fs then do
        fps <- listDirectory source
        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)
     else fail ("copyTree: Bad source " ++ source)
   IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_ :: IOException) -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"copyTree: Bad source " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
source)

-- | Recursively copy a directory, where the target directory does not yet
-- exist but it's parent does.
copySubTree :: FilePath -> FilePath -> IO ()
copySubTree :: String -> String -> IO ()
copySubTree String
source String
dest =
 do fs <- String -> IO FileStatus
getSymbolicLinkStatus String
source
    if isDirectory fs then do
        createDirectory dest
        fps <- listDirectory source
        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)
     else if isRegularFile fs then
        copyFile source dest
     else fail ("copySubTree: Bad source "++ source)
    IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isDoesNotExistError IOError
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e)

backupByRenaming :: FilePath -> IO ()
backupByRenaming :: String -> IO ()
backupByRenaming = (String -> String -> IO ()) -> String -> IO ()
backupBy String -> String -> IO ()
rename
 where rename :: String -> String -> IO ()
rename String
x String
y = do
         isD <- String -> IO Bool
doesDirectoryExist String
x
         if isD then renameDirectory x y else renameFile x y

backupByCopying :: FilePath -> IO ()
backupByCopying :: String -> IO ()
backupByCopying = (String -> String -> IO ()) -> String -> IO ()
backupBy String -> String -> IO ()
copy
 where
  copy :: String -> String -> IO ()
copy String
x String
y = do
    isD <- String -> IO Bool
doesDirectoryExist String
x
    if isD then do createDirectory y
                   copyTree (normalise x) (normalise y)
           else copyFile x y

backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
backupBy :: (String -> String -> IO ()) -> String -> IO ()
backupBy String -> String -> IO ()
backup String
f =
           do hasBF <- String -> IO Bool
doesFileExist String
f
              hasBD <- doesDirectoryExist f
              when (hasBF || hasBD) $ helper 0
  where
  helper :: Int -> IO ()
  helper :: Int -> IO ()
helper Int
i = do existsF <- String -> IO Bool
doesFileExist String
next
                existsD <- doesDirectoryExist next
                if existsF || existsD
                   then helper (i + 1)
                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"
                           backup f next
             where next :: String
next = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
                   suffix :: String
suffix = String
".~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~"

-- | Generic file fetching support function that takes care of downloading
-- remote files to a temporary location if necessary before invoking the actual
-- reading procedure.
copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a
copyAndReadFile :: forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO a
readfn String
fou Cachable
_ | String -> Bool
isValidLocalPath String
fou = String -> IO a
readfn String
fou
copyAndReadFile String -> IO a
readfn String
fou Cachable
cache = (String -> IO a) -> IO a
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
t -> do
  String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
defaultRemoteDarcsCmd String
fou String
t Cachable
cache
  String -> IO a
readfn String
t

-- | @fetchFilePS fileOrUrl cache@ returns the content of its argument (either a
-- file or an URL). If it has to download an url, then it will use a cache as
-- required by its second argument.
--
-- We always use default remote darcs, since it is not fatal if the remote
-- darcs does not exist or is too old -- anything that supports transfer-mode
-- should do, and if not, we will fall back to SFTP or SCP.
fetchFilePS :: String -> Cachable -> IO B.ByteString
fetchFilePS :: String -> Cachable -> IO ByteString
fetchFilePS = (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO ByteString
B.readFile

-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument
-- (either a file or an URL). Warning: this function may constitute a fd leak;
-- make sure to force consumption of file contents to avoid that. See
-- "fetchFilePS" for details.
fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString
fetchFileLazyPS :: String -> Cachable -> IO ByteString
fetchFileLazyPS String
x Cachable
c =
  case String -> Maybe URI
parseURI String
x of
    Just URI
x'
      | let s :: String
s = URI -> String
uriScheme URI
x'
      , String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"http:" Bool -> Bool -> Bool
|| String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"https:" -> String -> Cachable -> IO ByteString
HTTP.copyRemoteLazy String
x Cachable
c
    Maybe URI
_ -> (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO ByteString
BL.readFile String
x Cachable
c

-- | Like 'fetchFilePS' but transparently handle gzip compressed files.
gzFetchFilePS :: String -> Cachable -> IO B.ByteString
gzFetchFilePS :: String -> Cachable -> IO ByteString
gzFetchFilePS = (String -> IO ByteString) -> String -> Cachable -> IO ByteString
forall a. (String -> IO a) -> String -> Cachable -> IO a
copyAndReadFile String -> IO ByteString
gzReadFilePS

-- | Initiate background file download for the given file path or URL
-- to the given location.
speculateFileOrUrl :: String -> FilePath -> IO ()
speculateFileOrUrl :: String -> String -> IO ()
speculateFileOrUrl String
fou String
out
  | String -> Bool
isHttpUrl String
fou = String -> String -> IO ()
HTTP.speculateRemote String
fou String
out
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Invoke the given action on a file that is temporarily created
-- in the current directory, and removed afterwards.
withTemp :: (FilePath -> IO a) -> IO a
withTemp :: forall a. (String -> IO a) -> IO a
withTemp = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO String
get_empty_file String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
  where
    get_empty_file :: IO String
get_empty_file = do
      (f, h) <- String -> String -> IO (String, Handle)
openBinaryTempFile String
"." String
"darcs"
      hClose h `catchall` return ()
      return f

-- | Invoke the given action on a file that is temporarily created and opened
-- in the current directory, and closed and removed afterwards.
withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a
withOpenTemp :: forall a. ((Handle, String) -> IO a) -> IO a
withOpenTemp = IO (Handle, String)
-> ((Handle, String) -> IO ())
-> ((Handle, String) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, String)
get_empty_file (Handle, String) -> IO ()
forall {p}. FilePathLike p => (Handle, p) -> IO ()
cleanup
  where
    cleanup :: (Handle, p) -> IO ()
cleanup (Handle
h, p
f) = do
      Handle -> IO ()
hClose Handle
h IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      p -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist p
f
    get_empty_file :: IO (Handle, String)
get_empty_file = (String, Handle) -> (Handle, String)
forall {b} {a}. (b, a) -> (a, b)
swap ((String, Handle) -> (Handle, String))
-> IO (String, Handle) -> IO (Handle, 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 -> IO (String, Handle)
openBinaryTempFile String
"." String
"darcs"
    swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)