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
|
{- 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
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 -> 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
h <- inRepo hashObjectStart
treesha <- adjustTree (adjustTreeItem adj h) origbranch =<< Annex.gitRepo
liftIO $ hashObjectStop h
commitsha <- commitAdjustedTree treesha origbranch
inRepo $ Git.Branch.update adjbranch commitsha
return adjbranch
where
adjbranch = originalToAdjusted origbranch adj
{- 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 = do
error "updateAdjustedBranch"
|
