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
|
{- git-annex assistant git merge thread
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
import Assistant.Sync
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import qualified Command.Sync
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let dir = Git.localGitDir g </> "refs"
liftIO $ createDirectoryIfMissing True dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
errhook <- hook onErr
let hooks = mkWatchHooks
{ addHook = changehook
, modifyHook = changehook
, errHook = errhook
}
void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching", dir]
type Handler = FilePath -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
onErr :: Handler
onErr = error
{- Called when a new branch ref is written, or a branch ref is modified.
-
- At startup, synthetic add events fire, causing this to run, but that's
- ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in.
-}
onChange :: Handler
onChange file
| ".lock" `isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate
when diverged $
queueDeferredDownloads "retrying deferred download" Later
| "/synced/" `isInfixOf` file =
mergecurrent =<< liftAnnex (join Command.Sync.getCurrBranch)
| otherwise = noop
where
changedbranch = fileToBranch file
mergecurrent currbranch@(Just b, _)
| equivBranches changedbranch b =
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
debug
[ "merging", Git.fromRef changedbranch
, "into", Git.fromRef b
]
void $ liftAnnex $ Command.Sync.merge
currbranch Command.Sync.mergeConfig
Git.Branch.AutomaticCommit
changedbranch
mergecurrent _ = noop
equivBranches :: Git.Ref -> Git.Ref -> Bool
equivBranches x y = base x == base y
where
base = takeFileName . Git.fromRef
isAnnexBranch :: FilePath -> Bool
isAnnexBranch f = n `isSuffixOf` f
where
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ "refs" </> base
where
base = Prelude.last $ split "/refs/" f
|
