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