module FileIO (
FHandle
, openReadWrite
, write
, read
, flush
, close
, seek
, setFileSize
, getFileSize
, PrefixLock
, prefixLockFromPrefix
, obtainPrefixLock
, releasePrefixLock
) where
import Prelude hiding (read)
import qualified Prelude as P
import Control.Applicative ((<$>))
import Control.Exception (SomeException(..), throw, try)
import Control.Monad (void)
import Data.Maybe (listToMaybe)
import Data.Word (Word8, Word64)
import Foreign (Ptr)
import System.Directory (createDirectoryIfMissing, removeFile)
import System.FilePath
import System.IO
import System.Posix (Fd,
openFd,
fdReadBuf,
fdWriteBuf,
fdToHandle,
fdSeek,
setFdSize,
fileSynchronise,
closeFd,
OpenMode(ReadWrite),
exclusive, trunc,
defaultFileFlags,
stdFileMode)
import System.Posix.Process (getProcessID)
import System.Posix.Signals (nullSignal, signalProcess)
import System.Posix.Types (ProcessID)
import qualified System.IO.Error as SE
newtype PrefixLock = PrefixLock FilePath
prefixLockFromPrefix :: FilePath -> PrefixLock
prefixLockFromPrefix = PrefixLock . (++ ".lock")
newtype FHandle = FHandle Fd
openReadWrite :: FilePath -> IO FHandle
openReadWrite filename =
FHandle <$> openFd filename ReadWrite (Just stdFileMode) defaultFileFlags
write :: FHandle -> Ptr Word8 -> Word64 -> IO Word64
write (FHandle fd) data' length' =
fmap fromIntegral $ fdWriteBuf fd data' $ fromIntegral length'
read :: FHandle -> Ptr Word8 -> Word64 -> IO Word64
read (FHandle fd) buf len =
fromIntegral <$> fdReadBuf fd buf (fromIntegral len)
flush :: FHandle -> IO ()
flush (FHandle fd) = fileSynchronise fd
seek :: FHandle -> Word64 -> IO ()
seek (FHandle fd) offset = void $ fdSeek fd AbsoluteSeek (fromIntegral offset)
setFileSize :: FHandle -> Word64 -> IO ()
setFileSize (FHandle fd) size = setFdSize fd (fromIntegral size)
getFileSize :: FHandle -> IO Word64
getFileSize (FHandle fd) = fromIntegral <$> fdSeek fd SeekFromEnd 0
close :: FHandle -> IO ()
close (FHandle fd) = closeFd fd
obtainPrefixLock :: FilePath -> IO PrefixLock
obtainPrefixLock prefix = checkLock fp >> takeLock fp
where fp = prefix ++ ".lock"
checkLock :: FilePath -> IO ()
checkLock fp = readLock fp >>= maybeBreakLock fp
readLock :: FilePath -> IO (Maybe ProcessID)
readLock fp = do
pid <- try (readFile fp)
return $ either (checkReadFileError fp)
(fmap (fromInteger . P.read) . listToMaybe . lines)
pid
checkReadFileError :: String -> IOError -> Maybe ProcessID
checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp))
| SE.isDoesNotExistError e = Nothing
| otherwise = throw e
maybeBreakLock :: FilePath -> Maybe ProcessID -> IO ()
maybeBreakLock fp Nothing =
breakLock fp
maybeBreakLock fp (Just pid) = do
exists <- doesProcessExist pid
if exists
then throw (lockedBy fp pid)
else breakLock fp
doesProcessExist :: ProcessID -> IO Bool
doesProcessExist pid = do
v <- try (signalProcess nullSignal pid)
return $ either checkException (const True) v
where checkException e | SE.isDoesNotExistError e = False
| otherwise = throw e
breakLock :: FilePath -> IO ()
breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ()))
checkBreakError :: IOError -> IO ()
checkBreakError e | SE.isDoesNotExistError e = return ()
| otherwise = throw e
takeLock :: FilePath -> IO PrefixLock
takeLock fp = do
createDirectoryIfMissing True (takeDirectory fp)
h <- openFd fp ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= fdToHandle
pid <- getProcessID
hPrint h pid >> hClose h
readLock fp >>= maybe (throw (cantLock fp pid))
(\ pid' -> if pid /= pid'
then throw (stolenLock fp pid pid')
else return (PrefixLock fp))
lockedBy :: (Show a) => FilePath -> a -> SomeException
lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp))
cantLock :: FilePath -> ProcessID -> SomeException
cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp))
stolenLock :: FilePath -> ProcessID -> ProcessID -> SomeException
stolenLock fp pid pid' = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ "'s lock was stolen by process " ++ show pid') Nothing (Just fp))
releasePrefixLock :: PrefixLock -> IO ()
releasePrefixLock (PrefixLock fp) =
dropLock >>= either checkDrop return
where
dropLock = try (removeFile fp)
checkDrop e | SE.isDoesNotExistError e = return ()
| otherwise = throw e