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

more RawFilePath conversion

Browse source 
535/645

This commit was sponsored by Brett Eisenberg on Patreon.
This commit is contained in:
Joey Hess 2020-11-03 10:11:04 -04:00
parent 55400a03d3
commit eb42cd4d46
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
23 changed files with 182 additions and 159 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Annex/CheckIgnore.hs
View file

@ -22,7 +22,7 @@ import Annex.Concurrent.Utility
newtype CheckGitIgnore = CheckGitIgnore Bool newtype CheckGitIgnore = CheckGitIgnore Bool
checkIgnored :: CheckGitIgnore -> FilePath -> Annex Bool checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool
checkIgnored (CheckGitIgnore False) _ = pure False checkIgnored (CheckGitIgnore False) _ = pure False
checkIgnored (CheckGitIgnore True) file = checkIgnored (CheckGitIgnore True) file =
ifM (Annex.getState Annex.force) ifM (Annex.getState Annex.force)

5
Annex/Content/PointerFile.hs
View file

@ -64,12 +64,13 @@ depopulatePointerFile key file = do
secureErase file secureErase file
liftIO $ removeWhenExistsWith R.removeLink file liftIO $ removeWhenExistsWith R.removeLink file
ic <- replaceWorkTreeFile file' $ \tmp -> do 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) #if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unncessary re-smudging -- Don't advance mtime; this avoids unncessary re-smudging
-- by git in some cases. -- by git in some cases.
liftIO $ maybe noop liftIO $ maybe noop
(\t -> touch tmp t False) (\t -> touch tmp' t False)
(fmap modificationTimeHiRes st) (fmap modificationTimeHiRes st)
#endif #endif
withTSDelta (liftIO . genInodeCache (toRawFilePath tmp)) withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))

48
Annex/Ingest.hs
View file

@ -61,7 +61,7 @@ data LockedDown = LockedDown
data LockDownConfig = LockDownConfig data LockDownConfig = LockDownConfig
{ lockingFile :: Bool { lockingFile :: Bool
-- ^ write bit removed during lock down -- ^ write bit removed during lock down
, hardlinkFileTmpDir :: Maybe FilePath , hardlinkFileTmpDir :: Maybe RawFilePath
-- ^ hard link to temp directory -- ^ hard link to temp directory
} }
deriving (Show) deriving (Show)
@ -109,7 +109,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
when (lockingFile cfg) $ when (lockingFile cfg) $
freezeContent file freezeContent file
withTSDelta $ \delta -> liftIO $ do withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTempFile tmpdir $ (tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $
relatedTemplate $ "ingest-" ++ takeFileName file relatedTemplate $ "ingest-" ++ takeFileName file
hClose h hClose h
removeWhenExistsWith removeLink tmpfile removeWhenExistsWith removeLink tmpfile
@ -139,7 +139,7 @@ ingestAdd' ci meterupdate ld@(Just (LockedDown cfg source)) mk = do
Just k -> do Just k -> do
let f = keyFilename source let f = keyFilename source
if lockingFile cfg if lockingFile cfg
then addLink ci (fromRawFilePath f) k mic then addLink ci f k mic
else do else do
mode <- liftIO $ catchMaybeIO $ mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (contentLocation source) fileMode <$> R.getFileStatus (contentLocation source)
@ -272,10 +272,10 @@ restoreFile file key e = do
throwM e throwM e
{- Creates the symlink to the annexed content, returns the link target. -} {- Creates the symlink to the annexed content, returns the link target. -}
makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex LinkTarget makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do makeLink file key mcache = flip catchNonAsync (restoreFile file' key) $ do
l <- calcRepo $ gitAnnexLink (toRawFilePath file) key l <- calcRepo $ gitAnnexLink file key
replaceWorkTreeFile file $ makeAnnexLink l . toRawFilePath replaceWorkTreeFile file' $ makeAnnexLink l . toRawFilePath
-- touch symlink to have same time as the original file, -- touch symlink to have same time as the original file,
-- as provided in the InodeCache -- as provided in the InodeCache
@ -284,6 +284,8 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
Nothing -> noop Nothing -> noop
return l return l
where
file' = fromRawFilePath file
{- Creates the symlink to the annexed content, and stages it in git. {- 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 - Also, using git add allows it to skip gitignored files, unless forced
- to include them. - 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) addLink ci file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
( do ( do
_ <- makeLink file key mcache _ <- makeLink file key mcache
ps <- gitAddParams ci ps <- gitAddParams ci
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file]
, do , do
l <- makeLink file key mcache l <- makeLink file key mcache
addAnnexLink l (toRawFilePath file) addAnnexLink l file
) )
{- Parameters to pass to git add, forcing addition of ignored files. {- 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. - 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) addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
( do ( do
mode <- maybe mode <- maybe
(pure Nothing) (pure Nothing)
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp)
mtmp mtmp
stagePointerFile file' mode =<< hashPointerFile key stagePointerFile file mode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file') Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
case mtmp of case mtmp of
Just tmp -> ifM (moveAnnex key (toRawFilePath tmp)) Just tmp -> ifM (moveAnnex key tmp)
( linkunlocked mode >> return True ( linkunlocked mode >> return True
, writepointer mode >> return False , writepointer mode >> return False
) )
@ -360,19 +362,19 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
, do , do
addLink ci file key Nothing addLink ci file key Nothing
case mtmp of case mtmp of
Just tmp -> moveAnnex key (toRawFilePath tmp) Just tmp -> moveAnnex key tmp
Nothing -> return True Nothing -> return True
) )
where where
mi = case mtmp of mi = case mtmp of
Just tmp -> MatchingFile $ FileInfo Just tmp -> MatchingFile $ FileInfo
{ contentFile = Just (toRawFilePath tmp) { contentFile = Just tmp
, matchFile = file' , matchFile = file
} }
-- Provide as much info as we can without access to the -- Provide as much info as we can without access to the
-- file's content. -- file's content.
Nothing -> MatchingInfo $ ProvidedInfo Nothing -> MatchingInfo $ ProvidedInfo
{ providedFilePath = file' { providedFilePath = file
, providedKey = Just key , providedKey = Just key
, providedFileSize = fromMaybe 0 $ , providedFileSize = fromMaybe 0 $
keySize `fromKey` key keySize `fromKey` key
@ -380,10 +382,8 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
, providedMimeEncoding = Nothing , providedMimeEncoding = Nothing
} }
linkunlocked mode = linkFromAnnex key file' mode >>= \case linkunlocked mode = linkFromAnnex key file mode >>= \case
LinkAnnexFailed -> liftIO $ LinkAnnexFailed -> liftIO $ writepointer mode
writePointerFile file' key mode
_ -> return () _ -> return ()
writepointer mode = liftIO $ writePointerFile file' key mode
file' = toRawFilePath file writepointer mode = liftIO $ writePointerFile file key mode

