1{- Waiting for changed git refs
2 -
3 - Copyright 2014-2016 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Annex.ChangedRefs
11	( ChangedRefs(..)
12	, ChangedRefsHandle
13	, waitChangedRefs
14	, drainChangedRefs
15	, stopWatchingChangedRefs
16	, watchChangedRefs
17	) where
18
19import Annex.Common
20import Utility.DirWatcher
21import Utility.DirWatcher.Types
22import Utility.Directory.Create
23import qualified Git
24import Git.Sha
25import qualified Utility.SimpleProtocol as Proto
26
27import Control.Concurrent
28import Control.Concurrent.STM
29import Control.Concurrent.STM.TBMChan
30import qualified Data.ByteString as S
31import qualified System.FilePath.ByteString as P
32
33newtype ChangedRefs = ChangedRefs [Git.Ref]
34	deriving (Show)
35
36instance Proto.Serializable ChangedRefs where
37	serialize (ChangedRefs l) = unwords $ map Git.fromRef l
38	deserialize = Just . ChangedRefs . map (Git.Ref . encodeBS) . words
39
40data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
41
42-- | Wait for one or more git refs to change.
43--
44-- When possible, coalesce ref writes that occur closely together
45-- in time. Delay up to 0.05 seconds to get more ref writes.
46waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
47waitChangedRefs (ChangedRefsHandle _ chan) =
48	atomically (readTBMChan chan) >>= \case
49		Nothing -> return $ ChangedRefs []
50		Just r -> do
51			threadDelay 50000
52			rs <- atomically $ loop []
53			return $ ChangedRefs (r:rs)
54  where
55	loop rs = tryReadTBMChan chan >>= \case
56		Just (Just r) -> loop (r:rs)
57		_ -> return rs
58
59-- | Remove any changes that might be buffered in the channel,
60-- without waiting for any new changes.
61drainChangedRefs :: ChangedRefsHandle -> IO ()
62drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
63  where
64	go = tryReadTBMChan chan >>= \case
65		Just (Just _) -> go
66		_ -> return ()
67
68stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
69stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
70	stopWatchDir wh
71	atomically $ closeTBMChan chan
72	drainChangedRefs h
73
74watchChangedRefs :: Annex (Maybe ChangedRefsHandle)
75watchChangedRefs = do
76	-- This channel is used to accumulate notifications,
77	-- because the DirWatcher might have multiple threads that find
78	-- changes at the same time. It is bounded to allow a watcher
79	-- to be started once and reused, without too many changes being
80	-- buffered in memory.
81	chan <- liftIO $ newTBMChanIO 100
82
83	g <- gitRepo
84	let gittop = Git.localGitDir g
85	let refdir = gittop P.</> "refs"
86	liftIO $ createDirectoryUnder gittop refdir
87
88	let notifyhook = Just $ notifyHook chan
89	let hooks = mkWatchHooks
90		{ addHook = notifyhook
91		, modifyHook = notifyhook
92		}
93
94	if canWatch
95		then do
96			h <- liftIO $ watchDir
97				(fromRawFilePath refdir)
98				(const False) True hooks id
99			return $ Just $ ChangedRefsHandle h chan
100		else return Nothing
101
102notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
103notifyHook chan reffile _
104	| ".lock" `isSuffixOf` reffile = noop
105	| otherwise = void $ do
106		sha <- catchDefaultIO Nothing $
107			extractSha <$> S.readFile reffile
108		-- When the channel is full, there is probably no reader
109		-- running, or ref changes have been occuring very fast,
110		-- so it's ok to not write the change to it.
111		maybe noop (void . atomically . tryWriteTBMChan chan) sha
112