25703e1413
Fourth or fifth try at this and finally found a way to make it work. Absurd amount of busy-work forced on me by change in cabal's behavior. Split up Utility modules that need posix stuff out of ones used by Setup. Various other hacks around inability for Setup to use anything that ifdefs a use of unix. Probably lost a full day of my life to this. This is how build systems make their users hate them. Just saying.
79 lines
2.2 KiB
Haskell
79 lines
2.2 KiB
Haskell
{- git lock files
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Git.LockFile where
|
|
|
|
import Common
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
import System.Posix.Types
|
|
import System.Posix.IO
|
|
#else
|
|
import System.Win32.Types
|
|
import System.Win32.File
|
|
#endif
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
data LockHandle = LockHandle FilePath Fd
|
|
#else
|
|
data LockHandle = LockHandle FilePath HANDLE
|
|
#endif
|
|
|
|
{- Uses the same exclusive locking that git does.
|
|
- Throws an IO exception if the file is already locked.
|
|
-
|
|
- Note that git's locking method suffers from the problem that
|
|
- a dangling lock can be left if a process is terminated at the wrong
|
|
- time.
|
|
-}
|
|
openLock :: FilePath -> IO LockHandle
|
|
openLock lck = openLock' lck `catchNonAsync` lckerr
|
|
where
|
|
lckerr e = do
|
|
-- Same error message displayed by git.
|
|
whenM (doesFileExist lck) $
|
|
hPutStrLn stderr $ unlines
|
|
[ "fatal: Unable to create '" ++ lck ++ "': " ++ show e
|
|
, ""
|
|
, "If no other git process is currently running, this probably means a"
|
|
, "git process crashed in this repository earlier. Make sure no other git"
|
|
, "process is running and remove the file manually to continue."
|
|
]
|
|
throwM e
|
|
|
|
openLock' :: FilePath -> IO LockHandle
|
|
openLock' lck = do
|
|
#ifndef mingw32_HOST_OS
|
|
-- On unix, git simply uses O_EXCL
|
|
h <- openFd lck ReadWrite (Just 0O666)
|
|
(defaultFileFlags { exclusive = True })
|
|
setFdOption h CloseOnExec True
|
|
#else
|
|
-- It's not entirely clear how git manages locking on Windows,
|
|
-- since it's buried in the portability layer, and different
|
|
-- versions of git for windows use different portability layers.
|
|
-- But, we can be fairly sure that holding the lock file open on
|
|
-- windows is enough to prevent another process from opening it.
|
|
--
|
|
-- So, all that's needed is a way to open the file, that fails
|
|
-- if the file already exists. Using CreateFile with CREATE_NEW
|
|
-- accomplishes that.
|
|
h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing
|
|
cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing
|
|
#endif
|
|
return (LockHandle lck h)
|
|
|
|
closeLock :: LockHandle -> IO ()
|
|
closeLock (LockHandle lck h) = do
|
|
#ifndef mingw32_HOST_OS
|
|
closeFd h
|
|
#else
|
|
closeHandle h
|
|
#endif
|
|
removeFile lck
|