12
Annex/Locations.hs
View file

@ -362,19 +362,19 @@ gitAnnexFsckResultsLog u r =
{- .git/annex/smudge.log is used to log smudges worktree files that need to {- .git/annex/smudge.log is used to log smudges worktree files that need to
- be updated. -} - be updated. -}
gitAnnexSmudgeLog :: Git.Repo -> FilePath gitAnnexSmudgeLog :: Git.Repo -> RawFilePath
gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P.</> "smudge.log" gitAnnexSmudgeLog r = gitAnnexDir r P.</> "smudge.log"
gitAnnexSmudgeLock :: Git.Repo -> RawFilePath gitAnnexSmudgeLock :: Git.Repo -> RawFilePath
gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck" gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck"
{- .git/annex/move.log is used to log moves that are in progress, {- .git/annex/move.log is used to log moves that are in progress,
- to better support resuming an interrupted move. -} - to better support resuming an interrupted move. -}
gitAnnexMoveLog :: Git.Repo -> FilePath gitAnnexMoveLog :: Git.Repo -> RawFilePath
gitAnnexMoveLog r = fromRawFilePath $ gitAnnexDir r P.</> "move.log" gitAnnexMoveLog r = gitAnnexDir r P.</> "move.log"
gitAnnexMoveLock :: Git.Repo -> FilePath gitAnnexMoveLock :: Git.Repo -> RawFilePath
gitAnnexMoveLock r = fromRawFilePath $ gitAnnexDir r P.</> "move.lck" gitAnnexMoveLock r = gitAnnexDir r P.</> "move.lck"
{- .git/annex/export/ is used to store information about {- .git/annex/export/ is used to store information about
- exports to special remotes. -} - exports to special remotes. -}

4
Annex/Perms.hs
View file

