summaryrefslogtreecommitdiff
path: root/Utility/LockFile
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-11-12 15:38:02 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-11-12 15:39:49 -0400
commit0c24c5e78a6c460caa02075857dbf7efd6239857 (patch)
tree35f366c3a023999fd9a18c9a109bb8930185016e /Utility/LockFile
parentb42df643c6512ecdc29bf1aeb20fd842528c41f7 (diff)
module for pid lock files with atomic stale lock file takeover when possible
Diffstat (limited to 'Utility/LockFile')
-rw-r--r--Utility/LockFile/LockStatus.hs13
-rw-r--r--Utility/LockFile/PidLock.hs132
-rw-r--r--Utility/LockFile/Posix.hs4
3 files changed, 146 insertions, 3 deletions
diff --git a/Utility/LockFile/LockStatus.hs b/Utility/LockFile/LockStatus.hs
new file mode 100644
index 000000000..3f466c125
--- /dev/null
+++ b/Utility/LockFile/LockStatus.hs
@@ -0,0 +1,13 @@
+{- LockStatus type
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.LockFile.LockStatus where
+
+import System.Posix
+
+data LockStatus = StatusUnLocked | StatusLockedBy ProcessID | StatusNoLockFile
+ deriving (Eq)
diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
new file mode 100644
index 000000000..d4290e91c
--- /dev/null
+++ b/Utility/LockFile/PidLock.hs
@@ -0,0 +1,132 @@
+{- pid-based lock files
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.LockFile.PidLock (
+ LockHandle,
+ tryLock,
+ waitLock,
+ LockStatus(..),
+ getLockStatus,
+ dropLock,
+) where
+
+import Utility.PartialPrelude
+import Utility.Exception
+import Utility.Applicative
+import Utility.Directory
+import Utility.ThreadScheduler
+import Utility.Tmp
+import Utility.Monad
+import Utility.Path
+import Utility.FileMode
+import Utility.LockFile.LockStatus
+import qualified Utility.LockFile.Posix as Posix
+
+import System.IO
+import System.Posix
+import System.Posix.IO
+import System.Posix.Process
+import Data.Maybe
+import Data.List
+import Control.Applicative
+import Network.BSD
+import System.FilePath
+
+type LockFile = FilePath
+
+data LockHandle = LockHandle FilePath Handle (Maybe Posix.LockHandle)
+
+data PidLock = PidLock
+ { lockingPid :: ProcessID
+ , lockingHost :: HostName
+ }
+ deriving (Eq, Read, Show)
+
+mkPidLock :: IO PidLock
+mkPidLock = PidLock
+ <$> getProcessID
+ <*> getHostName
+
+readPidLock :: LockFile -> IO (Maybe PidLock)
+readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile lockfile)
+
+-- To avoid races when taking over a stale pid lock, a side lock is used.
+-- This is a regular posix exclusive lock. The side lock is put in
+-- /dev/shm. This will work on most any Linux system, even if its whole
+-- root filesystem doesn't support posix locks.
+trySideLock :: LockFile -> (Maybe Posix.LockHandle -> IO a) -> IO a
+trySideLock lockfile a = do
+ f <- absPath lockfile
+ let sidelock = "/dev/shm" </>
+ intercalate "_" (splitDirectories (makeRelative "/" f)) ++ ".lck"
+ mlck <- catchDefaultIO Nothing $
+ withUmask nullFileMode $
+ Posix.tryLockExclusive (Just mode) sidelock
+ a mlck
+ where
+ -- Let all users write to the lock file in /dev/shm,
+ -- so that other users can reuse it to take the lock.
+ -- Since /dev/shm is sticky, a user cannot delete another user's
+ -- lock file there, so could not delete a stale lock.
+ mode = combineModes (readModes ++ writeModes)
+
+-- | Tries to take a lock; does not block when the lock is already held.
+--
+-- The method used is atomic even on NFS without needing O_EXCL support.
+--
+-- Note that stale locks are automatically detected and broken.
+-- However, if the lock file is on a networked file system, and was
+-- created on a different host than the current host (determined by hostname),
+-- this can't be done and stale locks may persist.
+tryLock :: LockFile -> IO (Maybe LockHandle)
+tryLock lockfile = trySideLock lockfile $ \sidelock -> do
+ (tmp, h) <- openTempFile (takeDirectory lockfile) "locktmp"
+ setFileMode tmp (combineModes readModes)
+ hPutStr h . show =<< mkPidLock
+ hClose h
+ let failedlock = do
+ hClose h
+ nukeFile tmp
+ return Nothing
+ let tooklock = return $ Just $ LockHandle lockfile h sidelock
+ ifM (isJust <$> catchMaybeIO (createLink tmp lockfile))
+ ( tooklock
+ , do
+ v <- readPidLock lockfile
+ hn <- getHostName
+ case v of
+ Just pl | isJust sidelock && hn == lockingHost pl -> do
+ -- Since we have the sidelock,
+ -- and are on the same host that
+ -- the pidlock was take on,
+ -- we know that the pidlock is
+ -- stale, and can take it over.
+ rename tmp lockfile
+ tooklock
+ _ -> failedlock
+ )
+
+-- | Waits as necessary to take a lock.
+--
+-- Uses a 1 second wait-loop.
+--
+-- May wait forever if the lock file is stale and is on a network file
+-- system, or on a system where the side lock cannot be taken.
+waitLock :: LockFile -> IO LockHandle
+waitLock lockfile = go
+ where
+ go = maybe (threadDelaySeconds (Seconds 1) >> go) return
+ =<< tryLock lockfile
+
+getLockStatus :: LockFile -> IO LockStatus
+getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock
+
+dropLock :: LockHandle -> IO ()
+dropLock (LockHandle lockfile lockhandle plh) = do
+ hClose lockhandle
+ nukeFile lockfile
+ maybe noop Posix.dropLock plh
diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs
index cf88fa87d..b1c4cc551 100644
--- a/Utility/LockFile/Posix.hs
+++ b/Utility/LockFile/Posix.hs
@@ -20,6 +20,7 @@ module Utility.LockFile.Posix (
import Utility.Exception
import Utility.Applicative
+import Utility.LockFile.LockStatus
import System.IO
import System.Posix
@@ -80,9 +81,6 @@ openLockFile lockreq filemode lockfile = do
checkLocked :: LockFile -> IO (Maybe Bool)
checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus'
-data LockStatus = StatusUnLocked | StatusLockedBy ProcessID | StatusNoLockFile
- deriving (Eq)
-
getLockStatus :: LockFile -> IO LockStatus
getLockStatus lockfile = do
v <- getLockStatus' lockfile