%  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_GHC -cpp -fffi #-}
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,
            ) where

import Prelude hiding ( catch )
import Control.Monad ( liftM )
import Data.List ( inits )
import Data.Maybe ( 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, finally, throwIO,
                           Exception(IOException), catch, try )
import System.Directory ( setCurrentDirectory, removeFile, removeDirectory,
                   doesFileExist, doesDirectoryExist,
                   getDirectoryContents, createDirectory,
                   getTemporaryDirectory,
                 )
import Workaround ( renameFile, getCurrentDirectory )
import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO )
import Control.Monad ( when )
import Workaround ( fileMode, getFileStatus, setFileMode )

import Darcs.URL ( is_relative )
import Darcs.Utils ( catchall, add_to_error_loc )
import FastPackedString ( PackedString, hPutPS, readFilePS, unpackPS,
                          gzWriteFilePSs, nullPS,
                        )
import Darcs.SignalHandler ( withSignalsBlocked )
import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import FileName ( breakup )
import Darcs.Global ( atexit, darcsdir )
import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink,
                atomic_create, sloppy_atomic_create )
import System.Posix.Files ( getSymbolicLinkStatus, isDirectory )
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 :: 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

releaseLock s = removeFileMayNotExist s

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 (f,h) <- openBinaryTempFile "." "darcs"
                              hClose h
                              return f

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
\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 whatever your operating system considers to be a
a temporary directory (e.g. \verb!$TMPDIR! under Unix, \verb!$TEMP! under
Windows).
If none of those exist it creates the temporary directory
in the current directory, unless the current directory is under a \verb!_darcs!
directory, in which case the temporary directory in the parent of the highest
\verb!_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.

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

\begin{code}
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
                                                         
getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs = do
  c <- getCurrentDirectory
  return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits c
  where no_darcs x = not $ darcsdir `elem` breakup x

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}