%  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.


\begin{code}
{-# OPTIONS -fffi #-}
module Lock ( withLock, withLockCanFail,
              withTemp, withOpenTemp, withStdoutTemp,
              withTempDir, withPermDir, withDelayedDir, withNamedTemp,
              writeToFile, appendToFile,
              writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile,
              readBinFile, readDocBinFile,
              writeAtomicFilePS,
              gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,
              rm_recursive,
              canonFilename, maybeRelink,
              world_readable_temp, tempdir_loc,
              takeLock, releaseLock,
            ) where

import Prelude hiding ( catch )
import Monad ( liftM )
import System ( exitWith, ExitCode(..), getEnv )
import System.IO ( openBinaryFile, hClose, hPutStr, Handle,
                   IOMode(WriteMode, AppendMode), hFlush, stdout )
import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )
import Control.Exception ( bracket, catchJust, ioErrors, finally, throwIO,
                           Exception(IOException), catch, try )
import Directory ( setCurrentDirectory, removeFile, removeDirectory,
                   doesFileExist, doesDirectoryExist,
                   getDirectoryContents, createDirectory,
                 )
import Workaround ( renameFile, getCurrentDirectory )
import DarcsUtils ( withCurrentDirectory )
import Monad ( when )
import Workaround ( fileMode, getFileStatus, setFileMode )

import DarcsURL ( is_relative )
import DarcsUtils ( catchall, add_to_error_loc )
import FastPackedString ( PackedString, hPutPS, readFilePS, unpackPS,
                          gzWriteFilePSs, nullPS,
                        )
import SignalHandler ( withSignalsBlocked )
import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import Global ( atexit )
import Compat ( mkstemp, mk_stdout_temp, canonFilename, maybeRelink,
                atomic_create, sloppy_atomic_create )
import System.Posix.Files ( getSymbolicLinkStatus, isDirectory )
import System.Posix ( sleep )

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 :: FilePath -> IO ()
removeFileMayNotExist f = catchNonExistence (removeFile f) ()

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

-- | Note that this is exported only for use by Gui code
-- Most likely, you want 'withLock' instead
releaseLock s = removeFileMayNotExist s

-- | Note that this is exported only for use by Gui code
-- Most likely, you want 'withLock' instead
takeLock :: FilePath -> IO Bool
takeLock fp =
    do 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
                                            ("takeLock "++fp++" in "++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 "++pwd)
\end{code}

\verb!withTemp! safely creates an empty file (not open for writing) and
returns its name.  \verb!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).

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.

\begin{code}
withTemp :: (String -> IO a) -> IO a
withTemp = bracket get_empty_file removeFileMayNotExist
    where get_empty_file = do (h,f) <- mkstemp "darcs"
                              hClose h
                              return f

withOpenTemp :: ((Handle, String) -> IO a) -> IO a
withOpenTemp = bracket (mkstemp "darcs") cleanup
    where cleanup (h,f) = do try $ hClose h
                             removeFileMayNotExist f

withStdoutTemp :: (String -> IO a) -> IO a
withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist
\end{code}

\verb!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 \verb!$DARCS_TMPDIR!, and if
that doesn't exist then \verb!$TMPDIR!, and if that doesn't exist, then
\verb!\tmp!.  Finally, if none of those exist (as may be the case under
windows) it creates the temporary directory in the current directory.  So
you'd better not call it while in \verb!_darcs/current!\ldots

\verb!withPermDir! is like \verb!withTempDir!, except that it doesn't
delete the directory afterwards.

\begin{code}
tempdir_loc :: IO FilePath
tempdir_loc = do td <- ((head . words) `liftM` readBinFile "_darcs/prefs/tmpdir")
                       `catchall` resort_to_environment
                 try_directory td resort_to_environment
    where resort_to_environment = look_for_tmp ["DARCS_TMPDIR", "TMPDIR"]
          look_for_tmp (p:ps) = do t <- getEnv p
                                   try_directory t $ look_for_tmp ps
                                `catchall` look_for_tmp ps
          look_for_tmp [] = try_directory "/tmp" $ return ""
          try_directory d backup_plan = do exist <- doesDirectoryExist d
                                           if exist then return $ d++"/"
                                                    else backup_plan

data WithDirKind = Perm | Temp | Delayed

withDir :: WithDirKind -> String -> (String -> IO a) -> IO a
withDir kind abs_or_relative_name job = do
  absolute_name <- if is_relative abs_or_relative_name
                   then liftM (++ abs_or_relative_name) tempdir_loc
                   else return abs_or_relative_name
  formerdir <- getCurrentDirectory
  bracket (create_directory absolute_name 0)
          (case kind of
               Perm -> (\_ -> setCurrentDirectory formerdir)
               Temp -> remove_directory formerdir
               Delayed -> (\dir -> do setCurrentDirectory formerdir
                                      atexit (rm_recursive dir)))
          job
    where newname name 0 = name
          newname name n = name ++ "-" ++ show n
          create_directory :: FilePath -> Int -> IO FilePath
          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)
          remove_directory f d = do
              setCurrentDirectory f
              still_here <- doesDirectoryReallyExist d
              when still_here $
                   rm_recursive d `finally` setCurrentDirectory f

withPermDir :: String -> (String -> IO a) -> IO a
withPermDir = withDir Perm

withTempDir :: String -> (String -> IO a) -> IO a
withTempDir = withDir Temp

withDelayedDir :: String -> (String -> 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 $
                               (sequence_ $ map rm_recursive conts)
                             removeDirectory d
    where actual_dir_contents = -- doesn't include . or ..
              do c <- getDirectoryContents d
                 return $ filter (/=".") $ filter (/="..") c
\end{code}

\begin{code}
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 = do ok <- takeFile $ f++"-"++show n
                     if ok then return $ f++"-"++show n
                           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

readBinFile :: FilePath -> IO String
readBinFile = liftM unpackPS . readFilePS

readDocBinFile :: FilePath -> IO Doc
readDocBinFile fp = do ps <- readFilePS fp
                       return $ if nullPS ps then empty else packedString ps

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

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

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

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

writeAtomicFilePS :: FilePath -> PackedString -> IO ()
writeAtomicFilePS f ps = writeToFile f $ \h -> hPutPS h ps

gzWriteAtomicFilePS :: FilePath -> PackedString -> IO ()
gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]

gzWriteAtomicFilePSs :: FilePath -> [PackedString] -> IO ()
gzWriteAtomicFilePSs f pss =
    withSignalsBlocked $ withNamedTemp f $ \newf -> do
    gzWriteFilePSs newf pss
    already_exists <- doesFileExist f
    when already_exists $ do mode <- fileMode `liftM` getFileStatus f
                             setFileMode newf mode
             `catchall` return ()
    renameFile newf f

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

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

appendToFile :: FilePath -> (Handle -> IO ()) -> IO ()
appendToFile f job = withSignalsBlocked $ do
    h <- openBinaryFile f AppendMode
    job h
    hClose h
\end{code}