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
|
{- git-annex assistant git merge thread
-
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
import Assistant.Sync
import Utility.DirWatcher
import Utility.DirWatcher.Types
import Utility.Directory.Create
import Annex.CurrentBranch
import Assistant.Commits
import qualified Annex
import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import qualified Git.Ref
import qualified Command.Sync
import qualified Utility.OsString as OS
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let gitd = Git.localGitDir g
let dir = gitd </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gitd] 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", fromOsPath dir]
type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler t -> t -> 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 String
onErr = giveup
{- 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 OsPath
onChange file
| literalOsPath ".lock" `OS.isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
u@(Annex.Branch.UpdateMade {}) -> Annex.Branch.refsWereMerged u
(Annex.Branch.UpdateFailedPermissions {}) -> True
when diverged $ do
updateExportTreeFromLogAll
queueDeferredDownloads "retrying deferred download" Later
| otherwise = mergecurrent
where
changedbranch = fileToBranch file
mergecurrent =
mergecurrent' =<< liftAnnex getCurrentBranch
mergecurrent' currbranch@(Just b, _)
| changedbranch `isRelatedTo` b = do
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
debug
[ "merging", Git.fromRef changedbranch
, "into", Git.fromRef b
]
void $ liftAnnex $ do
cmode <- annexCommitMode <$> Annex.getGitConfig
-- Allow merging unrelated histories.
mc <- Command.Sync.mergeConfig True
Command.Sync.merge
currbranch
mc
def
cmode
[changedbranch]
recordCommit
| changedbranch == b =
-- Record commit so the pusher pushes it out.
-- This makes sure pushes happen when
-- annex.autocommit=false
recordCommit
mergecurrent' _ = noop
{- Is the first branch a synced branch or remote tracking branch related
- to the second branch, which should be merged into it? -}
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
isRelatedTo x y
| basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False
| "/synced/" `isInfixOf` Git.fromRef x = True
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
| otherwise = False
where
basex = Git.fromRef $ Git.Ref.base x
basey = Git.fromRef $ Git.Ref.base y
isAnnexBranch :: OsPath -> Bool
isAnnexBranch f = n `isSuffixOf` fromOsPath f
where
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: OsPath -> Git.Ref
fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" </> toOsPath base
where
base = Prelude.last $ split "/refs/" (fromOsPath f)
|
