mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

more OsPath conversion (650/749)

Browse source 
Sponsored-by: Nicholas Golder-Manning
This commit is contained in:
Joey Hess 2025-02-07 17:03:31 -04:00
parent c74c75b352
commit 5eef09a3cc
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
9 changed files with 79 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Annex/Drop.hs
View file

@ -108,7 +108,7 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do
[ "dropped" [ "dropped"
, case afile of , case afile of
AssociatedFile Nothing -> serializeKey key AssociatedFile Nothing -> serializeKey key
AssociatedFile (Just af) -> fromRawFilePath af AssociatedFile (Just af) -> fromOsPath af
, "(from " ++ maybe "here" show u ++ ")" , "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (have - 1) ++ ")" , "(copies now " ++ show (have - 1) ++ ")"
, ": " ++ reason , ": " ++ reason

22
Annex/Import.hs
View file

@ -69,7 +69,6 @@ import Control.Concurrent.STM
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Set as S import qualified Data.Set as S
import qualified System.FilePath.Posix.ByteString as Posix import qualified System.FilePath.Posix.ByteString as Posix
import qualified System.FilePath.ByteString as P
import qualified Data.ByteArray.Encoding as BA import qualified Data.ByteArray.Encoding as BA
{- Configures how to build an import tree. -} {- Configures how to build an import tree. -}
@ -154,7 +153,7 @@ recordImportTree remote importtreeconfig addunlockedmatcher imported = do
let subtreeref = Ref $ let subtreeref = Ref $
fromRef' finaltree fromRef' finaltree
<> ":" <> ":"
<> getTopFilePath dir <> fromOsPath (getTopFilePath dir)
in fromMaybe emptyTree in fromMaybe emptyTree
<$> inRepo (Git.Ref.tree subtreeref) <$> inRepo (Git.Ref.tree subtreeref)
updateexportdb importedtree updateexportdb importedtree
@ -349,11 +348,11 @@ mkImportTreeItem maddunlockedmatcher msubdir loc v = case v of
lf = fromImportLocation loc lf = fromImportLocation loc
treepath = asTopFilePath lf treepath = asTopFilePath lf
topf = asTopFilePath $ topf = asTopFilePath $
maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir maybe lf (\sd -> getTopFilePath sd </> lf) msubdir
mklink k = do mklink k = do
relf <- fromRepo $ fromTopFilePath topf relf <- fromRepo $ fromTopFilePath topf
symlink <- calcRepo $ gitAnnexLink relf k symlink <- calcRepo $ gitAnnexLink relf k
linksha <- hashSymlink symlink linksha <- hashSymlink (fromOsPath symlink)
return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha
mkpointer k = TreeItem treepath (fromTreeItemType TreeFile) mkpointer k = TreeItem treepath (fromTreeItemType TreeFile)
<$> hashPointerFile k <$> hashPointerFile k
@ -429,7 +428,8 @@ buildImportTreesGeneric converttree basetree msubdir importable@(ImportableConte
-- Full directory prefix where the sub tree is located. -- Full directory prefix where the sub tree is located.
let fullprefix = asTopFilePath $ case msubdir of let fullprefix = asTopFilePath $ case msubdir of
Nothing -> subdir Nothing -> subdir
Just d -> getTopFilePath d Posix.</> subdir Just d -> toOsPath $
fromOsPath (getTopFilePath d) Posix.</> fromOsPath subdir
Tree ts <- converttree (Just fullprefix) $ Tree ts <- converttree (Just fullprefix) $
map (\(p, i) -> (mkImportLocation p, i)) map (\(p, i) -> (mkImportLocation p, i))
(importableContentsSubTree c) (importableContentsSubTree c)
@ -853,7 +853,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
let af = AssociatedFile (Just f) let af = AssociatedFile (Just f)
let downloader p' tmpfile = do let downloader p' tmpfile = do
_ <- Remote.retrieveExportWithContentIdentifier _ <- Remote.retrieveExportWithContentIdentifier
ia loc [cid] (fromRawFilePath tmpfile) ia loc [cid] tmpfile
(Left k) (Left k)
(combineMeterUpdate p' p) (combineMeterUpdate p' p)
ok <- moveAnnex k af tmpfile ok <- moveAnnex k af tmpfile
@ -871,7 +871,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
doimportsmall cidmap loc cid sz p = do doimportsmall cidmap loc cid sz p = do
let downloader tmpfile = do let downloader tmpfile = do
(k, _) <- Remote.retrieveExportWithContentIdentifier (k, _) <- Remote.retrieveExportWithContentIdentifier
ia loc [cid] (fromRawFilePath tmpfile) ia loc [cid] tmpfile
(Right (mkkey tmpfile)) (Right (mkkey tmpfile))
p p
case keyGitSha k of case keyGitSha k of
@ -894,7 +894,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
let af = AssociatedFile (Just f) let af = AssociatedFile (Just f)
let downloader tmpfile p = do let downloader tmpfile p = do
(k, _) <- Remote.retrieveExportWithContentIdentifier (k, _) <- Remote.retrieveExportWithContentIdentifier
ia loc [cid] (fromRawFilePath tmpfile) ia loc [cid] tmpfile
(Right (mkkey tmpfile)) (Right (mkkey tmpfile))
p p
case keyGitSha k of case keyGitSha k of
@ -950,7 +950,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
case importtreeconfig of case importtreeconfig of
ImportTree -> fromImportLocation loc ImportTree -> fromImportLocation loc
ImportSubTree subdir _ -> ImportSubTree subdir _ ->
getTopFilePath subdir P.</> fromImportLocation loc getTopFilePath subdir </> fromImportLocation loc
getcidkey cidmap db cid = liftIO $ getcidkey cidmap db cid = liftIO $
-- Avoiding querying the database when it's empty speeds up -- Avoiding querying the database when it's empty speeds up
@ -1091,7 +1091,7 @@ getImportableContents r importtreeconfig ci matcher = do
isknown <||> (matches <&&> notignored) isknown <||> (matches <&&> notignored)
where where
-- Checks, from least to most expensive. -- Checks, from least to most expensive.
ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc) ingitdir = ".git" `elem` Posix.splitDirectories (fromOsPath (fromImportLocation loc))
matches = matchesImportLocation matcher loc sz matches = matchesImportLocation matcher loc sz
isknown = isKnownImportLocation dbhandle loc isknown = isKnownImportLocation dbhandle loc
notignored = notIgnoredImportLocation importtreeconfig ci loc notignored = notIgnoredImportLocation importtreeconfig ci loc
@ -1120,6 +1120,6 @@ notIgnoredImportLocation importtreeconfig ci loc = not <$> checkIgnored ci f
where where
f = case importtreeconfig of f = case importtreeconfig of
ImportSubTree dir _ -> ImportSubTree dir _ ->
getTopFilePath dir P.</> fromImportLocation loc getTopFilePath dir </> fromImportLocation loc
ImportTree -> ImportTree ->
fromImportLocation loc fromImportLocation loc

68
CmdLine/GitRemoteAnnex.hs
View file

@ -66,7 +66,6 @@ import Data.Char
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P
import qualified Data.Set as S import qualified Data.Set as S
run :: [String] -> IO () run :: [String] -> IO ()
@ -146,13 +145,14 @@ list st rmt forpush = do
else downloadManifestOrFail rmt else downloadManifestOrFail rmt
l <- forM (inManifest manifest) $ \k -> do l <- forM (inManifest manifest) $ \k -> do
b <- downloadGitBundle rmt k b <- downloadGitBundle rmt k
heads <- inRepo $ Git.Bundle.listHeads b let b' = fromOsPath b
heads <- inRepo $ Git.Bundle.listHeads b'
-- Get all the objects from the bundle. This is done here -- Get all the objects from the bundle. This is done here
-- so that the tracking refs can be updated with what is -- so that the tracking refs can be updated with what is
-- listed, and so what when a full repush is done, all -- listed, and so what when a full repush is done, all
-- objects are available to be pushed. -- objects are available to be pushed.
when forpush $ when forpush $
inRepo $ Git.Bundle.unbundle b inRepo $ Git.Bundle.unbundle b'
-- The bundle may contain tracking refs, or regular refs, -- The bundle may contain tracking refs, or regular refs,
-- make sure we're operating on regular refs. -- make sure we're operating on regular refs.
return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads
@ -202,7 +202,8 @@ fetch' :: State -> Remote -> Annex ()
fetch' st rmt = do fetch' st rmt = do
manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st) manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st)
forM_ (inManifest manifest) $ \k -> forM_ (inManifest manifest) $ \k ->
downloadGitBundle rmt k >>= inRepo . Git.Bundle.unbundle downloadGitBundle rmt k
>>= inRepo . Git.Bundle.unbundle . fromOsPath
-- Newline indicates end of fetch. -- Newline indicates end of fetch.
liftIO $ do liftIO $ do
putStrLn "" putStrLn ""
@ -496,10 +497,9 @@ resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String)
resolveSpecialRemoteWebUrl url resolveSpecialRemoteWebUrl url
| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =
Url.withUrlOptionsPromptingCreds $ \uo -> Url.withUrlOptionsPromptingCreds $ \uo ->
withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do
liftIO $ hClose h liftIO $ hClose h
let tmp' = fromRawFilePath $ fromOsPath tmp Url.download' nullMeterUpdate Nothing url tmp uo >>= \case
Url.download' nullMeterUpdate Nothing url tmp' uo >>= \case
Left err -> giveup $ url ++ " " ++ err Left err -> giveup $ url ++ " " ++ err
Right () -> liftIO $ Right () -> liftIO $
fmap decodeBS fmap decodeBS
@ -728,9 +728,9 @@ downloadManifest rmt = get mkmain >>= maybe (get mkbak) (pure . Just)
-- it needs to re-download it fresh every time, and the object -- it needs to re-download it fresh every time, and the object
-- file should not be stored locally. -- file should not be stored locally.
gettotmp dl = withOtherTmp $ \othertmp -> gettotmp dl = withOtherTmp $ \othertmp ->
withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do withTmpFileIn othertmp (literalOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ hClose tmph liftIO $ hClose tmph
_ <- dl (fromRawFilePath (fromOsPath tmp)) _ <- dl tmp
b <- liftIO (F.readFile' tmp) b <- liftIO (F.readFile' tmp)
case parseManifest b of case parseManifest b of
Right m -> Just <$> verifyManifest rmt m Right m -> Just <$> verifyManifest rmt m
@ -778,7 +778,7 @@ uploadManifest rmt manifest = do
dropKey' rmt mk dropKey' rmt mk
put mk put mk
put mk = withTmpFile (toOsPath "GITMANIFEST") $ \tmp tmph -> do put mk = withTmpFile (literalOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ B8.hPut tmph (formatManifest manifest) liftIO $ B8.hPut tmph (formatManifest manifest)
liftIO $ hClose tmph liftIO $ hClose tmph
-- Uploading needs the key to be in the annex objects -- Uploading needs the key to be in the annex objects
@ -789,13 +789,13 @@ uploadManifest rmt manifest = do
-- keys, which it is not. -- keys, which it is not.
objfile <- calcRepo (gitAnnexLocation mk) objfile <- calcRepo (gitAnnexLocation mk)
modifyContentDir objfile $ modifyContentDir objfile $
linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case linkOrCopy mk tmp objfile Nothing >>= \case
-- Important to set the right perms even -- Important to set the right perms even
-- though the object is only present -- though the object is only present
-- briefly, since sending objects may rely -- briefly, since sending objects may rely
-- on or even copy file perms. -- on or even copy file perms.
Just _ -> do Just _ -> do
liftIO $ R.setFileMode objfile liftIO $ R.setFileMode (fromOsPath objfile)
=<< defaultFileMode =<< defaultFileMode
freezeContent objfile freezeContent objfile
Nothing -> uploadfailed Nothing -> uploadfailed
@ -843,9 +843,11 @@ parseManifest b =
- interrupted before updating the manifest on the remote, or when a race - interrupted before updating the manifest on the remote, or when a race
- causes the uploaded manigest to be overwritten. - causes the uploaded manigest to be overwritten.
-} -}
lastPushedManifestFile :: UUID -> Git.Repo -> RawFilePath lastPushedManifestFile :: UUID -> Git.Repo -> OsPath
lastPushedManifestFile u r = gitAnnexDir r P.</> "git-remote-annex" lastPushedManifestFile u r = gitAnnexDir r
P.</> fromUUID u P.</> "manifest" </> literalOsPath "git-remote-annex"
</> fromUUID u
</> literalOsPath "manifest"
{- Call before uploading anything. The returned manifest has added {- Call before uploading anything. The returned manifest has added
- to it any bundle keys that were in the lastPushedManifestFile - to it any bundle keys that were in the lastPushedManifestFile
@ -861,7 +863,7 @@ startPush' rmt manifest = do
f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt)) f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt))
oldmanifest <- liftIO $ oldmanifest <- liftIO $
fromRight mempty . parseManifest fromRight mempty . parseManifest
<$> F.readFile' (toOsPath f) <$> F.readFile' f
`catchNonAsync` (const (pure mempty)) `catchNonAsync` (const (pure mempty))
let oldmanifest' = mkManifest [] $ let oldmanifest' = mkManifest [] $
S.fromList (inManifest oldmanifest) S.fromList (inManifest oldmanifest)
@ -911,7 +913,7 @@ verifyManifest rmt manifest =
-- and so more things pulled from it, etc. -- and so more things pulled from it, etc.
-- 3. Git bundle objects are not usually transferred between repositories -- 3. Git bundle objects are not usually transferred between repositories
-- except special remotes (although the user can if they want to). -- except special remotes (although the user can if they want to).
downloadGitBundle :: Remote -> Key -> Annex FilePath downloadGitBundle :: Remote -> Key -> Annex OsPath
downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case
Nothing -> dlwith $ Nothing -> dlwith $
download rmt k (AssociatedFile Nothing) stdRetry noNotification download rmt k (AssociatedFile Nothing) stdRetry noNotification
@ -919,7 +921,7 @@ downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case
anyM getexport locs anyM getexport locs
where where
dlwith a = ifM a dlwith a = ifM a
( decodeBS <$> calcRepo (gitAnnexLocation k) ( calcRepo (gitAnnexLocation k)
, giveup $ "Failed to download " ++ serializeKey k , giveup $ "Failed to download " ++ serializeKey k
) )
@ -927,7 +929,7 @@ downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case
getexport' loc = getexport' loc =
getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do
v <- Remote.retrieveExport (Remote.exportActions rmt) v <- Remote.retrieveExport (Remote.exportActions rmt)
k loc (decodeBS tmp) nullMeterUpdate k loc tmp nullMeterUpdate
return (True, v) return (True, v)
rsp = Remote.retrievalSecurityPolicy rmt rsp = Remote.retrievalSecurityPolicy rmt
vc = Remote.RemoteVerify rmt vc = Remote.RemoteVerify rmt
@ -952,7 +954,7 @@ checkPresentGitBundle rmt k =
uploadGitObject :: Remote -> Key -> Annex () uploadGitObject :: Remote -> Key -> Annex ()
uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case
Just (loc:_) -> do Just (loc:_) -> do
objfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation k) objfile <- calcRepo (gitAnnexLocation k)
Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate
_ -> _ ->
unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $ unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $
@ -977,15 +979,14 @@ generateGitBundle
-> Manifest -> Manifest
-> Annex (Key, Annex ()) -> Annex (Key, Annex ())
generateGitBundle rmt bs manifest = generateGitBundle rmt bs manifest =
withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do withTmpFile (literalOsPath "GITBUNDLE") $ \tmp tmph -> do
let tmp' = fromOsPath tmp
liftIO $ hClose tmph liftIO $ hClose tmph
inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs inRepo $ Git.Bundle.create (fromOsPath tmp) bs
bundlekey <- genGitBundleKey (Remote.uuid rmt) bundlekey <- genGitBundleKey (Remote.uuid rmt)
tmp' nullMeterUpdate tmp nullMeterUpdate
if (bundlekey `notElem` inManifest manifest) if (bundlekey `notElem` inManifest manifest)
then do then do
unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $ unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp) $
giveup "Unable to push" giveup "Unable to push"
return (bundlekey, uploadaction bundlekey) return (bundlekey, uploadaction bundlekey)
else return (bundlekey, noop) else return (bundlekey, noop)
@ -1025,7 +1026,7 @@ getKeyExportLocations rmt k = do
keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation] keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation]
keyExportLocations rmt k cfg uuid keyExportLocations rmt k cfg uuid
| exportTree (Remote.config rmt) || importTree (Remote.config rmt) = | exportTree (Remote.config rmt) || importTree (Remote.config rmt) =
Just $ map (\p -> mkExportLocation (".git" P.</> p)) $ Just $ map (\p -> mkExportLocation (literalOsPath ".git" </> p)) $
concatMap (`annexLocationsBare` k) cfgs concatMap (`annexLocationsBare` k) cfgs
| otherwise = Nothing | otherwise = Nothing
where where
@ -1094,7 +1095,7 @@ getRepo = getEnv "GIT_WORK_TREE" >>= \case
Nothing -> fixup <$> Git.CurrentRepo.get Nothing -> fixup <$> Git.CurrentRepo.get
where where
fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) = fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) =
r { location = loc { worktree = Just (P.takeDirectory (gitdir loc)) } } r { location = loc { worktree = Just (takeDirectory (gitdir loc)) } }
fixup r = r fixup r = r
-- Records what the git-annex branch was at the beginning of this command. -- Records what the git-annex branch was at the beginning of this command.
@ -1127,11 +1128,11 @@ startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches)
-- journal writes to a temporary directory, so that all writes -- journal writes to a temporary directory, so that all writes
-- to the git-annex branch by the action will be discarded. -- to the git-annex branch by the action will be discarded.
specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a
specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do specialRemoteFromUrl sab a = withTmpDir (literalOsPath "journal") $ \tmpdir -> do
Annex.overrideGitConfig $ \c -> Annex.overrideGitConfig $ \c ->
c { annexAlwaysCommit = False } c { annexAlwaysCommit = False }
Annex.BranchState.changeState $ \st -> Annex.BranchState.changeState $ \st ->
st { alternateJournal = Just (toRawFilePath tmpdir) } st { alternateJournal = Just tmpdir }
a `finally` cleanupInitialization sab tmpdir a `finally` cleanupInitialization sab tmpdir
-- If the git-annex branch did not exist when this command started, -- If the git-annex branch did not exist when this command started,
@ -1165,16 +1166,15 @@ specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do
-- involve checking out an adjusted branch. But git clone wants to do its -- involve checking out an adjusted branch. But git clone wants to do its
-- own checkout. So no initialization is done then, and the git bundle -- own checkout. So no initialization is done then, and the git bundle
-- objects are deleted. -- objects are deleted.
cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () cleanupInitialization :: StartAnnexBranch -> OsPath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
liftIO $ mapM_ R.removeLink liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir
=<< dirContents (toRawFilePath alternatejournaldir)
case sab of case sab of
AnnexBranchExistedAlready _ -> noop AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r -> AnnexBranchCreatedEmpty r ->
whenM ((r ==) <$> Annex.Branch.getBranch) $ do whenM ((r ==) <$> Annex.Branch.getBranch) $ do
indexfile <- fromRepo gitAnnexIndex indexfile <- fromRepo gitAnnexIndex
liftIO $ removeWhenExistsWith R.removeLink indexfile liftIO $ removeWhenExistsWith removeFile indexfile
-- When cloning failed and this is being -- When cloning failed and this is being
-- run as an exception is thrown, HEAD will -- run as an exception is thrown, HEAD will
-- not be set to a valid value, which will -- not be set to a valid value, which will
@ -1202,7 +1202,7 @@ cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
forM_ ks $ \k -> case fromKey keyVariety k of forM_ ks $ \k -> case fromKey keyVariety k of
GitBundleKey -> lockContentForRemoval k noop removeAnnex GitBundleKey -> lockContentForRemoval k noop removeAnnex
_ -> noop _ -> noop
void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir) void $ liftIO $ tryIO $ removeDirectory annexobjectdir
notcrippledfilesystem = not <$> probeCrippledFileSystem notcrippledfilesystem = not <$> probeCrippledFileSystem

