summaryrefslogtreecommitdiff
path: root/Remote/Helper/Hooks.hs
blob: c3ff970c621e7baede592acf83f6396c8a3b2e90 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
{- Adds hooks to remotes.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Remote.Helper.Hooks (addHooks) where

import qualified Data.Map as M

import Common.Annex
import Types.Remote
import Types.CleanupActions
import qualified Annex
import Annex.LockFile
#ifndef mingw32_HOST_OS
import Annex.Perms
#else
import Utility.WinLock
#endif

{- Modifies a remote's access functions to first run the
 - annex-start-command hook, and trigger annex-stop-command on shutdown.
 - This way, the hooks are only run when a remote is actively being used.
 -}
addHooks :: Remote -> Remote
addHooks r = addHooks' r
	(remoteAnnexStartCommand $ gitconfig r)
	(remoteAnnexStopCommand $ gitconfig r)
addHooks' :: Remote -> Maybe String -> Maybe String -> Remote
addHooks' r Nothing Nothing = r
addHooks' r starthook stophook = r'
  where
	r' = r
		{ storeKey = \k f p -> wrapper $ storeKey r k f p
		, retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p
		, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
		, removeKey = wrapper . removeKey r
		, hasKey = wrapper . hasKey r
		}
	  where
		wrapper = runHooks r' starthook stophook

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
		liftIO $ createDirectoryIfMissing True dir
		firstrun lck
	a
  where
	remoteid = show (uuid r)
	run Nothing = noop
	run (Just command) = void $ liftIO $
		boolSystem "sh" [Param "-c", Param command]
	firstrun lck = do
		-- Take a shared lock; This indicates that git-annex
		-- is using the remote, and prevents other instances
		-- 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

		-- The starthook is run even if some other git-annex
		-- is already running, and ran it before.
		-- It would be difficult to use locking to ensure
		-- it's only run once, and it's also possible for
		-- git-annex to be interrupted before it can run the
		-- stophook, in which case the starthook
		-- would be run again by the next git-annex.
		-- So, requiring idempotency is the right approach.
		run starthook

		Annex.addCleanup (StopHook $ uuid r) $ runstop lck
	runstop lck = do
		-- Drop any shared lock we have, and take an
		-- exclusive lock, without blocking. If the lock
		-- succeeds, we're the only process using this remote,
		-- so can stop it.
		unlockFile lck
#ifndef mingw32_HOST_OS
		mode <- annexFileMode
		fd <- liftIO $ noUmask mode $
			openFd lck ReadWrite (Just mode) defaultFileFlags
		v <- liftIO $ tryIO $
			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
		case v of
			Left _ -> noop
			Right _ -> run stophook
		liftIO $ closeFd fd
#else
		v <- liftIO $ lockExclusive lck
		case v of
			Nothing -> noop
			Just lockhandle -> do
				run stophook
				liftIO $ dropLock lockhandle
#endif