more RawFilePath conversion
535/645 This commit was sponsored by Brett Eisenberg on Patreon.
This commit is contained in:
Joey Hess
parent
55400a03d3
commit
eb42cd4d46
23 changed files with 182 additions and 159 deletions
|
|
@ -22,7 +22,7 @@ import Annex.Concurrent.Utility
|
|||
|
||||
newtype CheckGitIgnore = CheckGitIgnore Bool
|
||||
|
||||
checkIgnored :: CheckGitIgnore -> FilePath -> Annex Bool
|
||||
checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool
|
||||
checkIgnored (CheckGitIgnore False) _ = pure False
|
||||
checkIgnored (CheckGitIgnore True) file =
|
||||
ifM (Annex.getState Annex.force)
|
||||
|
|
|
|||
|
|
@ -64,12 +64,13 @@ depopulatePointerFile key file = do
|
|||
secureErase file
|
||||
liftIO $ removeWhenExistsWith R.removeLink file
|
||||
ic <- replaceWorkTreeFile file' $ \tmp -> do
|
||||
liftIO $ writePointerFile (toRawFilePath tmp) key mode
|
||||
let tmp' = toRawFilePath tmp
|
||||
liftIO $ writePointerFile tmp' key mode
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
-- Don't advance mtime; this avoids unncessary re-smudging
|
||||
-- by git in some cases.
|
||||
liftIO $ maybe noop
|
||||
(\t -> touch tmp t False)
|
||||
(\t -> touch tmp' t False)
|
||||
(fmap modificationTimeHiRes st)
|
||||
#endif
|
||||
withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ data LockedDown = LockedDown
|
|||
data LockDownConfig = LockDownConfig
|
||||
{ lockingFile :: Bool
|
||||
-- ^ write bit removed during lock down
|
||||
, hardlinkFileTmpDir :: Maybe FilePath
|
||||
, hardlinkFileTmpDir :: Maybe RawFilePath
|
||||
-- ^ hard link to temp directory
|
||||
}
|
||||
deriving (Show)
|
||||
|
|
@ -109,7 +109,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
|
|||
when (lockingFile cfg) $
|
||||
freezeContent file
|
||||
withTSDelta $ \delta -> liftIO $ do
|
||||
(tmpfile, h) <- openTempFile tmpdir $
|
||||
(tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $
|
||||
relatedTemplate $ "ingest-" ++ takeFileName file
|
||||
hClose h
|
||||
removeWhenExistsWith removeLink tmpfile
|
||||
|
|
@ -139,7 +139,7 @@ ingestAdd' ci meterupdate ld@(Just (LockedDown cfg source)) mk = do
|
|||
Just k -> do
|
||||
let f = keyFilename source
|
||||
if lockingFile cfg
|
||||
then addLink ci (fromRawFilePath f) k mic
|
||||
then addLink ci f k mic
|
||||
else do
|
||||
mode <- liftIO $ catchMaybeIO $
|
||||
fileMode <$> R.getFileStatus (contentLocation source)
|
||||
|
|
@ -272,10 +272,10 @@ restoreFile file key e = do
|
|||
throwM e
|
||||
|
||||
{- Creates the symlink to the annexed content, returns the link target. -}
|
||||
makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
|
||||
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
|
||||
l <- calcRepo $ gitAnnexLink (toRawFilePath file) key
|
||||
replaceWorkTreeFile file $ makeAnnexLink l . toRawFilePath
|
||||
makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
|
||||
makeLink file key mcache = flip catchNonAsync (restoreFile file' key) $ do
|
||||
l <- calcRepo $ gitAnnexLink file key
|
||||
replaceWorkTreeFile file' $ makeAnnexLink l . toRawFilePath
|
||||
|
||||
-- touch symlink to have same time as the original file,
|
||||
-- as provided in the InodeCache
|
||||
|
|
@ -284,6 +284,8 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
|
|||
Nothing -> noop
|
||||
|
||||
return l
|
||||
where
|
||||
file' = fromRawFilePath file
|
||||
|
||||
{- Creates the symlink to the annexed content, and stages it in git.
|
||||
-
|
||||
|
|
@ -294,15 +296,15 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
|
|||
- Also, using git add allows it to skip gitignored files, unless forced
|
||||
- to include them.
|
||||
-}
|
||||
addLink :: CheckGitIgnore -> FilePath -> Key -> Maybe InodeCache -> Annex ()
|
||||
addLink :: CheckGitIgnore -> RawFilePath -> Key -> Maybe InodeCache -> Annex ()
|
||||
addLink ci file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
|
||||
( do
|
||||
_ <- makeLink file key mcache
|
||||
ps <- gitAddParams ci
|
||||
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
|
||||
Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file]
|
||||
, do
|
||||
l <- makeLink file key mcache
|
||||
addAnnexLink l (toRawFilePath file)
|
||||
addAnnexLink l file
|
||||
)
|
||||
|
||||
{- Parameters to pass to git add, forcing addition of ignored files.
|
||||
|
|
@ -339,17 +341,17 @@ addUnlocked matcher mi =
|
|||
-
|
||||
- When the content of the key is not accepted into the annex, returns False.
|
||||
-}
|
||||
addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool
|
||||
addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool
|
||||
addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
|
||||
( do
|
||||
mode <- maybe
|
||||
(pure Nothing)
|
||||
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
|
||||
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp)
|
||||
mtmp
|
||||
stagePointerFile file' mode =<< hashPointerFile key
|
||||
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file')
|
||||
stagePointerFile file mode =<< hashPointerFile key
|
||||
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
|
||||
case mtmp of
|
||||
Just tmp -> ifM (moveAnnex key (toRawFilePath tmp))
|
||||
Just tmp -> ifM (moveAnnex key tmp)
|
||||
( linkunlocked mode >> return True
|
||||
, writepointer mode >> return False
|
||||
)
|
||||
|
|
@ -360,19 +362,19 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
|
|||
, do
|
||||
addLink ci file key Nothing
|
||||
case mtmp of
|
||||
Just tmp -> moveAnnex key (toRawFilePath tmp)
|
||||
Just tmp -> moveAnnex key tmp
|
||||
Nothing -> return True
|
||||
)
|
||||
where
|
||||
mi = case mtmp of
|
||||
Just tmp -> MatchingFile $ FileInfo
|
||||
{ contentFile = Just (toRawFilePath tmp)
|
||||
, matchFile = file'
|
||||
{ contentFile = Just tmp
|
||||
, matchFile = file
|
||||
}
|
||||
-- Provide as much info as we can without access to the
|
||||
-- file's content.
|
||||
Nothing -> MatchingInfo $ ProvidedInfo
|
||||
{ providedFilePath = file'
|
||||
{ providedFilePath = file
|
||||
, providedKey = Just key
|
||||
, providedFileSize = fromMaybe 0 $
|
||||
keySize `fromKey` key
|
||||
|
|
@ -380,10 +382,8 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
|
|||
, providedMimeEncoding = Nothing
|
||||
}
|
||||
|
||||
linkunlocked mode = linkFromAnnex key file' mode >>= \case
|
||||
LinkAnnexFailed -> liftIO $
|
||||
writePointerFile file' key mode
|
||||
linkunlocked mode = linkFromAnnex key file mode >>= \case
|
||||
LinkAnnexFailed -> liftIO $ writepointer mode
|
||||
_ -> return ()
|
||||
writepointer mode = liftIO $ writePointerFile file' key mode
|
||||
|
||||
file' = toRawFilePath file
|
||||
|
||||
writepointer mode = liftIO $ writePointerFile file key mode
|
||||
|
|
|
|||
|
|
@ -362,19 +362,19 @@ gitAnnexFsckResultsLog u r =
|
|||
|
||||
{- .git/annex/smudge.log is used to log smudges worktree files that need to
|
||||
- be updated. -}
|
||||
gitAnnexSmudgeLog :: Git.Repo -> FilePath
|
||||
gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P.</> "smudge.log"
|
||||
gitAnnexSmudgeLog :: Git.Repo -> RawFilePath
|
||||
gitAnnexSmudgeLog r = gitAnnexDir r P.</> "smudge.log"
|
||||
|
||||
gitAnnexSmudgeLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck"
|
||||
|
||||
{- .git/annex/move.log is used to log moves that are in progress,
|
||||
- to better support resuming an interrupted move. -}
|
||||
gitAnnexMoveLog :: Git.Repo -> FilePath
|
||||
gitAnnexMoveLog r = fromRawFilePath $ gitAnnexDir r P.</> "move.log"
|
||||
gitAnnexMoveLog :: Git.Repo -> RawFilePath
|
||||
gitAnnexMoveLog r = gitAnnexDir r P.</> "move.log"
|
||||
|
||||
gitAnnexMoveLock :: Git.Repo -> FilePath
|
||||
gitAnnexMoveLock r = fromRawFilePath $ gitAnnexDir r P.</> "move.lck"
|
||||
gitAnnexMoveLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexMoveLock r = gitAnnexDir r P.</> "move.lck"
|
||||
|
||||
{- .git/annex/export/ is used to store information about
|
||||
- exports to special remotes. -}
|
||||
|
|
|
|||
|
|
@ -143,7 +143,7 @@ freezeContent file = unlessM crippledFileSystem $
|
|||
removeModes writeModes .
|
||||
addModes [ownerReadMode]
|
||||
|
||||
isContentWritePermOk :: FilePath -> Annex Bool
|
||||
isContentWritePermOk :: RawFilePath -> Annex Bool
|
||||
isContentWritePermOk file = ifM crippledFileSystem
|
||||
( return True
|
||||
, withShared go
|
||||
|
|
@ -153,7 +153,7 @@ isContentWritePermOk file = ifM crippledFileSystem
|
|||
go AllShared = want writeModes
|
||||
go _ = return True
|
||||
want wantmode =
|
||||
liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case
|
||||
liftIO (catchMaybeIO $ fileMode <$> R.getFileStatus file) >>= return . \case
|
||||
Nothing -> True
|
||||
Just havemode -> havemode == combineModes (havemode:wantmode)
|
||||
|
||||
|
|
|
|||
|
|
@ -81,8 +81,9 @@ seek o = startConcurrency commandStages $ do
|
|||
annexdotfiles <- getGitConfigVal annexDotFiles
|
||||
let gofile (si, file) = case largeFilesOverride o of
|
||||
Nothing ->
|
||||
let file' = fromRawFilePath file
|
||||
in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force))
|
||||
ifM (pure (annexdotfiles || not (dotfile file))
|
||||
<&&> (checkFileMatcher largematcher file
|
||||
<||> Annex.getState Annex.force))
|
||||
( start o si file addunlockedmatcher
|
||||
, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
|
||||
( startSmall o si file
|
||||
|
|
@ -128,20 +129,19 @@ startSmallOverridden o si file =
|
|||
addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool
|
||||
addSmallOverridden o file = do
|
||||
showNote "adding content to git repository"
|
||||
let file' = fromRawFilePath file
|
||||
s <- liftIO $ getSymbolicLinkStatus file'
|
||||
s <- liftIO $ R.getSymbolicLinkStatus file
|
||||
if not (isRegularFile s)
|
||||
then addFile (checkGitIgnoreOption o) file
|
||||
else do
|
||||
-- Can't use addFile because the clean filter will
|
||||
-- honor annex.largefiles and it has been overridden.
|
||||
-- Instead, hash the file and add to the index.
|
||||
sha <- hashFile file'
|
||||
sha <- hashFile file
|
||||
let ty = if isExecutable (fileMode s)
|
||||
then TreeExecutable
|
||||
else TreeFile
|
||||
Annex.Queue.addUpdateIndex =<<
|
||||
inRepo (Git.UpdateIndex.stageFile sha ty file')
|
||||
inRepo (Git.UpdateIndex.stageFile sha ty (fromRawFilePath file))
|
||||
return True
|
||||
|
||||
addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool
|
||||
|
|
@ -172,7 +172,7 @@ start o si file addunlockedmatcher = do
|
|||
fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do
|
||||
-- the annexed symlink is present but not yet added to git
|
||||
liftIO $ removeFile (fromRawFilePath file)
|
||||
addLink (checkGitIgnoreOption o) (fromRawFilePath file) key Nothing
|
||||
addLink (checkGitIgnoreOption o) file key Nothing
|
||||
next $
|
||||
cleanup key =<< inAnnex key
|
||||
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.AddUnused where
|
||||
|
||||
import Logs.Location
|
||||
|
|
@ -33,7 +35,7 @@ perform key = next $ do
|
|||
addLink (CheckGitIgnore False) file key Nothing
|
||||
return True
|
||||
where
|
||||
file = "unused." ++ fromRawFilePath (keyFile key)
|
||||
file = "unused." <> keyFile key
|
||||
|
||||
{- The content is not in the annex, but in another directory, and
|
||||
- it seems better to error out, rather than moving bad/tmp content into
|
||||
|
|
|
|||
|
|
@ -7,8 +7,6 @@
|
|||
|
||||
module Command.AddUrl where
|
||||
|
||||
import Network.URI
|
||||
|
||||
import Command
|
||||
import Backend
|
||||
import qualified Annex
|
||||
|
|
@ -32,8 +30,12 @@ import Logs.Location
|
|||
import Utility.Metered
|
||||
import Utility.HtmlDetect
|
||||
import Utility.Path.Max
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Annex.Transfer as Transfer
|
||||
|
||||
import Network.URI
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
cmd :: Command
|
||||
cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $
|
||||
command "addurl" SectionCommon "add urls to annex"
|
||||
|
|
@ -182,7 +184,7 @@ performRemote addunlockedmatcher r o uri file sz = ifAnnexed (toRawFilePath file
|
|||
downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
|
||||
downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do
|
||||
let urlkey = Backend.URL.fromUrl uri sz
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
createWorkTreeDirectory (parentDir (toRawFilePath file))
|
||||
ifM (Annex.getState Annex.fast <||> pure (relaxedOption o))
|
||||
( do
|
||||
addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing
|
||||
|
|
@ -313,7 +315,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
)
|
||||
normalfinish tmp = checkCanAdd o file $ \canadd -> do
|
||||
showDestinationFile file
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
createWorkTreeDirectory (parentDir (toRawFilePath file))
|
||||
Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file
|
||||
-- Ask youtube-dl what filename it will download first,
|
||||
-- so it's only used when the file contains embedded media.
|
||||
|
|
@ -326,7 +328,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
Left _ -> normalfinish tmp
|
||||
where
|
||||
dl dest = withTmpWorkDir mediakey $ \workdir -> do
|
||||
let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink)
|
||||
let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)
|
||||
showNote "using youtube-dl"
|
||||
Transfer.notifyTransfer Transfer.Download url $
|
||||
Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p ->
|
||||
|
|
@ -400,7 +402,7 @@ downloadWith' downloader dummykey u url afile =
|
|||
then return (Just tmp)
|
||||
else return Nothing
|
||||
|
||||
finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key
|
||||
finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> UUID -> URLString -> RawFilePath -> Annex Key
|
||||
finishDownloadWith canadd addunlockedmatcher tmp u url file = do
|
||||
backend <- chooseBackend file
|
||||
let source = KeySource
|
||||
|
|
@ -419,14 +421,16 @@ addSizeUrlKey urlinfo key = alterKey key $ \d -> d
|
|||
}
|
||||
|
||||
{- Adds worktree file to the repository. -}
|
||||
addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
|
||||
addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> RawFilePath -> Key -> Maybe RawFilePath -> Annex ()
|
||||
addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
|
||||
Nothing -> go
|
||||
Just tmp -> do
|
||||
-- Move to final location for large file check.
|
||||
pruneTmpWorkDirBefore tmp $ \_ -> do
|
||||
createWorkTreeDirectory (takeDirectory file)
|
||||
liftIO $ renameFile tmp file
|
||||
createWorkTreeDirectory (P.takeDirectory file)
|
||||
liftIO $ renameFile
|
||||
(fromRawFilePath tmp)
|
||||
(fromRawFilePath file)
|
||||
largematcher <- largeFilesMatcher
|
||||
large <- checkFileMatcher largematcher file
|
||||
if large
|
||||
|
|
@ -434,9 +438,11 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
|
|||
-- Move back to tmp because addAnnexedFile
|
||||
-- needs the file in a different location
|
||||
-- than the work tree file.
|
||||
liftIO $ renameFile file tmp
|
||||
liftIO $ renameFile
|
||||
(fromRawFilePath file)
|
||||
(fromRawFilePath tmp)
|
||||
go
|
||||
else void $ Command.Add.addSmall noci (toRawFilePath file)
|
||||
else void $ Command.Add.addSmall noci file
|
||||
where
|
||||
go = do
|
||||
maybeShowJSON $ JSONChunk [("key", serializeKey key)]
|
||||
|
|
@ -446,18 +452,18 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
|
|||
( do
|
||||
when (isJust mtmp) $
|
||||
logStatus key InfoPresent
|
||||
, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink)) mtmp
|
||||
, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp
|
||||
)
|
||||
|
||||
-- git does not need to check ignores, because that has already
|
||||
-- been done, as witnessed by the CannAddFile.
|
||||
noci = CheckGitIgnore False
|
||||
|
||||
nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
|
||||
nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key)
|
||||
nodownloadWeb addunlockedmatcher o url urlinfo file
|
||||
| Url.urlExists urlinfo = if rawOption o
|
||||
then nomedia
|
||||
else either (const nomedia) usemedia
|
||||
else either (const nomedia) (usemedia . toRawFilePath)
|
||||
=<< youtubeDlFileName url
|
||||
| otherwise = do
|
||||
warning $ "unable to access url: " ++ url
|
||||
|
|
@ -472,14 +478,14 @@ nodownloadWeb addunlockedmatcher o url urlinfo file
|
|||
let mediakey = Backend.URL.fromUrl mediaurl Nothing
|
||||
nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest
|
||||
|
||||
youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath
|
||||
youtubeDlDestFile :: DownloadOptions -> RawFilePath -> RawFilePath -> RawFilePath
|
||||
youtubeDlDestFile o destfile mediafile
|
||||
| isJust (fileOption o) = destfile
|
||||
| otherwise = takeFileName mediafile
|
||||
| otherwise = P.takeFileName mediafile
|
||||
|
||||
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key)
|
||||
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key)
|
||||
nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
|
||||
showDestinationFile file
|
||||
showDestinationFile (fromRawFilePath file)
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
|
||||
return (Just key)
|
||||
|
|
@ -515,14 +521,14 @@ adjustFile o = addprefix . addsuffix
|
|||
|
||||
data CanAddFile = CanAddFile
|
||||
|
||||
checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
|
||||
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file))
|
||||
checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
|
||||
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file))
|
||||
( do
|
||||
warning $ file ++ " already exists; not overwriting"
|
||||
warning $ fromRawFilePath file ++ " already exists; not overwriting"
|
||||
return Nothing
|
||||
, ifM (checkIgnored (checkGitIgnoreOption o) file)
|
||||
( do
|
||||
warning $ "not adding " ++ file ++ " which is .gitignored (use --no-check-gitignore to override)"
|
||||
warning $ "not adding " ++ fromRawFilePath file ++ " which is .gitignored (use --no-check-gitignore to override)"
|
||||
return Nothing
|
||||
, a CanAddFile
|
||||
)
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ start o si file key = stopUnless shouldCopy $
|
|||
Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key
|
||||
where
|
||||
shouldCopy
|
||||
| autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<)
|
||||
| autoMode o = want <||> numCopiesCheck file key (<)
|
||||
| otherwise = return True
|
||||
want = case fromToOptions o of
|
||||
Right (ToRemote dest) ->
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ import qualified Git
|
|||
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
|
||||
import Annex.NumCopies
|
||||
import Annex.Content
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
cmd :: Command
|
||||
cmd = command "dropunused" SectionMaintenance
|
||||
|
|
@ -63,8 +64,8 @@ perform from numcopies key = case from of
|
|||
where
|
||||
droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies []
|
||||
|
||||
performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
|
||||
performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform
|
||||
performOther filespec key = do
|
||||
f <- fromRepo $ filespec key
|
||||
pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeLink)
|
||||
pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink)
|
||||
next $ return True
|
||||
|
|
|
|||
|
|
@ -46,11 +46,10 @@ data FixWhat = FixSymlinks | FixAll
|
|||
start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start fixwhat si file key = do
|
||||
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file
|
||||
wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key
|
||||
wantlink <- calcRepo $ gitAnnexLink file key
|
||||
case currlink of
|
||||
Just l
|
||||
| l /= toRawFilePath wantlink -> fixby $
|
||||
fixSymlink (fromRawFilePath file) wantlink
|
||||
| l /= wantlink -> fixby $ fixSymlink file wantlink
|
||||
| otherwise -> stop
|
||||
Nothing -> case fixwhat of
|
||||
FixAll -> fixthin
|
||||
|
|
@ -78,7 +77,7 @@ breakHardLink file key obj = do
|
|||
unlessM (checkedCopyFile key obj' tmp mode) $
|
||||
error "unable to break hard link"
|
||||
thawContent tmp
|
||||
modifyContent obj' $ freezeContent obj'
|
||||
modifyContent obj $ freezeContent obj'
|
||||
Database.Keys.storeInodeCaches key [file]
|
||||
next $ return True
|
||||
|
||||
|
|
@ -86,25 +85,25 @@ makeHardLink :: RawFilePath -> Key -> CommandPerform
|
|||
makeHardLink file key = do
|
||||
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
|
||||
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
|
||||
linkFromAnnex key tmp mode >>= \case
|
||||
linkFromAnnex key (toRawFilePath tmp) mode >>= \case
|
||||
LinkAnnexFailed -> error "unable to make hard link"
|
||||
_ -> noop
|
||||
next $ return True
|
||||
|
||||
fixSymlink :: FilePath -> FilePath -> CommandPerform
|
||||
fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform
|
||||
fixSymlink file link = do
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
-- preserve mtime of symlink
|
||||
mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes
|
||||
<$> getSymbolicLinkStatus file
|
||||
<$> R.getSymbolicLinkStatus file
|
||||
#endif
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
liftIO $ removeFile file
|
||||
liftIO $ createSymbolicLink link file
|
||||
liftIO $ R.removeLink file
|
||||
liftIO $ R.createSymbolicLink link file
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
liftIO $ maybe noop (\t -> touch file t False) mtime
|
||||
#endif
|
||||
next $ cleanupSymlink file
|
||||
next $ cleanupSymlink (fromRawFilePath file)
|
||||
|
||||
cleanupSymlink :: FilePath -> CommandCleanup
|
||||
cleanupSymlink file = do
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ import Annex.WorkTree
|
|||
import Annex.Perms
|
||||
import qualified Annex
|
||||
import qualified Backend.URL
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import Network.URI
|
||||
|
||||
|
|
@ -51,12 +52,12 @@ seekBatch fmt = batchInput fmt parse (commandAction . go)
|
|||
let (keyname, file) = separate (== ' ') s
|
||||
if not (null keyname) && not (null file)
|
||||
then do
|
||||
file' <- liftIO $ relPathCwdToFile file
|
||||
file' <- liftIO $ relPathCwdToFile (toRawFilePath file)
|
||||
return $ Right (file', keyOpt keyname)
|
||||
else return $
|
||||
Left "Expected pairs of key and filename"
|
||||
go (si, (file, key)) =
|
||||
let ai = mkActionItem (key, toRawFilePath file)
|
||||
let ai = mkActionItem (key, file)
|
||||
in starting "fromkey" ai si $
|
||||
perform key file
|
||||
|
||||
|
|
@ -67,9 +68,11 @@ start force (si, (keyname, file)) = do
|
|||
inbackend <- inAnnex key
|
||||
unless inbackend $ giveup $
|
||||
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
|
||||
let ai = mkActionItem (key, toRawFilePath file)
|
||||
let ai = mkActionItem (key, file')
|
||||
starting "fromkey" ai si $
|
||||
perform key file
|
||||
perform key file'
|
||||
where
|
||||
file' = toRawFilePath file
|
||||
|
||||
-- From user input to a Key.
|
||||
-- User can input either a serialized key, or an url.
|
||||
|
|
@ -86,15 +89,15 @@ keyOpt s = case parseURI s of
|
|||
Just k -> k
|
||||
Nothing -> giveup $ "bad key/url " ++ s
|
||||
|
||||
perform :: Key -> FilePath -> CommandPerform
|
||||
perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case
|
||||
Nothing -> ifM (liftIO $ doesFileExist file)
|
||||
perform :: Key -> RawFilePath -> CommandPerform
|
||||
perform key file = lookupKeyNotHidden file >>= \case
|
||||
Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file))
|
||||
( hasothercontent
|
||||
, do
|
||||
link <- calcRepo $ gitAnnexLink file key
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
liftIO $ createSymbolicLink link file
|
||||
Annex.Queue.addCommand "add" [Param "--"] [file]
|
||||
liftIO $ R.createSymbolicLink link file
|
||||
Annex.Queue.addCommand "add" [Param "--"] [fromRawFilePath file]
|
||||
next $ return True
|
||||
)
|
||||
Just k
|
||||
|
|
@ -102,5 +105,5 @@ perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case
|
|||
| otherwise -> hasothercontent
|
||||
where
|
||||
hasothercontent = do
|
||||
warning $ file ++ " already exists with different content"
|
||||
warning $ fromRawFilePath file ++ " already exists with different content"
|
||||
next $ return False
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.Fsck where
|
||||
|
||||
|
|
@ -42,6 +43,7 @@ import System.Posix.Types (EpochTime)
|
|||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import Data.Either
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
cmd :: Command
|
||||
cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $
|
||||
|
|
@ -115,7 +117,7 @@ start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> Comma
|
|||
start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case
|
||||
Nothing -> stop
|
||||
Just backend -> do
|
||||
numcopies <- getFileNumCopies (fromRawFilePath file)
|
||||
numcopies <- getFileNumCopies file
|
||||
case from of
|
||||
Nothing -> go $ perform key file backend numcopies
|
||||
Just r -> go $ performRemote key afile backend numcopies r
|
||||
|
|
@ -177,11 +179,11 @@ performRemote key afile backend numcopies remote =
|
|||
pid <- liftIO getPID
|
||||
t <- fromRepo gitAnnexTmpObjectDir
|
||||
createAnnexDirectory t
|
||||
let tmp = t </> "fsck" ++ show pid ++ "." ++ fromRawFilePath (keyFile key)
|
||||
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
|
||||
let tmp = t P.</> "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key
|
||||
let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop)
|
||||
cleanup
|
||||
cleanup `after` a tmp
|
||||
getfile tmp = ifM (checkDiskSpace (Just (takeDirectory tmp)) key 0 True)
|
||||
getfile tmp = ifM (checkDiskSpace (Just (fromRawFilePath (P.takeDirectory tmp))) key 0 True)
|
||||
( ifM (getcheap tmp)
|
||||
( return (Just True)
|
||||
, ifM (Annex.getState Annex.fast)
|
||||
|
|
@ -191,10 +193,10 @@ performRemote key afile backend numcopies remote =
|
|||
)
|
||||
, return (Just False)
|
||||
)
|
||||
getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter
|
||||
getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter
|
||||
dummymeter _ = noop
|
||||
getcheap tmp = case Remote.retrieveKeyFileCheap remote of
|
||||
Just a -> isRight <$> tryNonAsync (a key afile tmp)
|
||||
Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp))
|
||||
Nothing -> return False
|
||||
|
||||
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart
|
||||
|
|
@ -222,16 +224,16 @@ check cs = and <$> sequence cs
|
|||
{- Checks that symlinks points correctly to the annexed content. -}
|
||||
fixLink :: Key -> RawFilePath -> Annex Bool
|
||||
fixLink key file = do
|
||||
want <- calcRepo $ gitAnnexLink (fromRawFilePath file) key
|
||||
want <- calcRepo $ gitAnnexLink file key
|
||||
have <- getAnnexLinkTarget file
|
||||
maybe noop (go want) have
|
||||
return True
|
||||
where
|
||||
go want have
|
||||
| want /= fromRawFilePath (fromInternalGitPath have) = do
|
||||
| want /= fromInternalGitPath have = do
|
||||
showNote "fixing link"
|
||||
createWorkTreeDirectory (parentDir (fromRawFilePath file))
|
||||
liftIO $ removeFile (fromRawFilePath file)
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
liftIO $ R.removeLink file
|
||||
addAnnexLink want file
|
||||
| otherwise = noop
|
||||
|
||||
|
|
@ -239,9 +241,9 @@ fixLink key file = do
|
|||
- in this repository only. -}
|
||||
verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
|
||||
verifyLocationLog key keystatus ai = do
|
||||
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
|
||||
obj <- calcRepo (gitAnnexLocation key)
|
||||
present <- if isKeyUnlockedThin keystatus
|
||||
then liftIO (doesFileExist obj)
|
||||
then liftIO (doesFileExist (fromRawFilePath obj))
|
||||
else inAnnex key
|
||||
u <- getUUID
|
||||
|
||||
|
|
@ -249,12 +251,12 @@ verifyLocationLog key keystatus ai = do
|
|||
- in a permission fixup here too. -}
|
||||
when present $ do
|
||||
void $ tryIO $ case keystatus of
|
||||
KeyUnlockedThin -> thawContent obj
|
||||
KeyLockedThin -> thawContent obj
|
||||
_ -> freezeContent obj
|
||||
KeyUnlockedThin -> thawContent (fromRawFilePath obj)
|
||||
KeyLockedThin -> thawContent (fromRawFilePath obj)
|
||||
_ -> freezeContent (fromRawFilePath obj)
|
||||
unlessM (isContentWritePermOk obj) $
|
||||
warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file"
|
||||
whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
|
||||
warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file"
|
||||
whenM (liftIO $ R.doesPathExist $ parentDir obj) $
|
||||
freezeContentDir obj
|
||||
|
||||
{- Warn when annex.securehashesonly is set and content using an
|
||||
|
|
@ -263,7 +265,7 @@ verifyLocationLog key keystatus ai = do
|
|||
- config was set. -}
|
||||
whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
|
||||
whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
|
||||
warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
|
||||
warning $ "** Despite annex.securehashesonly being set, " ++ fromRawFilePath obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
|
||||
|
||||
verifyLocationLog' key ai present u (logChange key u)
|
||||
|
||||
|
|
@ -346,7 +348,7 @@ verifyWorkTree key file = do
|
|||
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
|
||||
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
|
||||
ifM (annexThin <$> Annex.getGitConfig)
|
||||
( void $ linkFromAnnex key tmp mode
|
||||
( void $ linkFromAnnex key (toRawFilePath tmp) mode
|
||||
, do
|
||||
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
|
||||
void $ checkedCopyFile key obj tmp mode
|
||||
|
|
@ -366,23 +368,23 @@ checkKeySize _ KeyUnlockedThin _ = return True
|
|||
checkKeySize key _ ai = do
|
||||
file <- calcRepo $ gitAnnexLocation key
|
||||
ifM (liftIO $ R.doesPathExist file)
|
||||
( checkKeySizeOr badContent key (fromRawFilePath file) ai
|
||||
( checkKeySizeOr badContent key file ai
|
||||
, return True
|
||||
)
|
||||
|
||||
withLocalCopy :: Maybe FilePath -> (FilePath -> Annex Bool) -> Annex Bool
|
||||
withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool
|
||||
withLocalCopy Nothing _ = return True
|
||||
withLocalCopy (Just localcopy) f = f localcopy
|
||||
|
||||
checkKeySizeRemote :: Key -> Remote -> ActionItem -> FilePath -> Annex Bool
|
||||
checkKeySizeRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool
|
||||
checkKeySizeRemote key remote ai localcopy =
|
||||
checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai
|
||||
|
||||
checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> ActionItem -> Annex Bool
|
||||
checkKeySizeOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool
|
||||
checkKeySizeOr bad key file ai = case fromKey keySize key of
|
||||
Nothing -> return True
|
||||
Just size -> do
|
||||
size' <- liftIO $ getFileSize file
|
||||
size' <- liftIO $ getFileSize (fromRawFilePath file)
|
||||
comparesizes size size'
|
||||
where
|
||||
comparesizes a b = do
|
||||
|
|
@ -436,30 +438,30 @@ checkBackend backend key keystatus afile = do
|
|||
content <- calcRepo (gitAnnexLocation key)
|
||||
ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
|
||||
( nocheck
|
||||
, checkBackendOr badContent backend key (fromRawFilePath content) ai
|
||||
, checkBackendOr badContent backend key content ai
|
||||
)
|
||||
where
|
||||
nocheck = return True
|
||||
|
||||
ai = mkActionItem (key, afile)
|
||||
|
||||
checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> FilePath -> Annex Bool
|
||||
checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool
|
||||
checkBackendRemote backend key remote ai localcopy =
|
||||
checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai
|
||||
|
||||
checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool
|
||||
checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool
|
||||
checkBackendOr bad backend key file ai =
|
||||
checkBackendOr' bad backend key file ai (return True)
|
||||
|
||||
-- The postcheck action is run after the content is verified,
|
||||
-- in order to detect situations where the file is changed while being
|
||||
-- verified.
|
||||
checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool -> Annex Bool
|
||||
checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool -> Annex Bool
|
||||
checkBackendOr' bad backend key file ai postcheck =
|
||||
case Types.Backend.verifyKeyContent backend of
|
||||
Nothing -> return True
|
||||
Just verifier -> do
|
||||
ok <- verifier key file
|
||||
ok <- verifier key (fromRawFilePath file)
|
||||
ifM postcheck
|
||||
( do
|
||||
unless ok $ do
|
||||
|
|
@ -529,19 +531,20 @@ badContent key = do
|
|||
- symlink to a file in the remote). To avoid any further data loss,
|
||||
- that temp file is moved to the bad content directory unless
|
||||
- the local annex has a copy of the content. -}
|
||||
badContentRemote :: Remote -> FilePath -> Key -> Annex String
|
||||
badContentRemote :: Remote -> RawFilePath -> Key -> Annex String
|
||||
badContentRemote remote localcopy key = do
|
||||
bad <- fromRepo gitAnnexBadDir
|
||||
let destbad = bad </> fromRawFilePath (keyFile key)
|
||||
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad))
|
||||
let destbad = bad P.</> keyFile key
|
||||
let destbad' = fromRawFilePath destbad
|
||||
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad'))
|
||||
( return False
|
||||
, do
|
||||
createAnnexDirectory (parentDir destbad)
|
||||
liftIO $ catchDefaultIO False $
|
||||
ifM (isSymbolicLink <$> getSymbolicLinkStatus localcopy)
|
||||
( copyFileExternal CopyTimeStamps localcopy destbad
|
||||
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy)
|
||||
( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad'
|
||||
, do
|
||||
moveFile localcopy destbad
|
||||
moveFile (fromRawFilePath localcopy) destbad'
|
||||
return True
|
||||
)
|
||||
)
|
||||
|
|
@ -551,7 +554,7 @@ badContentRemote remote localcopy key = do
|
|||
Remote.logStatus remote key InfoMissing
|
||||
return $ case (movedbad, dropped) of
|
||||
(True, Right ()) -> "moved from " ++ Remote.name remote ++
|
||||
" to " ++ destbad
|
||||
" to " ++ fromRawFilePath destbad
|
||||
(False, Right ()) -> "dropped from " ++ Remote.name remote
|
||||
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
|
||||
|
||||
|
|
@ -583,22 +586,23 @@ recordFsckTime inc key = withFsckDb inc $ \h -> liftIO $ FsckDb.addDb h key
|
|||
recordStartTime :: UUID -> Annex ()
|
||||
recordStartTime u = do
|
||||
f <- fromRepo (gitAnnexFsckState u)
|
||||
let f' = fromRawFilePath f
|
||||
createAnnexDirectory $ parentDir f
|
||||
liftIO $ removeWhenExistsWith removeLink f
|
||||
liftIO $ withFile f WriteMode $ \h -> do
|
||||
liftIO $ removeWhenExistsWith R.removeLink f
|
||||
liftIO $ withFile f' WriteMode $ \h -> do
|
||||
#ifndef mingw32_HOST_OS
|
||||
t <- modificationTime <$> getFileStatus f
|
||||
t <- modificationTime <$> R.getFileStatus f
|
||||
#else
|
||||
t <- getPOSIXTime
|
||||
#endif
|
||||
hPutStr h $ showTime $ realToFrac t
|
||||
setAnnexFilePerm f
|
||||
setAnnexFilePerm f'
|
||||
where
|
||||
showTime :: POSIXTime -> String
|
||||
showTime = show
|
||||
|
||||
resetStartTime :: UUID -> Annex ()
|
||||
resetStartTime u = liftIO . removeWhenExistsWith removeLink
|
||||
resetStartTime u = liftIO . removeWhenExistsWith R.removeLink
|
||||
=<< fromRepo (gitAnnexFsckState u)
|
||||
|
||||
{- Gets the incremental fsck start time. -}
|
||||
|
|
@ -606,9 +610,9 @@ getStartTime :: UUID -> Annex (Maybe EpochTime)
|
|||
getStartTime u = do
|
||||
f <- fromRepo (gitAnnexFsckState u)
|
||||
liftIO $ catchDefaultIO Nothing $ do
|
||||
timestamp <- modificationTime <$> getFileStatus f
|
||||
timestamp <- modificationTime <$> R.getFileStatus f
|
||||
let fromstatus = Just (realToFrac timestamp)
|
||||
fromfile <- parsePOSIXTime <$> readFile f
|
||||
fromfile <- parsePOSIXTime <$> readFile (fromRawFilePath f)
|
||||
return $ if matchingtimestamp fromfile fromstatus
|
||||
then Just timestamp
|
||||
else Nothing
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ start o from si file key = start' expensivecheck from key afile ai si
|
|||
afile = AssociatedFile (Just file)
|
||||
ai = mkActionItem (key, afile)
|
||||
expensivecheck
|
||||
| autoMode o = numCopiesCheck (fromRawFilePath file) key (<)
|
||||
| autoMode o = numCopiesCheck file key (<)
|
||||
<||> wantGet False (Just key) afile
|
||||
| otherwise = return True
|
||||
|
||||
|
|
@ -118,5 +118,6 @@ getKey' key afile = dispatch
|
|||
download (Remote.uuid r) key afile stdRetry
|
||||
(\p -> do
|
||||
showAction $ "from " ++ Remote.name r
|
||||
Remote.verifiedAction (Remote.retrieveKeyFile r key afile dest p)
|
||||
Remote.verifiedAction $
|
||||
Remote.retrieveKeyFile r key afile (fromRawFilePath dest) p
|
||||
) witness
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ start si file key = ifM (isJust <$> isAnnexLink file)
|
|||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
lockdown =<< calcRepo (gitAnnexLocation key)
|
||||
addLink (CheckGitIgnore False) (fromRawFilePath file) key
|
||||
addLink (CheckGitIgnore False) file key
|
||||
=<< withTSDelta (liftIO . genInodeCache file)
|
||||
next $ cleanup file key
|
||||
where
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ start si file key = do
|
|||
Just oldbackend -> do
|
||||
exists <- inAnnex key
|
||||
newbackend <- maybe defaultBackend return
|
||||
=<< chooseBackend (fromRawFilePath file)
|
||||
=<< chooseBackend file
|
||||
if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
|
||||
then starting "migrate" (mkActionItem (key, file)) si $
|
||||
perform file key oldbackend newbackend
|
||||
|
|
|
|||
|
|
@ -88,4 +88,4 @@ startKey o afile (si, key, ai) = case fromToOptions o of
|
|||
where
|
||||
getnumcopies = case afile of
|
||||
AssociatedFile Nothing -> getNumCopies
|
||||
AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af)
|
||||
AssociatedFile (Just af) -> getFileNumCopies af
|
||||
|
|
|
|||
|
|
@ -226,7 +226,7 @@ fromPerform src removewhen key afile = do
|
|||
get = notifyTransfer Download afile $
|
||||
download (Remote.uuid src) key afile stdRetry $ \p ->
|
||||
getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t ->
|
||||
Remote.verifiedAction $ Remote.retrieveKeyFile src key afile t p
|
||||
Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p
|
||||
|
||||
dispatch _ _ False = stop -- failed
|
||||
dispatch RemoveNever _ True = next $ return True -- copy complete
|
||||
|
|
@ -363,7 +363,7 @@ logMove srcuuid destuuid deststartedwithcopy key a = bracket setup cleanup go
|
|||
go logf
|
||||
-- Only need to check log when there is a copy.
|
||||
| deststartedwithcopy = do
|
||||
wasnocopy <- checkLogFile logf gitAnnexMoveLock
|
||||
wasnocopy <- checkLogFile (fromRawFilePath logf) gitAnnexMoveLock
|
||||
(== logline)
|
||||
if wasnocopy
|
||||
then go' False
|
||||
|
|
|
|||
|
|
@ -124,7 +124,7 @@ cleanup file oldkey newkey = do
|
|||
( do
|
||||
-- Update symlink to use the new key.
|
||||
liftIO $ removeFile (fromRawFilePath file)
|
||||
addLink (CheckGitIgnore False) (fromRawFilePath file) newkey Nothing
|
||||
addLink (CheckGitIgnore False) file newkey Nothing
|
||||
, do
|
||||
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
|
||||
liftIO $ whenM (isJust <$> isPointerFile file) $
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ import Git.Command
|
|||
import qualified Utility.CoProcess as CoProcess
|
||||
|
||||
import System.IO.Error
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
type CheckIgnoreHandle = CoProcess.CoProcessHandle
|
||||
|
||||
|
|
@ -51,11 +52,11 @@ checkIgnoreStop :: CheckIgnoreHandle -> IO ()
|
|||
checkIgnoreStop = void . tryIO . CoProcess.stop
|
||||
|
||||
{- Returns True if a file is ignored. -}
|
||||
checkIgnored :: CheckIgnoreHandle -> FilePath -> IO Bool
|
||||
checkIgnored :: CheckIgnoreHandle -> RawFilePath -> IO Bool
|
||||
checkIgnored h file = CoProcess.query h send (receive "")
|
||||
where
|
||||
send to = do
|
||||
hPutStr to $ file ++ "\0"
|
||||
B.hPutStr to $ file `B.snoc` 0
|
||||
hFlush to
|
||||
receive c from = do
|
||||
s <- hGetSomeString from 1024
|
||||
|
|
|
|||
26
Logs/File.hs
26
Logs/File.hs
|
|
@ -51,12 +51,15 @@ withLogHandle f a = do
|
|||
|
||||
-- | Appends a line to a log file, first locking it to prevent
|
||||
-- concurrent writers.
|
||||
appendLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex ()
|
||||
appendLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex ()
|
||||
appendLogFile f lck c =
|
||||
createDirWhenNeeded (toRawFilePath f) $
|
||||
createDirWhenNeeded f $
|
||||
withExclusiveLock lck $ do
|
||||
liftIO $ withFile f AppendMode $ \h -> L8.hPutStrLn h c
|
||||
setAnnexFilePerm f
|
||||
liftIO $ withFile f' AppendMode $
|
||||
\h -> L8.hPutStrLn h c
|
||||
setAnnexFilePerm f'
|
||||
where
|
||||
f' = fromRawFilePath f
|
||||
|
||||
-- | Modifies a log file.
|
||||
--
|
||||
|
|
@ -66,18 +69,19 @@ appendLogFile f lck c =
|
|||
--
|
||||
-- The file is locked to prevent concurrent writers, and it is written
|
||||
-- atomically.
|
||||
modifyLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile f lck modf = withExclusiveLock lck $ do
|
||||
ls <- liftIO $ fromMaybe []
|
||||
<$> tryWhenExists (L8.lines <$> L.readFile f)
|
||||
<$> tryWhenExists (L8.lines <$> L.readFile f')
|
||||
let ls' = modf ls
|
||||
when (ls' /= ls) $
|
||||
createDirWhenNeeded (toRawFilePath f) $
|
||||
viaTmp writelog f (L8.unlines ls')
|
||||
createDirWhenNeeded f $
|
||||
viaTmp writelog f' (L8.unlines ls')
|
||||
where
|
||||
writelog f' b = do
|
||||
liftIO $ L.writeFile f' b
|
||||
setAnnexFilePerm f'
|
||||
f' = fromRawFilePath f
|
||||
writelog lf b = do
|
||||
liftIO $ L.writeFile lf b
|
||||
setAnnexFilePerm lf
|
||||
|
||||
-- | Checks the content of a log file to see if any line matches.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ smudgeLog k f = do
|
|||
streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex ()
|
||||
streamSmudged a = do
|
||||
logf <- fromRepo gitAnnexSmudgeLog
|
||||
streamLogFile logf gitAnnexSmudgeLock $ \l ->
|
||||
streamLogFile (fromRawFilePath logf) gitAnnexSmudgeLock $ \l ->
|
||||
case parse l of
|
||||
Nothing -> noop
|
||||
Just (k, f) -> a k f
|
||||
|
|
|
|||
|
|
@ -14,19 +14,20 @@ module Utility.Touch (
|
|||
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
|
||||
import System.Posix.Files
|
||||
import System.FilePath.ByteString (RawFilePath)
|
||||
import System.Posix.Files.ByteString
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
{- Changes the access and modification times of an existing file.
|
||||
Can follow symlinks, or not. -}
|
||||
touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
|
||||
touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
|
||||
touchBoth file atime mtime follow
|
||||
| follow = setFileTimesHiRes file atime mtime
|
||||
| otherwise = setSymbolicLinkTimesHiRes file atime mtime
|
||||
|
||||
{- Changes the access and modification times of an existing file
|
||||
- to the same value. Can follow symlinks, or not. -}
|
||||
touch :: FilePath -> POSIXTime -> Bool -> IO ()
|
||||
touch :: RawFilePath -> POSIXTime -> Bool -> IO ()
|
||||
touch file mtime = touchBoth file mtime mtime
|
||||
|
||||
#else
|
||||
|
|
@ -34,10 +35,10 @@ touch file mtime = touchBoth file mtime mtime
|
|||
import Data.Time.Clock.POSIX
|
||||
|
||||
{- Noop for Windows -}
|
||||
touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
|
||||
touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
|
||||
touchBoth _ _ _ _ = return ()
|
||||
|
||||
touch :: FilePath -> POSIXTime -> Bool -> IO ()
|
||||
touch :: RawFilePath -> POSIXTime -> Bool -> IO ()
|
||||
touch _ _ _ = return ()
|
||||
|
||||
#endif
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue