{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Darcs.Util.Compat
( stdoutIsAPipe
, canonFilename
, maybeRelink
, atomicCreate
, sloppyAtomicCreate
) where
import Darcs.Prelude
import Darcs.Util.File ( withCurrentDirectory )
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,
defaultFileFlags, exclusive,
OpenMode(WriteOnly) )
import Darcs.Util.SignalHandler ( stdoutIsAPipe )
canonFilename :: FilePath -> IO FilePath
canonFilename :: [Char] -> IO [Char]
canonFilename f :: [Char]
f@(Char
_:Char
':':[Char]
_) = [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
f
canonFilename f :: [Char]
f@(Char
'/':[Char]
_) = [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
f
canonFilename (Char
'.':Char
'/':[Char]
f) = do [Char]
cd <- IO [Char]
getCurrentDirectory
[Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
cd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f
canonFilename [Char]
f = case [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
f of
[Char]
"" -> ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Char
'/'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
f)) IO [Char]
getCurrentDirectory
[Char]
rd -> [Char] -> IO [Char] -> IO [Char]
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory [Char]
rd (IO [Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$
do [Char]
fd <- IO [Char]
getCurrentDirectory
[Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
fd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
simplefilename
where
simplefilename :: [Char]
simplefilename = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
f
foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink
:: CString -> CString -> CInt -> IO CInt
maybeRelink :: String -> String -> IO Bool
maybeRelink :: [Char] -> [Char] -> IO Bool
maybeRelink [Char]
src [Char]
dst =
[Char] -> (CString -> IO Bool) -> IO Bool
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
src ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
csrc ->
[Char] -> (CString -> IO Bool) -> IO Bool
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
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 -> [Char] -> IO Bool
forall a. [Char] -> IO a
throwErrno ([Char]
"Relinking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dst)
-2 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
-3 -> do [Char] -> IO ()
putStrLn ([Char]
"Relinking: race condition avoided on file " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
dst)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
CInt
_ -> [Char] -> IO Bool
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unexpected situation when relinking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dst)
sloppyAtomicCreate :: FilePath -> IO ()
sloppyAtomicCreate :: [Char] -> IO ()
sloppyAtomicCreate [Char]
fp
= do Fd
fd <- [Char] -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd [Char]
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 :: [Char] -> IO ()
atomicCreate [Char]
fp = [Char] -> (CString -> IO ()) -> IO ()
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
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
[Char]
pwd <- IO [Char]
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 -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
alreadyExistsErrorType
([Char]
"atomicCreate in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
pwd)
Maybe Handle
forall a. Maybe a
Nothing ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
fp)
else [Char] -> IO ()
forall a. [Char] -> IO a
throwErrno ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"atomicCreate "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
fp[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
pwd
foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create
:: CString -> IO CInt