convert withKnownUrls to use overBranchFileContents

This only partly fixes importfeed to see journalled files, since it
separately cats metadata directly from the branch. Held off on a
changelog for a bug fix until that's dealt with.
This commit is contained in:
Joey Hess 2021-04-23 11:32:25 -04:00
parent da0a696c96
commit 657d55c401
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 8 additions and 23 deletions

View file

@ -765,8 +765,8 @@ rememberTreeishLocked treeish graftpoint jl = do
-} -}
overBranchFileContents overBranchFileContents
:: (RawFilePath -> Maybe v) :: (RawFilePath -> Maybe v)
-> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex ()) -> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a)
-> Annex () -> Annex a
overBranchFileContents select go = do overBranchFileContents select go = do
st <- update st <- update
g <- Annex.gitRepo g <- Annex.gitRepo
@ -796,7 +796,7 @@ overBranchFileContents select go = do
Nothing -> drain buf =<< getJournalledFilesStale Nothing -> drain buf =<< getJournalledFilesStale
Just fs -> drain buf fs Just fs -> drain buf fs
catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go'
liftIO $ void cleanup `finally` liftIO (void cleanup)
where where
getnext [] = Nothing getnext [] = Nothing
getnext (f:fs) = case select f of getnext (f:fs) = case select f of

View file

@ -30,9 +30,6 @@ import Logs
import Logs.Presence import Logs.Presence
import Logs.Location import Logs.Location
import qualified Annex.Branch import qualified Annex.Branch
import qualified Git.LsTree
import Git.CatFile (catObjectStreamLsTree)
import Git.FilePath
import Utility.Url import Utility.Url
import Annex.UUID import Annex.UUID
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
@ -90,26 +87,14 @@ setUrlMissing key url = do
{- Finds all known urls. -} {- Finds all known urls. -}
withKnownUrls :: (Annex (Maybe (Key, [URLString])) -> Annex a) -> Annex a withKnownUrls :: (Annex (Maybe (Key, [URLString])) -> Annex a) -> Annex a
withKnownUrls a = do withKnownUrls a = Annex.Branch.overBranchFileContents urlLogFileKey (a . go)
{- Ensure any journalled changes are committed to the git-annex
- branch, since we're going to look at its tree. -}
_ <- Annex.Branch.update
Annex.Branch.commit =<< Annex.Branch.commitMessage
(l, cleanup) <- inRepo $ Git.LsTree.lsTree
Git.LsTree.LsTreeRecursive
(Git.LsTree.LsTreeLong False)
Annex.Branch.fullname
g <- Annex.gitRepo
let want = urlLogFileKey . getTopFilePath . Git.LsTree.file
catObjectStreamLsTree l want g (\reader -> a (go reader))
`finally` void (liftIO cleanup)
where where
go reader = liftIO reader >>= \case go reader = reader >>= \case
Just (k, Just content) -> Just (k, _, Just content) ->
case geturls content of case geturls content of
[] -> go reader [] -> go reader
us -> return (Just (k, us)) us -> return (Just (k, us))
Just (_, Nothing) -> go reader Just (_, _, Nothing) -> go reader
Nothing -> return Nothing Nothing -> return Nothing
geturls = map (decodeBS . fromLogInfo) . getLog geturls = map (decodeBS . fromLogInfo) . getLog

View file

@ -156,7 +156,7 @@ later write.
> * Any other similar direct accesses of the branch, not going through > * Any other similar direct accesses of the branch, not going through
> Annex.Branch, also need to be fixed (and may be missing journal files > Annex.Branch, also need to be fixed (and may be missing journal files
> already?) Command.ImportFeed.knownItems is one. Command.Log behavior > already?) Command.ImportFeed.knownItems is one. Command.Log behavior
> needs to be investigated, may be ok. And Logs.Web.withKnownUrls is another. > needs to be investigated, may be ok.
> >
> * Need to implement regardingPrivateUUID and privateUUIDsKnown, > * Need to implement regardingPrivateUUID and privateUUIDsKnown,
> which need to look at the git config to find the private uuids. > which need to look at the git config to find the private uuids.