c784ef4586
Removed old extensible-exceptions, only needed for very old ghc. Made webdav use Utility.Exception, to work after some changes in DAV's exception handling. Removed Annex.Exception. Mostly this was trivial, but note that tryAnnex is replaced with tryNonAsync and catchAnnex replaced with catchNonAsync. In theory that could be a behavior change, since the former caught all exceptions, and the latter don't catch async exceptions. However, in practice, nothing in the Annex monad uses async exceptions. Grepping for throwTo and killThread only find stuff in the assistant, which does not seem related. Command.Add.undo is changed to accept a SomeException, and things that use it for rollback now catch non-async exceptions, rather than only IOExceptions.
86 lines
2.1 KiB
Haskell
86 lines
2.1 KiB
Haskell
{- git-annex lock files.
|
|
-
|
|
- Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Annex.LockFile (
|
|
lockFileShared,
|
|
unlockFile,
|
|
getLockPool,
|
|
withExclusiveLock,
|
|
) where
|
|
|
|
import Common.Annex
|
|
import Annex
|
|
import Types.LockPool
|
|
import qualified Git
|
|
import Annex.Perms
|
|
|
|
import qualified Data.Map as M
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
import Utility.WinLock
|
|
#endif
|
|
|
|
{- Create a specified lock file, and takes a shared lock, which is retained
|
|
- in the pool. -}
|
|
lockFileShared :: FilePath -> Annex ()
|
|
lockFileShared file = go =<< fromLockPool file
|
|
where
|
|
go (Just _) = noop -- already locked
|
|
go Nothing = do
|
|
#ifndef mingw32_HOST_OS
|
|
mode <- annexFileMode
|
|
lockhandle <- liftIO $ noUmask mode $
|
|
openFd file ReadOnly (Just mode) defaultFileFlags
|
|
liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
|
|
#else
|
|
lockhandle <- liftIO $ waitToLock $ lockShared file
|
|
#endif
|
|
changeLockPool $ M.insert file lockhandle
|
|
|
|
unlockFile :: FilePath -> Annex ()
|
|
unlockFile file = maybe noop go =<< fromLockPool file
|
|
where
|
|
go lockhandle = do
|
|
#ifndef mingw32_HOST_OS
|
|
liftIO $ closeFd lockhandle
|
|
#else
|
|
liftIO $ dropLock lockhandle
|
|
#endif
|
|
changeLockPool $ M.delete file
|
|
|
|
getLockPool :: Annex LockPool
|
|
getLockPool = getState lockpool
|
|
|
|
fromLockPool :: FilePath -> Annex (Maybe LockHandle)
|
|
fromLockPool file = M.lookup file <$> getLockPool
|
|
|
|
changeLockPool :: (LockPool -> LockPool) -> Annex ()
|
|
changeLockPool a = do
|
|
m <- getLockPool
|
|
changeState $ \s -> s { lockpool = a m }
|
|
|
|
{- Runs an action with an exclusive lock held. If the lock is already
|
|
- held, blocks until it becomes free. -}
|
|
withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
|
|
withExclusiveLock getlockfile a = do
|
|
lockfile <- fromRepo getlockfile
|
|
createAnnexDirectory $ takeDirectory lockfile
|
|
mode <- annexFileMode
|
|
bracketIO (lock lockfile mode) unlock (const a)
|
|
where
|
|
#ifndef mingw32_HOST_OS
|
|
lock lockfile mode = do
|
|
l <- noUmask mode $ createFile lockfile mode
|
|
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
|
|
return l
|
|
unlock = closeFd
|
|
#else
|
|
lock lockfile _mode = waitToLock $ lockExclusive lockfile
|
|
unlock = dropLock
|
|
#endif
|