pid locking configuration and abstraction layer for git-annex

(not actually used anywhere yet)

Annex/LockPool.hs

@@ -0,0 +1,17 @@
+{- Wraps Utility.LockPool, making pid locks be used when git-annex is so
+ - configured.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.LockPool (module X) where
+
+#ifndef mingw32_HOST_OS
+import Annex.LockPool.PosixOrPid as X
+#else
+import Utility.LockPool.Windows as X
+#endif

Annex/LockPool/PosixOrPid.hs

@@ -0,0 +1,74 @@
+{- Wraps Utility.LockPool, making pid locks be used when git-annex is so
+ - configured.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.LockPool.PosixOrPid where
+
+import Common.Annex
+import qualified Annex
+import qualified Utility.LockPool.Posix as Posix
+import qualified Utility.LockPool.PidLock as Pid
+import Utility.LockFile.Posix (openLockFile)
+import Utility.LockPool.STM (LockFile)
+import Utility.LockPool.LockHandle
+import Utility.LockFile.LockStatus
+
+import System.Posix
+
+lockShared :: Maybe FileMode -> LockFile -> Annex LockHandle
+lockShared m f = pidLock m f $ Posix.lockShared m f
+
+lockExclusive :: Maybe FileMode -> LockFile -> Annex LockHandle
+lockExclusive m f = pidLock m f $ Posix.lockExclusive m f
+
+tryLockShared :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)
+tryLockShared m f = tryPidLock m f $ Posix.tryLockShared m f
+
+tryLockExclusive :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)
+tryLockExclusive m f = tryPidLock m f $ Posix.tryLockExclusive m f
+
+checkLocked :: LockFile -> Annex (Maybe Bool)
+checkLocked f = Posix.checkLocked f
+	`pidLockCheck` Pid.checkLocked
+
+getLockStatus :: LockFile -> Annex LockStatus
+getLockStatus f = Posix.getLockStatus f
+	`pidLockCheck` Pid.getLockStatus
+
+pidLockFile :: Annex (Maybe FilePath)
+pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
+	( Just <$> fromRepo gitAnnexPidLockFile
+	, pure Nothing
+	)
+
+pidLockCheck :: IO a -> (LockFile -> IO a) -> Annex a
+pidLockCheck posixcheck pidcheck = 
+	liftIO . maybe posixcheck pidcheck =<< pidLockFile
+
+pidLock :: Maybe FileMode -> LockFile -> IO LockHandle -> Annex LockHandle
+pidLock m f posixlock = go =<< pidLockFile
+  where
+	go Nothing = liftIO posixlock
+	go (Just pidlock) = do
+		timeout <- annexPidLockTimeout <$> Annex.getGitConfig
+		liftIO $ do
+			dummyPosixLock m f
+			Pid.waitLock timeout pidlock
+
+tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)
+tryPidLock m f posixlock = liftIO . go =<< pidLockFile
+  where
+	go Nothing = posixlock
+	go (Just pidlock) = do
+		dummyPosixLock m f
+		Pid.tryLock pidlock
+
+-- The posix lock file is created even when using pid locks, in order to
+-- avoid complicating any code that might expect to be able to see that
+-- lock file.
+dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()
+dummyPosixLock m f = closeFd =<< openLockFile ReadLock m f

Locations.hs

@@ -51,6 +51,7 @@ module Locations (
 	gitAnnexViewLog,
 	gitAnnexIgnoredRefs,
 	gitAnnexPidFile,
+	gitAnnexPidLockFile,
 	gitAnnexDaemonStatusFile,
 	gitAnnexLogFile,
 	gitAnnexFuzzTestLogFile,
@@ -334,6 +335,10 @@ gitAnnexIgnoredRefs r = gitAnnexDir r </> "ignoredrefs"
 gitAnnexPidFile :: Git.Repo -> FilePath
 gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid"
 
+{- Pid lock file for pidlock mode -}
+gitAnnexPidLockFile :: Git.Repo -> FilePath
+gitAnnexPidLockFile r = gitAnnexDir r </> "pidlock"
+
 {- Status file for daemon mode. -}
 gitAnnexDaemonStatusFile :: Git.Repo -> FilePath
 gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"

Types/GitConfig.hs

@@ -1,6 +1,6 @@
 {- git-annex configuration
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -26,6 +26,7 @@ import Types.Difference
 import Types.RefSpec
 import Utility.HumanTime
 import Utility.Gpg (GpgCmd, mkGpgCmd)
+import Utility.ThreadScheduler (Seconds(..))
 
 {- Main git-annex settings. Each setting corresponds to a git-config key
  - such as annex.foo -}
@@ -62,6 +63,8 @@ data GitConfig = GitConfig
 	, annexDifferences :: Differences
 	, annexUsedRefSpec :: Maybe RefSpec
 	, annexVerify :: Bool
+	, annexPidLock :: Bool
+	, annexPidLockTimeout :: Seconds
 	, coreSymlinks :: Bool
 	, coreSharedRepository :: SharedRepository
 	, gcryptId :: Maybe String
@@ -105,6 +108,9 @@ extractGitConfig r = GitConfig
 	, annexUsedRefSpec = either (const Nothing) Just . parseRefSpec 
 		=<< getmaybe (annex "used-refspec")
 	, annexVerify = getbool (annex "verify") True
+	, annexPidLock = getbool (annex "pidlock") False
+	, annexPidLockTimeout = Seconds $ fromMaybe 300 $
+		getmayberead (annex "pidlocktimeout")
 	, coreSymlinks = getbool "core.symlinks" True
 	, coreSharedRepository = getSharedRepository r
 	, gcryptId = getmaybe "core.gcrypt-id"

Utility/LockFile/Posix.hs

@@ -16,6 +16,8 @@ module Utility.LockFile.Posix (
 	LockStatus(..),
 	dropLock,
 	checkSaneLock,
+	LockRequest(..),
+	openLockFile,
 ) where
 
 import Utility.Exception

debian/changelog

@@ -27,6 +27,8 @@ git-annex (5.20151102.2) UNRELEASED; urgency=medium
     dead repo.
   * assistant: Pass ssh-options through 3 more git pull/push calls
     that were missed before.
+  * Added annex.pidlock and annex.pidlocktimeout configuration to support
+    filesystems where POSIX fcntl locks cannot be used.
 
  -- Joey Hess <id@joeyh.name>  Wed, 04 Nov 2015 12:50:20 -0400
 

doc/git-annex.mdwn

@@ -965,6 +965,30 @@ Here are all the supported configuration settings.
   which does not support symbolic links, or hard links, or unix permissions.
   This is automatically probed by "git annex init".
 
+* `annex.pidlock`
+
+  Normally, git-annex uses fine-grained lock files to allow multiple
+  processes to run concurrently without getting in each others' way.
+  That works great, unless you are using git-annex on a filesystem that
+  does not support POSIX fcntl locks. This is sometimes the case when
+  using NFS or Lustre filesystems. 
+  
+  To support such situations, you can set annex.pidlock to true, and it
+  will fall back to a single top-level pid file lock.
+
+  (Although, often, you'd really be better off fixing your networked
+  filesystem configuration to support POSIX locks..)
+
+* `annex.pidlocktimeout`
+
+  When using pid lock files, it's possible for a stale lock file to get
+  left behind by previous run of git-annex that crashed or was interrupted.
+  This is mostly avoided, but can occur especially when using a network
+  file system.
+
+  git-annex will wait up to this many seconds for the pid lock
+  file to go away, and will then abort if it cannot continue. Default: 300
+
 * `remote.<name>.annex-cost`
 
   When determining which repository to