@ -143,7 +143,7 @@ freezeContent file = unlessM crippledFileSystem $
removeModes writeModes . removeModes writeModes .
addModes [ownerReadMode] addModes [ownerReadMode]
isContentWritePermOk :: FilePath -> Annex Bool isContentWritePermOk :: RawFilePath -> Annex Bool
isContentWritePermOk file = ifM crippledFileSystem isContentWritePermOk file = ifM crippledFileSystem
( return True ( return True
, withShared go , withShared go
@ -153,7 +153,7 @@ isContentWritePermOk file = ifM crippledFileSystem
go AllShared = want writeModes go AllShared = want writeModes
go _ = return True go _ = return True
want wantmode = want wantmode =
liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case liftIO (catchMaybeIO $ fileMode <$> R.getFileStatus file) >>= return . \case
Nothing -> True Nothing -> True
Just havemode -> havemode == combineModes (havemode:wantmode) Just havemode -> havemode == combineModes (havemode:wantmode)

14
Command/Add.hs
View file

@ -81,8 +81,9 @@ seek o = startConcurrency commandStages $ do
annexdotfiles <- getGitConfigVal annexDotFiles annexdotfiles <- getGitConfigVal annexDotFiles
let gofile (si, file) = case largeFilesOverride o of let gofile (si, file) = case largeFilesOverride o of
Nothing -> Nothing ->
let file' = fromRawFilePath file ifM (pure (annexdotfiles || not (dotfile file))
in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force)) <&&> (checkFileMatcher largematcher file
<||> Annex.getState Annex.force))
( start o si file addunlockedmatcher ( start o si file addunlockedmatcher
, ifM (annexAddSmallFiles <$> Annex.getGitConfig) , ifM (annexAddSmallFiles <$> Annex.getGitConfig)
( startSmall o si file ( startSmall o si file
@ -128,20 +129,19 @@ startSmallOverridden o si file =
addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool
addSmallOverridden o file = do addSmallOverridden o file = do
showNote "adding content to git repository" showNote "adding content to git repository"
let file' = fromRawFilePath file s <- liftIO $ R.getSymbolicLinkStatus file
s <- liftIO $ getSymbolicLinkStatus file'
if not (isRegularFile s) if not (isRegularFile s)
then addFile (checkGitIgnoreOption o) file then addFile (checkGitIgnoreOption o) file
else do else do
-- Can't use addFile because the clean filter will -- Can't use addFile because the clean filter will
-- honor annex.largefiles and it has been overridden. -- honor annex.largefiles and it has been overridden.
-- Instead, hash the file and add to the index. -- Instead, hash the file and add to the index.
sha <- hashFile file' sha <- hashFile file
let ty = if isExecutable (fileMode s) let ty = if isExecutable (fileMode s)
then TreeExecutable then TreeExecutable
else TreeFile else TreeFile
Annex.Queue.addUpdateIndex =<< Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha ty file') inRepo (Git.UpdateIndex.stageFile sha ty (fromRawFilePath file))
return True return True
addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool
@ -172,7 +172,7 @@ start o si file addunlockedmatcher = do
fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do
-- the annexed symlink is present but not yet added to git -- the annexed symlink is present but not yet added to git
liftIO $ removeFile (fromRawFilePath file) liftIO $ removeFile (fromRawFilePath file)
addLink (checkGitIgnoreOption o) (fromRawFilePath file) key Nothing addLink (checkGitIgnoreOption o) file key Nothing
next $ next $
cleanup key =<< inAnnex key cleanup key =<< inAnnex key
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do

4
Command/AddUnused.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Command.AddUnused where module Command.AddUnused where
import Logs.Location import Logs.Location
@ -33,7 +35,7 @@ perform key = next $ do
addLink (CheckGitIgnore False) file key Nothing addLink (CheckGitIgnore False) file key Nothing
return True return True
where where
file = "unused." ++ fromRawFilePath (keyFile key) file = "unused." <> keyFile key
{- The content is not in the annex, but in another directory, and {- 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 - it seems better to error out, rather than moving bad/tmp content into

50
Command/AddUrl.hs
View file

@ -7,8 +7,6 @@
module Command.AddUrl where module Command.AddUrl where
import Network.URI
import Command import Command
import Backend import Backend
import qualified Annex import qualified Annex
@ -32,8 +30,12 @@ import Logs.Location
import Utility.Metered import Utility.Metered
import Utility.HtmlDetect import Utility.HtmlDetect
import Utility.Path.Max import Utility.Path.Max
import qualified Utility.RawFilePath as R
import qualified Annex.Transfer as Transfer import qualified Annex.Transfer as Transfer
import Network.URI
import qualified System.FilePath.ByteString as P
cmd :: Command cmd :: Command
cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $
command "addurl" SectionCommon "add urls to annex" 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 -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do
let urlkey = Backend.URL.fromUrl uri sz let urlkey = Backend.URL.fromUrl uri sz
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir (toRawFilePath file))
ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) ifM (Annex.getState Annex.fast <||> pure (relaxedOption o))
( do ( do
addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing 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 normalfinish tmp = checkCanAdd o file $ \canadd -> do
showDestinationFile file showDestinationFile file
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir (toRawFilePath file))
Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file
-- Ask youtube-dl what filename it will download first, -- Ask youtube-dl what filename it will download first,
-- so it's only used when the file contains embedded media. -- so it's only used when the file contains embedded media.
@ -326,7 +328,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
Left _ -> normalfinish tmp Left _ -> normalfinish tmp
where where
dl dest = withTmpWorkDir mediakey $ \workdir -> do 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" showNote "using youtube-dl"
Transfer.notifyTransfer Transfer.Download url $ Transfer.notifyTransfer Transfer.Download url $
Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p ->
@ -400,7 +402,7 @@ downloadWith' downloader dummykey u url afile =
then return (Just tmp) then return (Just tmp)
else return Nothing 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 finishDownloadWith canadd addunlockedmatcher tmp u url file = do
backend <- chooseBackend file backend <- chooseBackend file
let source = KeySource let source = KeySource
@ -419,14 +421,16 @@ addSizeUrlKey urlinfo key = alterKey key $ \d -> d
} }
{- Adds worktree file to the repository. -} {- 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 addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
Nothing -> go Nothing -> go
Just tmp -> do Just tmp -> do
-- Move to final location for large file check. -- Move to final location for large file check.
pruneTmpWorkDirBefore tmp $ \_ -> do pruneTmpWorkDirBefore tmp $ \_ -> do
createWorkTreeDirectory (takeDirectory file) createWorkTreeDirectory (P.takeDirectory file)
liftIO $ renameFile tmp file liftIO $ renameFile
(fromRawFilePath tmp)
(fromRawFilePath file)
largematcher <- largeFilesMatcher largematcher <- largeFilesMatcher
large <- checkFileMatcher largematcher file large <- checkFileMatcher largematcher file
if large if large
@ -434,9 +438,11 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
-- Move back to tmp because addAnnexedFile -- Move back to tmp because addAnnexedFile
-- needs the file in a different location -- needs the file in a different location
-- than the work tree file. -- than the work tree file.
liftIO $ renameFile file tmp liftIO $ renameFile
(fromRawFilePath file)
(fromRawFilePath tmp)
go go
else void $ Command.Add.addSmall noci (toRawFilePath file) else void $ Command.Add.addSmall noci file
where where
go = do go = do
maybeShowJSON $ JSONChunk [("key", serializeKey key)] maybeShowJSON $ JSONChunk [("key", serializeKey key)]
@ -446,18 +452,18 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
( do ( do
when (isJust mtmp) $ when (isJust mtmp) $
logStatus key InfoPresent 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 -- git does not need to check ignores, because that has already
-- been done, as witnessed by the CannAddFile. -- been done, as witnessed by the CannAddFile.
noci = CheckGitIgnore False 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 nodownloadWeb addunlockedmatcher o url urlinfo file
| Url.urlExists urlinfo = if rawOption o | Url.urlExists urlinfo = if rawOption o
then nomedia then nomedia
else either (const nomedia) usemedia else either (const nomedia) (usemedia . toRawFilePath)
=<< youtubeDlFileName url =<< youtubeDlFileName url
| otherwise = do | otherwise = do
warning $ "unable to access url: " ++ url warning $ "unable to access url: " ++ url
@ -472,14 +478,14 @@ nodownloadWeb addunlockedmatcher o url urlinfo file
let mediakey = Backend.URL.fromUrl mediaurl Nothing let mediakey = Backend.URL.fromUrl mediaurl Nothing
nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest
youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath youtubeDlDestFile :: DownloadOptions -> RawFilePath -> RawFilePath -> RawFilePath
youtubeDlDestFile o destfile mediafile youtubeDlDestFile o destfile mediafile
| isJust (fileOption o) = destfile | 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 nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
showDestinationFile file showDestinationFile (fromRawFilePath file)
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir file)
addWorkTree canadd addunlockedmatcher webUUID url file key Nothing addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
return (Just key) return (Just key)
@ -515,14 +521,14 @@ adjustFile o = addprefix . addsuffix
data CanAddFile = CanAddFile data CanAddFile = CanAddFile
checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file))
( do ( do
warning $ file ++ " already exists; not overwriting" warning $ fromRawFilePath file ++ " already exists; not overwriting"
return Nothing return Nothing
, ifM (checkIgnored (checkGitIgnoreOption o) file) , ifM (checkIgnored (checkGitIgnoreOption o) file)
( do ( 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 return Nothing
, a CanAddFile , a CanAddFile
) )

2
Command/Copy.hs
View file

@ -72,7 +72,7 @@ start o si file key = stopUnless shouldCopy $
Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key
where where
shouldCopy shouldCopy
| autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<) | autoMode o = want <||> numCopiesCheck file key (<)
| otherwise = return True | otherwise = return True
want = case fromToOptions o of want = case fromToOptions o of
Right (ToRemote dest) -> Right (ToRemote dest) ->

5
Command/DropUnused.hs
View file

@ -15,6 +15,7 @@ import qualified Git
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Annex.NumCopies import Annex.NumCopies
import Annex.Content import Annex.Content
import qualified Utility.RawFilePath as R
cmd :: Command cmd :: Command
cmd = command "dropunused" SectionMaintenance cmd = command "dropunused" SectionMaintenance
@ -63,8 +64,8 @@ perform from numcopies key = case from of
where where
droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies [] 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 performOther filespec key = do
f <- fromRepo $ filespec key f <- fromRepo $ filespec key
pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeLink) pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink)
next $ return True next $ return True

19
Command/Fix.hs
View file

@ -46,11 +46,10 @@ data FixWhat = FixSymlinks | FixAll
start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart
start fixwhat si file key = do start fixwhat si file key = do
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file
wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key wantlink <- calcRepo $ gitAnnexLink file key
case currlink of case currlink of
Just l Just l
| l /= toRawFilePath wantlink -> fixby $ | l /= wantlink -> fixby $ fixSymlink file wantlink
fixSymlink (fromRawFilePath file) wantlink
| otherwise -> stop | otherwise -> stop
Nothing -> case fixwhat of Nothing -> case fixwhat of
FixAll -> fixthin FixAll -> fixthin
@ -78,7 +77,7 @@ breakHardLink file key obj = do
unlessM (checkedCopyFile key obj' tmp mode) $ unlessM (checkedCopyFile key obj' tmp mode) $
error "unable to break hard link" error "unable to break hard link"
thawContent tmp thawContent tmp
modifyContent obj' $ freezeContent obj' modifyContent obj $ freezeContent obj'
Database.Keys.storeInodeCaches key [file] Database.Keys.storeInodeCaches key [file]
next $ return True next $ return True
@ -86,25 +85,25 @@ makeHardLink :: RawFilePath -> Key -> CommandPerform
makeHardLink file key = do makeHardLink file key = do
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file 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" LinkAnnexFailed -> error "unable to make hard link"
_ -> noop _ -> noop
next $ return True next $ return True
fixSymlink :: FilePath -> FilePath -> CommandPerform fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform
fixSymlink file link = do fixSymlink file link = do
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
-- preserve mtime of symlink -- preserve mtime of symlink
mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes
<$> getSymbolicLinkStatus file <$> R.getSymbolicLinkStatus file
#endif #endif
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir file)
liftIO $ removeFile file liftIO $ R.removeLink file
liftIO $ createSymbolicLink link file liftIO $ R.createSymbolicLink link file
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
liftIO $ maybe noop (\t -> touch file t False) mtime liftIO $ maybe noop (\t -> touch file t False) mtime
#endif #endif
next $ cleanupSymlink file next $ cleanupSymlink (fromRawFilePath file)
cleanupSymlink :: FilePath -> CommandCleanup cleanupSymlink :: FilePath -> CommandCleanup
cleanupSymlink file = do cleanupSymlink file = do

23
Command/FromKey.hs
View file

@ -16,6 +16,7 @@ import Annex.WorkTree
import Annex.Perms import Annex.Perms
import qualified Annex import qualified Annex
import qualified Backend.URL import qualified Backend.URL
import qualified Utility.RawFilePath as R
import Network.URI import Network.URI
@ -51,12 +52,12 @@ seekBatch fmt = batchInput fmt parse (commandAction . go)
let (keyname, file) = separate (== ' ') s let (keyname, file) = separate (== ' ') s
if not (null keyname) && not (null file) if not (null keyname) && not (null file)
then do then do
file' <- liftIO $ relPathCwdToFile file file' <- liftIO $ relPathCwdToFile (toRawFilePath file)
return $ Right (file', keyOpt keyname) return $ Right (file', keyOpt keyname)
else return $ else return $
Left "Expected pairs of key and filename" Left "Expected pairs of key and filename"
go (si, (file, key)) = go (si, (file, key)) =
let ai = mkActionItem (key, toRawFilePath file) let ai = mkActionItem (key, file)
in starting "fromkey" ai si $ in starting "fromkey" ai si $
perform key file perform key file
@ -67,9 +68,11 @@ start force (si, (keyname, file)) = do
inbackend <- inAnnex key inbackend <- inAnnex key
unless inbackend $ giveup $ unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" "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 $ starting "fromkey" ai si $
perform key file perform key file'
where
file' = toRawFilePath file
-- From user input to a Key. -- From user input to a Key.
-- User can input either a serialized key, or an url. -- User can input either a serialized key, or an url.
@ -86,15 +89,15 @@ keyOpt s = case parseURI s of
Just k -> k Just k -> k
Nothing -> giveup $ "bad key/url " ++ s Nothing -> giveup $ "bad key/url " ++ s
perform :: Key -> FilePath -> CommandPerform perform :: Key -> RawFilePath -> CommandPerform
perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case perform key file = lookupKeyNotHidden file >>= \case
Nothing -> ifM (liftIO $ doesFileExist file) Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file))
( hasothercontent ( hasothercontent
, do , do
link <- calcRepo $ gitAnnexLink file key link <- calcRepo $ gitAnnexLink file key
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir file)
liftIO $ createSymbolicLink link file liftIO $ R.createSymbolicLink link file
Annex.Queue.addCommand "add" [Param "--"] [file] Annex.Queue.addCommand "add" [Param "--"] [fromRawFilePath file]
next $ return True next $ return True
) )
Just k Just k
@ -102,5 +105,5 @@ perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case
| otherwise -> hasothercontent | otherwise -> hasothercontent
where where
hasothercontent = do hasothercontent = do
warning $ file ++ " already exists with different content" warning $ fromRawFilePath file ++ " already exists with different content"
next $ return False next $ return False

