blob: a7a14411441075e5c7d3876482195d58c5b2fa7e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
{- 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
#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
|
