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

more OsPath conversion

Browse source 
Sponsored-by: Graham Spencer
This commit is contained in:
Joey Hess 2025-02-03 15:16:42 -04:00
parent 5cc8d9d03b
commit cf986bc7e2
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 69 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

87
Upgrade/V1.hs
View file

@ -15,7 +15,6 @@ import Data.Default
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.ByteString.Short as S (toShort, fromShort)
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isRegularFile) import System.PosixCompat.Files (isRegularFile)
import Text.Read import Text.Read
@ -82,20 +81,19 @@ moveContent = do
forM_ files move forM_ files move
where where
move f = do move f = do
let f' = toRawFilePath f let k = fileKey1 (fromOsPath $ takeFileName f)
let k = fileKey1 (fromRawFilePath (P.takeFileName f')) let d = parentDir f
let d = parentDir f'
liftIO $ allowWrite d liftIO $ allowWrite d
liftIO $ allowWrite f' liftIO $ allowWrite f
_ <- moveAnnex k (AssociatedFile Nothing) f' _ <- moveAnnex k (AssociatedFile Nothing) f
liftIO $ removeDirectory (fromRawFilePath d) liftIO $ removeDirectory d
updateSymlinks :: Annex () updateSymlinks :: Annex ()
updateSymlinks = do updateSymlinks = do
showAction "updating symlinks" showAction "updating symlinks"
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
(files, cleanup) <- inRepo $ LsFiles.inRepo [] [top] (files, cleanup) <- inRepo $ LsFiles.inRepo [] [top]
forM_ files (fixlink . fromRawFilePath) forM_ files fixlink
void $ liftIO cleanup void $ liftIO cleanup
where where
fixlink f = do fixlink f = do
@ -103,11 +101,10 @@ updateSymlinks = do
case r of case r of
Nothing -> noop Nothing -> noop
Just (k, _) -> do Just (k, _) -> do
link <- fromRawFilePath link <- calcRepo (gitAnnexLink f k)
<$> calcRepo (gitAnnexLink (toRawFilePath f) k)
liftIO $ removeFile f liftIO $ removeFile f
liftIO $ R.createSymbolicLink (toRawFilePath link) (toRawFilePath f) liftIO $ R.createSymbolicLink (fromOsPath link) (fromOsPath f)
Annex.Queue.addCommand [] "add" [Param "--"] [f] Annex.Queue.addCommand [] "add" [Param "--"] [(fromOsPath f)]
moveLocationLogs :: Annex () moveLocationLogs :: Annex ()
moveLocationLogs = do moveLocationLogs = do
@ -118,15 +115,15 @@ moveLocationLogs = do
oldlocationlogs = do oldlocationlogs = do
dir <- fromRepo Upgrade.V2.gitStateDir dir <- fromRepo Upgrade.V2.gitStateDir
ifM (liftIO $ doesDirectoryExist dir) ifM (liftIO $ doesDirectoryExist dir)
( mapMaybe oldlog2key ( mapMaybe (oldlog2key . fromOsPath)
<$> liftIO (getDirectoryContents dir) <$> liftIO (getDirectoryContents dir)
, return [] , return []
) )
move (l, k) = do move (l, k) = do
dest <- fromRepo (logFile2 k) dest <- fromRepo (logFile2 k)
dir <- fromRepo Upgrade.V2.gitStateDir dir <- fromRepo Upgrade.V2.gitStateDir
let f = dir </> l let f = dir </> toOsPath l
createWorkTreeDirectory (parentDir (toRawFilePath dest)) createWorkTreeDirectory (parentDir dest)
-- could just git mv, but this way deals with -- could just git mv, but this way deals with
-- log files that are not checked into git, -- log files that are not checked into git,
-- as well as merging with already upgraded -- as well as merging with already upgraded
@ -134,9 +131,9 @@ moveLocationLogs = do
old <- liftIO $ readLog1 f old <- liftIO $ readLog1 f
new <- liftIO $ readLog1 dest new <- liftIO $ readLog1 dest
liftIO $ writeLog1 dest (old++new) liftIO $ writeLog1 dest (old++new)
Annex.Queue.addCommand [] "add" [Param "--"] [dest] Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath dest]
Annex.Queue.addCommand [] "add" [Param "--"] [f] Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath f]
Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f] Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [fromOsPath f]
oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key :: FilePath -> Maybe (FilePath, Key)
oldlog2key l oldlog2key l
@ -197,70 +194,64 @@ fileKey1 :: FilePath -> Key
fileKey1 file = readKey1 $ fileKey1 file = readKey1 $
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
writeLog1 :: FilePath -> [LogLine] -> IO () writeLog1 :: OsPath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp F.writeFile writeLog1 file ls = viaTmp F.writeFile file (toLazyByteString $ buildLog ls)
(toOsPath (toRawFilePath file))
(toLazyByteString $ buildLog ls)
readLog1 :: FilePath -> IO [LogLine] readLog1 :: OsPath -> IO [LogLine]
readLog1 file = catchDefaultIO [] $ readLog1 file = catchDefaultIO [] $ parseLog <$> F.readFile file
parseLog <$> F.readFile (toOsPath (toRawFilePath file))
lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend)) lookupKey1 :: OsPath -> Annex (Maybe (Key, Backend))
lookupKey1 file = do lookupKey1 file = do
tl <- liftIO $ tryIO getsymlink tl <- liftIO $ tryIO getsymlink
case tl of case tl of
Left _ -> return Nothing Left _ -> return Nothing
Right l -> makekey l Right l -> makekey l
where where
getsymlink = takeFileName . fromRawFilePath getsymlink :: IO OsPath
<$> R.readSymbolicLink (toRawFilePath file) getsymlink = takeFileName . toOsPath
<$> R.readSymbolicLink (fromOsPath file)
makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Nothing -> do Nothing -> do
unless (null kname || null bname || unless (null kname || null bname ||
not (isLinkToAnnex (toRawFilePath l))) $ not (isLinkToAnnex (fromOsPath l))) $
warning (UnquotedString skip) warning (UnquotedString skip)
return Nothing return Nothing
Just backend -> return $ Just (k, backend) Just backend -> return $ Just (k, backend)
where where
k = fileKey1 l k = fileKey1 (fromOsPath l)
bname = decodeBS (formatKeyVariety (fromKey keyVariety k)) bname = decodeBS (formatKeyVariety (fromKey keyVariety k))
kname = decodeBS (S.fromShort (fromKey keyName k)) kname = decodeBS (S.fromShort (fromKey keyName k))
skip = "skipping " ++ file ++ skip = "skipping " ++ fromOsPath file ++
" (unknown backend " ++ bname ++ ")" " (unknown backend " ++ bname ++ ")"
getKeyFilesPresent1 :: Annex [FilePath] getKeyFilesPresent1 :: Annex [OsPath]
getKeyFilesPresent1 = getKeyFilesPresent1' . fromRawFilePath getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir
=<< fromRepo gitAnnexObjectDir getKeyFilesPresent1' :: OsPath -> Annex [OsPath]
getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
getKeyFilesPresent1' dir = getKeyFilesPresent1' dir =
ifM (liftIO $ doesDirectoryExist dir) ifM (liftIO $ doesDirectoryExist dir)
( do ( do
dirs <- liftIO $ getDirectoryContents dir dirs <- liftIO $ getDirectoryContents dir
let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs let files = map (\d -> dir <> literalOsPath "/" <> d <> literalOsPath "/" <> takeFileName d) dirs
liftIO $ filterM present files liftIO $ filterM present files
, return [] , return []
) )
where where
present :: OsPath -> IO Bool
present f = do present f = do
result <- tryIO $ R.getFileStatus (toRawFilePath f) result <- tryIO $ R.getFileStatus (fromOsPath f)
case result of case result of
Right s -> return $ isRegularFile s Right s -> return $ isRegularFile s
Left _ -> return False Left _ -> return False
logFile1 :: Git.Repo -> Key -> String logFile2 :: Key -> Git.Repo -> OsPath
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
logFile2 :: Key -> Git.Repo -> String
logFile2 = logFile' (hashDirLower def) logFile2 = logFile' (hashDirLower def)
logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String logFile' :: (Key -> OsPath) -> Key -> Git.Repo -> OsPath
logFile' hasher key repo = logFile' hasher key repo =
gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log" gitStateDir repo <> hasher key <> keyFile key <> literalOsPath ".log"
stateDir :: FilePath stateDir :: OsPath
stateDir = addTrailingPathSeparator ".git-annex" stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
gitStateDir :: Git.Repo -> FilePath gitStateDir :: Git.Repo -> OsPath
gitStateDir repo = addTrailingPathSeparator $ gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
fromRawFilePath (Git.repoPath repo) </> stateDir

