summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex.hs6
-rw-r--r--Annex/Content.hs2
-rw-r--r--Annex/LockFile.hs36
-rw-r--r--Annex/Ssh.hs6
-rw-r--r--Annex/Transfer.hs2
-rw-r--r--Database/Fsck.hs2
-rw-r--r--Logs/Transfer.hs2
-rw-r--r--Remote/Helper/Hooks.hs6
-rw-r--r--Types/LockCache.hs (renamed from Types/LockPool.hs)10
-rw-r--r--Utility/LockFile.hs3
-rw-r--r--Utility/LockPool/Posix.hs4
-rw-r--r--Utility/LockPool/STM.hs9
-rw-r--r--debian/changelog1
13 files changed, 45 insertions, 44 deletions
diff --git a/Annex.hs b/Annex.hs
index b0ebd81ae..2c0d65ee6 100644
--- a/Annex.hs
+++ b/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 = []
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 2b11f1baf..801bbdef2 100644
--- a/Annex/Content.hs
+++ b/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. -}
diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs
index 62a101aa5..928b36ec5 100644
--- a/Annex/LockFile.hs
+++ b/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. -}
-lockFileShared :: FilePath -> Annex ()
-lockFileShared file = go =<< fromLockPool file
+ - in the cache. -}
+lockFileCached :: FilePath -> Annex ()
+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
-getLockPool = getState lockpool
+getLockCache :: Annex LockCache
+getLockCache = getState lockcache
-fromLockPool :: FilePath -> Annex (Maybe LockHandle)
-fromLockPool file = M.lookup file <$> getLockPool
+fromLockCache :: FilePath -> Annex (Maybe LockHandle)
+fromLockCache file = M.lookup file <$> getLockCache
-changeLockPool :: (LockPool -> LockPool) -> Annex ()
-changeLockPool a = do
- m <- getLockPool
- changeState $ \s -> s { lockpool = a m }
+changeLockCache :: (LockCache -> LockCache) -> Annex ()
+changeLockCache a = do
+ m <- getLockCache
+ 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. -}
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index cd28d1fc0..627c04532 100644
--- a/Annex/Ssh.hs
+++ b/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
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 2511ae436..a2bac34be 100644
--- a/Annex/Transfer.hs
+++ b/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
diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index 50c08cf61..d9416927b 100644
--- a/Database/Fsck.hs
+++ b/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
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 244e9f375..ef1db879c 100644
--- a/Logs/Transfer.hs
+++ b/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
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index 53bb370a6..1f46eaa4b 100644
--- a/Remote/Helper/Hooks.hs
+++ b/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.
diff --git a/Types/LockPool.hs b/Types/LockCache.hs
index 803822042..c1f394cf0 100644
--- a/Types/LockPool.hs
+++ b/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 (
- LockPool,
+module Types.LockCache (
+ 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
diff --git a/Utility/LockFile.hs b/Utility/LockFile.hs
index f9a0e6783..1d924fc1e 100644
--- a/Utility/LockFile.hs
+++ b/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
diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs
index e460272f2..e05ab9754 100644
--- a/Utility/LockPool/Posix.hs
+++ b/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
diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs
index a60bbc7bf..f422c8a73 100644
--- a/Utility/LockPool/STM.hs
+++ b/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
--- kept empty, anything that attempts to take a lock will block,
--- avoiding that race.
+-- danger of conflicting with locks created at the same time this is
+-- running. With the lock pool empty, anything that attempts
+-- 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)
- | n > 0 -> True
+ Just (LockStatus _ n) | n > 0 -> True
_ -> False
if threadlocked
then do
diff --git a/debian/changelog b/debian/changelog
index 77477078c..104648315 100644
--- a/debian/changelog
+++ b/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