refactor locking

This commit is contained in:
Joey Hess 2014-07-10 00:32:23 -04:00
parent e5b88713a1
commit 26ee27915a
6 changed files with 99 additions and 109 deletions

View file

@ -5,8 +5,6 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Direct where
import Common.Annex
@ -38,9 +36,7 @@ import Annex.Exception
import Annex.VariantFile
import Git.Index
import Annex.Index
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif
import Annex.LockFile
{- Uses git ls-files to find files that need to be committed, and stages
- them into the index. Returns True if some changes were staged. -}
@ -164,7 +160,7 @@ addDirect file cache = do
- normally.
-}
mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
mergeDirect startbranch oldref branch resolvemerge commitmode = lockMerge $ do
mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do
reali <- fromRepo indexFile
tmpi <- fromRepo indexFileLock
liftIO $ copyFile reali tmpi
@ -186,24 +182,8 @@ mergeDirect startbranch oldref branch resolvemerge commitmode = lockMerge $ do
liftIO $ rename tmpi reali
return r
lockMerge :: Annex a -> Annex a
lockMerge a = do
lockfile <- fromRepo gitAnnexMergeLock
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
exclusively = withExclusiveLock gitAnnexMergeLock
{- Stage a merge into the index, avoiding changing HEAD or the current
- branch. -}

View file

@ -17,10 +17,7 @@ import Common.Annex
import Annex.Exception
import qualified Git
import Annex.Perms
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif
import Annex.LockFile
{- Records content for a file in the branch to the journal.
-
@ -121,19 +118,4 @@ data JournalLocked = ProduceJournalLocked
{- Runs an action that modifies the journal, using locking to avoid
- contention with other git-annex processes. -}
lockJournal :: (JournalLocked -> Annex a) -> Annex a
lockJournal a = do
lockfile <- fromRepo gitAnnexJournalLock
createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked)
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
lockJournal a = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked

88
Annex/LockFile.hs Normal file
View file

@ -0,0 +1,88 @@
{- 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.Exception
import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import Annex.Perms
#else
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

View file

@ -1,60 +0,0 @@
{- git-annex lock pool
-
- Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.LockPool where
import Common.Annex
import Annex
import Types.LockPool
import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import Annex.Perms
#else
import Utility.WinLock
#endif
{- Create a specified lock file, and takes a shared lock. -}
lockFile :: FilePath -> Annex ()
lockFile file = go =<< fromPool 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
changePool $ M.insert file lockhandle
unlockFile :: FilePath -> Annex ()
unlockFile file = maybe noop go =<< fromPool file
where
go lockhandle = do
#ifndef mingw32_HOST_OS
liftIO $ closeFd lockhandle
#else
liftIO $ dropLock lockhandle
#endif
changePool $ M.delete file
getPool :: Annex LockPool
getPool = getState lockpool
fromPool :: FilePath -> Annex (Maybe LockHandle)
fromPool file = M.lookup file <$> getPool
changePool :: (LockPool -> LockPool) -> Annex ()
changePool a = do
m <- getPool
changeState $ \s -> s { lockpool = a m }

View file

@ -25,7 +25,7 @@ import Data.Hash.MD5
import System.Exit
import Common.Annex
import Annex.LockPool
import Annex.LockFile
import qualified Build.SysConfig as SysConfig
import qualified Annex
import qualified Git
@ -119,13 +119,13 @@ prepSocket socketfile = do
-- If the lock pool is empty, this is the first ssh of this
-- run. There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted.
whenM (not . any isLock . M.keys <$> getPool)
whenM (not . any isLock . M.keys <$> getLockPool)
sshCleanup
-- Cleanup at end of this run.
Annex.addCleanup SshCachingCleanup sshCleanup
liftIO $ createDirectoryIfMissing True $ parentDir socketfile
lockFile $ socket2lock socketfile
lockFileShared $ socket2lock socketfile
enumSocketFiles :: Annex [FilePath]
enumSocketFiles = go =<< sshCacheDir

View file

@ -15,7 +15,7 @@ import Common.Annex
import Types.Remote
import Types.CleanupActions
import qualified Annex
import Annex.LockPool
import Annex.LockFile
#ifndef mingw32_HOST_OS
import Annex.Perms
#else
@ -48,7 +48,7 @@ runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a
runHooks r starthook stophook a = do
dir <- fromRepo gitAnnexRemotesDir
let lck = dir </> remoteid ++ ".lck"
whenM (notElem lck . M.keys <$> getPool) $ do
whenM (notElem lck . M.keys <$> getLockPool) $ do
liftIO $ createDirectoryIfMissing True dir
firstrun lck
a
@ -63,7 +63,7 @@ runHooks r starthook stophook a = do
-- of it from running the stophook. If another
-- instance is shutting down right now, this
-- will block waiting for its exclusive lock to clear.
lockFile lck
lockFileShared lck
-- The starthook is run even if some other git-annex
-- is already running, and ran it before.