0a4d301051
This was a bug, but it was only used for ssh locks and by the hook special remote locking. At least in the case of ssh locks, the lock files happened to already exist before this tried to use them, so the bug didn't cause anything to break.
88 lines
2.2 KiB
Haskell
88 lines
2.2 KiB
Haskell
{- 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.Perms
|
|
|
|
import qualified Data.Map as M
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
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 ReadWrite (Just mode) defaultFileFlags
|
|
liftIO $ setFdOption lockhandle CloseOnExec True
|
|
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
|
|
setFdOption l CloseOnExec True
|
|
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
|
|
return l
|
|
unlock = closeFd
|
|
#else
|
|
lock lockfile _mode = waitToLock $ lockExclusive lockfile
|
|
unlock = dropLock
|
|
#endif
|