Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
acid state win32
module FileIO (FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where
import System.Win32(HANDLE,
import Data.Word(Word8,Word32)
import Foreign(Ptr)
import System.IO
import System.Directory(createDirectoryIfMissing,removeFile)
import Control.Exception.Extensible(try,throw)
import Control.Exception(SomeException,IOException)
import qualified Control.Exception as E
tryE :: IO a -> IO (Either SomeException a)
tryE = try
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = E.catch
type PrefixLock = (FilePath, Handle)
data FHandle = FHandle HANDLE
open :: FilePath -> IO FHandle
open filename =
fmap FHandle $ createFile filename gENERIC_WRITE fILE_SHARE_NONE Nothing cREATE_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing
write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32
write (FHandle handle) data' length = win32_WriteFile handle data' length Nothing
flush :: FHandle -> IO ()
flush (FHandle handle) = flushFileBuffers handle
close :: FHandle -> IO ()
close (FHandle handle) = closeHandle handle
-- Windows opens files for exclusive writing by default
openExclusively :: FilePath -> IO Handle
openExclusively fp = openFile fp ReadWriteMode
obtainPrefixLock :: FilePath -> IO PrefixLock
obtainPrefixLock prefix = do
createDirectoryIfMissing True prefix
-- catchIO obtainLock onError
catchIO obtainLock onError
where fp = prefix ++ ".lock"
obtainLock = do
h <- openExclusively fp
return (fp, h)
onError e = do
putStrLn "There may already be an instance of this application running, which could result in a loss of data."
putStrLn ("Please make sure there is no other application attempting to access '" ++ prefix ++ "'")
throw e
releasePrefixLock :: PrefixLock -> IO ()
releasePrefixLock (fp, h) = do
tryE $ hClose h
tryE $ removeFile fp
return ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment