{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.CAS.Lock
( Lock
, openLock
, closeLock
, withLock
) where
import Control.Concurrent (threadDelay)
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
import UnliftIO (MonadUnliftIO, withRunInIO)
import UnliftIO.MVar
data Lock = Lock
{ lockMVar :: MVar ()
, lockDir :: Path Abs Dir
}
openLock :: Path Abs Dir -> IO Lock
openLock dir = do
mvar <- newMVar ()
createDirIfMissing True dir
return $! Lock
{ lockMVar = mvar
, lockDir = dir
}
closeLock :: Lock -> IO ()
closeLock lock = do
takeMVar (lockMVar lock)
withLock :: MonadUnliftIO m => Lock -> m a -> m a
withLock lock action = withRunInIO $ \unliftIO ->
withMVar (lockMVar lock) $ \() ->
bracket_ (acquireDirLock $ lockDir lock) (releaseDirLock $ lockDir lock) $
unliftIO action
getUniqueFileName :: IO (Path Rel File)
getUniqueFileName = do
hostName <- getHostName
pid <- getProcessID
parseRelFile $ hostName ++ show pid
lockFileName :: Path Rel File
lockFileName = [relfile|lock|]
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
releaseDirLock :: Path Abs Dir -> IO ()
releaseDirLock dir = do
file <- getUniqueFileName
let path = dir </> file
removeLink (fromAbsFile $ dir </> lockFileName)
removeLink (fromAbsFile path)