convert TopFilePath to use RawFilePath

Adds a dependency on filepath-bytestring, an as yet unreleased fork of
filepath that operates on RawFilePath.

Git.Repo also changed to use RawFilePath for the path to the repo.

This does eliminate some RawFilePath -> FilePath -> RawFilePath
conversions. And filepath-bytestring's </> is probably faster.
But I don't expect a major performance improvement from this.
This is mostly groundwork for making Annex.Location use RawFilePath,
which will allow for a conversion-free pipleline.
This commit is contained in:
Joey Hess 2019-12-09 13:49:05 -04:00
parent a7004375ec
commit bdec7fed9c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
97 changed files with 323 additions and 271 deletions

View file

@ -114,7 +114,7 @@ start file = do
cleanup key =<< inAnnex key
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the pointer file is present, but not yet added to git
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file))
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
next $ addFile file
perform :: RawFilePath -> CommandPerform

View file

@ -251,7 +251,7 @@ startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled ->
startExport r db cvar allfilledvar ti = do
ek <- exportKey (Git.LsTree.sha ti)
stopUnless (notrecordedpresent ek) $
starting ("export " ++ name r) (ActionItemOther (Just f)) $
starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
( next $ cleanupExport r db ek loc False
, do
@ -259,9 +259,9 @@ startExport r db cvar allfilledvar ti = do
performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
)
where
loc = mkExportLocation (toRawFilePath f)
loc = mkExportLocation f
f = getTopFilePath (Git.LsTree.file ti)
af = AssociatedFile (Just (toRawFilePath f))
af = AssociatedFile (Just f)
notrecordedpresent ek = (||)
<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek))
-- If content was removed from the remote, the export db
@ -314,17 +314,17 @@ startUnexport r db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey
if null eks
then stop
else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
performUnexport r db eks loc
where
loc = mkExportLocation (toRawFilePath f')
loc = mkExportLocation f'
f' = getTopFilePath f
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
performUnexport r db [ek] loc
where
loc = mkExportLocation (toRawFilePath f')
loc = mkExportLocation f'
f' = getTopFilePath f
-- Unlike a usual drop from a repository, this does not check that
@ -368,15 +368,14 @@ startRecoverIncomplete r db sha oldf
liftIO $ removeExportedLocation db (asKey ek) oldloc
performUnexport r db [ek] loc
where
oldloc = mkExportLocation (toRawFilePath oldf')
oldf' = getTopFilePath oldf
oldloc = mkExportLocation $ getTopFilePath oldf
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r db f ek = starting ("rename " ++ name r)
(ActionItemOther $ Just $ f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
(ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
(performRename r db ek loc tmploc)
where
loc = mkExportLocation (toRawFilePath f')
loc = mkExportLocation f'
f' = getTopFilePath f
tmploc = exportTempName ek
@ -384,10 +383,10 @@ startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> C
startMoveFromTempName r db ek f = do
let tmploc = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ f'))) $
starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $
performRename r db ek tmploc loc
where
loc = mkExportLocation (toRawFilePath f')
loc = mkExportLocation f'
f' = getTopFilePath f
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
@ -469,7 +468,7 @@ filterPreferredContent r tree = logExportExcluded (uuid r) $ \logwriter -> do
-- Match filename relative to the
-- top of the tree.
let af = AssociatedFile $ Just $
toRawFilePath $ getTopFilePath topf
getTopFilePath topf
let mi = MatchingKey k af
ifM (checkMatcher' matcher mi mempty)
( return (Just ti)

View file

@ -74,7 +74,7 @@ start o file key =
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =
start o (toRawFilePath (getTopFilePath topf)) key
start o (getTopFilePath topf) key
startKeys _ _ = stop
showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()

View file

@ -313,7 +313,7 @@ verifyRequiredContent _ _ = return True
verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool
verifyAssociatedFiles key keystatus file = do
when (isKeyUnlockedThin keystatus) $ do
f <- inRepo $ toTopFilePath $ fromRawFilePath file
f <- inRepo $ toTopFilePath file
afs <- Database.Keys.getAssociatedFiles key
unless (getTopFilePath f `elem` map getTopFilePath afs) $
Database.Keys.addAssociatedFile key f

View file

@ -97,7 +97,7 @@ duplicateModeParser =
seek :: ImportOptions -> CommandSeek
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
unless (null inrepops) $ do
giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
@ -110,7 +110,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
giveup "That remote does not support imports."
subdir <- maybe
(pure Nothing)
(Just <$$> inRepo . toTopFilePath)
(Just <$$> inRepo . toTopFilePath . toRawFilePath)
(importToSubDir o)
seekRemote r (importToBranch o) subdir

View file

@ -566,7 +566,7 @@ getDirStatInfo o dir = do
where
initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty)
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =
ifM (matcher $ MatchingFile $ FileInfo file' file')
ifM (matcher $ MatchingFile $ FileInfo file file)
( do
!presentdata' <- ifM (inAnnex key)
( return $ addKey key presentdata
@ -577,13 +577,11 @@ getDirStatInfo o dir = do
then return (numcopiesstats, repodata)
else do
locs <- Remote.keyLocations key
nc <- updateNumCopiesStats file' numcopiesstats locs
nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs
return (nc, updateRepoData key locs repodata)
return $! (presentdata', referenceddata', numcopiesstats', repodata')
, return vs
)
where
file' = fromRawFilePath file
getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo)
getTreeStatInfo o r = do

View file

@ -80,7 +80,7 @@ performNew file key = do
-- Try to repopulate obj from an unmodified associated file.
repopulate obj = modifyContent obj $ do
g <- Annex.gitRepo
fs <- map (`fromTopFilePath` g)
fs <- map fromRawFilePath . map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs
liftIO $ nukeFile obj
@ -94,7 +94,7 @@ performNew file key = do
cleanupNew :: RawFilePath -> Key -> CommandCleanup
cleanupNew file key = do
Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file))
Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
return True
startOld :: RawFilePath -> CommandStart

View file

@ -199,7 +199,7 @@ compareChanges format changes = concatMap diff changes
getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool)
getKeyLog key os = do
top <- fromRepo Git.repoPath
p <- liftIO $ relPathCwdToFile top
p <- liftIO $ relPathCwdToFile $ fromRawFilePath top
config <- Annex.getGitConfig
let logfile = p </> fromRawFilePath (locationLogFile config key)
getGitLog [logfile] (Param "--remove-empty" : os)

View file

@ -176,7 +176,8 @@ absRepo reference r
| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
| Git.repoIsUrl r = return r
| otherwise = liftIO $ do
r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
r' <- Git.Construct.fromAbsPath
=<< absPath (fromRawFilePath (Git.repoPath r))
r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r'
return (fromMaybe r' r'')
@ -234,7 +235,7 @@ tryScan r
where
remotecmd = "sh -c " ++ shellEscape
(cddir ++ " && " ++ "git config --null --list")
dir = Git.repoPath r
dir = fromRawFilePath $ Git.repoPath r
cddir
| "/~" `isPrefixOf` dir =
let (userhome, reldir) = span (/= '/') (drop 1 dir)

View file

@ -137,7 +137,7 @@ send ups fs = do
mk <- lookupFile f
case mk of
Nothing -> noop
Just k -> withObjectLoc k (addlist (fromRawFilePath f))
Just k -> withObjectLoc k (addlist f)
liftIO $ hClose h
serverkey <- uftpKey

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Command.PostReceive where
import Command

View file

@ -123,7 +123,7 @@ cleanup file oldkey newkey = do
writePointerFile file newkey mode
stagePointerFile file mode =<< hashPointerFile newkey
Database.Keys.removeAssociatedFile oldkey
=<< inRepo (toTopFilePath (fromRawFilePath file))
=<< inRepo (toTopFilePath file)
)
whenM (inAnnex newkey) $
logStatus newkey InfoPresent

View file

@ -24,7 +24,7 @@ seek = withNothing (commandAction start)
start :: CommandStart
start = starting "resolvemerge" (ActionItemOther Nothing) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRepo Git.localGitDir
d <- fromRawFilePath <$> fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
them <- fromMaybe (error nomergehead) . extractSha
<$> liftIO (readFile merge_head)

View file

@ -70,7 +70,7 @@ smudge file = do
case parseLinkTargetOrPointerLazy b of
Nothing -> noop
Just k -> do
topfile <- inRepo (toTopFilePath file)
topfile <- inRepo (toTopFilePath (toRawFilePath file))
Database.Keys.addAssociatedFile k topfile
void $ smudgeLog k topfile
liftIO $ L.putStr b
@ -141,7 +141,8 @@ clean file = do
-- git diff can run the clean filter on files outside the
-- repository; can't annex those
fileoutsiderepo = do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
repopath <- liftIO . absPath . fromRawFilePath
=<< fromRepo Git.repoPath
filepath <- liftIO $ absPath file
return $ not $ dirContains repopath filepath
@ -204,7 +205,7 @@ update = do
updateSmudged :: Restage -> Annex ()
updateSmudged restage = streamSmudged $ \k topf -> do
f <- toRawFilePath <$> fromRepo (fromTopFilePath topf)
f <- fromRepo (fromTopFilePath topf)
whenM (inAnnex k) $ do
obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k)
unlessM (isJust <$> populatePointerFile restage k obj f) $

View file

@ -61,6 +61,6 @@ displayStatus (Renamed _ _) = noop
displayStatus s = do
let c = statusChar s
absf <- fromRepo $ fromTopFilePath (statusFile s)
f <- liftIO $ relPathCwdToFile absf
f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf
unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $
liftIO $ putStrLn $ [c] ++ " " ++ f

View file

@ -226,7 +226,7 @@ seek' o = do
- of the repo. This also means that sync always acts on all files in the
- repository, not just on a subdirectory. -}
prepMerge :: Annex ()
prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath
mergeConfig :: [Git.Merge.MergeConfig]
mergeConfig =
@ -409,7 +409,7 @@ importRemote o mergeconfig remote currbranch
let branch = Git.Ref b
let subdir = if null s
then Nothing
else Just (asTopFilePath s)
else Just (asTopFilePath (toRawFilePath s))
Command.Import.seekRemote remote branch subdir
void $ mergeRemote remote currbranch mergeconfig
(resolveMergeOverride o)
@ -468,7 +468,7 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need
( liftIO $ do
p <- readProgramFile
boolSystem' p [Param "post-receive"]
(\cp -> cp { cwd = Just wt })
(\cp -> cp { cwd = Just (fromRawFilePath wt) })
, return True
)
where

View file

@ -28,22 +28,22 @@ seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems
start :: RawFilePath -> Key -> CommandStart
start file key = stopUnless (inAnnex key) $
starting "unannex" (mkActionItem (key, file)) $
perform (fromRawFilePath file) key
perform file key
perform :: FilePath -> Key -> CommandPerform
perform :: RawFilePath -> Key -> CommandPerform
perform file key = do
liftIO $ removeFile file
liftIO $ removeFile (fromRawFilePath file)
inRepo $ Git.Command.run
[ Param "rm"
, Param "--cached"
, Param "--force"
, Param "--quiet"
, Param "--"
, File file
, File (fromRawFilePath file)
]
next $ cleanup file key
cleanup :: FilePath -> Key -> CommandCleanup
cleanup :: RawFilePath -> Key -> CommandCleanup
cleanup file key = do
Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
src <- calcRepo $ gitAnnexLocation key
@ -61,11 +61,12 @@ cleanup file key = do
, copyfrom src
)
where
file' = fromRawFilePath file
copyfrom src =
thawContent file `after` liftIO (copyFileExternal CopyAllMetaData src file)
thawContent file' `after` liftIO (copyFileExternal CopyAllMetaData src file')
hardlinkfrom src =
-- creating a hard link could fall; fall back to copying
ifM (liftIO $ catchBoolIO $ createLink src file >> return True)
ifM (liftIO $ catchBoolIO $ createLink src file' >> return True)
( return True
, copyfrom src
)

View file

@ -51,7 +51,7 @@ perform p = do
-- Get the reversed diff that needs to be applied to undo.
(diff, cleanup) <- inRepo $
diffLog [Param "-R", Param "--", Param p]
top <- inRepo $ toTopFilePath p
top <- inRepo $ toTopFilePath $ toRawFilePath p
let diff' = filter (`isDiffOf` top) diff
liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff')
@ -59,7 +59,8 @@ perform p = do
-- and then any adds. This order is necessary to handle eg, removing
-- a directory and replacing it with a file.
let (removals, adds) = partition (\di -> dstsha di == nullSha) diff'
let mkrel di = liftIO $ relPathCwdToFile $ fromTopFilePath (file di) g
let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $
fromTopFilePath (file di) g
forM_ removals $ \di -> do
f <- mkrel di

View file

@ -29,7 +29,7 @@ check = do
b <- current_branch
when (b == Annex.Branch.name) $ giveup $
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
top <- fromRepo Git.repoPath
top <- fromRawFilePath <$> fromRepo Git.repoPath
currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"

View file

@ -57,5 +57,5 @@ perform dest key = do
cleanup :: RawFilePath -> Key -> Maybe FileMode -> CommandCleanup
cleanup dest key destmode = do
stagePointerFile dest destmode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath dest))
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest)
return True

