1{- git lock files 2 - 3 - Copyright 2016 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP #-} 9 10module Git.LockFile where 11 12import Common 13 14#ifndef mingw32_HOST_OS 15import System.Posix.Types 16import System.Posix.IO 17#else 18import System.Win32.Types 19import System.Win32.File 20#endif 21 22#ifndef mingw32_HOST_OS 23data LockHandle = LockHandle FilePath Fd 24#else 25data LockHandle = LockHandle FilePath HANDLE 26#endif 27 28{- Uses the same exclusive locking that git does. 29 - Throws an IO exception if the file is already locked. 30 - 31 - Note that git's locking method suffers from the problem that 32 - a dangling lock can be left if a process is terminated at the wrong 33 - time. 34 -} 35openLock :: FilePath -> IO LockHandle 36openLock lck = openLock' lck `catchNonAsync` lckerr 37 where 38 lckerr e = do 39 -- Same error message displayed by git. 40 whenM (doesFileExist lck) $ 41 hPutStrLn stderr $ unlines 42 [ "fatal: Unable to create '" ++ lck ++ "': " ++ show e 43 , "" 44 , "If no other git process is currently running, this probably means a" 45 , "git process crashed in this repository earlier. Make sure no other git" 46 , "process is running and remove the file manually to continue." 47 ] 48 throwM e 49 50openLock' :: FilePath -> IO LockHandle 51openLock' lck = do 52#ifndef mingw32_HOST_OS 53 -- On unix, git simply uses O_EXCL 54 h <- openFd lck ReadWrite (Just 0O666) 55 (defaultFileFlags { exclusive = True }) 56 setFdOption h CloseOnExec True 57#else 58 -- It's not entirely clear how git manages locking on Windows, 59 -- since it's buried in the portability layer, and different 60 -- versions of git for windows use different portability layers. 61 -- But, we can be fairly sure that holding the lock file open on 62 -- windows is enough to prevent another process from opening it. 63 -- 64 -- So, all that's needed is a way to open the file, that fails 65 -- if the file already exists. Using CreateFile with CREATE_NEW 66 -- accomplishes that. 67 h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing 68 cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing 69#endif 70 return (LockHandle lck h) 71 72closeLock :: LockHandle -> IO () 73closeLock (LockHandle lck h) = do 74#ifndef mingw32_HOST_OS 75 closeFd h 76#else 77 closeHandle h 78#endif 79 removeFile lck 80