public
Created

acid state win32

  • Download Gist
FileIO.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
module FileIO (FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where
import System.Win32(HANDLE,
createFile,
gENERIC_WRITE,
fILE_SHARE_NONE,
cREATE_ALWAYS,
fILE_ATTRIBUTE_NORMAL,
win32_WriteFile,
flushFileBuffers,
closeHandle)
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 ()

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.