git.iko.soy/project-m36
on 63fbef0 help sign in
project-m36/src/lib/ProjectM36/FileLock.hs
106 lines 3.3 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 res <- c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op
53 if res then
54 pure ()
55 else
56 error "failed to wait for database lock"
58unlockFile :: HANDLE -> IO ()
59unlockFile winHandle = do
60 let sizeof_OVERLAPPED = 32
61 allocaBytes sizeof_OVERLAPPED $ \op -> do
62 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
63 res <- c_unlockFileEx winHandle 0 1 0 op
64 if res then
65 pure ()
66 else
67 error ("failed to unlock database lock: " ++ show res)
69#else
70--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles
71import qualified System.Posix.IO as P
72import System.Posix.Types
73import System.Posix.Files
74import System.IO
76lockStruct :: P.LockRequest -> P.FileLock
77lockStruct req = (req, AbsoluteSeek, 0, 0)
79newtype LockFile = LockFile Fd
81--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.
82openLockFile :: FilePath -> IO LockFile
83openLockFile path =
84 LockFile <$> P.createFile path ownerWriteMode
86closeLockFile :: LockFile -> IO ()
87closeLockFile l@(LockFile fd) = do
88 unlockFile l
89 P.closeFd fd
91--blocks on lock, if necessary
92lockFile :: LockFile -> LockType -> IO ()
93lockFile (LockFile fd) lock = do
94 let lockt = case lock of
95 WriteLock -> P.WriteLock
96 ReadLock -> P.ReadLock
97 P.waitToSetLock fd (lockStruct lockt)
99unlockFile :: LockFile -> IO ()
100unlockFile (LockFile fd) =
101 P.waitToSetLock fd (lockStruct P.Unlock)
102#endif
104data LockType = ReadLock | WriteLock