afb3e3e472
Turns out sqlite does not like having its database deleted out from underneath it. It might suffice to empty the table, but I would rather start each fsck over with a new database, so I added a lock file, and running incremental fscks use a shared lock. This leaves one concurrency bug left; running two concurrent fsck --more will lead to: "SQLite3 returned ErrorBusy while attempting to perform step." and one or both will fail. This is a concurrent writers problem.
91 lines
2.4 KiB
Haskell
91 lines
2.4 KiB
Haskell
{- git-annex lock files.
|
|
-
|
|
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Annex.LockFile (
|
|
lockFileShared,
|
|
unlockFile,
|
|
getLockPool,
|
|
withExclusiveLock,
|
|
tryExclusiveLock,
|
|
) where
|
|
|
|
import Common.Annex
|
|
import Annex
|
|
import Types.LockPool
|
|
import qualified Git
|
|
import Annex.Perms
|
|
import Utility.LockFile
|
|
|
|
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
|
|
where
|
|
go (Just _) = noop -- already locked
|
|
go Nothing = do
|
|
#ifndef mingw32_HOST_OS
|
|
mode <- annexFileMode
|
|
lockhandle <- liftIO $ noUmask mode $ lockShared (Just mode) file
|
|
#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
|
|
liftIO $ dropLock lockhandle
|
|
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 mode lockfile) dropLock (const a)
|
|
where
|
|
#ifndef mingw32_HOST_OS
|
|
lock mode = noUmask mode . lockExclusive (Just mode)
|
|
#else
|
|
lock _mode = waitToLock . lockExclusive
|
|
#endif
|
|
|
|
{- Tries to take an exclusive lock and run an action. If the lock is
|
|
- already held, returns Nothing. -}
|
|
tryExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex (Maybe a)
|
|
tryExclusiveLock getlockfile a = do
|
|
lockfile <- fromRepo getlockfile
|
|
createAnnexDirectory $ takeDirectory lockfile
|
|
mode <- annexFileMode
|
|
bracketIO (lock mode lockfile) unlock go
|
|
where
|
|
#ifndef mingw32_HOST_OS
|
|
lock mode = noUmask mode . tryLockExclusive (Just mode)
|
|
#else
|
|
lock _mode = lockExclusive
|
|
#endif
|
|
unlock = maybe noop dropLock
|
|
go Nothing = return Nothing
|
|
go (Just _) = Just <$> a
|