90
Command/Fsck.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.Fsck where module Command.Fsck where
@ -42,6 +43,7 @@ import System.Posix.Types (EpochTime)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import Data.Either import Data.Either
import qualified System.FilePath.ByteString as P
cmd :: Command cmd :: Command
cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ 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 start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case
Nothing -> stop Nothing -> stop
Just backend -> do Just backend -> do
numcopies <- getFileNumCopies (fromRawFilePath file) numcopies <- getFileNumCopies file
case from of case from of
Nothing -> go $ perform key file backend numcopies Nothing -> go $ perform key file backend numcopies
Just r -> go $ performRemote key afile backend numcopies r Just r -> go $ performRemote key afile backend numcopies r
@ -177,11 +179,11 @@ performRemote key afile backend numcopies remote =
pid <- liftIO getPID pid <- liftIO getPID
t <- fromRepo gitAnnexTmpObjectDir t <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory t createAnnexDirectory t
let tmp = t </> "fsck" ++ show pid ++ "." ++ fromRawFilePath (keyFile key) let tmp = t P.</> "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop)
cleanup cleanup
cleanup `after` a tmp 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) ( ifM (getcheap tmp)
( return (Just True) ( return (Just True)
, ifM (Annex.getState Annex.fast) , ifM (Annex.getState Annex.fast)
@ -191,10 +193,10 @@ performRemote key afile backend numcopies remote =
) )
, return (Just False) , 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 dummymeter _ = noop
getcheap tmp = case Remote.retrieveKeyFileCheap remote of 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 Nothing -> return False
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart 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. -} {- Checks that symlinks points correctly to the annexed content. -}
fixLink :: Key -> RawFilePath -> Annex Bool fixLink :: Key -> RawFilePath -> Annex Bool
fixLink key file = do fixLink key file = do
want <- calcRepo $ gitAnnexLink (fromRawFilePath file) key want <- calcRepo $ gitAnnexLink file key
have <- getAnnexLinkTarget file have <- getAnnexLinkTarget file
maybe noop (go want) have maybe noop (go want) have
return True return True
where where
go want have go want have
| want /= fromRawFilePath (fromInternalGitPath have) = do | want /= fromInternalGitPath have = do
showNote "fixing link" showNote "fixing link"
createWorkTreeDirectory (parentDir (fromRawFilePath file)) createWorkTreeDirectory (parentDir file)
liftIO $ removeFile (fromRawFilePath file) liftIO $ R.removeLink file
addAnnexLink want file addAnnexLink want file
| otherwise = noop | otherwise = noop
@ -239,9 +241,9 @@ fixLink key file = do
- in this repository only. -} - in this repository only. -}
verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
verifyLocationLog key keystatus ai = do verifyLocationLog key keystatus ai = do
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
present <- if isKeyUnlockedThin keystatus present <- if isKeyUnlockedThin keystatus
then liftIO (doesFileExist obj) then liftIO (doesFileExist (fromRawFilePath obj))
else inAnnex key else inAnnex key
u <- getUUID u <- getUUID
@ -249,12 +251,12 @@ verifyLocationLog key keystatus ai = do
- in a permission fixup here too. -} - in a permission fixup here too. -}
when present $ do when present $ do
void $ tryIO $ case keystatus of void $ tryIO $ case keystatus of
KeyUnlockedThin -> thawContent obj KeyUnlockedThin -> thawContent (fromRawFilePath obj)
KeyLockedThin -> thawContent obj KeyLockedThin -> thawContent (fromRawFilePath obj)
_ -> freezeContent obj _ -> freezeContent (fromRawFilePath obj)
unlessM (isContentWritePermOk obj) $ unlessM (isContentWritePermOk obj) $
warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file" warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file"
whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ whenM (liftIO $ R.doesPathExist $ parentDir obj) $
freezeContentDir obj freezeContentDir obj
{- Warn when annex.securehashesonly is set and content using an {- Warn when annex.securehashesonly is set and content using an
@ -263,7 +265,7 @@ verifyLocationLog key keystatus ai = do
- config was set. -} - config was set. -}
whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $ whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ 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) verifyLocationLog' key ai present u (logChange key u)
@ -346,7 +348,7 @@ verifyWorkTree key file = do
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
ifM (annexThin <$> Annex.getGitConfig) ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex key tmp mode ( void $ linkFromAnnex key (toRawFilePath tmp) mode
, do , do
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
void $ checkedCopyFile key obj tmp mode void $ checkedCopyFile key obj tmp mode
@ -366,23 +368,23 @@ checkKeySize _ KeyUnlockedThin _ = return True
checkKeySize key _ ai = do checkKeySize key _ ai = do
file <- calcRepo $ gitAnnexLocation key file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ R.doesPathExist file) ifM (liftIO $ R.doesPathExist file)
( checkKeySizeOr badContent key (fromRawFilePath file) ai ( checkKeySizeOr badContent key file ai
, return True , return True
) )
withLocalCopy :: Maybe FilePath -> (FilePath -> Annex Bool) -> Annex Bool withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool
withLocalCopy Nothing _ = return True withLocalCopy Nothing _ = return True
withLocalCopy (Just localcopy) f = f localcopy 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 = checkKeySizeRemote key remote ai localcopy =
checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai 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 checkKeySizeOr bad key file ai = case fromKey keySize key of
Nothing -> return True Nothing -> return True
Just size -> do Just size -> do
size' <- liftIO $ getFileSize file size' <- liftIO $ getFileSize (fromRawFilePath file)
comparesizes size size' comparesizes size size'
where where
comparesizes a b = do comparesizes a b = do
@ -436,30 +438,30 @@ checkBackend backend key keystatus afile = do
content <- calcRepo (gitAnnexLocation key) content <- calcRepo (gitAnnexLocation key)
ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
( nocheck ( nocheck
, checkBackendOr badContent backend key (fromRawFilePath content) ai , checkBackendOr badContent backend key content ai
) )
where where
nocheck = return True nocheck = return True
ai = mkActionItem (key, afile) 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 = checkBackendRemote backend key remote ai localcopy =
checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai 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 =
checkBackendOr' bad backend key file ai (return True) checkBackendOr' bad backend key file ai (return True)
-- The postcheck action is run after the content is verified, -- The postcheck action is run after the content is verified,
-- in order to detect situations where the file is changed while being -- in order to detect situations where the file is changed while being
-- verified. -- 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 = checkBackendOr' bad backend key file ai postcheck =
case Types.Backend.verifyKeyContent backend of case Types.Backend.verifyKeyContent backend of
Nothing -> return True Nothing -> return True
Just verifier -> do Just verifier -> do
ok <- verifier key file ok <- verifier key (fromRawFilePath file)
ifM postcheck ifM postcheck
( do ( do
unless ok $ do unless ok $ do
@ -529,19 +531,20 @@ badContent key = do
- symlink to a file in the remote). To avoid any further data loss, - symlink to a file in the remote). To avoid any further data loss,
- that temp file is moved to the bad content directory unless - that temp file is moved to the bad content directory unless
- the local annex has a copy of the content. -} - 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 badContentRemote remote localcopy key = do
bad <- fromRepo gitAnnexBadDir bad <- fromRepo gitAnnexBadDir
let destbad = bad </> fromRawFilePath (keyFile key) let destbad = bad P.</> keyFile key
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) let destbad' = fromRawFilePath destbad
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad'))
( return False ( return False
, do , do
createAnnexDirectory (parentDir destbad) createAnnexDirectory (parentDir destbad)
liftIO $ catchDefaultIO False $ liftIO $ catchDefaultIO False $
ifM (isSymbolicLink <$> getSymbolicLinkStatus localcopy) ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy)
( copyFileExternal CopyTimeStamps localcopy destbad ( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad'
, do , do
moveFile localcopy destbad moveFile (fromRawFilePath localcopy) destbad'
return True return True
) )
) )
@ -551,7 +554,7 @@ badContentRemote remote localcopy key = do
Remote.logStatus remote key InfoMissing Remote.logStatus remote key InfoMissing
return $ case (movedbad, dropped) of return $ case (movedbad, dropped) of
(True, Right ()) -> "moved from " ++ Remote.name remote ++ (True, Right ()) -> "moved from " ++ Remote.name remote ++
" to " ++ destbad " to " ++ fromRawFilePath destbad
(False, Right ()) -> "dropped from " ++ Remote.name remote (False, Right ()) -> "dropped from " ++ Remote.name remote
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e (_, 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 :: UUID -> Annex ()
recordStartTime u = do recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u) f <- fromRepo (gitAnnexFsckState u)
let f' = fromRawFilePath f
createAnnexDirectory $ parentDir f createAnnexDirectory $ parentDir f
liftIO $ removeWhenExistsWith removeLink f liftIO $ removeWhenExistsWith R.removeLink f
liftIO $ withFile f WriteMode $ \h -> do liftIO $ withFile f' WriteMode $ \h -> do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
t <- modificationTime <$> getFileStatus f t <- modificationTime <$> R.getFileStatus f
#else #else
t <- getPOSIXTime t <- getPOSIXTime
#endif #endif
hPutStr h $ showTime $ realToFrac t hPutStr h $ showTime $ realToFrac t
setAnnexFilePerm f setAnnexFilePerm f'
where where
showTime :: POSIXTime -> String showTime :: POSIXTime -> String
showTime = show showTime = show
resetStartTime :: UUID -> Annex () resetStartTime :: UUID -> Annex ()
resetStartTime u = liftIO . removeWhenExistsWith removeLink resetStartTime u = liftIO . removeWhenExistsWith R.removeLink
=<< fromRepo (gitAnnexFsckState u) =<< fromRepo (gitAnnexFsckState u)
{- Gets the incremental fsck start time. -} {- Gets the incremental fsck start time. -}
@ -606,9 +610,9 @@ getStartTime :: UUID -> Annex (Maybe EpochTime)
getStartTime u = do getStartTime u = do
f <- fromRepo (gitAnnexFsckState u) f <- fromRepo (gitAnnexFsckState u)
liftIO $ catchDefaultIO Nothing $ do liftIO $ catchDefaultIO Nothing $ do
timestamp <- modificationTime <$> getFileStatus f timestamp <- modificationTime <$> R.getFileStatus f
let fromstatus = Just (realToFrac timestamp) let fromstatus = Just (realToFrac timestamp)
fromfile <- parsePOSIXTime <$> readFile f fromfile <- parsePOSIXTime <$> readFile (fromRawFilePath f)
return $ if matchingtimestamp fromfile fromstatus return $ if matchingtimestamp fromfile fromstatus
then Just timestamp then Just timestamp
else Nothing else Nothing

