git-annex/Utility/LockPool/PidLock.hs

{- 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
	}