1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
{- 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,
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.Posix
import Control.Concurrent.STM
import Data.Maybe
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
-- Does locking using a pid lock, blocking until the lock is available
-- or the Seconds timeout if the pid lock is held by another process.
--
-- There are two levels of locks. A STM lock is used to handle
-- fine-grained locking among threads, locking a specific lockfile,
-- but only in memory. The pid lock handles locking between processes.
--
-- The pid lock is only taken once, and LockShared is used for it,
-- so multiple threads can have it locked. Only the first thread
-- will create the pid lock, and it remains until all threads drop
-- their locks.
waitLock
:: (MonadIO m, MonadMask m)
=> LockFile
-> LockMode
-> Seconds
-> F.PidLockFile
-> (String -> m ())
-> m LockHandle
waitLock finelockfile lockmode timeout pidlockfile displaymessage = do
fl <- takefinelock
pl <- takepidlock
`onException` liftIO (dropLock fl)
registerPostRelease fl pl
return fl
where
takefinelock = fst <$> makeLockHandle P.lockPool finelockfile
(\p f -> P.waitTakeLock p f lockmode)
(\_ _ -> pure (stmonlyflo, ()))
-- A shared STM lock is taken for each use of the pid lock,
-- but only the first thread to take it actually creates the pid
-- lock file.
takepidlock = makeLockHandle P.lockPool pidlockfile
(\p f -> P.waitTakeLock p f LockShared)
(\f (P.FirstLock firstlock firstlocksem) -> if firstlock
then waitlock f firstlocksem
else liftIO (atomically $ readTMVar firstlocksem) >>= \case
P.FirstLockSemWaited True -> alreadylocked f
P.FirstLockSemTried True -> alreadylocked f
P.FirstLockSemWaited False -> F.waitedLock timeout f displaymessage
P.FirstLockSemTried False -> waitlock f firstlocksem
)
waitlock f firstlocksem = do
h <- F.waitLock timeout f displaymessage $
void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited
return (mkflo h, Just h)
alreadylocked f = do
lh <- F.alreadyLocked f
return (mkflo lh, Nothing)
registerPostRelease :: MonadIO m => LockHandle -> (LockHandle, Maybe F.LockHandle) -> m ()
registerPostRelease (LockHandle flh _) (pl@(LockHandle plh _), mpidlock) = do
-- After the fine-grained lock gets dropped (and any shared locks
-- of it are also dropped), drop the associated pid lock.
liftIO $ atomically $
P.registerPostReleaseLock flh (dropLock pl)
-- When the last thread to use the pid lock has dropped it,
-- close the pid lock file itself.
case mpidlock of
Just pidlock -> liftIO $ atomically $
P.registerPostReleaseLock plh (F.dropLock pidlock)
Nothing -> return ()
-- Tries to take a pid lock, but does not block.
tryLock :: LockFile -> LockMode -> F.PidLockFile -> IO (Maybe LockHandle)
tryLock finelockfile lockmode pidlockfile = takefinelock >>= \case
Just fl -> tryLock' pidlockfile >>= \case
Just pl -> do
registerPostRelease fl pl
return (Just fl)
Nothing -> do
dropLock fl
return Nothing
Nothing -> return Nothing
where
takefinelock = fmap fst <$> tryMakeLockHandle P.lockPool finelockfile
(\p f -> P.tryTakeLock p f lockmode)
(\_ _ -> pure (Just (stmonlyflo, ())))
tryLock' :: F.PidLockFile -> IO (Maybe (LockHandle, Maybe F.LockHandle))
tryLock' pidlockfile = tryMakeLockHandle P.lockPool pidlockfile
(\p f -> P.tryTakeLock p f LockShared)
(\f (P.FirstLock firstlock firstlocksem) -> if firstlock
then do
mlh <- F.tryLock f
void $ atomically $ tryPutTMVar firstlocksem
(P.FirstLockSemTried (isJust mlh))
case mlh of
Just lh -> return (Just (mkflo lh, Just lh))
Nothing -> return Nothing
else liftIO (atomically $ readTMVar firstlocksem) >>= \case
P.FirstLockSemWaited True -> alreadylocked f
P.FirstLockSemTried True -> alreadylocked f
P.FirstLockSemWaited False -> return Nothing
P.FirstLockSemTried False -> return Nothing
)
where
alreadylocked f = do
lh <- F.alreadyLocked f
return (Just (mkflo lh, 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)
mkflo :: F.LockHandle -> FileLockOps
mkflo h = FileLockOps
{ fDropLock = return ()
, fCheckSaneLock = \f -> F.checkSaneLock f h
}
stmonlyflo :: FileLockOps
stmonlyflo = FileLockOps
{ fDropLock = return ()
, fCheckSaneLock = const (return True)
}
|
