Skip to content
Create a gist now

Instantly share code, notes, and snippets.

Embed URL


Subversion checkout URL

You can clone with
Download ZIP
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
Something went wrong with that request. Please try again.