3
Command/Assist.hs
View file

@ -28,7 +28,8 @@ myseek o = do
Command.Sync.prepMerge Command.Sync.prepMerge
Command.Add.seek Command.Add.AddOptions Command.Add.seek Command.Add.AddOptions
{ Command.Add.addThese = Command.Sync.contentOfOption o { Command.Add.addThese = map fromOsPath $
Command.Sync.contentOfOption o
, Command.Add.batchOption = NoBatch , Command.Add.batchOption = NoBatch
, Command.Add.updateOnly = False , Command.Add.updateOnly = False
, Command.Add.largeFilesOverride = Nothing , Command.Add.largeFilesOverride = Nothing

30
Command/Import.hs
View file

@ -129,7 +129,7 @@ seek :: ImportOptions -> CommandSeek
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) inrepops <- liftIO $ filter (dirContains repopath)
<$> mapM (absPath . toRawFilePath) (importFiles o) <$> mapM (absPath . toOsPath) (importFiles o)
unless (null inrepops) $ do unless (null inrepops) $ do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $ giveup $ decodeBS $ quote qp $
@ -145,7 +145,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
giveup "That remote does not support imports." giveup "That remote does not support imports."
subdir <- maybe subdir <- maybe
(pure Nothing) (pure Nothing)
(Just <$$> inRepo . toTopFilePath . toRawFilePath) (Just <$$> inRepo . toTopFilePath . toOsPath)
(importToSubDir o) (importToSubDir o)
addunlockedmatcher <- addUnlockedMatcher addunlockedmatcher <- addUnlockedMatcher
seekRemote r (importToBranch o) subdir (importContent o) seekRemote r (importToBranch o) subdir (importContent o)
@ -153,9 +153,9 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
addunlockedmatcher addunlockedmatcher
(messageOption o) (messageOption o)
startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (OsPath, OsPath) -> CommandStart
startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile) ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus (fromOsPath srcfile))
( starting "import" ai si pickaction ( starting "import" ai si pickaction
, stop , stop
) )
@ -167,7 +167,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
showNote $ UnquotedString $ "duplicate of " ++ serializeKey k showNote $ UnquotedString $ "duplicate of " ++ serializeKey k
verifyExisting k destfile verifyExisting k destfile
( do ( do
liftIO $ R.removeLink srcfile liftIO $ removeFile srcfile
next $ return True next $ return True
, do , do
warning "Could not verify that the content is still present in the annex; not removing from the import location." warning "Could not verify that the content is still present in the annex; not removing from the import location."
@ -183,26 +183,26 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)" warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)"
stop stop
else do else do
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile) existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destfile))
case existing of case existing of
Nothing -> importfilechecked ld k Nothing -> importfilechecked ld k
Just s Just s
| isDirectory s -> notoverwriting "(is a directory)" | isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getRead Annex.force) | isSymbolicLink s -> ifM (Annex.getRead Annex.force)
( do ( do
liftIO $ removeWhenExistsWith R.removeLink destfile liftIO $ removeWhenExistsWith removeFile destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(is a symlink)" , notoverwriting "(is a symlink)"
) )
| otherwise -> ifM (Annex.getRead Annex.force) | otherwise -> ifM (Annex.getRead Annex.force)
( do ( do
liftIO $ removeWhenExistsWith R.removeLink destfile liftIO $ removeWhenExistsWith removeFile destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)" , notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
) )
checkdestdir cont = do checkdestdir cont = do
let destdir = parentDir destfile let destdir = parentDir destfile
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir) existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destdir))
case existing of case existing of
Nothing -> cont Nothing -> cont
Just s Just s
@ -217,10 +217,8 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
createWorkTreeDirectory (parentDir destfile) createWorkTreeDirectory (parentDir destfile)
unwind <- liftIO $ if mode == Duplicate || mode == SkipDuplicates unwind <- liftIO $ if mode == Duplicate || mode == SkipDuplicates
then do then do
void $ copyFileExternal CopyAllMetaData void $ copyFileExternal CopyAllMetaData srcfile destfile
(fromRawFilePath srcfile) return $ removeWhenExistsWith removeFile destfile
(fromRawFilePath destfile)
return $ removeWhenExistsWith R.removeLink destfile
else do else do
moveFile srcfile destfile moveFile srcfile destfile
return $ moveFile destfile srcfile return $ moveFile destfile srcfile
@ -241,7 +239,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
-- weakly the same as the originally locked down file's -- weakly the same as the originally locked down file's
-- inode cache. (Since the file may have been copied, -- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.) -- its inodes may not be the same.)
s <- liftIO $ R.getSymbolicLinkStatus destfile s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath destfile)
newcache <- withTSDelta $ \d -> liftIO $ toInodeCache d destfile s newcache <- withTSDelta $ \d -> liftIO $ toInodeCache d destfile s
let unchanged = case (newcache, inodeCache (keySource ld)) of let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True (_, Nothing) -> True
@ -287,7 +285,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
-- the file gets copied into the repository. -- the file gets copied into the repository.
, checkWritePerms = False , checkWritePerms = False
} }
v <- lockDown cfg (fromRawFilePath srcfile) v <- lockDown cfg srcfile
case v of case v of
Just ld -> do Just ld -> do
backend <- chooseBackend destfile backend <- chooseBackend destfile
@ -314,7 +312,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
showNote (s <> "; skipping") showNote (s <> "; skipping")
next (return True) next (return True)
verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform verifyExisting :: Key -> OsPath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be -- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported. -- imported to, if it were imported.