5
Command/Get.hs
View file

@ -60,7 +60,7 @@ start o from si file key = start' expensivecheck from key afile ai si
afile = AssociatedFile (Just file) afile = AssociatedFile (Just file)
ai = mkActionItem (key, afile) ai = mkActionItem (key, afile)
expensivecheck expensivecheck
| autoMode o = numCopiesCheck (fromRawFilePath file) key (<) | autoMode o = numCopiesCheck file key (<)
<||> wantGet False (Just key) afile <||> wantGet False (Just key) afile
| otherwise = return True | otherwise = return True
@ -118,5 +118,6 @@ getKey' key afile = dispatch
download (Remote.uuid r) key afile stdRetry download (Remote.uuid r) key afile stdRetry
(\p -> do (\p -> do
showAction $ "from " ++ Remote.name r 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 ) witness

2
Command/Lock.hs
View file

@ -60,7 +60,7 @@ start si file key = ifM (isJust <$> isAnnexLink file)
perform :: RawFilePath -> Key -> CommandPerform perform :: RawFilePath -> Key -> CommandPerform
perform file key = do perform file key = do
lockdown =<< calcRepo (gitAnnexLocation key) lockdown =<< calcRepo (gitAnnexLocation key)
addLink (CheckGitIgnore False) (fromRawFilePath file) key addLink (CheckGitIgnore False) file key
=<< withTSDelta (liftIO . genInodeCache file) =<< withTSDelta (liftIO . genInodeCache file)
next $ cleanup file key next $ cleanup file key
where where

2
Command/Migrate.hs
View file

@ -44,7 +44,7 @@ start si file key = do
Just oldbackend -> do Just oldbackend -> do
exists <- inAnnex key exists <- inAnnex key
newbackend <- maybe defaultBackend return newbackend <- maybe defaultBackend return
=<< chooseBackend (fromRawFilePath file) =<< chooseBackend file
if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
then starting "migrate" (mkActionItem (key, file)) si $ then starting "migrate" (mkActionItem (key, file)) si $
perform file key oldbackend newbackend perform file key oldbackend newbackend

2
Command/Mirror.hs
View file

@ -88,4 +88,4 @@ startKey o afile (si, key, ai) = case fromToOptions o of
where where
getnumcopies = case afile of getnumcopies = case afile of
AssociatedFile Nothing -> getNumCopies AssociatedFile Nothing -> getNumCopies
AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af) AssociatedFile (Just af) -> getFileNumCopies af

