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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{- git-annex command
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module Command.Watch where
import Common.Annex
import Command
#if defined linux_HOST_OS
import Utility.Inotify
#endif
import Utility.ThreadLock
import qualified Annex
import qualified Annex.Queue
import qualified Command.Add
import qualified Git.Command
import qualified Git.UpdateIndex
import qualified Backend
import Annex.Content
import Control.Concurrent
#if defined linux_HOST_OS
import System.INotify
#endif
def :: [Command]
def = [command "watch" paramPaths seek "watch for changes"]
seek :: [CommandSeek]
seek = [withNothing start]
start :: CommandStart
#if defined linux_HOST_OS
start = notBareRepo $ do
showStart "watch" "."
showAction "scanning"
inRepo $ Git.Command.run "add" [Param "--update"]
next $ next $ withStateMVar $ \mvar -> liftIO $ withINotify $ \i -> do
let hook a = Just $ runHook mvar a
let hooks = WatchHooks
{ addHook = hook onAdd
, delHook = hook onDel
, addSymlinkHook = hook onAddSymlink
, delDirHook = hook onDelDir
, errHook = hook onErr
}
watchDir i "." (ignored . takeFileName) hooks
_ <- forkIO $ commitThread mvar
putStrLn "(started)"
waitForTermination
return True
#else
start = error "watch mode is so far only available on Linux"
#endif
ignored :: FilePath -> Bool
ignored ".git" = True
ignored ".gitignore" = True
ignored ".gitattributes" = True
ignored _ = False
{- Stores the Annex state in a MVar, so that threaded actions can access
- it.
-
- Once the action is finished, retrieves the state from the MVar.
-}
withStateMVar :: (MVar Annex.AnnexState -> Annex a) -> Annex a
withStateMVar a = do
state <- Annex.getState id
mvar <- liftIO $ newMVar state
r <- a mvar
newstate <- liftIO $ takeMVar mvar
Annex.changeState (const newstate)
return r
{- Runs an Annex action, using the state from the MVar. -}
runStateMVar :: MVar Annex.AnnexState -> Annex () -> IO ()
runStateMVar mvar a = do
startstate <- takeMVar mvar
!newstate <- Annex.exec startstate a
putMVar mvar newstate
{- Runs a hook, inside the Annex monad.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
runHook :: MVar Annex.AnnexState -> (FilePath -> Annex ()) -> FilePath -> IO ()
runHook mvar a f = handle =<< tryIO (runStateMVar mvar go)
where
go = do
a f
Annex.Queue.flushWhenFull
handle (Right ()) = return ()
handle (Left e) = putStrLn $ show e
{- Adding a file is tricky; the file has to be replaced with a symlink
- but this is race prone, as the symlink could be changed immediately
- after creation. To avoid that race, git add is not used to stage the
- symlink. -}
onAdd :: FilePath -> Annex ()
onAdd file = do
showStart "add" file
Command.Add.ingest file >>= go
where
go Nothing = showEndFail
go (Just key) = do
link <- Command.Add.link file key True
stageSymlink file link
showEndOk
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
- before adding it.
-}
onAddSymlink :: FilePath -> Annex ()
onAddSymlink file = go =<< Backend.lookupFile file
where
go Nothing = addlink =<< liftIO (readSymbolicLink file)
go (Just (key, _)) = do
link <- calcGitLink file key
ifM ((==) link <$> liftIO (readSymbolicLink file))
( addlink link
, do
liftIO $ removeFile file
liftIO $ createSymbolicLink link file
addlink link
)
addlink link = stageSymlink file link
onDel :: FilePath -> Annex ()
onDel file = Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file)
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
- use --cached to only delete it from the index.
-
- Note: This could use unstageFile, but would need to run another git
- command to get the recursive list of files in the directory, so rm is
- just as good. -}
onDelDir :: FilePath -> Annex ()
onDelDir dir = Annex.Queue.addCommand "rm"
[Params "--quiet -r --cached --ignore-unmatch --"] [dir]
{- Called when there's an error with inotify. -}
onErr :: String -> Annex ()
onErr = warning
{- Adds a symlink to the index, without ever accessing the actual symlink
- on disk. -}
stageSymlink :: FilePath -> String -> Annex ()
stageSymlink file linktext =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file linktext)
{- This thread wakes up periodically and makes git commits. -}
commitThread :: MVar Annex.AnnexState -> IO ()
commitThread mvar = forever $ do
threadDelay 1000000 -- 1 second
commit
where
commit = tryIO $ runStateMVar mvar $
whenM ((>) <$> Annex.Queue.size <*> pure 0) $ do
Annex.Queue.flush
{- Empty commits may be made if tree
- changes cancel each other out, etc. -}
inRepo $ Git.Command.run "commit"
[ Param "--allow-empty-message"
, Param "-m", Param ""
, Param "--allow-empty"
, Param "--quiet"
]
|
