1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
    2 
    3 module Darcs.Compat (stdout_is_a_pipe, mk_stdout_temp, canonFilename,
    4                maybeRelink, atomic_create, sloppy_atomic_create) where
    5 
    6 import Prelude hiding ( catch )
    7 
    8 import Darcs.Utils ( withCurrentDirectory )
    9 #ifdef WIN32
   10 import Darcs.Utils ( showHexLen )
   11 import Data.Bits ( (.&.) )
   12 import System.Random ( randomIO )
   13 #else
   14 import Foreign.C.String ( peekCString )
   15 #endif
   16 
   17 import Control.Monad ( unless )
   18 import Foreign.C.Types ( CInt )
   19 import Foreign.C.String ( CString, withCString )
   20 import Foreign.C.Error ( throwErrno, eEXIST, getErrno )
   21 import System.Directory ( getCurrentDirectory )
   22 import System.IO ( hFlush, stdout, stderr, hSetBuffering,
   23                    BufferMode(NoBuffering) )
   24 import System.IO.Error ( mkIOError, alreadyExistsErrorType )
   25 import System.Posix.Files ( stdFileMode )
   26 import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, 
   27                          dupTo, defaultFileFlags, exclusive,
   28                          OpenMode(WriteOnly) )
   29 import System.Posix.Types ( Fd(..) )
   30 
   31 import Darcs.SignalHandler ( stdout_is_a_pipe )
   32 
   33 canonFilename :: FilePath -> IO FilePath
   34 canonFilename f@(_:':':_) = return f -- absolute windows paths
   35 canonFilename f@('/':_) = return f
   36 canonFilename ('.':'/':f) = do cd <- getCurrentDirectory
   37                                return $ cd ++ "/" ++ f
   38 canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of
   39                   "" -> fmap (++('/':f)) getCurrentDirectory
   40                   rd -> withCurrentDirectory rd $
   41                           do fd <- getCurrentDirectory
   42                              return $ fd ++ "/" ++ simplefilename
   43     where
   44     simplefilename = reverse $ takeWhile (/='/') $ reverse f
   45 
   46 #ifdef WIN32
   47 mkstemp_core :: FilePath -> IO (Fd, String)
   48 mkstemp_core fp
   49  = do r <- randomIO
   50       let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))
   51       fd <- openFd fp' WriteOnly (Just stdFileMode) flags
   52       return (fd, fp')
   53   where flags = defaultFileFlags { exclusive = True }
   54 #else
   55 mkstemp_core :: String -> IO (Fd, String)
   56 mkstemp_core str = withCString (str++"XXXXXX") $
   57     \cstr -> do fd <- c_mkstemp cstr
   58                 if fd < 0
   59                   then throwErrno $ "Failed to create temporary file "++str
   60                   else do str' <- peekCString cstr
   61                           fname <- canonFilename str'
   62                           return (Fd fd, fname)
   63 
   64 foreign import ccall unsafe "static stdlib.h mkstemp"
   65     c_mkstemp :: CString -> IO CInt
   66 #endif
   67 
   68 mk_stdout_temp :: String -> IO String
   69 mk_stdout_temp str = do (fd, fn) <- mkstemp_core str
   70                         hFlush stdout
   71                         hFlush stderr
   72                         dupTo fd stdOutput
   73                         dupTo fd stdError
   74                         hFlush stdout
   75                         hFlush stderr
   76                         hSetBuffering stdout NoBuffering
   77                         hSetBuffering stderr NoBuffering
   78                         return fn
   79 
   80 
   81 
   82 foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink
   83     :: CString -> CString -> CInt -> IO CInt
   84 
   85 -- Checks whether src and dst are identical.  If so, makes dst into a
   86 -- link to src.  Returns True if dst is a link to src (either because
   87 -- we linked it or it already was).  Safe against changes to src if
   88 -- they are not in place, but not to dst.
   89 maybeRelink :: String -> String -> IO Bool
   90 maybeRelink src dst =
   91     withCString src $ \csrc ->
   92     withCString dst $ \cdst ->
   93     do rc <- maybe_relink csrc cdst 1
   94        (case rc of
   95         0 -> return True
   96         1 -> return True
   97         -1 -> throwErrno ("Relinking " ++ dst)
   98         -2 -> return False
   99         -3 -> do putStrLn ("Relinking: race condition avoided on file " ++
  100                             dst)
  101                  return False
  102         _ -> fail ("Unexpected situation when relinking " ++ dst))
  103 
  104 sloppy_atomic_create :: FilePath -> IO ()
  105 sloppy_atomic_create fp
  106     = do fd <- openFd fp WriteOnly (Just stdFileMode) flags
  107          closeFd fd
  108   where flags = defaultFileFlags { exclusive = True }
  109 
  110 atomic_create :: FilePath -> IO ()
  111 atomic_create fp = withCString fp $ \cstr -> do
  112     rc <- c_atomic_create cstr
  113     unless (rc >= 0) $
  114            do errno <- getErrno
  115               pwd <- getCurrentDirectory
  116               if errno == eEXIST
  117                  then ioError $ mkIOError alreadyExistsErrorType
  118                                           ("atomic_create in "++pwd)
  119                                           Nothing (Just fp)
  120                  else throwErrno $ "atomic_create "++fp++" in "++pwd
  121 
  122 foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create
  123     :: CString -> IO CInt