50
Upgrade/V2.hs
View file

@ -21,11 +21,12 @@ import Utility.Tmp
import Logs import Logs
import Messages.Progress import Messages.Progress
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified Utility.OsString as OS
olddir :: Git.Repo -> FilePath olddir :: Git.Repo -> OsPath
olddir g olddir g
| Git.repoIsLocalBare g = "" | Git.repoIsLocalBare g = literalOsPath ""
| otherwise = ".git-annex" | otherwise = literalOsPath ".git-annex"
{- .git-annex/ moved to a git-annex branch. {- .git-annex/ moved to a git-annex branch.
- -
@ -54,14 +55,14 @@ upgrade = do
e <- liftIO $ doesDirectoryExist old e <- liftIO $ doesDirectoryExist old
when e $ do when e $ do
config <- Annex.getGitConfig config <- Annex.getGitConfig
mapM_ (\(k, f) -> inject f $ fromRawFilePath $ locationLogFile config k) =<< locationLogs mapM_ (\(k, f) -> inject f $ locationLogFile config k) =<< locationLogs
mapM_ (\f -> inject f f) =<< logFiles old mapM_ (\f -> inject f f) =<< logFiles old
saveState False saveState False
showProgressDots showProgressDots
when e $ do when e $ do
inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File old] inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File (fromOsPath old)]
unless bare $ inRepo gitAttributesUnWrite unless bare $ inRepo gitAttributesUnWrite
showProgressDots showProgressDots
@ -69,29 +70,29 @@ upgrade = do
return UpgradeSuccess return UpgradeSuccess
locationLogs :: Annex [(Key, FilePath)] locationLogs :: Annex [(Key, OsPath)]
locationLogs = do locationLogs = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
dir <- fromRepo gitStateDir dir <- fromRepo gitStateDir
liftIO $ do liftIO $ do
levela <- dirContents (toRawFilePath dir) levela <- dirContents dir
levelb <- mapM tryDirContents levela levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb) files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files) return $ mapMaybe (islogfile config) (concat files)
where where
tryDirContents d = catchDefaultIO [] $ dirContents d tryDirContents d = catchDefaultIO [] $ dirContents d
islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $ islogfile config f = maybe Nothing (\k -> Just (k, f)) $
locationLogFileKey config f locationLogFileKey config f
inject :: FilePath -> FilePath -> Annex () inject :: OsPath -> OsPath -> Annex ()
inject source dest = do inject source dest = do
old <- fromRepo olddir old <- fromRepo olddir
new <- liftIO (readFile $ old </> source) new <- liftIO (readFile $ fromOsPath $ old </> source)
Annex.Branch.change (Annex.Branch.RegardingUUID []) (toRawFilePath dest) $ \prev -> Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev ->
encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new
logFiles :: FilePath -> Annex [FilePath] logFiles :: OsPath -> Annex [OsPath]
logFiles dir = return . filter (".log" `isSuffixOf`) logFiles dir = return . filter (literalOsPath ".log" `OS.isSuffixOf`)
<=< liftIO $ getDirectoryContents dir <=< liftIO $ getDirectoryContents dir
push :: Annex () push :: Annex ()
@ -130,25 +131,22 @@ push = do
{- Old .gitattributes contents, not needed anymore. -} {- Old .gitattributes contents, not needed anymore. -}
attrLines :: [String] attrLines :: [String]
attrLines = attrLines =
[ stateDir </> "*.log merge=union" [ fromOsPath $ stateDir </> literalOsPath "*.log merge=union"
, stateDir </> "*/*/*.log merge=union" , fromOsPath $ stateDir </> literalOsPath "*/*/*.log merge=union"
] ]
gitAttributesUnWrite :: Git.Repo -> IO () gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do gitAttributesUnWrite repo = do
let attributes = Git.attributes repo let attributes = Git.attributes repo
let attributes' = fromRawFilePath attributes whenM (doesFileExist attributes) $ do
whenM (doesFileExist attributes') $ do
c <- map decodeBS . fileLines' c <- map decodeBS . fileLines'
<$> F.readFile' (toOsPath attributes) <$> F.readFile' attributes
liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath) liftIO $ viaTmp (writeFile . fromOsPath) attributes
(toOsPath attributes)
(unlines $ filter (`notElem` attrLines) c) (unlines $ filter (`notElem` attrLines) c)
Git.Command.run [Param "add", File attributes'] repo Git.Command.run [Param "add", File (fromOsPath attributes)] repo
stateDir :: FilePath stateDir :: OsPath
stateDir = addTrailingPathSeparator ".git-annex" stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
gitStateDir :: Git.Repo -> FilePath gitStateDir :: Git.Repo -> OsPath
gitStateDir repo = addTrailingPathSeparator $ gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
fromRawFilePath (Git.repoPath repo) </> stateDir

12
Upgrade/V5.hs
View file

@ -33,7 +33,6 @@ import Git.Ref
import Utility.InodeCache import Utility.InodeCache
import Utility.DottedVersion import Utility.DottedVersion
import Annex.AdjustedBranch import Annex.AdjustedBranch
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
upgrade :: Bool -> Annex UpgradeResult upgrade :: Bool -> Annex UpgradeResult
@ -130,7 +129,7 @@ upgradeDirectWorkTree = do
stagePointerFile f Nothing =<< hashPointerFile k stagePointerFile f Nothing =<< hashPointerFile k
ifM (isJust <$> getAnnexLinkTarget f) ifM (isJust <$> getAnnexLinkTarget f)
( writepointer f k ( writepointer f k
, fromdirect (fromRawFilePath f) k , fromdirect f k
) )
Database.Keys.addAssociatedFile k Database.Keys.addAssociatedFile k
=<< inRepo (toTopFilePath f) =<< inRepo (toTopFilePath f)
@ -138,14 +137,13 @@ upgradeDirectWorkTree = do
fromdirect f k = ifM (Direct.goodContent k f) fromdirect f k = ifM (Direct.goodContent k f)
( do ( do
let f' = toRawFilePath f
-- If linkToAnnex fails for some reason, the work tree -- If linkToAnnex fails for some reason, the work tree
-- file still has the content; the annex object file -- file still has the content; the annex object file
-- is just not populated with it. Since the work tree -- is just not populated with it. Since the work tree
-- file is recorded as an associated file, things will -- file is recorded as an associated file, things will
-- still work that way, it's just not ideal. -- still work that way, it's just not ideal.
ic <- withTSDelta (liftIO . genInodeCache f') ic <- withTSDelta (liftIO . genInodeCache f)
void $ Content.linkToAnnex k f' ic void $ Content.linkToAnnex k f ic
, unlessM (Content.inAnnex k) $ do , unlessM (Content.inAnnex k) $ do
-- Worktree file was deleted or modified; -- Worktree file was deleted or modified;
-- if there are no other copies of the content -- if there are no other copies of the content
@ -157,8 +155,8 @@ upgradeDirectWorkTree = do
) )
writepointer f k = liftIO $ do writepointer f k = liftIO $ do
removeWhenExistsWith R.removeLink f removeWhenExistsWith removeFile f
F.writeFile' (toOsPath f) (formatPointer k) F.writeFile' f (formatPointer k)
{- Remove all direct mode bookkeeping files. -} {- Remove all direct mode bookkeeping files. -}
removeDirectCruft :: Annex () removeDirectCruft :: Annex ()

2
Upgrade/V9.hs
View file

@ -55,7 +55,7 @@ upgrade automatic
- run for an entire year and so predate the v9 upgrade. -} - run for an entire year and so predate the v9 upgrade. -}
assistantrunning = do assistantrunning = do
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
isJust <$> liftIO (checkDaemon (fromRawFilePath pidfile)) isJust <$> liftIO (checkDaemon (fromOsPath pidfile))
unsafeupgrade = unsafeupgrade =
[ "Not upgrading from v9 to v10, because there may be git-annex" [ "Not upgrading from v9 to v10, because there may be git-annex"