git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/FileLock.hs
85 lines 2.6 kB history raw
1{-# LANGUAGE CPP #-}
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
5import System.IO
8#if defined(mingw32_HOST_OS)
9import ProjectM36.Win32Handle
10import System.Win32.Types
11import Foreign.Marshal.Alloc
12import System.Win32.File
13import System.Win32.Mem
14import Data.Bits
16#if defined(i386_HOST_ARCH)
17# define WINDOWS_CCONV stdcall
18#elif defined(x86_64_HOST_ARCH)
19# define WINDOWS_CCONV ccall
20#else
21# error Unknown mingw32 arch
22#endif
23foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
25foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
27--swiped from System.FileLock package
28lockFile :: Handle -> LockType -> IO ()
29lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do
30 let exFlag = case lock of
31 WriteLock -> 2
32 ReadLock -> 0
33 blockFlag = 0 --always block
34 sizeof_OVERLAPPED = 32
36 allocaBytes sizeof_OVERLAPPED $ \op -> do
37 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
38 res <- c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op
39 if res then
40 pure ()
41 else
42 error "failed to wait for database lock"
44unlockFile :: Handle -> IO ()
45unlockFile handle = withHandleToHANDLE handle $ \winHandle -> do
46 let sizeof_OVERLAPPED = 32
47 allocaBytes sizeof_OVERLAPPED $ \op -> do
48 zeroMemory op $ fromIntegral sizeof_OVERLAPPED
49 res <- c_unlockFileEx winHandle 0 1 0 op
50 if res then
51 pure ()
52 else
53 error ("failed to unlock database lock: " ++ show res)
55#else
56import qualified System.Posix.IO as P
58lockStruct :: P.LockRequest -> P.FileLock
59lockStruct req = (req, AbsoluteSeek, 0, 0)
61--blocks on lock, if necessary
62lockFile :: Handle -> LockType -> IO ()
63lockFile file lock = do
64 fd <- P.handleToFd file
65 let lockt = case lock of
66 WriteLock -> P.WriteLock
67 ReadLock -> P.ReadLock
68 P.waitToSetLock fd (lockStruct lockt)
70unlockFile :: Handle -> IO ()
71unlockFile file = do
72 fd <- P.handleToFd file
73 P.waitToSetLock fd (lockStruct P.Unlock)
74#endif
76data LockType = ReadLock | WriteLock
78{-
79lockFileSTM :: Handle -> LockType -> STM ()
80lockFileSTM file lock = unsafeIOToSTM $ onException (lockFile file lock) (unlockFile file)
82unlockFileSTM :: Handle -> STM ()
83unlockFileSTM file = unsafeIOToSTM $ unlockFile file
84-}