{-# LANGUAGE CPP #-} module General.FileLock(withLockFile) where import Control.Exception.Extra import System.FilePath import General.Extra #ifdef mingw32_HOST_OS import Data.Bits import Data.Word import Foreign.Ptr import Foreign.C.Types import Foreign.C.String #else import System.IO import System.Posix.IO #endif #ifdef mingw32_HOST_OS #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else #define CALLCONV stdcall #endif foreign import CALLCONV unsafe "Windows.h CreateFileW" c_CreateFileW :: Ptr CWchar -> Word32 -> Word32 -> Ptr () -> Word32 -> Word32 -> Ptr () -> IO (Ptr ()) foreign import CALLCONV unsafe "Windows.h CloseHandle" c_CloseHandle :: Ptr () -> IO Bool foreign import CALLCONV unsafe "Windows.h GetLastError" c_GetLastError :: IO Word32 c_GENERIC_WRITE = 0x40000000 :: Word32 c_GENERIC_READ = 0x80000000 :: Word32 c_FILE_SHARE_NONE = 0 :: Word32 c_OPEN_ALWAYS = 4 :: Word32 c_FILE_ATTRIBUTE_NORMAL = 0x80 :: Word32 c_INVALID_HANDLE_VALUE = intPtrToPtr (-1) c_ERROR_SHARING_VIOLATION = 32 #endif withLockFile :: FilePath -> IO a -> IO a #ifdef mingw32_HOST_OS withLockFile file act = withCWString file $ \cfile -> do createDirectoryRecursive $ takeDirectory file let open = c_CreateFileW cfile (c_GENERIC_READ .|. c_GENERIC_WRITE) c_FILE_SHARE_NONE nullPtr c_OPEN_ALWAYS c_FILE_ATTRIBUTE_NORMAL nullPtr bracket open c_CloseHandle $ \h -> if h == c_INVALID_HANDLE_VALUE then do err <- c_GetLastError errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" ++ (if err == c_ERROR_SHARING_VIOLATION then "ERROR_SHARING_VIOLATION - Shake is probably already running." else "Code " ++ show err ++ ", unknown reason for failure.") else act #else withLockFile :: FilePath -> IO a -> IO a withLockFile file :: FilePath file act :: IO a act = do FilePath -> IO () createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO () forall a b. (a -> b) -> a -> b $ FilePath -> FilePath takeDirectory FilePath file IO () -> IO (Either IOException ()) forall a. IO a -> IO (Either IOException a) tryIO (IO () -> IO (Either IOException ())) -> IO () -> IO (Either IOException ()) forall a b. (a -> b) -> a -> b $ FilePath -> FilePath -> IO () writeFile FilePath file "" IO Fd -> (Fd -> IO ()) -> (Fd -> IO a) -> IO a forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket (FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd openFd FilePath file OpenMode ReadWrite Maybe FileMode forall a. Maybe a Nothing OpenFileFlags defaultFileFlags) Fd -> IO () closeFd ((Fd -> IO a) -> IO a) -> (Fd -> IO a) -> IO a forall a b. (a -> b) -> a -> b $ \fd :: Fd fd -> do let lock :: (LockRequest, SeekMode, FileOffset, FileOffset) lock = (LockRequest WriteLock, SeekMode AbsoluteSeek, 0, 0) Either IOException () res <- IO () -> IO (Either IOException ()) forall a. IO a -> IO (Either IOException a) tryIO (IO () -> IO (Either IOException ())) -> IO () -> IO (Either IOException ()) forall a b. (a -> b) -> a -> b $ Fd -> (LockRequest, SeekMode, FileOffset, FileOffset) -> IO () setLock Fd fd (LockRequest, SeekMode, FileOffset, FileOffset) lock case Either IOException () res of Right () -> IO a act Left e :: IOException e -> do Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset)) res <- Fd -> (LockRequest, SeekMode, FileOffset, FileOffset) -> IO (Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset))) getLock Fd fd (LockRequest, SeekMode, FileOffset, FileOffset) lock FilePath -> IO a forall a. Partial => FilePath -> IO a errorIO (FilePath -> IO a) -> FilePath -> IO a forall a b. (a -> b) -> a -> b $ "Shake failed to acquire a file lock on " FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ FilePath file FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ "\n" FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ (case Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset)) res of Nothing -> "" Just (pid :: ProcessID pid, _) -> "Shake process ID " FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ ProcessID -> FilePath forall a. Show a => a -> FilePath show ProcessID pid FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ " is using this lock.\n") FilePath -> FilePath -> FilePath forall a. [a] -> [a] -> [a] ++ IOException -> FilePath forall a. Show a => a -> FilePath show IOException e #endif