View file

@ -207,7 +207,7 @@ withKeysReferenced' mdir initial a = do
( return ([], return True)
, do
top <- fromRepo Git.repoPath
inRepo $ LsFiles.allFiles [toRawFilePath top]
inRepo $ LsFiles.allFiles [top]
)
Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir]
go v [] = return v
@ -283,7 +283,7 @@ associatedFilesFilter = filterM go
checkunmodified _ [] = return True
checkunmodified cs (f:fs) = do
relf <- fromRepo $ fromTopFilePath f
ifM (sameInodeCache relf cs)
ifM (sameInodeCache (fromRawFilePath relf) cs)
( return False
, checkunmodified cs fs
)

View file

@ -99,7 +99,7 @@ checkoutViewBranch view mkbranch = do
- and this pollutes the view, so remove them.
- (However, emptry directories used by submodules are not
- removed.) -}
top <- liftIO . absPath =<< fromRepo Git.repoPath
top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
(l, cleanup) <- inRepo $
LsFiles.notInRepoIncludingEmptyDirectories False
[toRawFilePath top]
@ -110,8 +110,8 @@ checkoutViewBranch view mkbranch = do
return ok
where
removeemptydir top d = do
p <- inRepo $ toTopFilePath $ fromRawFilePath d
liftIO $ tryIO $ removeDirectory (top </> getTopFilePath p)
p <- inRepo $ toTopFilePath d
liftIO $ tryIO $ removeDirectory (top </> fromRawFilePath (getTopFilePath p))
cwdmissing top = unlines
[ "This view does not include the subdirectory you are currently in."
, "Perhaps you should: cd " ++ top