| By | fr33domlover |
| At | 2016-04-20 |
| Title | Implemen tag peeling in RefDiscover |
| Description |
Edit file src/Network/Git/Fetch/RefDiscovery.hs 0 → 0
+ 42 --
+ 43 -- But what's a peeled tag?
+ 44 --
+ 45 -- In Git, there are lightweight tags and annotated tags. A lightweight tag
+ 46 -- is just a named reference to a commit. An annotated tag is a Git object
+ 47 -- with a date, an author, its own SHA1, optional GPG signature and a
+ 48 -- pointer to a commit.
+ 49 --
+ 50 -- For a given tag symref /refs/tags/T which refers to a tag object, i.e.
+ 51 -- an annotated tag, its peeled tag /refs/tags/T^{} refers to the commit to+ 52 -- which T points. But you won't find the peeled tag in the actual Git
+ 53 -- repo: It's just a way for us to advertise the tagged commit in the Git
+ 54 -- protocol.
… … … … + 143 listHelper
+ 144 :: (Git -> IO (S.Set RefName))
+ 145 -> ByteString
+ 146 -> Git
+ 147 -> IO [(ObjId, ByteString)]
+ 148 listHelper get prefix git = do
+ 149 names <- S.mapMonotonic refNameRaw <$> get git
+ 150 let resolve name =
+ 151 let nameb = B.pack name
+ 152 in if prefix `B.isPrefixOf` nameb
+ 153 then do
+ 154 oid <- resolveName git name
+ 155 return (oid, B.drop (B.length prefix) nameb)
+ 156 else error "found name which doesn't have expected prefix"
+ 157 liftIO $ traverse resolve $ S.toAscList names
+ 158 + 159 resolveHead :: Git -> IO (Maybe ObjId)
+ 160 resolveHead git = resolveNameMaybe git "HEAD"
+ 161 + 162 listBranches :: Git -> IO [(ObjId, String)]
+ 163 listBranches = listHelper branchList "refs/heads/"
+ 164 + 165 listTags :: Git -> IO [(ObjId, String)]
+ 166 listTags = listHelper tagList "refs/tags/"
+ 167 + 168 -- | If the given object ID refers to a tag object, i.e. an annotated tag,
+ 169 -- return the object ID of the commit it points to. Otherwise, return
+ 170 -- 'Nothing'.
+ 171 peelRef :: Git -> ObjId -> IO (Maybe ObjId)
+ 172 peelRef git oid = do
+ 173 mobj <- getObject git $ unObjId oid
+ 174 case mobj of
+ 175 Just (ObjTag tag) -> return $ Just $ ObjId $ tagRef tag
+ 176 _ -> return Nothing
+ 177 + 178 buildRefDiscover' :: Git -> IO RefDiscover
+ 179 buildRefDiscover' git = do
+ 180 mhead <- resolveHead git
+ 181 branches <- listBranches git
+ 182 tags <- listTags git
+ 183 let peel (oid, name) = do
+ 184 moid <- peelRef git oid
+ 185 return (oid, name, moid)
+ 186 tagsPeels <- traverse peel tags
+ 187 head2ad oid = RefAd
+ 188 { refAdId = oid+ 189 , refAdSym = SymRefHead
+ 190 , refAdName = "HEAD"
+ 191 }
+ 192 branch2ad (oid, name) = RefAd
+ 193 { refAdId = oid+ 194 , refAdSym = SymRefBranch name
+ 195 , refAdName = "refs/heads/" <> name
+ 196 }
+ 197 tag2ad oid name = RefAd
+ 198 { refAdId = oid+ 199 , refAdSym = SymRefTag name False
+ 200 , refAdName = "refs/tags/" <> name
+ 201 }
+ 202 peel2ad name oid = RefAd
+ 203 { refAdId = oid+ 204 , refAdSym = SymRefTag name True
+ 205 , refAdName = "refs/tags/" <> name <> "^{}"+ 206 }
+ 207 addTag (oid, name, mpeel) l =
+ 208 let l' = tag2ad name oid : l
+ 209 in case mpeel of
+ 210 Nothing -> l'
+ 211 Just p -> peel2ad name p : l'
+ 212 return RefDiscover
+ 213 { rdAds =+ 214 let l = map branch2ad branches ++ foldr addTag [] tagsPeels
+ 215 in case mhead of
+ 216 Nothing -> l
+ 217 Just h -> head2ad h : l
+ 218 , rdCaps = []
+ 219 }
+ 220 … … … … - 211 refs <- liftIO $ listReferences git
- 212 let head = (== "HEAD")
- 213 mbranch = stripPrefix "refs/heads/"
- 214 mtag = stripPrefix "refs/tags/"
- 215 ref2ad (ref, name) = RefAd
- 216 { refAdId = ObjId ref- 217 , refAdSym =
- 218 case (head name, mbranch name, mtag name) of
- 219 (True, _, _) -> SymRefHead
- 220 (False, Just branch, _) -> SymRefBranch $ B.pack branch
- 221 (False, Nothing, Just tag) -> SymRefTag $ B.pack tag
- 222 _ -> error "oops... :-P"
- 223 , refAdName = name
- 224 }
- 225 return RefDiscover
- 226 { rdAds = map ref2ad refs- 227 , rdCaps = []
- 228 }
+ 302 liftIO $ buildRefDiscover' git
… … … …