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