Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

acid state win32

View FileIO.hs
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 ()
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.