{-# LANGUAGE CPP, ForeignFunctionInterface #-}

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

import Prelude ()
import Darcs.Prelude

import Darcs.Util.File ( withCurrentDirectory )
#ifdef WIN32
import Data.Bits ( (.&.) )
import System.Random ( randomIO )
import Numeric ( showHex )
#else
#endif

import Control.Monad ( unless )
import Foreign.C.Types ( CInt(..) )
import Foreign.C.String ( CString, withCString
#ifndef WIN32
                        , peekCString
#endif
                        )

import Foreign.C.Error ( throwErrno, eEXIST, getErrno )
import System.Directory ( getCurrentDirectory )
import System.IO ( hFlush, stdout, stderr, hSetBuffering,
                   BufferMode(NoBuffering) )
import System.IO.Error ( mkIOError, alreadyExistsErrorType )
import System.Posix.Files ( stdFileMode )
import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,
                         dupTo, defaultFileFlags, exclusive,
                         OpenMode(WriteOnly) )
import System.Posix.Types ( Fd(..) )

import Darcs.Util.SignalHandler ( stdoutIsAPipe )

canonFilename :: FilePath -> IO FilePath
canonFilename :: FilePath -> IO FilePath
canonFilename f :: FilePath
f@(_:':':_) = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f -- absolute windows paths
canonFilename f :: FilePath
f@('/':_) = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
canonFilename ('.':'/':f :: FilePath
f) = do FilePath
cd <- IO FilePath
getCurrentDirectory
                               FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
cd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f
canonFilename f :: FilePath
f = case FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='/') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
f of
                  "" -> (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++('/'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
f)) IO FilePath
getCurrentDirectory
                  rd :: FilePath
rd -> FilePath -> IO FilePath -> IO FilePath
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
rd (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
                          do FilePath
fd <- IO FilePath
getCurrentDirectory
                             FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
fd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
simplefilename
    where
    simplefilename :: FilePath
simplefilename = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='/') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
f

#ifdef WIN32
mkstempCore :: FilePath -> IO (Fd, String)
mkstempCore fp
 = do r <- randomIO
      let fp' = fp ++ showHexLen 6 (r .&. 0xFFFFFF :: Int)
      fd <- openFd fp' WriteOnly (Just stdFileMode) flags
      return (fd, fp')
  where flags = defaultFileFlags { exclusive = True }

showHexLen :: (Integral a, Show a)
           => Int
           -> a
           -> String
showHexLen n x = let s = showHex x ""
                 in replicate (n - length s) ' ' ++ s
#else
mkstempCore :: String -> IO (Fd, String)
mkstempCore :: FilePath -> IO (Fd, FilePath)
mkstempCore str :: FilePath
str = FilePath -> (CString -> IO (Fd, FilePath)) -> IO (Fd, FilePath)
forall a. FilePath -> (CString -> IO a) -> IO a
withCString (FilePath
strFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"XXXXXX") ((CString -> IO (Fd, FilePath)) -> IO (Fd, FilePath))
-> (CString -> IO (Fd, FilePath)) -> IO (Fd, FilePath)
forall a b. (a -> b) -> a -> b
$
    \cstr :: CString
cstr -> do CInt
fd <- CString -> IO CInt
c_mkstemp CString
cstr
                if CInt
fd CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0
                  then FilePath -> IO (Fd, FilePath)
forall a. FilePath -> IO a
throwErrno (FilePath -> IO (Fd, FilePath)) -> FilePath -> IO (Fd, FilePath)
forall a b. (a -> b) -> a -> b
$ "Failed to create temporary file "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
str
                  else do FilePath
str' <- CString -> IO FilePath
peekCString CString
cstr
                          FilePath
fname <- FilePath -> IO FilePath
canonFilename FilePath
str'
                          (Fd, FilePath) -> IO (Fd, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Fd
Fd CInt
fd, FilePath
fname)

foreign import ccall unsafe "static stdlib.h mkstemp"
    c_mkstemp :: CString -> IO CInt
#endif

mkStdoutTemp :: String -> IO String
mkStdoutTemp :: FilePath -> IO FilePath
mkStdoutTemp str :: FilePath
str =   do (fd :: Fd
fd, fn :: FilePath
fn) <- FilePath -> IO (Fd, FilePath)
mkstempCore FilePath
str
                        Handle -> IO ()
hFlush Handle
stdout
                        Handle -> IO ()
hFlush Handle
stderr
                        Fd
_ <- Fd -> Fd -> IO Fd
dupTo Fd
fd Fd
stdOutput
                        Fd
_ <- Fd -> Fd -> IO Fd
dupTo Fd
fd Fd
stdError
                        Handle -> IO ()
hFlush Handle
stdout
                        Handle -> IO ()
hFlush Handle
stderr
                        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
                        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
NoBuffering
                        FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fn



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 :: FilePath -> FilePath -> IO Bool
maybeRelink src :: FilePath
src dst :: FilePath
dst =
    FilePath -> (CString -> IO Bool) -> IO Bool
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
src ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \csrc :: CString
csrc ->
    FilePath -> (CString -> IO Bool) -> IO Bool
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
dst ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \cdst :: CString
cdst ->
    do CInt
rc <- CString -> CString -> CInt -> IO CInt
maybe_relink CString
csrc CString
cdst 1
       case CInt
rc of
        0 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        1 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        -1 -> FilePath -> IO Bool
forall a. FilePath -> IO a
throwErrno ("Relinking " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dst)
        -2 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -3 -> do FilePath -> IO ()
putStrLn ("Relinking: race condition avoided on file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                            FilePath
dst)
                 Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        _ -> FilePath -> IO Bool
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail ("Unexpected situation when relinking " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dst)

sloppyAtomicCreate :: FilePath -> IO ()
sloppyAtomicCreate :: FilePath -> IO ()
sloppyAtomicCreate fp :: FilePath
fp
    = do Fd
fd <- FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
fp OpenMode
WriteOnly (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just FileMode
stdFileMode) OpenFileFlags
flags
         Fd -> IO ()
closeFd Fd
fd
  where flags :: OpenFileFlags
flags = OpenFileFlags
defaultFileFlags { exclusive :: Bool
exclusive = Bool
True }

atomicCreate :: FilePath -> IO ()
atomicCreate :: FilePath -> IO ()
atomicCreate fp :: FilePath
fp = FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
fp ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cstr :: 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
>= 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           do Errno
errno <- IO Errno
getErrno
              FilePath
pwd <- IO FilePath
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
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
alreadyExistsErrorType
                                          ("atomicCreate in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
pwd)
                                          Maybe Handle
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp)
                 else FilePath -> IO ()
forall a. FilePath -> IO a
throwErrno (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "atomicCreate "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
fpFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++" in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
pwd

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