    -- Copyright (C) 2003 David Roundy
    --
    -- This program is free software; you can redistribute it and/or modify
    -- it under the terms of the GNU General Public License as published by
    -- the Free Software Foundation; either version 2, or (at your option)
    -- any later version.
    --
    -- This program is distributed in the hope that it will be useful,
    -- but WITHOUT ANY WARRANTY; without even the implied warranty of
    -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    -- GNU General Public License for more details.
    --
    -- You should have received a copy of the GNU General Public License
    -- along with this program; see the file COPYING.  If not, write to
    -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
    -- Boston, MA 02110-1301, USA.

    {-# LANGUAGE CPP, ForeignFunctionInterface #-}

    module Darcs.Lock ( withLock, withLockCanFail,
                  withTemp, withOpenTemp, withStdoutTemp,
                  withTempDir, withPermDir, withDelayedDir, withNamedTemp,
                  writeToFile, appendToFile,
                  writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile,
                  readBinFile, readDocBinFile,
                  writeAtomicFilePS,
                  gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,
                  rm_recursive, removeFileMayNotExist,
                  canonFilename, maybeRelink,
                  world_readable_temp, tempdir_loc,
                  editText,
                  environmentHelpTmpdir, environmentHelpKeepTmpdir
                ) where

    import Prelude hiding ( catch )
    import Data.List ( inits )
    import Data.Maybe ( isJust, listToMaybe )
    import System.Exit ( exitWith, ExitCode(..) )
    import System.IO ( openBinaryFile, openBinaryTempFile,
                       hClose, hPutStr, Handle,
                       IOMode(WriteMode, AppendMode), hFlush, stdout )
    import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )
    import Control.Exception ( bracket, catchJust, ioErrors, throwIO,
                               Exception(IOException), catch, try )
    import System.Directory ( removeFile, removeDirectory,
                       doesFileExist, doesDirectoryExist,
                       getDirectoryContents, createDirectory,
                       getTemporaryDirectory,
                     )
    import System.FilePath.Posix ( splitDirectories )
    import Workaround ( renameFile )
    import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, run_editor )
    import Control.Monad ( unless, when )

    import Darcs.URL ( is_relative )
    import Darcs.Utils ( catchall, add_to_error_loc )
    import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath,
                            getCurrentDirectory, setCurrentDirectory )

    import ByteStringUtils ( gzWriteFilePSs)
    import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString)
    import qualified Data.ByteString.Char8 as BC (unpack)

    import Darcs.SignalHandler ( withSignalsBlocked )
    import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
    import Darcs.Global ( atexit, darcsdir )
    import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink,
                    atomic_create, sloppy_atomic_create )
    import System.Posix.Files ( getSymbolicLinkStatus, isDirectory,
                                fileMode, getFileStatus, setFileMode )
    import System.Posix ( sleep )
    #include "impossible.h"

    withLock :: String -> IO a -> IO a
    releaseLock :: String -> IO ()

    withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)

    -- | Tries to perform some task if it can obtain the lock,
    -- Otherwise, just gives up without doing the task
    withLockCanFail :: String -> IO a -> IO (Either () a)
    withLockCanFail s job =
      bracket (takeLock s)
              (\l -> if l then releaseLock s else return ())
              (\l -> if l then job >>= (return.Right)
                          else return $ Left ())

    getlock :: String -> Int -> IO String
    getlock l 0 = do putStrLn $ "Couldn't get lock "++l
                     exitWith $ ExitFailure 1
    getlock lbad tl = do l <- canonFilename lbad
                         gotit <- takeLock l
                         if gotit then return l
                                  else do putStrLn $ "Waiting for lock "++l
                                          hFlush stdout -- for Windows
                                          done <- sleep 2
                                          if done == 0
                                             then getlock l (tl - 1)
                                             else getlock l 0

    removeFileMayNotExist :: FilePathLike p => p -> IO ()
    removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()

    catchNonExistence :: IO a -> a -> IO a
    catchNonExistence job nonexistval =
        catchJust ioErrors job $
        \e -> if isDoesNotExistError e then return nonexistval
                                       else ioError e

    releaseLock s = removeFileMayNotExist s

    takeLock :: FilePathLike p => p -> IO Bool
    takeLock fp =
        do atomic_create $ toFilePath fp
           return True
      `catch` \e -> case e of
                        IOException e'
                         | isAlreadyExistsError e' ->
                            return False
                        _ -> do pwd <- getCurrentDirectory
                                throwIO $ add_to_error_loc e
                                                ("takeLock "++toFilePath fp++" in "++toFilePath pwd)

    takeFile :: FilePath -> IO Bool
    takeFile fp =
        do sloppy_atomic_create fp
           return True
      `catch` \e -> case e of
                        IOException e'
                         | isAlreadyExistsError e' ->
                            return False
                        _ -> do pwd <- getCurrentDirectory
                                throwIO $ add_to_error_loc e
                                                ("takeFile "++fp++" in "++toFilePath pwd)

    -- |'withTemp' safely creates an empty file (not open for writing) and
    -- returns its name.
    --
    -- The temp file operations are rather similar to the locking operations, in
    -- that they both should always try to clean up, so exitWith causes trouble.
    withTemp :: (String -> IO a) -> IO a
    withTemp = bracket get_empty_file removeFileMayNotExist
        where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"
                                  hClose h
                                  return f

    -- |'withOpenTemp' creates an already open temporary
    -- file.  Both of them run their argument and then delete the file.  Also,
    -- both of them (to my knowledge) are not susceptible to race conditions on
    -- the temporary file (as long as you never delete the temporary file; that
    -- would reintroduce a race condition).
    withOpenTemp :: ((Handle, String) -> IO a) -> IO a
    withOpenTemp = bracket get_empty_file cleanup
        where cleanup (h,f) = do try $ hClose h
                                 removeFileMayNotExist f
              get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"
              invert (a,b) = (b,a)

    withStdoutTemp :: (String -> IO a) -> IO a
    withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist

    tempdir_loc :: IO FilePath
    tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir,
                                maybeGetEnv "DARCS_TMPDIR" >>= chkdir,
                                getTemporaryDirectory >>= chkdir . Just,
                                getCurrentDirectorySansDarcs,
                                return $ Just "."  -- always returns a Just
                              ]
                  >>= return . fromJust
        where chkdir Nothing = return Nothing
              chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing

    environmentHelpTmpdir :: ([String], [String])
    environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [
     "Darcs often creates temporary directories.  For example, the `darcs",
     "diff' command creates two for the working trees to be diffed.  By",
     "default temporary directories are created in /tmp, or if that doesn't",
     "exist, in _darcs (within the current repo).  This can be overridden by",
     "specifying some other directory in the file _darcs/prefs/tmpdir or the",
     "environment variable $DARCS_TMPDIR or $TMPDIR."])

    getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
    getCurrentDirectorySansDarcs = do
      c <- getCurrentDirectory
      return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c
      where no_darcs x = not $ darcsdir `elem` splitDirectories x

    data WithDirKind = Perm | Temp | Delayed

    withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
    withDir _ "" _ = bug "withDir called with empty directory name"
    withDir kind abs_or_relative_name job = do
      absolute_name <- if is_relative abs_or_relative_name
                       then fmap (++ abs_or_relative_name) tempdir_loc
                       else return abs_or_relative_name
      formerdir <- getCurrentDirectory
      bracket (create_directory absolute_name 0)
              (\dir -> do setCurrentDirectory formerdir
                          k <- keep_tmpdir
                          unless k $ do case kind of
                                          Perm -> return ()
                                          Temp -> rm_recursive (toFilePath dir)
                                          Delayed -> atexit $ rm_recursive (toFilePath dir))
              job
        where newname name 0 = name
              newname name n = name ++ "-" ++ show n
              create_directory :: FilePath -> Int -> IO AbsolutePath
              create_directory name n
                  = do createDirectory $ newname name n
                       setCurrentDirectory $ newname name n
                       getCurrentDirectory
                    `catch` (\e -> case e of
                                  IOException e'
                                   | isAlreadyExistsError e' ->
                                      create_directory name (n+1)
                                  _ -> throwIO e)
              keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"

    environmentHelpKeepTmpdir :: ([String], [String])
    environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[
     "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",
     "not remove the temporary directories it creates.  This is intended",
     "primarily for debugging Darcs itself, but it can also be useful, for",
     "example, to determine why your test preference (see `darcs setpref')",
     "is failing when you run `darcs record', but working when run manually."])

    -- |'withPermDir' is like 'withTempDir', except that it doesn't
    -- delete the directory afterwards.
    withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
    withPermDir = withDir Perm

    -- |'withTempDir' creates an empty directory and then removes it when it
    -- is no longer needed.  withTempDir creates a temporary directory.  The
    -- location of that directory is determined by the contents of
    -- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if
    -- that doesn't exist then whatever your operating system considers to be a
    -- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under
    -- Windows).
    --
    -- If none of those exist it creates the temporary directory
    -- in the current directory, unless the current directory is under a _darcs
    -- directory, in which case the temporary directory in the parent of the highest
    -- _darcs directory to avoid accidentally corrupting darcs's internals.
    -- This should not fail, but if it does indeed fail, we go ahead and use the
    -- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set
    -- temporary directory is not removed, this can be useful for debugging.
    withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
    withTempDir = withDir Temp

    withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a
    withDelayedDir = withDir Delayed

    doesDirectoryReallyExist :: FilePath -> IO Bool
    doesDirectoryReallyExist f =
        catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False

    rm_recursive :: FilePath -> IO ()
    rm_recursive d =
        do isd <- doesDirectoryReallyExist d
           if not isd
              then removeFile d
              else when isd $ do conts <- actual_dir_contents
                                 withCurrentDirectory d $
                                   mapM_ rm_recursive conts
                                 removeDirectory d
        where actual_dir_contents = -- doesn't include . or ..
                  do c <- getDirectoryContents d
                     return $ filter (/=".") $ filter (/="..") c

    world_readable_temp :: String -> IO String
    world_readable_temp f = wrt 0
        where wrt :: Int -> IO String
              wrt 100 = fail $ "Failure creating temp named "++f
              wrt n = let f_new = f++"-"++show n
                      in do ok <- takeFile f_new
                            if ok then return f_new
                                  else wrt (n+1)

    withNamedTemp :: String -> (String -> IO a) -> IO a
    withNamedTemp n = bracket get_empty_file removeFileMayNotExist
        where get_empty_file = world_readable_temp n

    editText :: String -> B.ByteString -> IO B.ByteString
    editText desc txt = withNamedTemp desc $ \f -> do
      B.writeFile f txt
      run_editor f
      B.readFile f

    readBinFile :: FilePathLike p => p -> IO String
    readBinFile = fmap BC.unpack . B.readFile . toFilePath

    readDocBinFile :: FilePathLike p => p -> IO Doc
    readDocBinFile fp = do ps <- B.readFile $ toFilePath fp
                           return $ if B.null ps then empty else packedString ps

    appendBinFile :: FilePathLike p => p -> String -> IO ()
    appendBinFile f s = appendToFile f $ \h -> hPutStr h s

    appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
    appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d

    writeBinFile :: FilePathLike p => p -> String -> IO ()
    writeBinFile f s = writeToFile f $ \h -> hPutStr h s

    writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
    writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d

    writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
    writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps

    gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
    gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]

    gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()
    gzWriteAtomicFilePSs f pss =
        withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do
        gzWriteFilePSs newf pss
        already_exists <- doesFileExist $ toFilePath f
        when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
                                 setFileMode newf mode
                 `catchall` return ()
        renameFile newf (toFilePath f)

    gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
    gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d

    writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
    writeToFile f job =
        withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do
        bracket (openBinaryFile newf WriteMode) hClose job
        already_exists <- doesFileExist (toFilePath f)
        when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
                                 setFileMode newf mode
                 `catchall` return ()
        renameFile newf (toFilePath f)

    appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
    appendToFile f job = withSignalsBlocked $
        bracket (openBinaryFile (toFilePath f) AppendMode) hClose job