68 lines
1.7 KiB
Haskell
68 lines
1.7 KiB
Haskell
{- Pid locks, using lock pools.
|
|
-
|
|
- Copyright 2015-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
module Utility.LockPool.PidLock (
|
|
P.LockFile,
|
|
LockHandle,
|
|
waitLock,
|
|
tryLock,
|
|
checkLocked,
|
|
getLockStatus,
|
|
LockStatus(..),
|
|
dropLock,
|
|
checkSaneLock,
|
|
) where
|
|
|
|
import qualified Utility.LockFile.PidLock as F
|
|
import Utility.LockFile.LockStatus
|
|
import qualified Utility.LockPool.STM as P
|
|
import Utility.LockPool.STM (LockFile, LockMode(..))
|
|
import Utility.LockPool.LockHandle
|
|
import Utility.ThreadScheduler
|
|
|
|
import System.IO
|
|
import System.Posix
|
|
import Data.Maybe
|
|
import Control.Monad.Catch
|
|
import Control.Monad.IO.Class
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
-- Takes a pid lock, blocking until the lock is available or the timeout.
|
|
waitLock
|
|
:: (MonadIO m, MonadMask m)
|
|
=> Seconds
|
|
-> LockFile
|
|
-> (String -> m ())
|
|
-> m LockHandle
|
|
waitLock timeout file displaymessage = makeLockHandle P.lockPool file
|
|
-- LockShared for STM lock, because a pid lock can be the top-level
|
|
-- lock with various other STM level locks gated behind it.
|
|
(\p f -> P.waitTakeLock p f LockShared)
|
|
(\f -> mk <$> F.waitLock timeout f displaymessage)
|
|
|
|
-- Tries to take a pid lock, but does not block.
|
|
tryLock :: LockFile -> IO (Maybe LockHandle)
|
|
tryLock file = tryMakeLockHandle P.lockPool file
|
|
(\p f -> P.tryTakeLock p f LockShared)
|
|
(\f -> fmap mk <$> F.tryLock f)
|
|
|
|
checkLocked :: LockFile -> IO (Maybe Bool)
|
|
checkLocked file = P.getLockStatus P.lockPool file
|
|
(pure (Just True))
|
|
(F.checkLocked file)
|
|
|
|
getLockStatus :: LockFile -> IO LockStatus
|
|
getLockStatus file = P.getLockStatus P.lockPool file
|
|
(StatusLockedBy <$> getProcessID)
|
|
(F.getLockStatus file)
|
|
|
|
mk :: F.LockHandle -> FileLockOps
|
|
mk h = FileLockOps
|
|
{ fDropLock = F.dropLock h
|
|
, fCheckSaneLock = \f -> F.checkSaneLock f h
|
|
}
|