acid-state 0.7.0 → 0.7.1
raw patch · 4 files changed
+162/−7 lines, 4 filesdep +extensible-exceptionsPVP ok
version bump matches the API change (PVP)
Dependencies added: extensible-exceptions
API changes (from Hackage documentation)
Files
- acid-state.cabal +2/−2
- src-unix/FileIO.hs +124/−2
- src-win32/FileIO.hs +29/−2
- src/Data/Acid/Local.hs +7/−1
acid-state.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.7.0+Version: 0.7.1 -- A short (one-line) description of the package. Synopsis: Add ACID guarantees to any serializable Haskell data structure.@@ -63,7 +63,7 @@ -- Packages needed in order to build this package. -- We need hGetSome from bytestring, added in 0.9.1.8 Build-depends: base >= 4 && < 5, cereal >= 0.3.2.0, safecopy >= 0.6,- bytestring >= 0.9.1.8, stm,+ bytestring >= 0.9.1.8, stm, extensible-exceptions, filepath, directory, mtl, array, containers, template-haskell, network if os(windows)
src-unix/FileIO.hs view
@@ -1,17 +1,31 @@ {-# LANGUAGE ForeignFunctionInterface #-}-module FileIO(FHandle,open,write,flush,close) where+module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where import System.Posix(Fd(Fd), openFd, fdWriteBuf,+ fdToHandle, closeFd,- OpenMode(WriteOnly),+ 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 -- should handle opening flags correctly@@ -29,3 +43,111 @@ close :: FHandle -> IO () close (FHandle fd) = closeFd fd++-- Unix needs to use a special open call to open files for exclusive writing+--openExclusively :: FilePath -> IO Handle+--openExclusively fp =+-- fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags+-- where flags = defaultFileFlags {exclusive = True, trunc = True}+++++obtainPrefixLock :: FilePath -> IO PrefixLock+obtainPrefixLock prefix = do+ checkLock fp >> takeLock fp+ where fp = prefix ++ ".lock"++-- |Read the lock and break it if the process is dead.+checkLock :: FilePath -> IO ()+checkLock fp = readLock fp >>= maybeBreakLock fp++-- |Read the lock and return the process id if possible.+readLock :: FilePath -> IO (Maybe ProcessID)+readLock fp = try (readFile fp) >>=+ return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines)++-- |Is this a permission error? If so we don't have permission to+-- remove the lock file, abort.+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 =+ -- The lock file exists, but there's no PID in it. At this point,+ -- we will break the lock, because the other process either died+ -- or will give up when it failed to read its pid back from this+ -- file.+ breakLock fp+maybeBreakLock fp (Just pid) = do+ -- The lock file exists and there is a PID in it. We can break the+ -- lock if that process has died.+ -- getProcessStatus only works on the children of the calling process.+ -- exists <- try (getProcessStatus False True pid) >>= either checkException (return . isJust)+ exists <- doesProcessExist pid+ case exists of+ True -> throw (lockedBy fp pid)+ False -> breakLock fp++doesProcessExist :: ProcessID -> IO Bool+doesProcessExist pid =+ -- Implementation 1+ -- doesDirectoryExist ("/proc/" ++ show pid)+ -- Implementation 2+ try (signalProcess nullSignal pid) >>= return . either checkException (const True)+ where checkException e | SE.isDoesNotExistError e = False+ | True = throw e++-- |We have determined the locking process is gone, try to remove the+-- lock.+breakLock :: FilePath -> IO ()+breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ()))++-- |An exception when we tried to break a lock, if it says the lock+-- file has already disappeared we are still good to go.+checkBreakError :: IOError -> IO ()+checkBreakError e | SE.isDoesNotExistError e = return ()+ | True = throw e++-- |Try to create lock by opening the file with the O_EXCL flag and+-- writing our PID into it. Verify by reading the pid back out and+-- matching, maybe some other process slipped in before we were done+-- and broke our lock.+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+ -- Read back our own lock and make sure its still ours+ readLock fp >>= maybe (throw (cantLock fp pid))+ (\ pid' -> if pid /= pid'+ then throw (stolenLock fp pid pid')+ else return (PrefixLock fp))++-- |An exception saying the data is locked by another process.+lockedBy :: (Show a) => FilePath -> a -> SomeException+lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp))++-- |An exception saying we don't have permission to create lock.+cantLock :: FilePath -> ProcessID -> SomeException+cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp))++-- |An exception saying another process broke our lock before we+-- finished creating it.+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))++-- |Relinquish the lock by removing it and then verifying the removal.+releasePrefixLock :: PrefixLock -> IO ()+releasePrefixLock (PrefixLock fp) =+ dropLock >>= either checkDrop return+ where+ dropLock = try (removeFile fp)+ checkDrop e | SE.isDoesNotExistError e = return ()+ | True = throw e+++
src-win32/FileIO.hs view
@@ -1,4 +1,4 @@-module FileIO(FHandle,open,write,flush,close) where+module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where import System.Win32(HANDLE, createFile, gENERIC_WRITE,@@ -10,7 +10,10 @@ closeHandle) import Data.Word(Word8,Word32) import Foreign(Ptr)+import System.IO +type PrefixLock = (FilePath, Handle)+ data FHandle = FHandle HANDLE open :: FilePath -> IO FHandle@@ -18,10 +21,34 @@ 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 +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 ()
src/Data/Acid/Local.hs view
@@ -39,7 +39,9 @@ import Data.IORef import System.FilePath ( (</>) ) +import FileIO ( obtainPrefixLock, releasePrefixLock, PrefixLock ) + {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability) guarantees. @@ -58,6 +60,7 @@ , localCopy :: IORef st , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog Checkpoint+ , localLock :: PrefixLock } deriving (Typeable) @@ -180,7 +183,8 @@ -- found. -> IO (AcidState st) openLocalStateFrom directory initialState- = do core <- mkCore (eventsToMethods acidEvents) initialState+ = do lock <- obtainPrefixLock (directory </> "open")+ core <- mkCore (eventsToMethods acidEvents) initialState let eventsLogKey = LogKey { logDirectory = directory , logPrefix = "events" } checkpointsLogKey = LogKey { logDirectory = directory@@ -207,6 +211,7 @@ , localCopy = stateCopy , localEvents = eventsLog , localCheckpoints = checkpointsLog+ , localLock = lock } checkpointRestoreError msg@@ -219,6 +224,7 @@ = do closeCore (localCore acidState) closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState)+ releasePrefixLock (localLock acidState) -- | Move all log files that are no longer necessary for state restoration into the 'Archive'