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

finished this stage of the RawFilePath conversion

Browse source 
Finally compiles again, and test suite passes.

This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess 2020-11-04 14:20:37 -04:00
parent 4bcb4030a5
commit 5a1e73617d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
36 changed files with 188 additions and 147 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Command/Assistant.hs
View file

@ -12,6 +12,7 @@ import qualified Command.Watch
import Annex.Init
import Annex.Path
import Config.Files
import Config.Files.AutoStart
import qualified BuildInfo
import Utility.HumanTime
import Assistant.Install

56
Command/Import.hs
View file

@ -34,6 +34,7 @@ import Git.FilePath
import Git.Types
import Types.Import
import Utility.Metered
import qualified Utility.RawFilePath as R
import Control.Concurrent.STM
@ -118,10 +119,11 @@ duplicateModeParser =
seek :: ImportOptions -> CommandSeek
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath)
<$> mapM (absPath . toRawFilePath) (importFiles o)
unless (null inrepops) $ do
giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords (map fromRawFilePath inrepops)
largematcher <- largeFilesMatcher
addunlockedmatcher <- addUnlockedMatcher
(commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o))
@ -136,23 +138,21 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
(importToSubDir o)
seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o)
startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart
startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile)
( starting "import" ai si pickaction
, stop
)
where
ai = ActionItemWorkTreeFile destfile'
ai = ActionItemWorkTreeFile destfile
si = SeekInput []
destfile' = toRawFilePath destfile
deletedup k = do
showNote $ "duplicate of " ++ serializeKey k
verifyExisting k destfile
( do
liftIO $ removeFile srcfile
liftIO $ R.removeLink srcfile
next $ return True
, do
warning "Could not verify that the content is still present in the annex; not removing from the import location."
@ -165,35 +165,35 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
ignored <- checkIgnored (checkGitIgnoreOption o) destfile
if ignored
then do
warning $ "not importing " ++ destfile ++ " which is .gitignored (use --no-check-gitignore to override)"
warning $ "not importing " ++ fromRawFilePath destfile ++ " which is .gitignored (use --no-check-gitignore to override)"
stop
else do
existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
case existing of
Nothing -> importfilechecked ld k
Just s
| isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getState Annex.force)
( do
liftIO $ removeWhenExistsWith removeLink destfile
liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k
, notoverwriting "(is a symlink)"
)
| otherwise -> ifM (Annex.getState Annex.force)
( do
liftIO $ removeWhenExistsWith removeLink destfile
liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
)
checkdestdir cont = do
let destdir = parentDir destfile
existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destdir)
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir)
case existing of
Nothing -> cont
Just s
| isDirectory s -> cont
| otherwise -> do
warning $ "not importing " ++ destfile ++ " because " ++ destdir ++ " is not a directory"
warning $ "not importing " ++ fromRawFilePath destfile ++ " because " ++ fromRawFilePath destdir ++ " is not a directory"
stop
importfilechecked ld k = do
@ -201,13 +201,17 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
-- The dest file is what will be ingested.
createWorkTreeDirectory (parentDir destfile)
liftIO $ if mode == Duplicate || mode == SkipDuplicates
then void $ copyFileExternal CopyAllMetaData srcfile destfile
else moveFile srcfile destfile
then void $ copyFileExternal CopyAllMetaData
(fromRawFilePath srcfile)
(fromRawFilePath destfile)
else moveFile
(fromRawFilePath srcfile)
(fromRawFilePath destfile)
-- Get the inode cache of the dest file. It should be
-- weakly the same as the originally locked down file's
-- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.)
newcache <- withTSDelta $ liftIO . genInodeCache destfile'
newcache <- withTSDelta $ liftIO . genInodeCache destfile
let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True
(Just newc, Just c) | compareWeak c newc -> True
@ -218,8 +222,8 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
-- is what will be ingested.
let ld' = ld
{ keySource = KeySource
{ keyFilename = destfile'
, contentLocation = destfile'
{ keyFilename = destfile
, contentLocation = destfile
, inodeCache = newcache
}
}
@ -228,15 +232,15 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
>>= maybe
stop
(\addedk -> next $ Command.Add.cleanup addedk True)
, next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile'
, next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile
)
notoverwriting why = do
warning $ "not overwriting existing " ++ destfile ++ " " ++ why
warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why
stop
lockdown a = do
let mi = MatchingFile $ FileInfo
{ contentFile = Just (toRawFilePath srcfile)
, matchFile = toRawFilePath destfile
{ contentFile = Just srcfile
, matchFile = destfile
}
lockingfile <- not <$> addUnlocked addunlockedmatcher mi
-- Minimal lock down with no hard linking so nothing
@ -245,7 +249,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
{ lockingFile = lockingfile
, hardlinkFileTmpDir = Nothing
}
v <- lockDown cfg srcfile
v <- lockDown cfg (fromRawFilePath srcfile)
case v of
Just ld -> do
backend <- chooseBackend destfile
@ -270,7 +274,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
_ -> importfile ld k
skipbecause s = showNote (s ++ "; skipping") >> next (return True)
verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported.

15
Command/ImportFeed.hs
View file

@ -22,6 +22,7 @@ import Data.Time.LocalTime
import qualified Data.Text as T
import System.Log.Logger
import Control.Concurrent.Async
import qualified System.FilePath.ByteString as P
import Command
import qualified Annex
@ -188,13 +189,14 @@ performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownloa
performDownload addunlockedmatcher opts cache todownload = case location todownload of
Enclosure url -> checkknown url $
rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do
let f' = fromRawFilePath f
r <- Remote.claimingUrl url
if Remote.uuid r == webUUID || rawOption (downloadOptions opts)
then do
let dlopts = (downloadOptions opts)
-- force using the filename
-- chosen here
{ fileOption = Just f
{ fileOption = Just f'
-- don't use youtube-dl
, rawOption = True
}
@ -218,7 +220,8 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz
Right (UrlMulti l) -> do
kl <- forM l $ \(url', sz, subf) ->
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f </> sanitizeFilePath subf) sz
let dest = f P.</> toRawFilePath (sanitizeFilePath subf)
in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz
return $ Just $ if all isJust kl
then catMaybes kl
else []
@ -257,7 +260,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
Nothing -> return True
Just f -> do
showStartOther "addurl" (Just url) (SeekInput [])
getter f >>= \case
getter (toRawFilePath f) >>= \case
Just ks
-- Download problem.
| null ks -> do
@ -307,7 +310,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
| rawOption (downloadOptions opts) = downloadlink
| otherwise = do
r <- withTmpWorkDir mediakey $ \workdir -> do
dl <- youtubeDl linkurl workdir nullMeterUpdate
dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate
case dl of
Right (Just mediafile) -> do
let ext = case takeExtension mediafile of
@ -315,7 +318,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
s -> s
ok <- rundownload linkurl ext $ \f ->
checkCanAdd (downloadOptions opts) f $ \canadd -> do
addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)
addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile))
return (Just [mediakey])
return (Just ok)
-- youtude-dl didn't support it, so
@ -457,7 +460,7 @@ checkFeedBroken url = checkFeedBroken' url =<< feedState url
checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool
checkFeedBroken' url f = do
prev <- maybe Nothing readish
<$> liftIO (catchMaybeIO $ readFile (fromRawFlePath f))
<$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f))
now <- liftIO getCurrentTime
case prev of
Nothing -> do

