use lock pools throughout git-annex

The one exception is in Utility.Daemon. As long as a process only
daemonizes once, which seems reasonable, and as long as it avoids calling
checkDaemon once it's already running as a daemon, the fcntl locking
gotchas won't be a problem there.

Annex.LockFile has it's own separate lock pool layer, which has been
renamed to LockCache. This is a persistent cache of locks that persist
until closed.

This is not quite done; lockContent stil needs to be converted.

Annex.hs

@@ -57,7 +57,7 @@ import Types.Messages
 import Types.UUID
 import Types.FileMatcher
 import Types.NumCopies
-import Types.LockPool
+import Types.LockCache
 import Types.MetaData
 import Types.DesktopNotify
 import Types.CleanupActions
@@ -120,7 +120,7 @@ data AnnexState = AnnexState
 	, trustmap :: Maybe TrustMap
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
-	, lockpool :: LockPool
+	, lockcache :: LockCache
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
 	, modmeta :: [ModMeta]
@@ -166,7 +166,7 @@ newState c r = AnnexState
 	, trustmap = Nothing
 	, groupmap = Nothing
 	, ciphers = M.empty
-	, lockpool = M.empty
+	, lockcache = M.empty
 	, flags = M.empty
 	, fields = M.empty
 	, modmeta = []

Annex/Content.hs

@@ -58,7 +58,7 @@ import Annex.Perms
 import Annex.Link
 import Annex.Content.Direct
 import Annex.ReplaceFile
-import Utility.LockFile
+import Utility.LockPool
 import Messages.Progress
 
 {- Checks if a given key's content is currently present. -}

Annex/LockFile.hs

@@ -8,26 +8,26 @@
 {-# LANGUAGE CPP #-}
 
 module Annex.LockFile (
-	lockFileShared,
+	lockFileCached,
 	unlockFile,
-	getLockPool,
+	getLockCache,
 	withExclusiveLock,
 	tryExclusiveLock,
 ) where
 
 import Common.Annex
 import Annex
-import Types.LockPool
+import Types.LockCache
 import qualified Git
 import Annex.Perms
-import Utility.LockFile
+import Utility.LockPool
 
 import qualified Data.Map as M
 
 {- Create a specified lock file, and takes a shared lock, which is retained
- - in the pool. -}
+ - in the cache. -}
-lockFileShared :: FilePath -> Annex ()
+lockFileCached :: FilePath -> Annex ()
-lockFileShared file = go =<< fromLockPool file
+lockFileCached file = go =<< fromLockCache file
   where
 	go (Just _) = noop -- already locked
 	go Nothing = do
@@ -37,25 +37,25 @@ lockFileShared file = go =<< fromLockPool file
 #else
 		lockhandle <- liftIO $ waitToLock $ lockShared file
 #endif
-		changeLockPool $ M.insert file lockhandle
+		changeLockCache $ M.insert file lockhandle
 
 unlockFile :: FilePath -> Annex ()
-unlockFile file = maybe noop go =<< fromLockPool file
+unlockFile file = maybe noop go =<< fromLockCache file
   where
 	go lockhandle = do
 		liftIO $ dropLock lockhandle
-		changeLockPool $ M.delete file
+		changeLockCache $ M.delete file
 
-getLockPool :: Annex LockPool
+getLockCache :: Annex LockCache
-getLockPool = getState lockpool
+getLockCache = getState lockcache
 
-fromLockPool :: FilePath -> Annex (Maybe LockHandle)
+fromLockCache :: FilePath -> Annex (Maybe LockHandle)
-fromLockPool file = M.lookup file <$> getLockPool
+fromLockCache file = M.lookup file <$> getLockCache
 
-changeLockPool :: (LockPool -> LockPool) -> Annex ()
+changeLockCache :: (LockCache -> LockCache) -> Annex ()
-changeLockPool a = do
+changeLockCache a = do
-	m <- getLockPool
+	m <- getLockCache
-	changeState $ \s -> s { lockpool = a m }
+	changeState $ \s -> s { lockcache = a m }
 
 {- Runs an action with an exclusive lock held. If the lock is already
  - held, blocks until it becomes free. -}

Annex/Ssh.hs

@@ -37,7 +37,7 @@ import Types.CleanupActions
 import Annex.Index (addGitEnv)
 #ifndef mingw32_HOST_OS
 import Annex.Perms
-import Utility.LockFile
+import Utility.LockPool
 #endif
 
 {- Generates parameters to ssh to a given host (or user@host) on a given
@@ -126,13 +126,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 <$> getLockPool)
+	whenM (not . any isLock . M.keys <$> getLockCache)
 		sshCleanup
 	-- Cleanup at end of this run.
 	Annex.addCleanup SshCachingCleanup sshCleanup
 
 	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
-	lockFileShared $ socket2lock socketfile
+	lockFileCached $ socket2lock socketfile
 
 enumSocketFiles :: Annex [FilePath]
 enumSocketFiles = go =<< sshCacheDir

Annex/Transfer.hs

@@ -23,7 +23,7 @@ import Logs.Transfer as X
 import Annex.Notification as X
 import Annex.Perms
 import Utility.Metered
-import Utility.LockFile
+import Utility.LockPool
 
 import Control.Concurrent
 

Database/Fsck.hs

@@ -74,7 +74,7 @@ openDb u = do
 		liftIO $ do
 			void $ tryIO $ removeDirectoryRecursive dbdir
 			rename tmpdbdir dbdir
-	lockFileShared =<< fromRepo (gitAnnexFsckDbLock u)
+	lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)
 	h <- liftIO $ H.openDb db "fscked"
 	return $ FsckHandle h u
 

