refactor locking

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. -}

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

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

Annex/LockPool.hs

@@ -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 }

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

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.