git-annex-shell: Added notifychanges command.
This will be used by the remote-daemon to quickly tell when changes have been pushed from some other repository into a ssh remote. Adjusted the remote-daemon protocol to communicate changed shas, rather than git branch refs. This way, it can easily check if a sha is new. This commit was sponsored by Carlos Trijueque Albarran.
This commit is contained in:
parent
e0b04f2e37
commit
0fbbec261d
8 changed files with 152 additions and 37 deletions
83
Command/NotifyChanges.hs
Normal file
83
Command/NotifyChanges.hs
Normal file
|
@ -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
|
Loading…
Add table
Add a link
Reference in a new issue