src/Darcs/Compat.hs

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