2
Command/Sync.hs
View file

@ -191,7 +191,7 @@ instance DeferredParseClass SyncOptions where
<*> pure (pushOption v)
<*> pure (contentOption v)
<*> pure (noContentOption v)
<*> liftIO (mapM absPath (contentOfOption v))
<*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v))
<*> pure (cleanupOption v)
<*> pure (keyOptions v)
<*> pure (resolveMergeOverride v)

7
Command/Undo.hs
View file

@ -16,6 +16,7 @@ import qualified Git.LsFiles as LsFiles
import qualified Git.Command as Git
import qualified Git.Branch
import qualified Command.Sync
import qualified Utility.RawFilePath as R
cmd :: Command
cmd = notBareRepo $
@ -62,15 +63,15 @@ 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 `elem` nullShas) diff'
let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $
let mkrel di = liftIO $ relPathCwdToFile $
fromTopFilePath (file di) g
forM_ removals $ \di -> do
f <- mkrel di
liftIO $ removeWhenExistsWith removeLink f
liftIO $ removeWhenExistsWith R.removeLink f
forM_ adds $ \di -> do
f <- mkrel di
f <- fromRawFilePath <$> mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f]
next $ liftIO cleanup

16
Command/WebApp.hs
View file

@ -27,7 +27,7 @@ import Git.Types (fromConfigValue)
import qualified Git.Config
import qualified Git.CurrentRepo
import qualified Annex
import Config.Files
import Config.Files.AutoStart
import Upgrade
import Annex.Version
import Utility.Android
@ -75,15 +75,15 @@ start' allowauto o = do
listenAddress' <- if isJust (listenAddress o)
then pure (listenAddress o)
else annexListen <$> Annex.getGitConfig
ifM (checkpid <&&> checkshim f)
ifM (checkpid <&&> checkshim (fromRawFilePath f))
( if isJust (listenAddress o)
then giveup "The assistant is already running, so --listen cannot be used."
else do
url <- liftIO . readFile
url <- liftIO . readFile . fromRawFilePath
=<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress'
then putStrLn url
else liftIO $ openBrowser browser f url Nothing Nothing
else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
, do
startDaemon True True Nothing cannotrun listenAddress' $ Just $
\origout origerr url htmlshim ->
@ -93,7 +93,7 @@ start' allowauto o = do
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile
liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
checkshim f = liftIO $ doesFileExist f
notinitialized = do
g <- Annex.gitRepo
@ -105,8 +105,8 @@ start' allowauto o = do
notHome :: Annex Bool
notHome = do
g <- Annex.gitRepo
d <- liftIO $ absPath (Git.repoLocation g)
h <- liftIO $ absPath =<< myHomeDir
d <- liftIO $ absPath (Git.repoPath g)
h <- liftIO $ absPath . toRawFilePath =<< myHomeDir
return (d /= h)
{- When run without a repo, start the first available listed repository in
@ -191,7 +191,7 @@ firstRun o = do
openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do
htmlshim' <- absPath htmlshim
htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim)
openBrowser' mcmd htmlshim' realurl outh errh
openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()