{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module Darcs.Util.Compat
    ( stdoutIsAPipe
    , maybeRelink
    , atomicCreate
    , sloppyAtomicCreate
    ) where

#ifdef WIN32
#define USE_CREAT
#else
#if MIN_VERSION_unix(2,8,0)
#define USE_CREAT
#endif
#endif

import Darcs.Prelude

import Control.Monad ( unless )
import Foreign.C.Types ( CInt(..) )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno, eEXIST, getErrno )
import System.Directory ( getCurrentDirectory )
import System.IO.Error ( mkIOError, alreadyExistsErrorType )
import System.Posix.Files ( stdFileMode )
import System.Posix.IO ( openFd, closeFd,
#ifdef USE_CREAT
                         creat,
#endif
                         defaultFileFlags, exclusive,
                         OpenMode(WriteOnly) )

import Darcs.Util.SignalHandler ( stdoutIsAPipe )

foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink
    :: CString -> CString -> CInt -> IO CInt

-- Checks whether src and dst are identical.  If so, makes dst into a
-- link to src.  Returns True if dst is a link to src (either because
-- we linked it or it already was).  Safe against changes to src if
-- they are not in place, but not to dst.
maybeRelink :: String -> String -> IO Bool
maybeRelink :: String -> String -> IO Bool
maybeRelink String
src String
dst =
    String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
src ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
csrc ->
    String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
dst ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
cdst ->
    do CInt
rc <- CString -> CString -> CInt -> IO CInt
maybe_relink CString
csrc CString
cdst CInt
1
       case CInt
rc of
        CInt
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        CInt
1 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        -1 -> String -> IO Bool
forall a. String -> IO a
throwErrno (String
"Relinking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dst)
        -2 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -3 -> do String -> IO ()
putStrLn (String
"Relinking: race condition avoided on file " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
dst)
                 Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        CInt
_ -> String -> IO Bool
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected situation when relinking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dst)

sloppyAtomicCreate :: FilePath -> IO ()
sloppyAtomicCreate :: String -> IO ()
sloppyAtomicCreate String
fp
#ifdef USE_CREAT
    = do Fd
fd <- String -> OpenMode -> OpenFileFlags -> IO Fd
openFd String
fp OpenMode
WriteOnly OpenFileFlags
flags {creat = Just stdFileMode}
#else
    = do fd <- openFd fp WriteOnly (Just stdFileMode) flags
#endif
         Fd -> IO ()
closeFd Fd
fd
  where flags :: OpenFileFlags
flags = OpenFileFlags
defaultFileFlags { exclusive = True }

atomicCreate :: FilePath -> IO ()
atomicCreate :: String -> IO ()
atomicCreate String
fp = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
fp ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
    CInt
rc <- CString -> IO CInt
c_atomic_create CString
cstr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
>= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           do Errno
errno <- IO Errno
getErrno
              String
pwd <- IO String
getCurrentDirectory
              if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eEXIST
                 then IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
alreadyExistsErrorType
                                          (String
"atomicCreate in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pwd)
                                          Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
                 else String -> IO ()
forall a. String -> IO a
throwErrno (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"atomicCreate "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pwd

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