module Extra.Lock
( withLock
, awaitLock
) where
import Control.Exception
import Control.Monad.RWS
import Prelude hiding (catch)
import System.Directory
import System.IO
import System.IO.Error hiding (try, catch)
import System.Posix.Files
import System.Posix.IO
import System.Posix.Unistd
withLock :: (MonadIO m) => FilePath -> m a -> m a
withLock path task =
liftIO (checkLock >> takeLock) >> task >>= \ result -> liftIO dropLock >> return result
where
checkLock = readFile path `catch` checkReadError >>= processRunning . lines
checkReadError :: IOError -> IO String
checkReadError e | isDoesNotExistError e = return ""
checkReadError e = throw e
processRunning :: [String] -> IO ()
processRunning (pid : _) =
do exists <- doesDirectoryExist ("/proc/" ++ pid)
case exists of
True -> throw (lockedBy pid path)
False -> breakLock
processRunning [] = breakLock
breakLock = removeFile path `catch` checkBreakError
checkBreakError (e :: IOException) | isDoesNotExistError e = return ()
checkBreakError e = throw e
takeLock :: IO ()
takeLock =
openFd path ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>=
fdToHandle >>= \ h -> processID >>= hPutStrLn h >> hClose h
dropLock = removeFile path `catch` checkDrop
checkDrop (e :: IOException) | isDoesNotExistError e = return ()
checkDrop e = throw e
awaitLock tries usecs path task =
attempt 0
where
attempt n | n >= tries = error "awaitLock: too many failures"
attempt n = withLock path task `catch` checkLockError
where
checkLockError e | isAlreadyInUseError e = liftIO (usleep usecs) >> attempt (n + 1)
checkLockError e = throw e
processID :: IO String
processID = readSymbolicLink "/proc/self"
lockedBy pid path = mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path)