diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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_ diff --git a/System/FileLock.hs b/System/FileLock.hs --- a/System/FileLock.hs +++ b/System/FileLock.hs @@ -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) diff --git a/System/FileLock/Internal/Flock.hsc b/System/FileLock/Internal/Flock.hsc --- a/System/FileLock/Internal/Flock.hsc +++ b/System/FileLock/Internal/Flock.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE InterruptibleFFI #-} + module System.FileLock.Internal.Flock #ifndef USE_FLOCK () where @@ -7,13 +9,22 @@ #include 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 */ diff --git a/filelock.cabal b/filelock.cabal --- a/filelock.cabal +++ b/filelock.cabal @@ -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 diff --git a/tests/interrupt.hs b/tests/interrupt.hs new file mode 100644 --- /dev/null +++ b/tests/interrupt.hs @@ -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" diff --git a/tests/lock.log.expected b/tests/lock.log.expected new file mode 100644 --- /dev/null +++ b/tests/lock.log.expected @@ -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 diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -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"