4
Command/Move.hs
View file

@ -226,7 +226,7 @@ fromPerform src removewhen key afile = do
get = notifyTransfer Download afile $ get = notifyTransfer Download afile $
download (Remote.uuid src) key afile stdRetry $ \p -> download (Remote.uuid src) key afile stdRetry $ \p ->
getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t -> 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 _ _ False = stop -- failed
dispatch RemoveNever _ True = next $ return True -- copy complete dispatch RemoveNever _ True = next $ return True -- copy complete
@ -363,7 +363,7 @@ logMove srcuuid destuuid deststartedwithcopy key a = bracket setup cleanup go
go logf go logf
-- Only need to check log when there is a copy. -- Only need to check log when there is a copy.
| deststartedwithcopy = do | deststartedwithcopy = do
wasnocopy <- checkLogFile logf gitAnnexMoveLock wasnocopy <- checkLogFile (fromRawFilePath logf) gitAnnexMoveLock
(== logline) (== logline)
if wasnocopy if wasnocopy
then go' False then go' False

2
Command/ReKey.hs
View file

@ -124,7 +124,7 @@ cleanup file oldkey newkey = do
( do ( do
-- Update symlink to use the new key. -- Update symlink to use the new key.
liftIO $ removeFile (fromRawFilePath file) liftIO $ removeFile (fromRawFilePath file)
addLink (CheckGitIgnore False) (fromRawFilePath file) newkey Nothing addLink (CheckGitIgnore False) file newkey Nothing
, do , do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
liftIO $ whenM (isJust <$> isPointerFile file) $ liftIO $ whenM (isJust <$> isPointerFile file) $

5
Git/CheckIgnore.hs
View file

@ -18,6 +18,7 @@ import Git.Command
import qualified Utility.CoProcess as CoProcess import qualified Utility.CoProcess as CoProcess
import System.IO.Error import System.IO.Error
import qualified Data.ByteString as B
type CheckIgnoreHandle = CoProcess.CoProcessHandle type CheckIgnoreHandle = CoProcess.CoProcessHandle
@ -51,11 +52,11 @@ checkIgnoreStop :: CheckIgnoreHandle -> IO ()
checkIgnoreStop = void . tryIO . CoProcess.stop checkIgnoreStop = void . tryIO . CoProcess.stop
{- Returns True if a file is ignored. -} {- 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 "") checkIgnored h file = CoProcess.query h send (receive "")
where where
send to = do send to = do
hPutStr to $ file ++ "\0" B.hPutStr to $ file `B.snoc` 0
hFlush to hFlush to
receive c from = do receive c from = do
s <- hGetSomeString from 1024 s <- hGetSomeString from 1024

26
Logs/File.hs
View file

@ -51,12 +51,15 @@ withLogHandle f a = do
-- | Appends a line to a log file, first locking it to prevent -- | Appends a line to a log file, first locking it to prevent
-- concurrent writers. -- concurrent writers.
appendLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex () appendLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex ()
appendLogFile f lck c = appendLogFile f lck c =
createDirWhenNeeded (toRawFilePath f) $ createDirWhenNeeded f $
withExclusiveLock lck $ do withExclusiveLock lck $ do
liftIO $ withFile f AppendMode $ \h -> L8.hPutStrLn h c liftIO $ withFile f' AppendMode $
setAnnexFilePerm f \h -> L8.hPutStrLn h c
setAnnexFilePerm f'
where
f' = fromRawFilePath f
-- | Modifies a log file. -- | Modifies a log file.
-- --
@ -66,18 +69,19 @@ appendLogFile f lck c =
-- --
-- The file is locked to prevent concurrent writers, and it is written -- The file is locked to prevent concurrent writers, and it is written
-- atomically. -- 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 modifyLogFile f lck modf = withExclusiveLock lck $ do
ls <- liftIO $ fromMaybe [] ls <- liftIO $ fromMaybe []
<$> tryWhenExists (L8.lines <$> L.readFile f) <$> tryWhenExists (L8.lines <$> L.readFile f')
let ls' = modf ls let ls' = modf ls
when (ls' /= ls) $ when (ls' /= ls) $
createDirWhenNeeded (toRawFilePath f) $ createDirWhenNeeded f $
viaTmp writelog f (L8.unlines ls') viaTmp writelog f' (L8.unlines ls')
where where
writelog f' b = do f' = fromRawFilePath f
liftIO $ L.writeFile f' b writelog lf b = do
setAnnexFilePerm f' liftIO $ L.writeFile lf b
setAnnexFilePerm lf
-- | Checks the content of a log file to see if any line matches. -- | Checks the content of a log file to see if any line matches.
-- --

2
Logs/Smudge.hs
View file

@ -32,7 +32,7 @@ smudgeLog k f = do
streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex () streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex ()
streamSmudged a = do streamSmudged a = do
logf <- fromRepo gitAnnexSmudgeLog logf <- fromRepo gitAnnexSmudgeLog
streamLogFile logf gitAnnexSmudgeLock $ \l -> streamLogFile (fromRawFilePath logf) gitAnnexSmudgeLock $ \l ->
case parse l of case parse l of
Nothing -> noop Nothing -> noop
Just (k, f) -> a k f Just (k, f) -> a k f

11
Utility/Touch.hs
View file

@ -14,19 +14,20 @@ module Utility.Touch (
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
import System.Posix.Files import System.FilePath.ByteString (RawFilePath)
import System.Posix.Files.ByteString
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
{- Changes the access and modification times of an existing file. {- Changes the access and modification times of an existing file.
Can follow symlinks, or not. -} Can follow symlinks, or not. -}
touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO () touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
touchBoth file atime mtime follow touchBoth file atime mtime follow
| follow = setFileTimesHiRes file atime mtime | follow = setFileTimesHiRes file atime mtime
| otherwise = setSymbolicLinkTimesHiRes file atime mtime | otherwise = setSymbolicLinkTimesHiRes file atime mtime
{- Changes the access and modification times of an existing file {- Changes the access and modification times of an existing file
- to the same value. Can follow symlinks, or not. -} - 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 touch file mtime = touchBoth file mtime mtime
#else #else
@ -34,10 +35,10 @@ touch file mtime = touchBoth file mtime mtime
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
{- Noop for Windows -} {- Noop for Windows -}
touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO () touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()
touchBoth _ _ _ _ = return () touchBoth _ _ _ _ = return ()
touch :: FilePath -> POSIXTime -> Bool -> IO () touch :: RawFilePath -> POSIXTime -> Bool -> IO ()
touch _ _ _ = return () touch _ _ _ = return ()
#endif #endif