refactor ref change watching

Added to change notification to P2P protocol.

Switched to a TBChan so that a single long-running thread can be
started, and serve perhaps intermittent requests for change
notifications, without buffering all changes in memory.

The P2P runner currently starts up a new thread each times it waits
for a change, but that should allow later reusing a thread. Although
each connection from a peer will still need a new watcher thread to run.

The dependency on stm-chans is more or less free; some stuff in yesod
uses it, so it was already indirectly pulled in when building with the
webapp.

This commit was sponsored by Francois Marier on Patreon.
This commit is contained in:
Joey Hess 2016-12-09 14:52:38 -04:00
parent 596e1685a6
commit e152c322f8
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
9 changed files with 142 additions and 53 deletions

View file

@ -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