more OsPath conversion
Sponsored-by: Graham Spencer
This commit is contained in:
parent
5cc8d9d03b
commit
cf986bc7e2
4 changed files with 69 additions and 82 deletions
|
@ -15,7 +15,6 @@ import Data.Default
|
|||
import Data.ByteString.Builder
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Short as S (toShort, fromShort)
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import System.PosixCompat.Files (isRegularFile)
|
||||
import Text.Read
|
||||
|
||||
|
@ -82,20 +81,19 @@ moveContent = do
|
|||
forM_ files move
|
||||
where
|
||||
move f = do
|
||||
let f' = toRawFilePath f
|
||||
let k = fileKey1 (fromRawFilePath (P.takeFileName f'))
|
||||
let d = parentDir f'
|
||||
let k = fileKey1 (fromOsPath $ takeFileName f)
|
||||
let d = parentDir f
|
||||
liftIO $ allowWrite d
|
||||
liftIO $ allowWrite f'
|
||||
_ <- moveAnnex k (AssociatedFile Nothing) f'
|
||||
liftIO $ removeDirectory (fromRawFilePath d)
|
||||
liftIO $ allowWrite f
|
||||
_ <- moveAnnex k (AssociatedFile Nothing) f
|
||||
liftIO $ removeDirectory d
|
||||
|
||||
updateSymlinks :: Annex ()
|
||||
updateSymlinks = do
|
||||
showAction "updating symlinks"
|
||||
top <- fromRepo Git.repoPath
|
||||
(files, cleanup) <- inRepo $ LsFiles.inRepo [] [top]
|
||||
forM_ files (fixlink . fromRawFilePath)
|
||||
forM_ files fixlink
|
||||
void $ liftIO cleanup
|
||||
where
|
||||
fixlink f = do
|
||||
|
@ -103,11 +101,10 @@ updateSymlinks = do
|
|||
case r of
|
||||
Nothing -> noop
|
||||
Just (k, _) -> do
|
||||
link <- fromRawFilePath
|
||||
<$> calcRepo (gitAnnexLink (toRawFilePath f) k)
|
||||
link <- calcRepo (gitAnnexLink f k)
|
||||
liftIO $ removeFile f
|
||||
liftIO $ R.createSymbolicLink (toRawFilePath link) (toRawFilePath f)
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [f]
|
||||
liftIO $ R.createSymbolicLink (fromOsPath link) (fromOsPath f)
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [(fromOsPath f)]
|
||||
|
||||
moveLocationLogs :: Annex ()
|
||||
moveLocationLogs = do
|
||||
|
@ -118,15 +115,15 @@ moveLocationLogs = do
|
|||
oldlocationlogs = do
|
||||
dir <- fromRepo Upgrade.V2.gitStateDir
|
||||
ifM (liftIO $ doesDirectoryExist dir)
|
||||
( mapMaybe oldlog2key
|
||||
( mapMaybe (oldlog2key . fromOsPath)
|
||||
<$> liftIO (getDirectoryContents dir)
|
||||
, return []
|
||||
)
|
||||
move (l, k) = do
|
||||
dest <- fromRepo (logFile2 k)
|
||||
dir <- fromRepo Upgrade.V2.gitStateDir
|
||||
let f = dir </> l
|
||||
createWorkTreeDirectory (parentDir (toRawFilePath dest))
|
||||
let f = dir </> toOsPath l
|
||||
createWorkTreeDirectory (parentDir dest)
|
||||
-- could just git mv, but this way deals with
|
||||
-- log files that are not checked into git,
|
||||
-- as well as merging with already upgraded
|
||||
|
@ -134,9 +131,9 @@ moveLocationLogs = do
|
|||
old <- liftIO $ readLog1 f
|
||||
new <- liftIO $ readLog1 dest
|
||||
liftIO $ writeLog1 dest (old++new)
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [dest]
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [f]
|
||||
Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f]
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath dest]
|
||||
Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath f]
|
||||
Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [fromOsPath f]
|
||||
|
||||
oldlog2key :: FilePath -> Maybe (FilePath, Key)
|
||||
oldlog2key l
|
||||
|
@ -197,70 +194,64 @@ fileKey1 :: FilePath -> Key
|
|||
fileKey1 file = readKey1 $
|
||||
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
|
||||
|
||||
writeLog1 :: FilePath -> [LogLine] -> IO ()
|
||||
writeLog1 file ls = viaTmp F.writeFile
|
||||
(toOsPath (toRawFilePath file))
|
||||
(toLazyByteString $ buildLog ls)
|
||||
writeLog1 :: OsPath -> [LogLine] -> IO ()
|
||||
writeLog1 file ls = viaTmp F.writeFile file (toLazyByteString $ buildLog ls)
|
||||
|
||||
readLog1 :: FilePath -> IO [LogLine]
|
||||
readLog1 file = catchDefaultIO [] $
|
||||
parseLog <$> F.readFile (toOsPath (toRawFilePath file))
|
||||
readLog1 :: OsPath -> IO [LogLine]
|
||||
readLog1 file = catchDefaultIO [] $ parseLog <$> F.readFile file
|
||||
|
||||
lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
|
||||
lookupKey1 :: OsPath -> Annex (Maybe (Key, Backend))
|
||||
lookupKey1 file = do
|
||||
tl <- liftIO $ tryIO getsymlink
|
||||
case tl of
|
||||
Left _ -> return Nothing
|
||||
Right l -> makekey l
|
||||
where
|
||||
getsymlink = takeFileName . fromRawFilePath
|
||||
<$> R.readSymbolicLink (toRawFilePath file)
|
||||
getsymlink :: IO OsPath
|
||||
getsymlink = takeFileName . toOsPath
|
||||
<$> R.readSymbolicLink (fromOsPath file)
|
||||
makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
|
||||
Nothing -> do
|
||||
unless (null kname || null bname ||
|
||||
not (isLinkToAnnex (toRawFilePath l))) $
|
||||
not (isLinkToAnnex (fromOsPath l))) $
|
||||
warning (UnquotedString skip)
|
||||
return Nothing
|
||||
Just backend -> return $ Just (k, backend)
|
||||
where
|
||||
k = fileKey1 l
|
||||
k = fileKey1 (fromOsPath l)
|
||||
bname = decodeBS (formatKeyVariety (fromKey keyVariety k))
|
||||
kname = decodeBS (S.fromShort (fromKey keyName k))
|
||||
skip = "skipping " ++ file ++
|
||||
skip = "skipping " ++ fromOsPath file ++
|
||||
" (unknown backend " ++ bname ++ ")"
|
||||
|
||||
getKeyFilesPresent1 :: Annex [FilePath]
|
||||
getKeyFilesPresent1 = getKeyFilesPresent1' . fromRawFilePath
|
||||
=<< fromRepo gitAnnexObjectDir
|
||||
getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
|
||||
getKeyFilesPresent1 :: Annex [OsPath]
|
||||
getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir
|
||||
getKeyFilesPresent1' :: OsPath -> Annex [OsPath]
|
||||
getKeyFilesPresent1' dir =
|
||||
ifM (liftIO $ doesDirectoryExist dir)
|
||||
( do
|
||||
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
|
||||
, return []
|
||||
)
|
||||
where
|
||||
present :: OsPath -> IO Bool
|
||||
present f = do
|
||||
result <- tryIO $ R.getFileStatus (toRawFilePath f)
|
||||
result <- tryIO $ R.getFileStatus (fromOsPath f)
|
||||
case result of
|
||||
Right s -> return $ isRegularFile s
|
||||
Left _ -> return False
|
||||
|
||||
logFile1 :: Git.Repo -> Key -> String
|
||||
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
|
||||
|
||||
logFile2 :: Key -> Git.Repo -> String
|
||||
logFile2 :: Key -> Git.Repo -> OsPath
|
||||
logFile2 = logFile' (hashDirLower def)
|
||||
|
||||
logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String
|
||||
logFile' :: (Key -> OsPath) -> Key -> Git.Repo -> OsPath
|
||||
logFile' hasher key repo =
|
||||
gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log"
|
||||
gitStateDir repo <> hasher key <> keyFile key <> literalOsPath ".log"
|
||||
|
||||
stateDir :: FilePath
|
||||
stateDir = addTrailingPathSeparator ".git-annex"
|
||||
stateDir :: OsPath
|
||||
stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
|
||||
|
||||
gitStateDir :: Git.Repo -> FilePath
|
||||
gitStateDir repo = addTrailingPathSeparator $
|
||||
fromRawFilePath (Git.repoPath repo) </> stateDir
|
||||
gitStateDir :: Git.Repo -> OsPath
|
||||
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
|
||||
|
|
|
@ -21,11 +21,12 @@ import Utility.Tmp
|
|||
import Logs
|
||||
import Messages.Progress
|
||||
import qualified Utility.FileIO as F
|
||||
import qualified Utility.OsString as OS
|
||||
|
||||
olddir :: Git.Repo -> FilePath
|
||||
olddir :: Git.Repo -> OsPath
|
||||
olddir g
|
||||
| Git.repoIsLocalBare g = ""
|
||||
| otherwise = ".git-annex"
|
||||
| Git.repoIsLocalBare g = literalOsPath ""
|
||||
| otherwise = literalOsPath ".git-annex"
|
||||
|
||||
{- .git-annex/ moved to a git-annex branch.
|
||||
-
|
||||
|
@ -54,14 +55,14 @@ upgrade = do
|
|||
e <- liftIO $ doesDirectoryExist old
|
||||
when e $ do
|
||||
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
|
||||
|
||||
saveState False
|
||||
showProgressDots
|
||||
|
||||
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
|
||||
showProgressDots
|
||||
|
||||
|
@ -69,29 +70,29 @@ upgrade = do
|
|||
|
||||
return UpgradeSuccess
|
||||
|
||||
locationLogs :: Annex [(Key, FilePath)]
|
||||
locationLogs :: Annex [(Key, OsPath)]
|
||||
locationLogs = do
|
||||
config <- Annex.getGitConfig
|
||||
dir <- fromRepo gitStateDir
|
||||
liftIO $ do
|
||||
levela <- dirContents (toRawFilePath dir)
|
||||
levela <- dirContents dir
|
||||
levelb <- mapM tryDirContents levela
|
||||
files <- mapM tryDirContents (concat levelb)
|
||||
return $ mapMaybe (islogfile config) (concat files)
|
||||
where
|
||||
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
|
||||
|
||||
inject :: FilePath -> FilePath -> Annex ()
|
||||
inject :: OsPath -> OsPath -> Annex ()
|
||||
inject source dest = do
|
||||
old <- fromRepo olddir
|
||||
new <- liftIO (readFile $ old </> source)
|
||||
Annex.Branch.change (Annex.Branch.RegardingUUID []) (toRawFilePath dest) $ \prev ->
|
||||
new <- liftIO (readFile $ fromOsPath $ old </> source)
|
||||
Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev ->
|
||||
encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new
|
||||
|
||||
logFiles :: FilePath -> Annex [FilePath]
|
||||
logFiles dir = return . filter (".log" `isSuffixOf`)
|
||||
logFiles :: OsPath -> Annex [OsPath]
|
||||
logFiles dir = return . filter (literalOsPath ".log" `OS.isSuffixOf`)
|
||||
<=< liftIO $ getDirectoryContents dir
|
||||
|
||||
push :: Annex ()
|
||||
|
@ -130,25 +131,22 @@ push = do
|
|||
{- Old .gitattributes contents, not needed anymore. -}
|
||||
attrLines :: [String]
|
||||
attrLines =
|
||||
[ stateDir </> "*.log merge=union"
|
||||
, stateDir </> "*/*/*.log merge=union"
|
||||
[ fromOsPath $ stateDir </> literalOsPath "*.log merge=union"
|
||||
, fromOsPath $ stateDir </> literalOsPath "*/*/*.log merge=union"
|
||||
]
|
||||
|
||||
gitAttributesUnWrite :: Git.Repo -> IO ()
|
||||
gitAttributesUnWrite repo = do
|
||||
let attributes = Git.attributes repo
|
||||
let attributes' = fromRawFilePath attributes
|
||||
whenM (doesFileExist attributes') $ do
|
||||
whenM (doesFileExist attributes) $ do
|
||||
c <- map decodeBS . fileLines'
|
||||
<$> F.readFile' (toOsPath attributes)
|
||||
liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath)
|
||||
(toOsPath attributes)
|
||||
<$> F.readFile' attributes
|
||||
liftIO $ viaTmp (writeFile . fromOsPath) attributes
|
||||
(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 = addTrailingPathSeparator ".git-annex"
|
||||
stateDir :: OsPath
|
||||
stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
|
||||
|
||||
gitStateDir :: Git.Repo -> FilePath
|
||||
gitStateDir repo = addTrailingPathSeparator $
|
||||
fromRawFilePath (Git.repoPath repo) </> stateDir
|
||||
gitStateDir :: Git.Repo -> OsPath
|
||||
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
|
||||
|
|
|
@ -33,7 +33,6 @@ import Git.Ref
|
|||
import Utility.InodeCache
|
||||
import Utility.DottedVersion
|
||||
import Annex.AdjustedBranch
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
upgrade :: Bool -> Annex UpgradeResult
|
||||
|
@ -130,7 +129,7 @@ upgradeDirectWorkTree = do
|
|||
stagePointerFile f Nothing =<< hashPointerFile k
|
||||
ifM (isJust <$> getAnnexLinkTarget f)
|
||||
( writepointer f k
|
||||
, fromdirect (fromRawFilePath f) k
|
||||
, fromdirect f k
|
||||
)
|
||||
Database.Keys.addAssociatedFile k
|
||||
=<< inRepo (toTopFilePath f)
|
||||
|
@ -138,14 +137,13 @@ upgradeDirectWorkTree = do
|
|||
|
||||
fromdirect f k = ifM (Direct.goodContent k f)
|
||||
( do
|
||||
let f' = toRawFilePath f
|
||||
-- If linkToAnnex fails for some reason, the work tree
|
||||
-- file still has the content; the annex object file
|
||||
-- is just not populated with it. Since the work tree
|
||||
-- file is recorded as an associated file, things will
|
||||
-- still work that way, it's just not ideal.
|
||||
ic <- withTSDelta (liftIO . genInodeCache f')
|
||||
void $ Content.linkToAnnex k f' ic
|
||||
ic <- withTSDelta (liftIO . genInodeCache f)
|
||||
void $ Content.linkToAnnex k f ic
|
||||
, unlessM (Content.inAnnex k) $ do
|
||||
-- Worktree file was deleted or modified;
|
||||
-- if there are no other copies of the content
|
||||
|
@ -157,8 +155,8 @@ upgradeDirectWorkTree = do
|
|||
)
|
||||
|
||||
writepointer f k = liftIO $ do
|
||||
removeWhenExistsWith R.removeLink f
|
||||
F.writeFile' (toOsPath f) (formatPointer k)
|
||||
removeWhenExistsWith removeFile f
|
||||
F.writeFile' f (formatPointer k)
|
||||
|
||||
{- Remove all direct mode bookkeeping files. -}
|
||||
removeDirectCruft :: Annex ()
|
||||
|
|
|
@ -55,7 +55,7 @@ upgrade automatic
|
|||
- run for an entire year and so predate the v9 upgrade. -}
|
||||
assistantrunning = do
|
||||
pidfile <- fromRepo gitAnnexPidFile
|
||||
isJust <$> liftIO (checkDaemon (fromRawFilePath pidfile))
|
||||
isJust <$> liftIO (checkDaemon (fromOsPath pidfile))
|
||||
|
||||
unsafeupgrade =
|
||||
[ "Not upgrading from v9 to v10, because there may be git-annex"
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue