git-annex/Utility/LockPool/PidLock.hs

{- Pid locks, using lock pools.
 -
 - Copyright 2015-2021 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 Control.Concurrent.STM
import Data.Maybe
import Control.Monad
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 (P.FirstLock firstlock firstlocksem) -> mk 
		<$> if firstlock
			then F.waitLock timeout f displaymessage $
				void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited
			else liftIO (atomically $ readTMVar firstlocksem) >>= \case
				P.FirstLockSemWaited True -> F.alreadyLocked f
				P.FirstLockSemTried True -> F.alreadyLocked f
				P.FirstLockSemWaited False -> F.waitedLock timeout f displaymessage
				P.FirstLockSemTried False -> F.waitLock timeout f displaymessage $
					void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited
	)

-- 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 (P.FirstLock firstlock firstlocksem) -> fmap mk
		<$> if firstlock
			then do
				lh <- F.tryLock f
				void $ atomically $ tryPutTMVar firstlocksem 
					(P.FirstLockSemTried (isJust lh))
				return lh
			else liftIO (atomically $ readTMVar firstlocksem) >>= \case
					P.FirstLockSemWaited True -> Just <$> F.alreadyLocked f
					P.FirstLockSemTried True -> Just <$> F.alreadyLocked f
					P.FirstLockSemWaited False -> return Nothing
					P.FirstLockSemTried False -> return Nothing
	)

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
	}