6
Command/PostReceive.hs
View file

@ -9,6 +9,7 @@
module Command.PostReceive where module Command.PostReceive where
import Common
import Command import Command
import qualified Annex import qualified Annex
import Annex.UpdateInstead import Annex.UpdateInstead
@ -107,12 +108,11 @@ fixPostReceiveHookEnv :: Annex ()
fixPostReceiveHookEnv = do fixPostReceiveHookEnv = do
g <- Annex.gitRepo g <- Annex.gitRepo
case location g of case location g of
Local { gitdir = ".", worktree = Just "." } -> l@(Local {}) | gitdir l == literalOsPath "." && worktree l == Just (literalOsPath ".") ->
Annex.adjustGitRepo $ \g' -> pure $ g' Annex.adjustGitRepo $ \g' -> pure $ g'
{ location = case location g' of { location = case location g' of
loc@(Local {}) -> loc loc@(Local {}) -> loc
{ worktree = Just ".." } { worktree = Just (literalOsPath "..") }
loc -> loc loc -> loc
} }
_ -> noop _ -> noop

18
Command/Sync.hs
View file

@ -110,7 +110,7 @@ data SyncOptions = SyncOptions
, pushOption :: Bool , pushOption :: Bool
, contentOption :: Maybe Bool , contentOption :: Maybe Bool
, noContentOption :: Maybe Bool , noContentOption :: Maybe Bool
, contentOfOption :: [FilePath] , contentOfOption :: [OsPath]
, cleanupOption :: Bool , cleanupOption :: Bool
, keyOptions :: Maybe KeyOptions , keyOptions :: Maybe KeyOptions
, resolveMergeOverride :: Bool , resolveMergeOverride :: Bool
@ -201,7 +201,7 @@ optParser mode desc = SyncOptions
<> short 'g' <> short 'g'
<> help "do not transfer annexed file contents" <> help "do not transfer annexed file contents"
))) )))
<*> many (strOption <*> many (stringToOsPath <$> strOption
( long "content-of" ( long "content-of"
<> short 'C' <> short 'C'
<> help "transfer contents of annexed files in a given location" <> help "transfer contents of annexed files in a given location"
@ -248,7 +248,7 @@ instance DeferredParseClass SyncOptions where
<*> pure (pushOption v) <*> pure (pushOption v)
<*> pure (contentOption v) <*> pure (contentOption v)
<*> pure (noContentOption v) <*> pure (noContentOption v)
<*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v)) <*> liftIO (mapM absPath (contentOfOption v))
<*> pure (cleanupOption v) <*> pure (cleanupOption v)
<*> pure (keyOptions v) <*> pure (keyOptions v)
<*> pure (resolveMergeOverride v) <*> pure (resolveMergeOverride v)
@ -340,7 +340,7 @@ seek' o = startConcurrency transferStages $ do
- of the repo. This also means that sync always acts on all files in the - of the repo. This also means that sync always acts on all files in the
- repository, not just on a subdirectory. -} - repository, not just on a subdirectory. -}
prepMerge :: Annex () prepMerge :: Annex ()
prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig] mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig]
mergeConfig mergeunrelated = do mergeConfig mergeunrelated = do
@ -681,7 +681,7 @@ pushRemote o remote (Just branch, _) = do
Nothing -> return True Nothing -> return True
Just wt -> ifM needemulation Just wt -> ifM needemulation
( gitAnnexChildProcess "post-receive" [] ( gitAnnexChildProcess "post-receive" []
(\cp -> cp { cwd = Just (fromRawFilePath wt) }) (\cp -> cp { cwd = Just (fromOsPath wt) })
(\_ _ _ pid -> waitForProcess pid >>= return . \case (\_ _ _ pid -> waitForProcess pid >>= return . \case
ExitSuccess -> True ExitSuccess -> True
_ -> False _ -> False
@ -820,11 +820,13 @@ seekSyncContent o rs currbranch = do
) )
_ -> case currbranch of _ -> case currbranch of
(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do (Just origbranch, Just adj) | adjustmentHidesFiles adj -> do
l <- workTreeItems' (AllowHidden True) ww (contentOfOption o) l <- workTreeItems' (AllowHidden True) ww
(map fromOsPath (contentOfOption o))
seekincludinghidden origbranch mvar l (const noop) seekincludinghidden origbranch mvar l (const noop)
pure Nothing pure Nothing
_ -> do _ -> do
l <- workTreeItems ww (contentOfOption o) l <- workTreeItems ww
(map fromOsPath (contentOfOption o))
seekworktree mvar l (const noop) seekworktree mvar l (const noop)
pure Nothing pure Nothing
waitForAllRunningCommandActions waitForAllRunningCommandActions
@ -1013,7 +1015,7 @@ seekExportContent' o rs (mcurrbranch, madj)
mtree <- inRepo $ Git.Ref.tree b mtree <- inRepo $ Git.Ref.tree b
let addsubdir = case snd (splitRemoteAnnexTrackingBranchSubdir b) of let addsubdir = case snd (splitRemoteAnnexTrackingBranchSubdir b) of
Just subdir -> \cb -> Git.Ref $ Just subdir -> \cb -> Git.Ref $
Git.fromRef' cb <> ":" <> getTopFilePath subdir Git.fromRef' cb <> ":" <> fromOsPath (getTopFilePath subdir)
Nothing -> id Nothing -> id
mcurrtree <- maybe (pure Nothing) mcurrtree <- maybe (pure Nothing)
(inRepo . Git.Ref.tree . addsubdir) (inRepo . Git.Ref.tree . addsubdir)

6
Remote/Borg.hs
View file

@ -233,7 +233,7 @@ listImportableContentsM u borgrepo c = prompt $ do
-- importable keys, so avoids needing to buffer all -- importable keys, so avoids needing to buffer all
-- the rest of the files in memory. -- the rest of the files in memory.
in case ThirdPartyPopulated.importKey' loc reqsz of in case ThirdPartyPopulated.importKey' loc reqsz of
Just k -> (fromOsPath loc, (borgContentIdentifier, retsz k)) Just k -> (loc, (borgContentIdentifier, retsz k))
: parsefilelist archivename rest : parsefilelist archivename rest
Nothing -> parsefilelist archivename rest Nothing -> parsefilelist archivename rest
parsefilelist _ _ = [] parsefilelist _ _ = []
@ -296,7 +296,7 @@ extractImportLocation loc = go $ splitDirectories $
-- last imported tree. And the contents of those archives can be retrieved -- last imported tree. And the contents of those archives can be retrieved
-- by listing the subtree recursively, which will likely be quite a lot -- by listing the subtree recursively, which will likely be quite a lot
-- faster than running borg. -- faster than running borg.
getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(RawFilePath, (ContentIdentifier, ByteSize))])) getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(OsPath, (ContentIdentifier, ByteSize))]))
getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u)
where where
go t = M.fromList . mapMaybe mk go t = M.fromList . mapMaybe mk
@ -317,7 +317,7 @@ getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u)
mkImportLocation $ getTopFilePath $ LsTree.file ti mkImportLocation $ getTopFilePath $ LsTree.file ti
k <- fileKey (takeFileName f) k <- fileKey (takeFileName f)
return return
( fromOsPath (genImportLocation f) ( genImportLocation f
, ,
( borgContentIdentifier ( borgContentIdentifier
-- defaulting to 0 size is ok, this size -- defaulting to 0 size is ok, this size

2
Types/Import.hs
View file

@ -94,7 +94,7 @@ data ImportableContentsChunkable m info
- of the main tree. Nested subtrees are not allowed. -} - of the main tree. Nested subtrees are not allowed. -}
data ImportableContentsChunk m info = ImportableContentsChunk data ImportableContentsChunk m info = ImportableContentsChunk
{ importableContentsSubDir :: ImportChunkSubDir { importableContentsSubDir :: ImportChunkSubDir
, importableContentsSubTree :: [(RawFilePath, info)] , importableContentsSubTree :: [(OsPath, info)]
-- ^ locations are relative to importableContentsSubDir -- ^ locations are relative to importableContentsSubDir
, importableContentsNextChunk :: m (Maybe (ImportableContentsChunk m info)) , importableContentsNextChunk :: m (Maybe (ImportableContentsChunk m info))
-- ^ Continuation to get the next chunk. -- ^ Continuation to get the next chunk.