diff options
Diffstat (limited to 'Command/NotifyChanges.hs')
-rw-r--r-- | Command/NotifyChanges.hs | 48 |
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 |