filelock 0.1.0.1 → 0.1.1.9
raw patch · 7 files changed
Files
- CHANGELOG.md +46/−0
- System/FileLock.hs +12/−6
- System/FileLock/Internal/Flock.hsc +37/−5
- filelock.cabal +50/−13
- tests/interrupt.hs +24/−0
- tests/lock.log.expected +12/−0
- tests/test.hs +91/−0
+ CHANGELOG.md view
@@ -0,0 +1,46 @@+Changelog for filelock package++0.1.1.9+-------++_2026-02-02, Andreas Abel_++* Bump `cabal-version` to 2.2 to get license identifier to `CC0-1.0`+ ([Issue #10](https://github.com/haskell-pkg-janitors/filelock/issues/10)).+* Drop support for GHCs 8.0 and 8.2.++Tested with GHC 8.4 - 9.14.1.++0.1.1.8+-------++_2025-08-27, Andreas Abel_++* Remove obsolete `deriving Typeable`.++Tested with GHC 8.0 - 9.14.1-alpha1.++0.1.1.7+-------++_2023-08-03, Andreas Abel_++* Add `build-tools: hsc2hs` to `.cabal` for building with GHC 8.x++Tested with GHC 8.0 - 9.8.1-alpha1.++0.1.1.6+-------++_2023-04-06, Andreas Abel_++* Fix problem with locking when used with `unix-2.8`+ (issue [#12](https://github.com/takano-akio/filelock/issues/12)).+* Package moved to [@haskell-pkg-janitors](https://github.com/haskell-pkg-janitors/filelock).++Tested with GHC 8.2 - 9.6.++0.1.1.5+-------++_2020-06-30, Takano Akio_
System/FileLock.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -- | This module provides a portable interface to file locks as a mechanism for@@ -20,6 +19,10 @@ -- -- Note on the implementation: currently the module uses flock(2) on non-Windows -- platforms, and LockFileEx on Windows.+--+-- On non-Windows platforms, @InterruptibleFFI@ is used in the implementation to+-- ensures that blocking lock calls can be correctly interrupted by async+-- exceptions (e.g. functions like `timeout`). This has been tested on Linux. module System.FileLock ( FileLock , SharedExclusive(..)@@ -27,14 +30,14 @@ , tryLockFile , unlockFile , withFileLock+ , withTryFileLock ) where import Control.Applicative import qualified Control.Exception as E import Control.Monad import Data.IORef-import Data.Traversable (traverse)-import Data.Typeable+import Prelude #ifdef USE_FLOCK import qualified System.FileLock.Internal.Flock as I@@ -48,7 +51,6 @@ data FileLock = Lock {-# UNPACk #-} !I.Lock {-# UNPACk #-} !(IORef Bool) -- alive?- deriving (Typeable) instance Eq FileLock where Lock _ x == Lock _ y = x == y@@ -60,7 +62,7 @@ data SharedExclusive = Shared -- ^ Other process can hold a shared lock at the same time. | Exclusive -- ^ No other process can hold a lock, shared or exclusive.- deriving (Show, Eq, Typeable)+ deriving (Show, Eq) -- | Take a lock. This function blocks until the lock is available. lockFile :: FilePath -> SharedExclusive -> IO FileLock@@ -77,6 +79,10 @@ wasAlive <- atomicModifyIORef ref $ \old -> (False, old) when wasAlive $ I.unlock l --- | Perform some action with a lock held.+-- | Perform some action with a lock held. Blocks until the lock is available. withFileLock :: FilePath -> SharedExclusive -> (FileLock -> IO a) -> IO a withFileLock path mode = E.bracket (lockFile path mode) unlockFile++-- | Perform some action with a lock held. Non-blocking.+withTryFileLock :: FilePath -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)+withTryFileLock path mode f = E.bracket (tryLockFile path mode) (traverse unlockFile) (traverse f)
System/FileLock/Internal/Flock.hsc view
@@ -1,3 +1,5 @@+{-# LANGUAGE InterruptibleFFI #-}+ module System.FileLock.Internal.Flock #ifndef USE_FLOCK () where@@ -7,13 +9,22 @@ #include <sys/file.h> import Control.Applicative+import Control.Concurrent (yield) import qualified Control.Exception as E import Data.Bits import Foreign.C.Error import Foreign.C.Types import System.Posix.Files-import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(..))+import System.Posix.IO+ ( openFd, closeFd, defaultFileFlags, OpenMode(..)+#if MIN_VERSION_unix(2,8,0)+ , OpenFileFlags(cloexec, creat)+#else+ , setFdOption, FdOption(..)+#endif+ ) import System.Posix.Types+import Prelude type Lock = Fd @@ -37,7 +48,22 @@ unlock fd = closeFd fd open :: FilePath -> IO Fd-open path = openFd path WriteOnly (Just stdFileMode) defaultFileFlags+open path = do+#if MIN_VERSION_unix(2,8,0)+ fd <- openFd path WriteOnly defaultFileFlags{ cloexec = True, creat = Just stdFileMode }+ -- Field cloexec only available from unix-2.8+#else+ fd <- openFd path WriteOnly (Just stdFileMode) defaultFileFlags+ setFdOption fd CloseOnExec True+ -- Ideally, we would open the file descriptor with CLOEXEC enabled, but this+ -- is not available in unix < 2.9.+ -- So we set CLOEXEC after opening the file descriptor. This+ -- may seem like a race condition at first. However, since the lock is always+ -- taken after CLOEXEC is set, the worst that can happen is that a child+ -- process inherits the open FD in an unlocked state. While non-ideal from a+ -- performance standpoint, it doesn't introduce any locking bugs.+#endif+ return fd flock :: Fd -> Bool -> Bool -> IO Bool flock (Fd fd) exclusive block = do@@ -49,8 +75,12 @@ case () of _ | errno == eWOULDBLOCK -> return False -- already taken- | errno == eINTR- -> flock (Fd fd) exclusive block+ | errno == eINTR -> do+ -- If InterruptibleFFI interrupted the syscall with EINTR,+ -- we need to give the accompanying Haskell exception a chance to bubble.+ -- See also https://gitlab.haskell.org/ghc/ghc/issues/8684#note_142404.+ E.interruptible yield+ flock (Fd fd) exclusive block | otherwise -> throwErrno "flock" where modeOp = case exclusive of@@ -60,7 +90,9 @@ True -> 0 False -> #{const LOCK_NB} -foreign import ccall "flock"+-- `interruptible` so that async exceptions like `timeout` can stop it+-- when used in blocking mode (without `LOCK_NB`).+foreign import ccall interruptible "flock" c_flock :: CInt -> CInt -> IO CInt #endif /* USE_FLOCK */
filelock.cabal view
@@ -1,31 +1,46 @@--- Initial filelock.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/-+cabal-version: 2.2 name: filelock-version: 0.1.0.1+version: 0.1.1.9 synopsis: Portable interface to file locking (flock / LockFileEx) description: This package provides an interface to Windows and Unix file locking functionalities.-homepage: http://github.com/takano-akio/filelock-license: PublicDomain+homepage: https://github.com/haskell-pkg-janitors/filelock+license: CC0-1.0 license-file: LICENSE author: Takano Akio-maintainer: aljee@hyper.cx--- copyright: +maintainer: Andreas Abel category: System build-type: Simple--- extra-source-files: -cabal-version: >=1.10 +extra-doc-files:+ CHANGELOG.md+extra-source-files:+ tests/lock.log.expected++tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ library+ hs-source-dirs: . exposed-modules: System.FileLock other-modules: System.FileLock.Internal.Flock System.FileLock.Internal.LockFileEx- -- other-extensions: - build-depends: base >=4.5.1.0 && <5- -- hs-source-dirs: default-language: Haskell2010 + build-depends: base >=4.11.0.0 && <5+ build-tool-depends: hsc2hs:hsc2hs+ ghc-options: -Wall if os(windows) cpp-options: -DUSE_LOCKFILEEX@@ -33,3 +48,25 @@ else cpp-options: -DUSE_FLOCK build-depends: unix++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: test.hs+ build-depends: filelock, process >= 1.2.1.0, async >= 2.0.0.0, base+ ghc-options: -threaded+ default-language: Haskell2010++test-suite interrupt+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: interrupt.hs+ build-depends: filelock, base+ ghc-options: -threaded+ default-language: Haskell2010+ if os(windows)+ buildable: False++source-repository head+ type: git+ location: https://github.com/haskell-pkg-janitors/filelock.git
+ tests/interrupt.hs view
@@ -0,0 +1,24 @@+import Control.Concurrent+import Control.Exception+import Control.Monad+import System.FileLock+import System.Exit+import System.Timeout++main :: IO ()+main = withFileLock lockFilePath Exclusive $ \_ -> do+ mvar <- newMVar Nothing+ _ <- forkIO $ do+ -- The attempt to lock the file again should block, but it should be+ -- interrupted by the timeout, returning Nothing.+ --+ -- Also masking shouldn't change interruptibility.+ r <- timeout 1000000 $ mask $ \_ -> lockFile lockFilePath Exclusive+ _ <- swapMVar mvar (Just r)+ return ()+ threadDelay 2000000+ res <- readMVar mvar+ when (res /= Just Nothing) $+ die $ "unexpected result: " ++ show (fmap (const ()) <$> res)+ where+ lockFilePath = "interrupt_test.lock"
+ tests/lock.log.expected view
@@ -0,0 +1,12 @@+took shared lock+took shared lock+releasing shared lock+lock not available+took shared lock+releasing shared lock+releasing shared lock+took exclusive lock+releasing exclusive lock+took shared lock+releasing shared lock+lock was available
+ tests/test.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ViewPatterns #-}++import Control.Monad+import Control.Concurrent+import Control.Concurrent.Async+import Data.Maybe+import System.Environment+import System.Exit+import System.Process+import System.IO++import System.FileLock++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ args <- getArgs+ case args of+ ["shared", read -> duration]+ -> holdLock "shared" Shared duration+ ["exclusive", read -> duration]+ -> holdLock "exclusive" Exclusive duration+ ["try"]+ -> tryTakingLock+ ["tryshared", read -> duration]+ -> tryHoldLock "shared" Shared duration+ ["tryexclusive", read -> duration]+ -> tryHoldLock "exclusive" Exclusive duration+ _ -> do+ withFile "lock.log" WriteMode $ \h ->+ void $ mapConcurrently id+ [ callSelf h ["shared", "5"]+ , callSelf h ["shared", "2"]+ , sleep 1 >> callSelf h ["exclusive", "3"]+ , sleep 3 >> callSelf h ["try"]+ , sleep 4 >> callSelf h ["shared", "1"]+ , sleep 6 >> callSelf h ["shared", "1"]+ , sleep 10 >> callSelf h ["try"]+ ]+ sleep 11+ log <- readFile "lock.log"+ expected <- readFile "tests/lock.log.expected"+ when (log /= expected) $ do+ putStrLn "log mismatch!"+ putStrLn "log:"+ putStrLn log+ putStrLn "expected:"+ putStrLn expected+ exitFailure++callSelf :: Handle -> [String] -> IO ()+callSelf out args = do+ self <- getExecutablePath+ (_hin, _hout, _herr, ph) <- createProcess_ "callSelf"+ (proc self args) { std_out = UseHandle out }+ ExitSuccess <- waitForProcess ph+ return ()++sleep :: Int -> IO ()+sleep = threadDelay . (*1000000)++holdLock :: String -> SharedExclusive -> Int -> IO ()+holdLock ty sex duration = do+ withFileLock lockfile sex $ \_ -> do+ putStrLn $ "took " ++ desc+ sleep duration+ putStrLn $ "releasing " ++ desc+ where+ desc = ty ++ " lock"++tryTakingLock :: IO ()+tryTakingLock = do+ ml <- tryLockFile lockfile Exclusive+ case ml of+ Nothing -> putStrLn "lock not available"+ Just l -> do+ putStrLn "lock was available"+ unlockFile l++tryHoldLock :: String -> SharedExclusive -> Int -> IO ()+tryHoldLock ty sex duration = do+ res <- withTryFileLock lockfile sex $ \_ -> do+ putStrLn $ "took " ++ desc+ sleep duration+ putStrLn $ "released " ++ desc+ when (isNothing res) $ putStrLn "lock not available"+ where+ desc = ty ++ " lock"++lockfile :: String+lockfile = "lock"