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