1{- Posix lock files 2 - 3 - Copyright 2014 Joey Hess <id@joeyh.name> 4 - 5 - License: BSD-2-clause 6 -} 7 8module Utility.LockFile.Posix ( 9 LockHandle, 10 lockShared, 11 lockExclusive, 12 tryLockShared, 13 tryLockExclusive, 14 checkLocked, 15 getLockStatus, 16 LockStatus(..), 17 dropLock, 18 checkSaneLock, 19 LockRequest(..), 20 openLockFile, 21) where 22 23import Utility.Exception 24import Utility.Applicative 25import Utility.LockFile.LockStatus 26 27import System.IO 28import System.Posix.Types 29import System.Posix.IO.ByteString 30import System.Posix.Files.ByteString 31import System.FilePath.ByteString (RawFilePath) 32import Data.Maybe 33 34type LockFile = RawFilePath 35 36newtype LockHandle = LockHandle Fd 37 38-- Takes a shared lock, blocking until the lock is available. 39lockShared :: Maybe FileMode -> LockFile -> IO LockHandle 40lockShared = lock ReadLock 41 42-- Takes an exclusive lock, blocking until the lock is available. 43lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle 44lockExclusive = lock WriteLock 45 46-- Tries to take a shared lock, but does not block. 47tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) 48tryLockShared = tryLock ReadLock 49 50-- Tries to take an exclusive lock, but does not block. 51tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) 52tryLockExclusive = tryLock WriteLock 53 54-- Setting the FileMode allows creation of a new lock file. 55-- If it's Nothing then this only succeeds when the lock file already exists. 56lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle 57lock lockreq mode lockfile = do 58 l <- openLockFile lockreq mode lockfile 59 waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) 60 return (LockHandle l) 61 62-- Tries to take an lock, but does not block. 63tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle) 64tryLock lockreq mode lockfile = uninterruptibleMask_ $ do 65 l <- openLockFile lockreq mode lockfile 66 v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0) 67 case v of 68 Left _ -> do 69 closeFd l 70 return Nothing 71 Right _ -> return $ Just $ LockHandle l 72 73-- Close on exec flag is set so child processes do not inherit the lock. 74openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd 75openLockFile lockreq filemode lockfile = do 76 l <- openFd lockfile openfor filemode defaultFileFlags 77 setFdOption l CloseOnExec True 78 return l 79 where 80 openfor = case lockreq of 81 ReadLock -> ReadOnly 82 _ -> ReadWrite 83 84-- Returns Nothing when the file doesn't exist, for cases where 85-- that is different from it not being locked. 86checkLocked :: LockFile -> IO (Maybe Bool) 87checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus' 88 89getLockStatus :: LockFile -> IO LockStatus 90getLockStatus lockfile = do 91 v <- getLockStatus' lockfile 92 return $ case v of 93 Nothing -> StatusNoLockFile 94 Just Nothing -> StatusUnLocked 95 Just (Just pid) -> StatusLockedBy pid 96 97getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID)) 98getLockStatus' lockfile = bracket open close go 99 where 100 open = catchMaybeIO $ openLockFile ReadLock Nothing lockfile 101 102 close (Just h) = closeFd h 103 close Nothing = return () 104 105 go (Just h) = do 106 v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) 107 return (Just (fmap fst v)) 108 go Nothing = return Nothing 109 110dropLock :: LockHandle -> IO () 111dropLock (LockHandle fd) = closeFd fd 112 113-- Checks that the lock file still exists, and is the same file that was 114-- locked to get the LockHandle. 115-- 116-- This check is useful if the lock file might get deleted by something 117-- else. 118checkSaneLock :: LockFile -> LockHandle -> IO Bool 119checkSaneLock lockfile (LockHandle fd) = 120 go =<< catchMaybeIO (getFileStatus lockfile) 121 where 122 go Nothing = return False 123 go (Just st) = do 124 fdst <- getFdStatus fd 125 return $ deviceID fdst == deviceID st && fileID fdst == fileID st 126