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
|
{- adjusted version of main branch
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.AdjustedBranch (
Adjustment(..),
OrigBranch,
AdjBranch,
adjustedToOriginal,
enterAdjustedBranch,
updateAdjustedBranch,
) where
import Annex.Common
import qualified Annex
import Git.Types
import qualified Git.Branch
import qualified Git.Ref
import qualified Git.Command
import Git.Tree
import Git.Env
import Annex.CatFile
import Annex.Link
import Git.HashObject
import Annex.AutoMerge
import qualified Database.Keys
data Adjustment = UnlockAdjustment
deriving (Show)
adjustTreeItem :: Adjustment -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem)
adjustTreeItem UnlockAdjustment h ti@(TreeItem f m s)
| toBlobType m == Just SymlinkBlob = do
mk <- catKey s
case mk of
Just k -> do
Database.Keys.addAssociatedFile k f
Just . TreeItem f (fromBlobType FileBlob)
<$> hashPointerFile' h k
Nothing -> return (Just ti)
| otherwise = return (Just ti)
type OrigBranch = Branch
type AdjBranch = Branch
adjustedBranchPrefix :: String
adjustedBranchPrefix = "refs/heads/adjusted/"
serialize :: Adjustment -> String
serialize UnlockAdjustment = "unlock"
deserialize :: String -> Maybe Adjustment
deserialize "unlock" = Just UnlockAdjustment
deserialize _ = Nothing
originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
originalToAdjusted orig adj = Git.Ref.under base orig
where
base = adjustedBranchPrefix ++ serialize adj
adjustedToOriginal :: AdjBranch -> Maybe (Adjustment, OrigBranch)
adjustedToOriginal b
| adjustedBranchPrefix `isPrefixOf` bs = do
adj <- deserialize (takeWhile (/= '/') (drop prefixlen bs))
Just (adj, Git.Ref.basename b)
| otherwise = Nothing
where
bs = fromRef b
prefixlen = length adjustedBranchPrefix
originalBranch :: Annex (Maybe OrigBranch)
originalBranch = fmap getorig <$> inRepo Git.Branch.current
where
getorig currbranch = maybe currbranch snd (adjustedToOriginal currbranch)
{- Enter an adjusted version of current branch (or, if already in an
- adjusted version of a branch, changes the adjustment of the original
- branch).
-
- Can fail, if no branch is checked out, or perhaps if staged changes
- conflict with the adjusted branch.
-}
enterAdjustedBranch :: Adjustment -> Annex ()
enterAdjustedBranch adj = go =<< originalBranch
where
go (Just origbranch) = do
adjbranch <- adjustBranch adj origbranch
inRepo $ Git.Command.run
[ Param "checkout"
, Param $ fromRef $ Git.Ref.base $ adjbranch
]
go Nothing = error "not on any branch!"
adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch
adjustBranch adj origbranch = do
sha <- adjust adj origbranch
inRepo $ Git.Branch.update adjbranch sha
return adjbranch
where
adjbranch = originalToAdjusted origbranch adj
adjust :: Adjustment -> Ref -> Annex Sha
adjust adj orig = do
h <- inRepo hashObjectStart
treesha <- adjustTree (adjustTreeItem adj h) orig =<< Annex.gitRepo
liftIO $ hashObjectStop h
commitAdjustedTree treesha orig
{- Commits a given adjusted tree, with the provided parent ref.
-
- This should always yield the same value, even if performed in different
- clones of a repo, at different times. The commit message and other
- metadata is based on the parent.
-}
commitAdjustedTree :: Sha -> Ref -> Annex Sha
commitAdjustedTree treesha parent = go =<< catCommit parent
where
go Nothing = inRepo mkcommit
go (Just parentcommit) = inRepo $ commitWithMetaData
(commitAuthorMetaData parentcommit)
(commitCommitterMetaData parentcommit)
mkcommit
mkcommit = Git.Branch.commitTree
Git.Branch.AutomaticCommit "adjusted branch" [parent] treesha
{- Update the currently checked out adjusted branch, merging the provided
- branch into it. -}
updateAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Git.Branch.CommitMode -> Annex Bool
updateAdjustedBranch tomerge (origbranch, adj) commitmode =
go =<< (,)
<$> inRepo (Git.Ref.sha tomerge)
<*> inRepo Git.Branch.current
where
go (Just mergesha, Just currbranch) = ifM (inRepo $ Git.Branch.changed currbranch mergesha)
( do
propigateAdjustedCommits origbranch adj
adjustedtomerge <- adjust adj mergesha
ifM (inRepo $ Git.Branch.changed currbranch adjustedtomerge)
( ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
( recommit currbranch mergesha =<< catCommit currbranch
, return False
)
, return True -- no changes to merge
)
, return True -- no changes to merge
)
go _ = return False
{- Once a merge commit has been made, re-do it, removing
- the old version of the adjusted branch as a parent, and
- making the only parent be the branch that was merged in.
-
- Doing this ensures that the same commit Sha is
- always arrived at for a given commit from the merged in branch.
-}
recommit currbranch parent (Just commit) = do
commitsha <- commitAdjustedTree (commitTree commit) parent
inRepo $ Git.Branch.update currbranch commitsha
return True
recommit _ _ Nothing = return False
{- Check for any commits present on the adjusted branch that have not yet
- been propigated to the master branch, and propigate them. -}
propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex ()
propigateAdjustedCommits originbranch adj = return () -- TODO
|
