187b3e7780
Needs ghc 7.6.1, so minimum base version increased slightly. All builds are well above this version of ghc, and debian oldstable is as well. Code that could use lambdacase can be found by running: git grep -B 1 'case ' | less and searching in less for "<-" This commit was sponsored by andrea rota.
103 lines
3 KiB
Haskell
103 lines
3 KiB
Haskell
{- Waiting for changed git refs
|
|
-
|
|
- Copyright 2014-216 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.ChangedRefs
|
|
( ChangedRefs(..)
|
|
, ChangedRefsHandle
|
|
, waitChangedRefs
|
|
, drainChangedRefs
|
|
, stopWatchingChangedRefs
|
|
, watchChangedRefs
|
|
) where
|
|
|
|
import Annex.Common
|
|
import Utility.DirWatcher
|
|
import Utility.DirWatcher.Types
|
|
import qualified Git
|
|
import Git.Sha
|
|
import qualified Utility.SimpleProtocol as Proto
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.STM.TBMChan
|
|
|
|
newtype ChangedRefs = ChangedRefs [Git.Ref]
|
|
deriving (Show)
|
|
|
|
instance Proto.Serializable ChangedRefs where
|
|
serialize (ChangedRefs l) = unwords $ map Git.fromRef l
|
|
deserialize = Just . ChangedRefs . map Git.Ref . words
|
|
|
|
data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
|
|
|
|
-- | Wait for one or more git refs to change.
|
|
--
|
|
-- When possible, coalesce ref writes that occur closely together
|
|
-- in time. Delay up to 0.05 seconds to get more ref writes.
|
|
waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
|
|
waitChangedRefs (ChangedRefsHandle _ chan) =
|
|
atomically (readTBMChan chan) >>= \case
|
|
Nothing -> return $ ChangedRefs []
|
|
Just r -> do
|
|
threadDelay 50000
|
|
rs <- atomically $ loop []
|
|
return $ ChangedRefs (r:rs)
|
|
where
|
|
loop rs = tryReadTBMChan chan >>= \case
|
|
Just (Just r) -> loop (r:rs)
|
|
_ -> return rs
|
|
|
|
-- | Remove any changes that might be buffered in the channel,
|
|
-- without waiting for any new changes.
|
|
drainChangedRefs :: ChangedRefsHandle -> IO ()
|
|
drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
|
|
where
|
|
go = tryReadTBMChan chan >>= \case
|
|
Just (Just _) -> go
|
|
_ -> return ()
|
|
|
|
stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
|
|
stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
|
|
stopWatchDir wh
|
|
atomically $ closeTBMChan chan
|
|
drainChangedRefs h
|
|
|
|
watchChangedRefs :: Annex (Maybe ChangedRefsHandle)
|
|
watchChangedRefs = do
|
|
-- This channel is used to accumulate notifications,
|
|
-- because the DirWatcher might have multiple threads that find
|
|
-- changes at the same time. It is bounded to allow a watcher
|
|
-- to be started once and reused, without too many changes being
|
|
-- buffered in memory.
|
|
chan <- liftIO $ newTBMChanIO 100
|
|
|
|
g <- gitRepo
|
|
let refdir = Git.localGitDir g </> "refs"
|
|
liftIO $ createDirectoryIfMissing True refdir
|
|
|
|
let notifyhook = Just $ notifyHook chan
|
|
let hooks = mkWatchHooks
|
|
{ addHook = notifyhook
|
|
, modifyHook = notifyhook
|
|
}
|
|
|
|
if canWatch
|
|
then do
|
|
h <- liftIO $ watchDir refdir (const False) True hooks id
|
|
return $ Just $ ChangedRefsHandle h chan
|
|
else return Nothing
|
|
|
|
notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
|
|
notifyHook chan reffile _
|
|
| ".lock" `isSuffixOf` reffile = noop
|
|
| otherwise = void $ do
|
|
sha <- catchDefaultIO Nothing $
|
|
extractSha <$> readFile reffile
|
|
-- When the channel is full, there is probably no reader
|
|
-- running, or ref changes have been occuring very fast,
|
|
-- so it's ok to not write the change to it.
|
|
maybe noop (void . atomically . tryWriteTBMChan chan) sha
|