make LockPool's LockHandle be able to support multiple different types of file locks

diff --git a/Utility/LockPool/LockHandle.hs b/Utility/LockPool/LockHandle.hs
index 5582d768257fd8bc30a3441e83c3d0b6a3706c83..1fa8e7ca7b6b40e9111c6131228189407ec7ff59 100644 (file)
--- a/Utility/LockPool/LockHandle.hs
+++ b/Utility/LockPool/LockHandle.hs
@@ -10,33 +10,38 @@
 module Utility.LockPool.LockHandle where
 
 import qualified Utility.LockPool.STM as P
-#ifndef mingw32_HOST_OS
-import qualified Utility.LockFile.Posix as F
-#else
-import qualified Utility.LockFile.Windows as F
-#endif
 
 import Control.Concurrent.STM
 import Control.Exception
 
-data LockHandle = LockHandle P.LockHandle F.LockHandle
+data LockHandle = LockHandle
+       { poolHandle :: P.LockHandle
+       , fileLockOps :: FileLockOps
+       }
+
+data FileLockOps = FileLockOps
+       { fDropLock :: IO ()
+#ifndef mingw32_HOST_OS
+       , fCheckSaneLock :: FilePath -> IO Bool
+#endif
+       }
 
 dropLock :: LockHandle -> IO ()
-dropLock (LockHandle ph fh) = P.releaseLock ph (F.dropLock fh)
+dropLock h = P.releaseLock (poolHandle h) (fDropLock (fileLockOps h))
 
 -- Take a lock, by first updating the lock pool, and then taking the file
 -- lock. If taking the file lock fails for any reason, take care to
 -- release the lock in the lock pool.
-makeLockHandle :: STM P.LockHandle -> IO F.LockHandle -> IO LockHandle
+makeLockHandle :: STM P.LockHandle -> IO FileLockOps -> IO LockHandle
 makeLockHandle pa fa = bracketOnError setup cleanup go
   where
        setup = atomically pa
        cleanup ph = P.releaseLock ph (return ())
        go ph = do
-               fh <- fa
-               return $ LockHandle ph fh
+               fo <- fa
+               return $ LockHandle ph fo
 
-tryMakeLockHandle :: STM (Maybe P.LockHandle) -> IO (Maybe F.LockHandle) -> IO (Maybe LockHandle)
+tryMakeLockHandle :: STM (Maybe P.LockHandle) -> IO (Maybe FileLockOps) -> IO (Maybe LockHandle)
 tryMakeLockHandle pa fa = bracketOnError setup cleanup go
   where
        setup = atomically pa
@@ -44,9 +49,9 @@ tryMakeLockHandle pa fa = bracketOnError setup cleanup go
        cleanup (Just ph) = P.releaseLock ph (return ())
        go Nothing = return Nothing
        go (Just ph) = do
-               mfh <- fa
-               case mfh of
+               mfo <- fa
+               case mfo of
                        Nothing -> do
                                cleanup (Just ph)
                                return Nothing
-                       Just fh -> return $ Just $ LockHandle ph fh
+                       Just fo -> return $ Just $ LockHandle ph fo

diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs
index 3e445e1a199aabe2038b226851f6f05a4ca54860..eb679b7e8901a36b3634feeebc3f68487ea7e29b 100644 (file)
--- a/Utility/LockPool/Posix.hs
+++ b/Utility/LockPool/Posix.hs
@@ -35,25 +35,25 @@ import Prelude
 lockShared :: Maybe FileMode -> LockFile -> IO LockHandle
 lockShared mode file = makeLockHandle
        (P.waitTakeLock P.lockPool file LockShared)
-       (F.lockShared mode file)
+       (mk <$> F.lockShared mode file)
 
 -- Takes an exclusive lock, blocking until the lock is available.
 lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
 lockExclusive mode file = makeLockHandle
        (P.waitTakeLock P.lockPool file LockExclusive)
-       (F.lockExclusive mode file)
+       (mk <$> F.lockExclusive mode file)
 
 -- Tries to take a shared lock, but does not block.
 tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
 tryLockShared mode file = tryMakeLockHandle
        (P.tryTakeLock P.lockPool file LockShared)
-       (F.tryLockShared mode file)
+       (fmap mk <$> F.tryLockShared mode file)
 
 -- Tries to take an exclusive lock, but does not block.
 tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
 tryLockExclusive mode file = tryMakeLockHandle
        (P.tryTakeLock P.lockPool file LockExclusive)
-       (F.tryLockExclusive mode file)
+       (fmap mk <$> F.tryLockExclusive mode file)
 
 -- Returns Nothing when the file doesn't exist, for cases where
 -- that is different from it not being locked.
@@ -68,4 +68,10 @@ getLockStatus file = P.getLockStatus P.lockPool file
        (F.getLockStatus file)
 
 checkSaneLock :: LockFile -> LockHandle -> IO Bool
-checkSaneLock lockfile (LockHandle _ fh) = F.checkSaneLock lockfile fh
+checkSaneLock lockfile (LockHandle _ flo) = fCheckSaneLock flo lockfile
+
+mk :: F.LockHandle -> FileLockOps
+mk h = FileLockOps
+       { fDropLock = F.dropLock h
+       , fCheckSaneLock = \f -> F.checkSaneLock f h
+       }

diff --git a/Utility/LockPool/Windows.hs b/Utility/LockPool/Windows.hs
index a88525a9ba891585a6700fe3d8e839235198698f..2641ac37d0bd61bf25056d5e0a8cd58824080529 100644 (file)
--- a/Utility/LockPool/Windows.hs
+++ b/Utility/LockPool/Windows.hs
@@ -24,7 +24,7 @@ import Utility.LockPool.STM (LockFile, LockMode(..))
 lockShared :: LockFile -> IO (Maybe LockHandle)
 lockShared file = tryMakeLockHandle
        (P.tryTakeLock P.lockPool file LockShared)
-       (F.lockShared file)
+       (fmap mk <$> F.lockShared file)
 
 {- Tries to take an exclusive lock on a file. Fails if another process has
  - a shared or exclusive lock.
@@ -35,9 +35,14 @@ lockShared file = tryMakeLockHandle
 lockExclusive :: LockFile -> IO (Maybe LockHandle)
 lockExclusive file = tryMakeLockHandle
        (P.tryTakeLock P.lockPool file LockExclusive)
-       (F.lockExclusive file)
+       (fmap mk <$> F.lockExclusive file)
 
 {- If the initial lock fails, this is a BUSY wait, and does not
  - guarentee FIFO order of waiters. In other news, Windows is a POS. -}
 waitToLock :: IO (Maybe lockhandle) -> IO lockhandle
 waitToLock = F.waitToLock
+
+mk :: F.LockHandle -> FileLockOps
+mk h = FileLockOps
+       { fDropLock = F.dropLock h
+       }