blob: ea6f0fa38012a686383644fe2941d71c612e2690 (
plain)
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
|
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Thread and process write lock.
--
-- Allows synchronisation between threads and processes.
-- Uses an 'MVar' for synchronisation between threads
-- and fcntl write locks for synchronisation between processes.
--
-- Only ever have one 'Lock' object per lock file per process!
module Control.Funflow.Lock
( Lock
, openLock
, closeLock
, withLock
) where
import Control.Concurrent
import Control.Exception.Safe
import Control.Monad (unless)
import Network.HostName (getHostName)
import Path
import Path.IO
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process
import System.Random
-- | Thread and process write lock.
--
-- Only ever have one 'Lock' object per lock file per process!
data Lock = Lock
{ lockMVar :: MVar ()
, lockDir :: Path Abs Dir
}
-- | Open the lock file and create a lock object.
--
-- This does not acquire the lock.
--
-- Only ever have one 'Lock' object per lock file per process!
openLock :: Path Abs Dir -> IO Lock
openLock dir = do
mvar <- newMVar ()
createDirIfMissing True dir
return $! Lock
{ lockMVar = mvar
, lockDir = dir
}
-- | Close the lock file.
--
-- Does not release the lock.
--
-- Blocks if the lock is taken.
closeLock :: Lock -> IO ()
closeLock lock = do
takeMVar (lockMVar lock)
-- | Acquire the lock for the duration of the given action and release after.
withLock :: Lock -> IO a -> IO a
withLock lock action =
withMVar (lockMVar lock) $ \() ->
bracket_ (acquireDirLock $ lockDir lock) (releaseDirLock $ lockDir lock) $
action
----------------------------------------------------------------------
-- Internals
-- | Generate unique (per process) filename.
--
-- Combines the host name and process ID.
getUniqueFileName :: IO (Path Rel File)
getUniqueFileName = do
hostName <- getHostName
pid <- getProcessID
parseRelFile $ hostName ++ show pid
lockFileName :: Path Rel File
lockFileName = [relfile|lock|]
-- | Acquire the lock.
--
-- Uses an algorithm that is described in the man-page of open (2) in the
-- last paragraph to @O_EXCL@ in release 4.14 of the Linux man-pages project.
--
-- Creates a file under a unique (per process) filename.
-- Attempts to hard-link that file to a common lock path.
-- If the operation succeeds, then the lock was acquired.
-- If not, but if the link count of the file under the unique filename
-- increased to two, then the lock was acquired.
-- Otherwise, another process holds the lock and this process waits
-- and retries.
acquireDirLock :: Path Abs Dir -> IO ()
acquireDirLock dir = do
file <- getUniqueFileName
let path = dir </> file
fd <- createFile (fromAbsFile path) ownerWriteMode
closeFd fd
r <- try $ createLink (fromAbsFile path) (fromAbsFile $ dir </> lockFileName)
case r of
Right () -> return ()
Left (_::IOError) -> do
count <- linkCount <$> getFileStatus (fromAbsFile path)
unless (count == 2) $ do
delay <- randomRIO (50000, 100000)
threadDelay delay
acquireDirLock dir
-- | Release the lock.
--
-- Unlinks the file under the unique file name and the common lock file.
releaseDirLock :: Path Abs Dir -> IO ()
releaseDirLock dir = do
file <- getUniqueFileName
let path = dir </> file
removeLink (fromAbsFile $ dir </> lockFileName)
removeLink (fromAbsFile path)
|
