git.iko.soy/project-m36
on 19798be help sign in
project-m36/src/lib/ProjectM36/FileLock.hs
98 lines 3.2 kB history raw
1{-# LANGUAGE CPP, NamedFieldPuns #-}
2--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking
3--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite
4module ProjectM36.FileLock where
7#if defined(mingw32_HOST_OS)
8import System.Win32.Types
9import Foreign.Marshal.Alloc
10import System.Win32.File
11import System.Win32.Mem
12import Data.Bits
14#if defined(i386_HOST_ARCH)
15# define WINDOWS_CCONV stdcall
16#elif defined(x86_64_HOST_ARCH)
17# define WINDOWS_CCONV ccall
18#else
19# error Unknown mingw32 arch
20#endif
21foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
23foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
25type LockFile = HANDLE
27openLockFile :: FilePath -> IO LockFile
28openLockFile path = createFile path
29 (gENERIC_READ .|. gENERIC_WRITE)
30 (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
31 Nothing
32 oPEN_ALWAYS
33 fILE_ATTRIBUTE_NORMAL
34 Nothing
36closeLockFile :: LockFile -> IO ()
37closeLockFile file = do
38 unlockFile file
39 closeHandle file
41--swiped from System.FileLock package
42lockFile :: HANDLE -> LockType -> IO ()
43lockFile winHandle lock = do
44 let exFlag = case lock of
45 WriteLock -> 2
46 ReadLock -> 0
47 blockFlag = 0 --always block
48 sizeof_OVERLAPPED = 32
50 allocaBytes sizeof_OVERLAPPED $ \op -> do
51 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
52 failIfFalse_ "LockFileEx" $ c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op
54unlockFile :: HANDLE -> IO ()
55unlockFile winHandle = do
56 let sizeof_OVERLAPPED = 32
57 allocaBytes sizeof_OVERLAPPED $ \op -> do
58 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
59 failIfFalse_ "UnlockFileEx" $ c_unlockFileEx winHandle 0 1 0 op
61#else
62--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles
63import qualified System.Posix.IO as P
64import System.Posix.Types
65import System.Posix.Files
66import System.IO
68lockStruct :: P.LockRequest -> P.FileLock
69lockStruct req = (req, AbsoluteSeek, 0, 0)
71newtype LockFile = LockFile Fd
73--we cannot use openFile from System.IO because it implements complicated locking which prevents opening the same file twice in write mode in the same process with no way to bypass the check.
74openLockFile :: FilePath -> IO LockFile
75openLockFile path =
76 LockFile <$> P.createFile path ownerWriteMode
78closeLockFile :: LockFile -> IO ()
79closeLockFile l@(LockFile fd) = do
80 unlockFile l
81 P.closeFd fd
83--blocks on lock, if necessary
84lockFile :: LockFile -> LockType -> IO ()
85lockFile (LockFile fd) lock = do
86 let lockt = case lock of
87 WriteLock -> P.WriteLock
88 ReadLock -> P.ReadLock
89 P.waitToSetLock fd (lockStruct lockt)
91unlockFile :: LockFile -> IO ()
92unlockFile (LockFile fd) =
93 P.waitToSetLock fd (lockStruct P.Unlock)
94#endif
96data LockType = ReadLock | WriteLock