diff options
| -rw-r--r-- | Annex/Direct.hs | 26 | ||||
| -rw-r--r-- | Annex/Journal.hs | 22 | ||||
| -rw-r--r-- | Annex/LockFile.hs | 88 | ||||
| -rw-r--r-- | Annex/LockPool.hs | 60 | ||||
| -rw-r--r-- | Annex/Ssh.hs | 6 | ||||
| -rw-r--r-- | Remote/Helper/Hooks.hs | 6 |
6 files changed, 99 insertions, 109 deletions
diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 9a305aab4..fdc67a720 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -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. -} diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 4d9c6ab66..f34a7be1b 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -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 diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs new file mode 100644 index 000000000..8b210df43 --- /dev/null +++ b/Annex/LockFile.hs @@ -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 diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs deleted file mode 100644 index 5fc167d28..000000000 --- a/Annex/LockPool.hs +++ /dev/null @@ -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 } diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 7b32c6196..246ac338d 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -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 diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index b7deae577..c3ff970c6 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -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. |