1{- git-annex lock files. 2 - 3 - Copyright 2012-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP #-} 9 10module Annex.LockFile ( 11 lockFileCached, 12 unlockFile, 13 getLockCache, 14 fromLockCache, 15 withSharedLock, 16 withExclusiveLock, 17 takeExclusiveLock, 18 tryExclusiveLock, 19) where 20 21import Annex.Common 22import Annex 23import Types.LockCache 24import qualified Git 25import Annex.Perms 26import Annex.LockPool 27 28import qualified Data.Map as M 29import qualified System.FilePath.ByteString as P 30 31{- Create a specified lock file, and takes a shared lock, which is retained 32 - in the cache. -} 33lockFileCached :: RawFilePath -> Annex () 34lockFileCached file = go =<< fromLockCache file 35 where 36 go (Just _) = noop -- already locked 37 go Nothing = do 38#ifndef mingw32_HOST_OS 39 mode <- annexFileMode 40 lockhandle <- noUmask mode $ lockShared (Just mode) file 41#else 42 lockhandle <- liftIO $ waitToLock $ lockShared file 43#endif 44 changeLockCache $ M.insert file lockhandle 45 46unlockFile :: RawFilePath -> Annex () 47unlockFile file = maybe noop go =<< fromLockCache file 48 where 49 go lockhandle = do 50 liftIO $ dropLock lockhandle 51 changeLockCache $ M.delete file 52 53getLockCache :: Annex LockCache 54getLockCache = getState lockcache 55 56fromLockCache :: RawFilePath -> Annex (Maybe LockHandle) 57fromLockCache file = M.lookup file <$> getLockCache 58 59changeLockCache :: (LockCache -> LockCache) -> Annex () 60changeLockCache a = do 61 m <- getLockCache 62 changeState $ \s -> s { lockcache = a m } 63 64{- Runs an action with a shared lock held. If an exclusive lock is held, 65 - blocks until it becomes free. -} 66withSharedLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a 67withSharedLock getlockfile a = debugLocks $ do 68 lockfile <- fromRepo getlockfile 69 createAnnexDirectory $ P.takeDirectory lockfile 70 mode <- annexFileMode 71 bracket (lock mode lockfile) (liftIO . dropLock) (const a) 72 where 73#ifndef mingw32_HOST_OS 74 lock mode = noUmask mode . lockShared (Just mode) 75#else 76 lock _mode = liftIO . waitToLock . lockShared 77#endif 78 79{- Runs an action with an exclusive lock held. If the lock is already 80 - held, blocks until it becomes free. -} 81withExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a 82withExclusiveLock getlockfile a = bracket 83 (takeExclusiveLock getlockfile) 84 (liftIO . dropLock) 85 (const a) 86 87{- Takes an exclusive lock, blocking until it's free. -} 88takeExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex LockHandle 89takeExclusiveLock getlockfile = debugLocks $ do 90 lockfile <- fromRepo getlockfile 91 createAnnexDirectory $ P.takeDirectory lockfile 92 mode <- annexFileMode 93 lock mode lockfile 94 where 95#ifndef mingw32_HOST_OS 96 lock mode = noUmask mode . lockExclusive (Just mode) 97#else 98 lock _mode = liftIO . waitToLock . lockExclusive 99#endif 100 101{- Tries to take an exclusive lock and run an action. If the lock is 102 - already held, returns Nothing. -} 103tryExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex (Maybe a) 104tryExclusiveLock getlockfile a = debugLocks $ do 105 lockfile <- fromRepo getlockfile 106 createAnnexDirectory $ P.takeDirectory lockfile 107 mode <- annexFileMode 108 bracket (lock mode lockfile) (liftIO . unlock) go 109 where 110#ifndef mingw32_HOST_OS 111 lock mode = noUmask mode . tryLockExclusive (Just mode) 112#else 113 lock _mode = liftIO . lockExclusive 114#endif 115 unlock = maybe noop dropLock 116 go Nothing = return Nothing 117 go (Just _) = Just <$> a 118