summaryrefslogtreecommitdiff
path: root/Command/NotifyChanges.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Command/NotifyChanges.hs')
-rw-r--r--Command/NotifyChanges.hs48
1 files changed, 6 insertions, 42 deletions
diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs
index bb9b10eee..83d7bca3f 100644
--- a/Command/NotifyChanges.hs
+++ b/Command/NotifyChanges.hs
@@ -8,6 +8,7 @@
module Command.NotifyChanges where
import Command
+import Annex.ChangedRefs
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Git
@@ -30,55 +31,18 @@ seek = withNothing start
start :: CommandStart
start = do
- -- This channel is used to accumulate notifcations,
- -- because the DirWatcher might have multiple threads that find
- -- changes at the same time.
- chan <- liftIO newTChanIO
-
- g <- gitRepo
- let refdir = Git.localGitDir g </> "refs"
- liftIO $ createDirectoryIfMissing True refdir
+ h <- watchChangedRefs
- let notifyhook = Just $ notifyHook chan
- let hooks = mkWatchHooks
- { addHook = notifyhook
- , modifyHook = notifyhook
- }
-
- void $ liftIO $ watchDir refdir (const False) True hooks id
-
- let sender = do
- send READY
- forever $ send . CHANGED =<< drain chan
-
-- No messages need to be received from the caller,
-- but when it closes the connection, notice and terminate.
let receiver = forever $ void $ getProtocolLine stdin
+ let sender = forever $ send . CHANGED =<< waitChangedRefs h
+
+ liftIO $ send READY
void $ liftIO $ concurrently sender receiver
+ liftIO $ stopWatchingChangedRefs h
stop
-notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
-notifyHook chan reffile _
- | ".lock" `isSuffixOf` reffile = noop
- | otherwise = void $ do
- sha <- catchDefaultIO Nothing $
- extractSha <$> readFile reffile
- maybe noop (atomically . writeTChan chan) sha
-
--- When possible, coalesce ref writes that occur closely together
--- in time. Delay up to 0.05 seconds to get more ref writes.
-drain :: TChan Git.Sha -> IO [Git.Sha]
-drain chan = do
- r <- atomically $ readTChan chan
- threadDelay 50000
- rs <- atomically $ drain' chan
- return (r:rs)
-
-drain' :: TChan Git.Sha -> STM [Git.Sha]
-drain' chan = loop []
- where
- loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan
-
send :: Notification -> IO ()
send n = do
putStrLn $ unwords $ formatMessage n