blob: f1c149d542cbe1c8b0261d5619cc716145f20160 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
{- git-annex-shell command
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.NotifyChanges where
import Command
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Git
import Git.Sha
import RemoteDaemon.Transport.Ssh.Types
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
cmd :: Command
cmd = noCommit $
command "notifychanges" SectionPlumbing
"sends notification when git refs are changed"
paramNothing (withParams seek)
seek :: CmdParams -> 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
|
