module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where
import System.Posix(Fd(Fd),
openFd,
fdWriteBuf,
fdToHandle,
closeFd,
OpenMode(WriteOnly,ReadWrite),
exclusive, trunc,
defaultFileFlags,
stdFileMode
)
import Data.Word(Word8,Word32)
import Foreign(Ptr)
import Foreign.C(CInt(..))
import System.IO
import Data.Maybe (listToMaybe)
import qualified System.IO.Error as SE
import System.Posix.Process (getProcessID)
import System.Posix.Signals (nullSignal, signalProcess)
import System.Posix.Types (ProcessID)
import Control.Exception.Extensible as E
import System.Directory ( createDirectoryIfMissing, removeFile)
import System.FilePath
newtype PrefixLock = PrefixLock FilePath
data FHandle = FHandle Fd
open :: FilePath -> IO FHandle
open filename = fmap FHandle $ openFd filename WriteOnly (Just stdFileMode) defaultFileFlags
write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32
write (FHandle fd) data' length = fmap fromIntegral $ fdWriteBuf fd data' $ fromIntegral length
flush :: FHandle -> IO ()
flush (FHandle (Fd c_fd)) = c_fsync c_fd >> return ()
foreign import ccall "fsync" c_fsync :: CInt -> IO CInt
close :: FHandle -> IO ()
close (FHandle fd) = closeFd fd
obtainPrefixLock :: FilePath -> IO PrefixLock
obtainPrefixLock prefix = do
checkLock fp >> takeLock fp
where fp = prefix ++ ".lock"
checkLock :: FilePath -> IO ()
checkLock fp = readLock fp >>= maybeBreakLock fp
readLock :: FilePath -> IO (Maybe ProcessID)
readLock fp = try (readFile fp) >>=
return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines)
checkReadFileError :: [Char] -> IOError -> Maybe ProcessID
checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp))
| SE.isDoesNotExistError e = Nothing
| True = throw e
maybeBreakLock :: FilePath -> Maybe ProcessID -> IO ()
maybeBreakLock fp Nothing =
breakLock fp
maybeBreakLock fp (Just pid) = do
exists <- doesProcessExist pid
case exists of
True -> throw (lockedBy fp pid)
False -> breakLock fp
doesProcessExist :: ProcessID -> IO Bool
doesProcessExist pid =
try (signalProcess nullSignal pid) >>= return . either checkException (const True)
where checkException e | SE.isDoesNotExistError e = False
| True = throw e
breakLock :: FilePath -> IO ()
breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ()))
checkBreakError :: IOError -> IO ()
checkBreakError e | SE.isDoesNotExistError e = return ()
| True = 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
hPutStrLn h (show 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 ()
| True = throw e