%  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; if not, write to the Free Software Foundation,
%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

\begin{code}
module Lock ( withLock,
              withTemp, withOpenTemp, withStdoutTemp,
              withTempDir, withPermDir, withNamedTemp,
              writeToFile, appendToFile,
              writeBinFile, appendBinFile, readBinFile,
              writeAtomicFilePS,
              rm_recursive,
              canonFilename,
            ) where

import Prelude hiding ( catch )
import Monad ( liftM )
import System ( exitWith, ExitCode(..), getEnv )
import IO hiding ( bracket )
import System.IO ( openBinaryFile )
import Control.Exception ( bracket, catchJust, ioErrors, block, finally )
import GHC.Handle ( openFd, hSetBinaryMode )
import Directory ( setCurrentDirectory, removeFile, removeDirectory,
                   doesFileExist, doesDirectoryExist,
                   getDirectoryContents, createDirectory,
                 )
import Workaround ( renameFile, getCurrentDirectory )
import DarcsUtils ( withCurrentDirectory )
import Foreign
import Foreign.C ( withCString, CString, peekCString,
                   throwErrno, getErrno, eEXIST )
import Monad ( when )
import Workaround ( fileMode, getFileStatus, setFileMode, )

import DarcsURL ( is_relative )
import DarcsUtils ( catchall )
import FastPackedString ( PackedString, hPutPS, readFilePS, unpackPS )

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

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

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
                                      done <- sleep 2
                                      if done == 0
                                         then getlock l (tl - 1)
                                         else getlock l 0

foreign import ccall unsafe "unistd.h sleep" sleep
    :: Int -> IO Int

removeFileMayNotExist :: FilePath -> IO ()
removeFileMayNotExist f = catchJust ioErrors (removeFile f) $
                          \e -> if isDoesNotExistError e then return ()
                                                         else ioError e

releaseLock s = removeFileMayNotExist s

takeLock s = withCString s $ \cstr -> do
    rc <- c_atomic_create cstr
    if rc >= 0 then return True
               else do errno <- getErrno
                       if errno == eEXIST then return False
                                          else throwErrno $ "takeLock "++s

foreign import ccall unsafe "compat.h atomic_create" c_atomic_create
    :: CString -> IO Int

canonFilename :: FilePath -> IO FilePath
canonFilename f@(_:':':_) = return f -- absolute windows paths
canonFilename f@('/':_) = return f
canonFilename ('.':'/':f) = do cd <- getCurrentDirectory
                               return $ cd ++ "/" ++ f
canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of
                  "" -> liftM (++('/':f)) getCurrentDirectory
                  rd -> withCurrentDirectory rd $
                          do fd <- getCurrentDirectory
                             return $ fd ++ "/" ++ simplefilename
    where
    simplefilename = reverse $ takeWhile (/='/') $ reverse f
\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

mk_stdout_temp :: String -> IO String
mk_stdout_temp str = withCString (str++"XXXXXX") $
    \cstr -> do fd <- c_mkstemp cstr
                if fd < 0
                  then throwErrno $ "Failed to create temporary file "++str
                  else do str' <- peekCString cstr
                          fname <- canonFilename str'
                          hFlush stdout
                          hFlush stderr
                          c_dup2 fd 1
                          c_dup2 fd 2
                          hFlush stdout
                          hFlush stderr
                          hSetBuffering stdout NoBuffering
                          hSetBuffering stderr NoBuffering
                          return fname

mkstemp :: String -> IO (Handle, String)
mkstemp str = withCString (str++"XXXXXX") $
    \cstr -> do fd <- c_mkstemp cstr
                if fd < 0
                  then throwErrno $ "Failed to create temporary file "++str
                  else do str' <- peekCString cstr
                          fname <- canonFilename str'
                          h <- openFd fd Nothing fname ReadWriteMode True False
                          hSetBinaryMode h True
                          return (h, fname)

foreign import ccall unsafe "static unistd.h dup2" c_dup2 :: Int -> Int -> IO Int
foreign import ccall unsafe "static stdlib.h mkstemp" c_mkstemp :: CString -> IO Int
\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 a the temporary directory in the current directory.  So
you'd better not call it while in \verb!_darcs/current!...

\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

withDir :: Bool -> String -> (String -> IO a) -> IO a
withDir perm abs_or_relative_name job = do
  absolute_name <- liftM (\t ->
                          if is_relative abs_or_relative_name
                          then t ++ abs_or_relative_name
                          else abs_or_relative_name)
                   tempdir_loc
  formerdir <- getCurrentDirectory
  bracket (create_directory absolute_name 0)
          (if perm then (\_ -> setCurrentDirectory formerdir)
                   else (remove_directory formerdir))
          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
                `IO.catch` (\e -> if isAlreadyExistsError e
                            then create_directory name (n+1)
                            else ioError 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 True

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

foreign import ccall unsafe "static compat.h isnt_symlink" isnt_symlink
    :: CString -> IO Int

doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = do
    fe <- doesDirectoryExist f
    if not fe then return False
       else withCString f $ \cf-> (0/=) `liftM` isnt_symlink cf

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 <- takeLock $ 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

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

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

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

writeToFile :: FilePath -> (Handle -> IO ()) -> IO ()
writeToFile f job =
    block $ 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 = block $ do
    h <- openBinaryFile f AppendMode
    job h
    hClose h
\end{code}