git.iko.soy/project-m36
on 2b3299a help sign in
project-m36/src/lib/ProjectM36/FileLock.hs
97 lines 3.1 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 closeHandle file
40--swiped from System.FileLock package
41lockFile :: HANDLE -> LockType -> IO ()
42lockFile winHandle lock = do
43 let exFlag = case lock of
44 WriteLock -> 2
45 ReadLock -> 0
46 blockFlag = 0 --always block
47 sizeof_OVERLAPPED = 32
49 allocaBytes sizeof_OVERLAPPED $ \op -> do
50 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
51 failIfFalse_ "LockFileEx" $ c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op
53unlockFile :: HANDLE -> IO ()
54unlockFile winHandle = do
55 let sizeof_OVERLAPPED = 32
56 allocaBytes sizeof_OVERLAPPED $ \op -> do
57 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
58 failIfFalse_ "UnlockFileEx" $ c_unlockFileEx winHandle 0 1 0 op
60#else
61--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles
62import qualified System.Posix.IO as P
63import System.Posix.Types
64import System.Posix.Files
65import System.IO
67lockStruct :: P.LockRequest -> P.FileLock
68lockStruct req = (req, AbsoluteSeek, 0, 0)
70newtype LockFile = LockFile Fd
72--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.
73openLockFile :: FilePath -> IO LockFile
74openLockFile path =
75 LockFile <$> P.createFile path ownerWriteMode
77closeLockFile :: LockFile -> IO ()
78closeLockFile l@(LockFile fd) = do
79 unlockFile l
80 P.closeFd fd
82--blocks on lock, if necessary
83lockFile :: LockFile -> LockType -> IO ()
84lockFile (LockFile fd) lock = do
85 let lockt = case lock of
86 WriteLock -> P.WriteLock
87 ReadLock -> P.ReadLock
88 P.waitToSetLock fd (lockStruct lockt)
90unlockFile :: LockFile -> IO ()
91unlockFile (LockFile fd) =
92 P.waitToSetLock fd (lockStruct P.Unlock)
93#endif
95data LockType = ReadLock | WriteLock