Logs/Transfer.hs

@@ -17,7 +17,7 @@ import Utility.Metered
 import Utility.Percentage
 import Utility.QuickCheck
 import Utility.PID
-import Utility.LockFile
+import Utility.LockPool
 import Logs.TimeStamp
 
 import Data.Time.Clock

Remote/Helper/Hooks.hs

@@ -16,7 +16,7 @@ import Types.Remote
 import Types.CleanupActions
 import qualified Annex
 import Annex.LockFile
-import Utility.LockFile
+import Utility.LockPool
 #ifndef mingw32_HOST_OS
 import Annex.Perms
 #endif
@@ -47,7 +47,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 <$> getLockPool) $ do
+	whenM (notElem lck . M.keys <$> getLockCache) $ do
 		liftIO $ createDirectoryIfMissing True dir
 		firstrun lck
 	a
@@ -62,7 +62,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.
-		lockFileShared lck
+		lockFileCached lck
 
 		-- The starthook is run even if some other git-annex
 		-- is already running, and ran it before.

Types/LockCache.hs

@@ -1,16 +1,16 @@
-{- git-annex lock pool data types
+{- git-annex lock cache data types
  - 
  - Copyright 2014 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Types.LockPool (
+module Types.LockCache (
-	LockPool,
+	LockCache,
 	LockHandle
 ) where
 
 import qualified Data.Map as M
-import Utility.LockFile
+import Utility.LockPool
 
-type LockPool = M.Map FilePath LockHandle
+type LockCache = M.Map FilePath LockHandle

Utility/LockFile.hs

@@ -4,6 +4,9 @@
  - This module does *not* attempt to be a portability shim, it just exposes
  - the native locking of the OS.
  -
+ - Posix fcntl locks have some gotchas. So, consider using
+ - Utility.LockPool instead of using this module directly.
+ -
  - Copyright 2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause

Utility/LockPool/Posix.hs

@@ -18,11 +18,9 @@ module Utility.LockPool.Posix (
 
 import qualified Utility.LockFile.Posix as F
 import qualified Utility.LockPool.STM as P
-import Utility.LockPool.STM (LockPool, LockFile, LockMode(..))
+import Utility.LockPool.STM (LockFile, LockMode(..))
 import Utility.LockPool.LockHandle
-import Utility.Monad
 
-import Control.Concurrent.STM
 import System.IO
 import System.Posix
 import Data.Maybe

Utility/LockPool/STM.hs

@@ -80,16 +80,15 @@ tryTakeLock pool file mode =
 --
 -- Note that the lock pool is left empty while the checker action is run.
 -- This allows checker actions that open/close files, and so would be in
--- danger of conflicting with existing locks. Since the lock pool is
+-- danger of conflicting with locks created at the same time this is
--- kept empty, anything that attempts to take a lock will block,
+-- running. With the lock pool empty, anything that attempts
--- avoiding that race.
+-- to take a lock will block, avoiding that race.
 getLockStatus :: LockPool -> LockFile -> IO v -> IO (Maybe v) -> IO (Maybe v)
 getLockStatus pool file getdefault checker = do
 	v <- atomically $ do
 		m <- takeTMVar pool
 		let threadlocked = case M.lookup file m of
-			Just (LockStatus _ n)
+			Just (LockStatus _ n) | n > 0 -> True
-				| n > 0 -> True
 			_ -> False
 		if threadlocked
 			then do

debian/changelog

@@ -23,6 +23,7 @@ git-annex (5.20150508.2) UNRELEASED; urgency=medium
     all refs used.
   * webapp: Fix zombie xdg-open process left when opening file browser.
     Closes: #785498
+  * Safer posix fctnl locking implementation, using lock pools and STM.
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 May 2015 12:45:06 -0400