diff options
Diffstat (limited to 'Command/NotifyChanges.hs')
-rw-r--r-- | Command/NotifyChanges.hs | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs new file mode 100644 index 000000000..a1a076718 --- /dev/null +++ b/Command/NotifyChanges.hs @@ -0,0 +1,83 @@ +{- git-annex-shell command + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.NotifyChanges where + +import Common.Annex +import Command +import Utility.DirWatcher +import Utility.DirWatcher.Types +import qualified Git +import Git.Sha +import RemoteDaemon.EndPoint.GitAnnexShell.Types + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM + +def :: [Command] +def = [noCommit $ command "notifychanges" paramNothing seek SectionPlumbing + "sends notification when git refs are changed"] + +seek :: CommandSeek +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 + + 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 $ getLine + void $ liftIO $ concurrently sender receiver + 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 + hFlush stdout |