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

remove most remnants of direct mode

Browse source 
A few remain, as needed for upgrades, and for accessing objects from
remotes that are direct mode repos that have not been converted yet.
This commit is contained in:
Joey Hess 2019-08-26 15:52:19 -04:00
parent adb89ee71b
commit 689d1fcc92
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
37 changed files with 193 additions and 799 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
Annex/AutoMerge.hs
View file

@ -13,7 +13,6 @@ module Annex.AutoMerge
import Annex.Common import Annex.Common
import qualified Annex.Queue import qualified Annex.Queue
import Annex.Direct
import Annex.CatFile import Annex.CatFile
import Annex.Link import Annex.Link
import Annex.Content import Annex.Content
@ -50,9 +49,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
Nothing -> go Nothing Nothing -> go Nothing
Just b -> go =<< inRepo (Git.Ref.sha b) Just b -> go =<< inRepo (Git.Ref.sha b)
where where
go old = ifM isDirect go old = do
( mergeDirect currbranch old branch resolvemerge mergeconfig commitmode
, do
r <- inRepo (Git.Merge.merge branch mergeconfig commitmode) r <- inRepo (Git.Merge.merge branch mergeconfig commitmode)
<||> (resolvemerge <&&> commitResolvedMerge commitmode) <||> (resolvemerge <&&> commitResolvedMerge commitmode)
-- Merging can cause new associated files to appear -- Merging can cause new associated files to appear
@ -61,7 +58,6 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
-- close the database if it was open. -- close the database if it was open.
Database.Keys.closeDb Database.Keys.closeDb
return r return r
)
where where
resolvemerge = ifM canresolvemerge resolvemerge = ifM canresolvemerge
( resolveMerge old branch False ( resolveMerge old branch False
@ -88,13 +84,9 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
- the other as a directory or non-annexed file. The annexed file - the other as a directory or non-annexed file. The annexed file
- is renamed to resolve the merge, and the other object is preserved as-is. - is renamed to resolve the merge, and the other object is preserved as-is.
- -
- In indirect mode, the merge is resolved in the work tree and files - The merge is resolved in the work tree and files
- staged, to clean up from a conflicted merge that was run in the work - staged, to clean up from a conflicted merge that was run in the work
- tree. - tree.
-
- In direct mode, the work tree is not touched here; files are staged to
- the index, and written to the gitAnnexMergeDir, for later handling by
- the direct mode merge code.
- -
- This is complicated by needing to support merges run in an overlay - This is complicated by needing to support merges run in an overlay
- work tree, in which case the CWD won't be within the work tree. - work tree, in which case the CWD won't be within the work tree.
@ -126,7 +118,7 @@ resolveMerge us them inoverlay = do
let merged = not (null mergedfs') let merged = not (null mergedfs')
void $ liftIO cleanup void $ liftIO cleanup
unlessM (pure inoverlay <||> isDirect) $ do unless inoverlay $ do
(deleted, cleanup2) <- inRepo (LsFiles.deleted [top]) (deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
unless (null deleted) $ unless (null deleted) $
Annex.Queue.addCommand "rm" Annex.Queue.addCommand "rm"
@ -136,7 +128,7 @@ resolveMerge us them inoverlay = do
when merged $ do when merged $ do
Annex.Queue.flush Annex.Queue.flush
unlessM (pure inoverlay <||> isDirect) $ do unless inoverlay $ do
unstagedmap <- inodeMap $ inRepo $ LsFiles.notInRepo False [top] unstagedmap <- inodeMap $ inRepo $ LsFiles.notInRepo False [top]
cleanConflictCruft mergedks' mergedfs' unstagedmap cleanConflictCruft mergedks' mergedfs' unstagedmap
showLongNote "Merge conflict was automatically resolved; you may want to examine the result." showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
@ -230,12 +222,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
Database.Keys.addAssociatedFile key Database.Keys.addAssociatedFile key
=<< inRepo (toTopFilePath dest) =<< inRepo (toTopFilePath dest)
withworktree f a = ifM isDirect withworktree f a = a f
( do
d <- fromRepo gitAnnexMergeDir
a (d </> f)
, a f
)
{- Stage a graft of a directory or file from a branch {- Stage a graft of a directory or file from a branch
- and update the work tree. -} - and update the work tree. -}

12
Annex/Content/Direct.hs
View file

@ -1,7 +1,4 @@
{- git-annex file content managing for direct mode {- git-annex file content managing for old direct mode repositories
-
- This is deprecated, and will be removed when direct mode gets removed
- from git-annex.
- -
- Copyright 2012-2014 Joey Hess <id@joeyh.name> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
@ -10,22 +7,15 @@
module Annex.Content.Direct ( module Annex.Content.Direct (
associatedFiles, associatedFiles,
associatedFilesRelative,
removeAssociatedFile, removeAssociatedFile,
removeAssociatedFileUnchecked,
removeAssociatedFiles, removeAssociatedFiles,
addAssociatedFile, addAssociatedFile,
goodContent, goodContent,
recordedInodeCache, recordedInodeCache,
updateInodeCache, updateInodeCache,
addInodeCache, addInodeCache,
writeInodeCache,
compareInodeCaches,
sameInodeCache, sameInodeCache,
elemInodeCaches,
sameFileStatus,
removeInodeCache, removeInodeCache,
toInodeCache,
addContentWhenNotPresent, addContentWhenNotPresent,
) where ) where

340
Annex/Direct.hs
View file

@ -1,26 +1,25 @@
{- git-annex direct mode {- git-annex direct mode
- -
- This is deprecated, and will be removed when direct mode gets removed - This only contains some remnants needed to convert away from direct mode.
- from git-annex.
- -
- Copyright 2012-2014 Joey Hess <id@joeyh.name> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
module Annex.Direct where module Annex.Direct (
switchHEADBack,
stageDirect,
setIndirect,
) where
import Annex.Common import Annex.Common
import qualified Annex import qualified Annex
import qualified Git import qualified Git
import qualified Git.LsFiles import qualified Git.LsFiles
import qualified Git.Merge
import qualified Git.DiffTree as DiffTree
import qualified Git.Config import qualified Git.Config
import qualified Git.Ref import qualified Git.Ref
import qualified Git.Branch import qualified Git.Branch
import Git.Sha
import Git.FilePath
import Git.Types import Git.Types
import Config import Config
import Annex.CatFile import Annex.CatFile
@ -28,17 +27,9 @@ import qualified Annex.Queue
import Logs.Location import Logs.Location
import Backend import Backend
import Types.KeySource import Types.KeySource
import Annex.Content
import Annex.Content.Direct import Annex.Content.Direct
import Annex.Link import Annex.Link
import Utility.InodeCache import Utility.InodeCache
import Utility.CopyFile
import Annex.Perms
import Annex.ReplaceFile
import Annex.VariantFile
import Git.Index
import Annex.GitOverlay
import Annex.LockFile
import Annex.InodeSentinal import Annex.InodeSentinal
import Utility.Metered import Utility.Metered
@ -102,25 +93,6 @@ stageDirect = do
deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file] deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file]
{- Run before a commit to update direct mode bookeeping to reflect the
- staged changes being committed. -}
preCommitDirect :: Annex Bool
preCommitDirect = do
(diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
makeabs <- flip fromTopFilePath <$> gitRepo
forM_ diffs (go makeabs)
liftIO clean
where
go makeabs diff = do
withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
where
withkey sha _mode a = when (sha /= nullSha) $
catKey sha >>= \case
Nothing -> noop
Just key -> void $ a key $
makeabs $ DiffTree.file diff
{- Adds a file to the annex in direct mode. Can fail, if the file is {- Adds a file to the annex in direct mode. Can fail, if the file is
- modified or deleted while it's being added. -} - modified or deleted while it's being added. -}
addDirect :: FilePath -> InodeCache -> Annex Bool addDirect :: FilePath -> InodeCache -> Annex Bool
@ -150,275 +122,14 @@ addDirect file cache = do
return False return False
) )
{- In direct mode, git merge would usually refuse to do anything, since it setIndirect :: Annex ()
- sees present direct mode files as type changed files. setIndirect = do
- setbare
- So, to handle a merge, it's run with the work tree set to a temp switchHEADBack
- directory, and the merge is staged into a copy of the index.
- Then the work tree is updated to reflect the merge, and
- finally, the merge is committed and the real index updated.
-
- A lock file is used to avoid races with any other caller of mergeDirect.
-
- To avoid other git processes from making changes to the index while our
- merge is in progress, the index lock file is used as the temp index
- file. This is the same as what git does when updating the index
- normally.
-}
mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool
mergeDirect startbranch oldref branch resolvemerge mergeconfig commitmode = exclusively $ do
reali <- liftIO . absPath =<< fromRepo indexFile
tmpi <- liftIO . absPath =<< fromRepo (indexFileLock . indexFile)
liftIO $ whenM (doesFileExist reali) $
copyFile reali tmpi
d <- fromRepo gitAnnexMergeDir
liftIO $ do
whenM (doesDirectoryExist d) $
removeDirectoryRecursive d
createDirectoryIfMissing True d
withIndexFile tmpi $ do
merged <- stageMerge d branch mergeconfig commitmode
ok <- if merged
then return True
else resolvemerge
if ok
then do
mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref)
mergeDirectCommit merged startbranch branch commitmode
liftIO $ whenM (doesFileExist tmpi) $
rename tmpi reali
else do
liftIO $ nukeFile tmpi
liftIO $ removeDirectoryRecursive d
return ok
where
exclusively = withExclusiveLock gitAnnexMergeLock
{- Stage a merge into the index, avoiding changing HEAD or the current
- branch. -}
stageMerge :: FilePath -> Git.Branch -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool
stageMerge d branch mergeconfig commitmode = do
-- XXX A bug in git makes stageMerge unsafe to use if the git repo
-- is configured with core.symlinks=false
-- Using merge is not ideal though, since it will
-- update the current branch immediately, before the work tree
-- has been updated, which would leave things in an inconsistent
-- state if mergeDirectCleanup is interrupted.
-- <http://marc.info/?l=git&m=140262402204212&w=2>
merger <- ifM (coreSymlinks <$> Annex.getGitConfig)
( return $ \ref -> Git.Merge.stageMerge ref mergeconfig
, return $ \ref -> Git.Merge.merge ref mergeconfig commitmode
)
inRepo $ \g -> do
wd <- liftIO $ absPath d
gd <- liftIO $ absPath $ Git.localGitDir g
merger branch $
g { location = Local { gitdir = gd, worktree = Just (addTrailingPathSeparator wd) } }
{- Commits after a direct mode merge is complete, and after the work
- tree has been updated by mergeDirectCleanup.
-}
mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Git.Branch.CommitMode -> Annex ()
mergeDirectCommit allowff old branch commitmode = do
void preCommitDirect
d <- fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
let merge_msg = d </> "MERGE_MSG"
let merge_mode = d </> "MERGE_MODE"
ifM (pure allowff <&&> canff)
( inRepo $ Git.Branch.update "merge" Git.Ref.headRef branch -- fast forward
, do
msg <- liftIO $
catchDefaultIO ("merge " ++ fromRef branch) $
readFile merge_msg
void $ inRepo $ Git.Branch.commit commitmode False msg
Git.Ref.headRef [Git.Ref.headRef, branch]
)
liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode]
where
canff = maybe (return False) (\o -> inRepo $ Git.Branch.fastForwardable o branch) old
mergeDirectCleanup :: FilePath -> Git.Ref -> Annex ()
mergeDirectCleanup d oldref = updateWorkTree d oldref False
{- Updates the direct mode work tree to reflect the changes staged in the
- index by a git command, that was run in a temporary work tree.
-
- Uses diff-index to compare the staged changes with provided ref
- which should be the tree before the merge, and applies those
- changes to the work tree.
-
- There are really only two types of changes: An old item can be deleted,
- or a new item added. Two passes are made, first deleting and then
- adding. This is to handle cases where eg, a file is deleted and a
- directory is added. (The diff-tree output may list these in the opposite
- order, but we cannot add the directory until the file with the
- same name is removed.)
-}
updateWorkTree :: FilePath -> Git.Ref -> Bool -> Annex ()
updateWorkTree d oldref force = do
(items, cleanup) <- inRepo $ DiffTree.diffIndex oldref
makeabs <- flip fromTopFilePath <$> gitRepo
let fsitems = zip (map (makeabs . DiffTree.file) items) items
forM_ fsitems $
go makeabs DiffTree.srcsha moveout moveout_raw
forM_ fsitems $
go makeabs DiffTree.dstsha movein movein_raw
void $ liftIO cleanup
where
go makeabs getsha a araw (f, item)
| getsha item == nullSha = noop
| otherwise = void $
tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
=<< catKey (getsha item)
moveout _ _ = removeDirect
{- Files deleted by the merge are removed from the work tree.
- Empty work tree directories are removed, per git behavior. -}
moveout_raw _ _ f = liftIO $ do
nukeFile f
void $ tryIO $ removeDirectory $ parentDir f
{- If the file is already present, with the right content for the
- key, it's left alone.
-
- If the file is already present, and does not exist in the
- oldref, preserve this local file.
-
- Otherwise, create the symlink and then if possible, replace it
- with the content. -}
movein item makeabs k f = unlessM (goodContent k f) $ do
unless force $ preserveUnannexed item makeabs f oldref
l <- calcRepo $ gitAnnexLink f k
replaceFile f $ makeAnnexLink l
toDirect k f
{- Any new, modified, or renamed files were written to the temp
- directory by the merge, and are moved to the real work tree. -}
movein_raw item makeabs f = do
unless force $ preserveUnannexed item makeabs f oldref
liftIO $ do
createDirectoryIfMissing True $ parentDir f
void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
{- If the file that's being moved in is already present in the work
- tree, but did not exist in the oldref, preserve this
- local, unannexed file (or directory), as "variant-local".
-
- It's also possible that the file that's being moved in
- is in a directory that collides with an exsting, non-annexed
- file (not a directory), which should be preserved.
-}
preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
preserveUnannexed item makeabs absf oldref = do
whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
liftIO $ findnewname absf 0
checkdirs (DiffTree.file item)
where
checkdirs from = case upFrom (getTopFilePath from) of
Nothing -> noop
Just p -> do
let d = asTopFilePath p
let absd = makeabs d
whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
liftIO $ findnewname absd 0
checkdirs d
collidingitem f = isJust
<$> catchMaybeIO (getSymbolicLinkStatus f)
colliding_nondir f = maybe False (not . isDirectory)
<$> catchMaybeIO (getSymbolicLinkStatus f)
unannexed f = (isNothing <$> isAnnexLink f)
<&&> (isNothing <$> catFileDetails oldref f)
findnewname :: FilePath -> Int -> IO ()
findnewname f n = do
let localf = mkVariant f
("local" ++ if n > 0 then show n else "")
ifM (collidingitem localf)
( findnewname f (n+1)
, rename f localf
`catchIO` const (findnewname f (n+1))
)
{- If possible, converts a symlink in the working tree into a direct
- mode file. If the content is not available, leaves the symlink
- unchanged. -}
toDirect :: Key -> FilePath -> Annex ()
toDirect k f = fromMaybe noop =<< toDirectGen k f
toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
toDirectGen k f = do
loc <- calcRepo $ gitAnnexLocation k
ifM (liftIO $ doesFileExist loc)
( return $ Just $ fromindirect loc
, do
{- Copy content from another direct file. -}
absf <- liftIO $ absPath f
dlocs <- filterM (goodContent k) =<<
filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
(filter (/= absf) <$> addAssociatedFile k f)
case dlocs of
[] -> return Nothing
(dloc:_) -> return $ Just $ fromdirect dloc
)
where
fromindirect loc = do
{- Move content from annex to direct file. -}
updateInodeCache k loc
void $ addAssociatedFile k f
modifyContent loc $ do
thawContent loc
liftIO (replaceFileFrom loc f)
`catchIO` (\_ -> freezeContent loc)
fromdirect loc = do
replaceFile f $
liftIO . void . copyFileExternal CopyAllMetaData loc
updateInodeCache k f
{- Removes a direct mode file, while retaining its content in the annex
- (unless its content has already been changed). -}
removeDirect :: Key -> FilePath -> Annex ()
removeDirect k f = do
void $ removeAssociatedFileUnchecked k f
unlessM (inAnnex k) $
-- If moveAnnex rejects the content of the key,
-- treat that the same as its content having changed.
ifM (goodContent k f)
( unlessM (moveAnnex k f) $
logStatus k InfoMissing
, logStatus k InfoMissing
)
liftIO $ do
nukeFile f
void $ tryIO $ removeDirectory $ parentDir f
{- Called when a direct mode file has been changed. Its old content may be
- lost. -}
changedDirect :: Key -> FilePath -> Annex ()
changedDirect oldk f = do
locs <- removeAssociatedFile oldk f
whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
logStatus oldk InfoMissing
{- Git config settings to enable/disable direct mode. -}
setDirect :: Bool -> Annex ()
setDirect wantdirect = do
if wantdirect
then do
switchHEAD
setbare
else do
setbare
switchHEADBack
setConfig (annexConfig "direct") val setConfig (annexConfig "direct") val
Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect } Annex.changeGitConfig $ \c -> c { annexDirect = False }
where where
val = Git.Config.boolConfig wantdirect val = Git.Config.boolConfig False
coreworktree = ConfigKey "core.worktree" coreworktree = ConfigKey "core.worktree"
indirectworktree = ConfigKey "core.indirect-worktree" indirectworktree = ConfigKey "core.indirect-worktree"
setbare = do setbare = do
@ -426,9 +137,7 @@ setDirect wantdirect = do
-- core.bare; git does not allow both to be set, so -- core.bare; git does not allow both to be set, so
-- unset it when enabling direct mode, caching in -- unset it when enabling direct mode, caching in
-- core.indirect-worktree -- core.indirect-worktree
if wantdirect moveconfig indirectworktree coreworktree
then moveconfig coreworktree indirectworktree
else moveconfig indirectworktree coreworktree
setConfig (ConfigKey Git.Config.coreBare) val setConfig (ConfigKey Git.Config.coreBare) val
moveconfig src dest = getConfigMaybe src >>= \case moveconfig src dest = getConfigMaybe src >>= \case
Nothing -> noop Nothing -> noop
@ -437,20 +146,6 @@ setDirect wantdirect = do
setConfig dest wt setConfig dest wt
reloadConfig reloadConfig
{- Since direct mode sets core.bare=true, incoming pushes could change
- the currently checked out branch. To avoid this problem, HEAD
- is changed to a internal ref that nothing is going to push to.
-
- For refs/heads/master, use refs/heads/annex/direct/master;
- this way things that show HEAD (eg shell prompts) will
- hopefully show just "master". -}
directBranch :: Ref -> Ref
directBranch orighead = case splitc '/' $ fromRef orighead of
("refs":"heads":"annex":"direct":_) -> orighead
("refs":"heads":rest) ->
Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
{- Converts a directBranch back to the original branch. {- Converts a directBranch back to the original branch.
- -
- Any other ref is left unchanged. - Any other ref is left unchanged.
@ -461,15 +156,6 @@ fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
Ref $ "refs/heads/" ++ intercalate "/" rest Ref $ "refs/heads/" ++ intercalate "/" rest
_ -> directhead _ -> directhead
switchHEAD :: Annex ()
switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
where
switch orighead = do
let newhead = directBranch orighead
maybe noop (inRepo . Git.Branch.update "entering direct mode" newhead)
=<< inRepo (Git.Ref.sha orighead)
inRepo $ Git.Branch.checkout newhead
switchHEADBack :: Annex () switchHEADBack :: Annex ()
switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
where where

12
Annex/Drop.hs
View file

@ -17,7 +17,6 @@ import qualified Command.Drop
import Command import Command
import Annex.Wanted import Annex.Wanted
import Config import Config
import Annex.Content.Direct
import qualified Database.Keys import qualified Database.Keys
import Git.FilePath import Git.FilePath
@ -44,20 +43,13 @@ type Reason = String
- A VerifiedCopy can be provided as an optimisation when eg, a key - A VerifiedCopy can be provided as an optimisation when eg, a key
- has just been uploaded to a remote. - has just been uploaded to a remote.
- -
- In direct mode, all associated files are checked, and only if all
- of them are unwanted are they dropped.
-
- The runner is used to run CommandStart sequentially, it's typically - The runner is used to run CommandStart sequentially, it's typically
- callCommandAction. - callCommandAction.
-} -}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
handleDropsFrom locs rs reason fromhere key afile preverified runner = do handleDropsFrom locs rs reason fromhere key afile preverified runner = do
l <- ifM isDirect g <- Annex.gitRepo
( associatedFilesRelative key l <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
, do
g <- Annex.gitRepo
map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
)
let fs = case afile of let fs = case afile of
AssociatedFile (Just f) -> nub (f : l) AssociatedFile (Just f) -> nub (f : l)
AssociatedFile Nothing -> l AssociatedFile Nothing -> l

47
Annex/Ingest.hs
View file

@ -13,7 +13,6 @@ module Annex.Ingest (
ingestAdd', ingestAdd',
ingest, ingest,
ingest', ingest',
finishIngestDirect,
finishIngestUnlocked, finishIngestUnlocked,
cleanOldKeys, cleanOldKeys,
addLink, addLink,
@ -28,7 +27,6 @@ import Annex.Common
import Types.KeySource import Types.KeySource
import Backend import Backend
import Annex.Content import Annex.Content
import Annex.Content.Direct
import Annex.Perms import Annex.Perms
import Annex.Link import Annex.Link
import Annex.MetaData import Annex.MetaData
@ -137,14 +135,9 @@ ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do
let f = keyFilename source let f = keyFilename source
if lockingFile cfg if lockingFile cfg
then addLink f k mic then addLink f k mic
else ifM isDirect else do
( do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source)
l <- calcRepo $ gitAnnexLink f k stagePointerFile f mode =<< hashPointerFile k
stageSymlink f =<< hashSymlink l
, do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source)
stagePointerFile f mode =<< hashPointerFile k
)
return (Just k) return (Just k)
{- Ingests a locked down file into the annex. Does not update the working {- Ingests a locked down file into the annex. Does not update the working
@ -170,10 +163,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
where where
go (Just key) mcache (Just s) go (Just key) mcache (Just s)
| lockingFile cfg = golocked key mcache s | lockingFile cfg = golocked key mcache s
| otherwise = ifM isDirect | otherwise = gounlocked key mcache s
( godirect key mcache s
, gounlocked key mcache s
)
go _ _ _ = failure "failed to generate a key" go _ _ _ = failure "failed to generate a key"
golocked key mcache s = golocked key mcache s =
@ -197,12 +187,6 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
success key (Just cache) s success key (Just cache) s
gounlocked _ _ _ = failure "failed statting file" gounlocked _ _ _ = failure "failed statting file"
godirect key (Just cache) s = do
addInodeCache key cache
finishIngestDirect key source
success key (Just cache) s
godirect _ _ _ = failure "failed statting file"
success k mcache s = do success k mcache s = do
genMetaData k (keyFilename source) s genMetaData k (keyFilename source) s
return (Just k, mcache) return (Just k, mcache)
@ -212,16 +196,6 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
cleanCruft source cleanCruft source
return (Nothing, Nothing) return (Nothing, Nothing)
finishIngestDirect :: Key -> KeySource -> Annex ()
finishIngestDirect key source = do
void $ addAssociatedFile key $ keyFilename source
cleanCruft source
{- Copy to any other locations using the same key. -}
otherfs <- filter (/= keyFilename source) <$> associatedFiles key
forM_ otherfs $
addContentWhenNotPresent key (keyFilename source)
finishIngestUnlocked :: Key -> KeySource -> Annex () finishIngestUnlocked :: Key -> KeySource -> Annex ()
finishIngestUnlocked key source = do finishIngestUnlocked key source = do
cleanCruft source cleanCruft source
@ -333,7 +307,7 @@ forceParams = ifM (Annex.getState Annex.force)
- Also, when in an adjusted unlocked branch, always add files unlocked. - Also, when in an adjusted unlocked branch, always add files unlocked.
-} -}
addUnlocked :: Annex Bool addUnlocked :: Annex Bool
addUnlocked = isDirect <||> addUnlocked =
(versionSupportsUnlockedPointers <&&> (versionSupportsUnlockedPointers <&&>
((not . coreSymlinks <$> Annex.getGitConfig) <||> ((not . coreSymlinks <$> Annex.getGitConfig) <||>
(annexAddUnlocked <$> Annex.getGitConfig) <||> (annexAddUnlocked <$> Annex.getGitConfig) <||>
@ -352,7 +326,7 @@ addUnlocked = isDirect <||>
- 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 :: FilePath -> Key -> Maybe FilePath -> Annex Bool addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool
addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect) addAnnexedFile file key mtmp = ifM addUnlocked
( do ( do
mode <- maybe mode <- maybe
(pure Nothing) (pure Nothing)
@ -371,15 +345,8 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
) )
, do , do
addLink file key Nothing addLink file key Nothing
whenM isDirect $ do
void $ addAssociatedFile key file
case mtmp of case mtmp of
Just tmp -> do Just tmp -> moveAnnex key tmp
{- For moveAnnex to work in direct mode, the
- symlink must already exist, so flush the queue. -}
whenM isDirect $
Annex.Queue.flush
moveAnnex key tmp
Nothing -> return True Nothing -> return True
) )
where where

4
Annex/Init.hs
View file

@ -35,7 +35,7 @@ import Annex.WorkTree
import Config import Config
import Config.Files import Config.Files
import Config.Smudge import Config.Smudge
import Annex.Direct import qualified Annex.Direct as Direct
import qualified Annex.AdjustedBranch as AdjustedBranch import qualified Annex.AdjustedBranch as AdjustedBranch
import Annex.Environment import Annex.Environment
import Annex.Hook import Annex.Hook
@ -126,7 +126,7 @@ initialize' mversion = checkCanInitialize $ do
-- Handle case where this repo was cloned from a -- Handle case where this repo was cloned from a
-- direct mode repo -- direct mode repo
, unlessM isBareRepo , unlessM isBareRepo
switchHEADBack Direct.switchHEADBack
) )
propigateSecureHashesOnly propigateSecureHashesOnly
createInodeSentinalFile False createInodeSentinalFile False

8
Annex/UpdateInstead.hs
View file

@ -9,17 +9,15 @@ module Annex.UpdateInstead where
import qualified Annex import qualified Annex
import Annex.Common import Annex.Common
import Config
import Annex.Version import Annex.Version
import Annex.AdjustedBranch import Annex.AdjustedBranch
import Git.Branch import Git.Branch
import Git.ConfigTypes import Git.ConfigTypes
{- receive.denyCurrentBranch=updateInstead does not work in direct mode {- receive.denyCurrentBranch=updateInstead does not work
- repositories or when an adjusted branch is checked out, so must be - when an adjusted branch is checked out, so must be emulated. -}
- emulated. -}
needUpdateInsteadEmulation :: Annex Bool needUpdateInsteadEmulation :: Annex Bool
needUpdateInsteadEmulation = updateinsteadset <&&> (isDirect <||> isadjusted) needUpdateInsteadEmulation = updateinsteadset <&&> isadjusted
where where
updateinsteadset = (== UpdateInstead) . receiveDenyCurrentBranch updateinsteadset = (== UpdateInstead) . receiveDenyCurrentBranch
<$> Annex.getGitConfig <$> Annex.getGitConfig

43
Assistant/Threads/Committer.hs
View file

@ -36,7 +36,6 @@ import Annex.Version
import Annex.CurrentBranch import Annex.CurrentBranch
import qualified Annex import qualified Annex
import Utility.InodeCache import Utility.InodeCache
import Annex.Content.Direct
import qualified Database.Keys import qualified Database.Keys
import qualified Command.Sync import qualified Command.Sync
import qualified Git.Branch import qualified Git.Branch
@ -245,7 +244,7 @@ commitStaged msg = do
- access the file after closing it. -} - access the file after closing it. -}
delayaddDefault :: Annex (Maybe Seconds) delayaddDefault :: Annex (Maybe Seconds)
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
delayaddDefault = ifM (isDirect <||> versionSupportsUnlockedPointers) delayaddDefault = ifM versionSupportsUnlockedPointers
( return Nothing ( return Nothing
, return $ Just $ Seconds 1 , return $ Just $ Seconds 1
) )
@ -275,14 +274,13 @@ delayaddDefault = return Nothing
handleAdds :: FilePath -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] handleAdds :: FilePath -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete let (pending, inprocess) = partition isPendingAddChange incomplete
direct <- liftAnnex isDirect
unlocked <- liftAnnex versionSupportsUnlockedPointers unlocked <- liftAnnex versionSupportsUnlockedPointers
let lockingfiles = not (unlocked || direct) let lockingfiles = not unlocked
let lockdownconfig = LockDownConfig let lockdownconfig = LockDownConfig
{ lockingFile = lockingfiles { lockingFile = lockingfiles
, hardlinkFileTmpDir = Just lockdowndir , hardlinkFileTmpDir = Just lockdowndir
} }
(pending', cleanup) <- if unlocked || direct (pending', cleanup) <- if unlocked
then return (pending, noop) then return (pending, noop)
else findnew pending else findnew pending
(postponed, toadd) <- partitionEithers (postponed, toadd) <- partitionEithers
@ -296,9 +294,9 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
added <- addaction toadd $ added <- addaction toadd $
catMaybes <$> catMaybes <$>
if not lockingfiles if not lockingfiles
then addunlocked direct toadd then addunlocked toadd
else forM toadd (add lockdownconfig) else forM toadd (add lockdownconfig)
if DirWatcher.eventsCoalesce || null added || unlocked || direct if DirWatcher.eventsCoalesce || null added || unlocked
then return $ added ++ otherchanges then return $ added ++ otherchanges
else do else do
r <- handleAdds lockdowndir havelsof delayadd =<< getChanges r <- handleAdds lockdowndir havelsof delayadd =<< getChanges
@ -341,10 +339,10 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
- same InodeCache as the new file. If so, we can just update - same InodeCache as the new file. If so, we can just update
- bookkeeping, and stage the file in git. - bookkeeping, and stage the file in git.
-} -}
addunlocked :: Bool -> [Change] -> Assistant [Maybe Change] addunlocked :: [Change] -> Assistant [Maybe Change]
addunlocked isdirect toadd = do addunlocked toadd = do
ct <- liftAnnex compareInodeCachesWith ct <- liftAnnex compareInodeCachesWith
m <- liftAnnex $ removedKeysMap isdirect ct cs m <- liftAnnex $ removedKeysMap ct cs
delta <- liftAnnex getTSDelta delta <- liftAnnex getTSDelta
let cfg = LockDownConfig let cfg = LockDownConfig
{ lockingFile = False { lockingFile = False
@ -359,26 +357,22 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
Just cache -> Just cache ->
case M.lookup (inodeCacheToKey ct cache) m of case M.lookup (inodeCacheToKey ct cache) m of
Nothing -> add cfg c Nothing -> add cfg c
Just k -> fastadd isdirect c k Just k -> fastadd c k
fastadd :: Bool -> Change -> Key -> Assistant (Maybe Change) fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd isdirect change key = do fastadd change key = do
let source = keySource $ lockedDown change let source = keySource $ lockedDown change
liftAnnex $ if isdirect liftAnnex $ finishIngestUnlocked key source
then finishIngestDirect key source
else finishIngestUnlocked key source
done change Nothing (keyFilename source) key done change Nothing (keyFilename source) key
removedKeysMap :: Bool -> InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap isdirect ct l = do removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c -> mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ changeFile c catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks) M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
if isdirect Database.Keys.getInodeCaches k
then recordedInodeCache k
else Database.Keys.getInodeCaches k
failedingest change = do failedingest change = do
refill [retryChange change] refill [retryChange change]
@ -392,11 +386,8 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
stagePointerFile file mode =<< hashPointerFile key stagePointerFile file mode =<< hashPointerFile key
, do , do
link <- ifM isDirect link <- makeLink file key mcache
( calcRepo $ gitAnnexLink file key when DirWatcher.eventsCoalesce $
, makeLink file key mcache
)
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $
stageSymlink file =<< hashSymlink link stageSymlink file =<< hashSymlink link
) )
showEndOk showEndOk

4
Assistant/Threads/SanityChecker.hs
View file

@ -32,7 +32,6 @@ import Utility.ThreadScheduler
import qualified Assistant.Threads.Watcher as Watcher import qualified Assistant.Threads.Watcher as Watcher
import Utility.Batch import Utility.Batch
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Config
import Utility.HumanTime import Utility.HumanTime
import Utility.Tense import Utility.Tense
import Git.Repair import Git.Repair
@ -200,8 +199,7 @@ dailyCheck urlrenderer = do
liftAnnex $ warning msg liftAnnex $ warning msg
void $ addAlert $ sanityCheckFixAlert msg void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do addsymlink file s = do
isdirect <- liftAnnex isDirect Watcher.runHandler Watcher.onAddSymlink file s
Watcher.runHandler (Watcher.onAddSymlink isdirect) file s
insanity $ "found unstaged symlink: " ++ file insanity $ "found unstaged symlink: " ++ file
hourlyCheck :: Assistant () hourlyCheck :: Assistant ()

55
Assistant/Threads/Watcher.hs
View file

@ -23,14 +23,13 @@ import Assistant.Types.Changes
import Assistant.Alert import Assistant.Alert
import Utility.DirWatcher import Utility.DirWatcher
import Utility.DirWatcher.Types import Utility.DirWatcher.Types
import Utility.InodeCache
import qualified Annex import qualified Annex
import qualified Annex.Queue import qualified Annex.Queue
import qualified Git import qualified Git
import qualified Git.UpdateIndex import qualified Git.UpdateIndex
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import Annex.WorkTree import Annex.WorkTree
import Annex.Direct
import Annex.Content.Direct
import Annex.CatFile import Annex.CatFile
import Annex.CheckIgnore import Annex.CheckIgnore
import Annex.Link import Annex.Link
@ -41,7 +40,6 @@ import Annex.Version
import Annex.InodeSentinal import Annex.InodeSentinal
import Git.Types import Git.Types
import Git.FilePath import Git.FilePath
import Config
import Config.GitConfig import Config.GitConfig
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Logs.Location import Logs.Location
@ -92,16 +90,13 @@ runWatcher :: Assistant ()
runWatcher = do runWatcher = do
startup <- asIO1 startupScan startup <- asIO1 startupScan
matcher <- liftAnnex largeFilesMatcher matcher <- liftAnnex largeFilesMatcher
direct <- liftAnnex isDirect
unlocked <- liftAnnex versionSupportsUnlockedPointers unlocked <- liftAnnex versionSupportsUnlockedPointers
symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig
addhook <- hook $ if unlocked addhook <- hook $ if unlocked
then onAddUnlocked symlinkssupported matcher then onAddUnlocked symlinkssupported matcher
else if direct else onAdd matcher
then onAddDirect symlinkssupported matcher
else onAdd matcher
delhook <- hook onDel delhook <- hook onDel
addsymlinkhook <- hook $ onAddSymlink direct addsymlinkhook <- hook onAddSymlink
deldirhook <- hook onDelDir deldirhook <- hook onDelDir
errhook <- hook onErr errhook <- hook onErr
let hooks = mkWatchHooks let hooks = mkWatchHooks
@ -224,7 +219,7 @@ onAddUnlocked :: Bool -> GetFileMatcher -> Handler
onAddUnlocked symlinkssupported matcher f fs = do onAddUnlocked symlinkssupported matcher f fs = do
mk <- liftIO $ isPointerFile f mk <- liftIO $ isPointerFile f
case mk of case mk of
Nothing -> onAddUnlocked' False contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs
Just k -> addlink f k Just k -> addlink f k
where where
addassociatedfile key file = addassociatedfile key file =
@ -247,27 +242,15 @@ onAddUnlocked symlinkssupported matcher f fs = do
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key) madeChange file $ LinkChange (Just key)
{- In direct mode, add events are received for both new files, and
- modified existing files.
-}
onAddDirect :: Bool -> GetFileMatcher -> Handler
onAddDirect = onAddUnlocked' True changedDirect addassociatedfile addlink sameFileStatus
where
addassociatedfile key file = void $ addAssociatedFile key file
addlink file key = do
link <- liftAnnex $ calcRepo $ gitAnnexLink file key
addLink file link (Just key)
onAddUnlocked' onAddUnlocked'
:: Bool :: (Key -> FilePath -> Annex ())
-> (Key -> FilePath -> Annex ())
-> (Key -> FilePath -> Annex ()) -> (Key -> FilePath -> Annex ())
-> (FilePath -> Key -> Assistant (Maybe Change)) -> (FilePath -> Key -> Assistant (Maybe Change))
-> (Key -> FilePath -> FileStatus -> Annex Bool) -> (Key -> FilePath -> FileStatus -> Annex Bool)
-> Bool -> Bool
-> GetFileMatcher -> GetFileMatcher
-> Handler -> Handler
onAddUnlocked' isdirect contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do
v <- liftAnnex $ catKeyFile file v <- liftAnnex $ catKeyFile file
case (v, fs) of case (v, fs) of
(Just key, Just filestatus) -> (Just key, Just filestatus) ->
@ -306,31 +289,28 @@ onAddUnlocked' isdirect contentchanged addassociatedfile addlink samefilestatus
Nothing -> noop Nothing -> noop
Just key -> liftAnnex $ Just key -> liftAnnex $
addassociatedfile key file addassociatedfile key file
onAddSymlink' (Just $ fromRawFilePath lt) mk isdirect file fs onAddSymlink' (Just $ fromRawFilePath lt) mk file fs
{- A symlink might be an arbitrary symlink, which is just added. {- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content - Or, if it is a git-annex symlink, ensure it points to the content
- before adding it. - before adding it.
-} -}
onAddSymlink :: Bool -> Handler onAddSymlink :: Handler
onAddSymlink isdirect file filestatus = unlessIgnored file $ do onAddSymlink file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (lookupFile file) kv <- liftAnnex (lookupFile file)
onAddSymlink' linktarget kv isdirect file filestatus onAddSymlink' linktarget kv file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler onAddSymlink' :: Maybe String -> Maybe Key -> Handler
onAddSymlink' linktarget mk isdirect file filestatus = go mk onAddSymlink' linktarget mk file filestatus = go mk
where where
go (Just key) = do go (Just key) = do
when isdirect $
liftAnnex $ void $ addAssociatedFile key file
link <- liftAnnex $ calcRepo $ gitAnnexLink file key link <- liftAnnex $ calcRepo $ gitAnnexLink file key
if linktarget == Just link if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus then ensurestaged (Just link) =<< getDaemonStatus
else do else do
unless isdirect $ liftAnnex $ replaceFile file $
liftAnnex $ replaceFile file $ makeAnnexLink link
makeAnnexLink link
addLink file link (Just key) addLink file link (Just key)
-- other symlink, not git-annex -- other symlink, not git-annex
go Nothing = ensurestaged linktarget =<< getDaemonStatus go Nothing = ensurestaged linktarget =<< getDaemonStatus
@ -376,11 +356,8 @@ onDel file _ = do
onDel' :: FilePath -> Annex () onDel' :: FilePath -> Annex ()
onDel' file = do onDel' file = do
topfile <- inRepo (toTopFilePath file) topfile <- inRepo (toTopFilePath file)
ifM versionSupportsUnlockedPointers whenM versionSupportsUnlockedPointers $
( withkey $ flip Database.Keys.removeAssociatedFile topfile withkey $ flip Database.Keys.removeAssociatedFile topfile
, whenM isDirect $
withkey $ \key -> void $ removeAssociatedFile key file
)
Annex.Queue.addUpdateIndex =<< Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file) inRepo (Git.UpdateIndex.unstageFile file)
where where

5
Command.hs
View file

@ -24,7 +24,6 @@ import CmdLine.Batch as ReExported
import Options.Applicative as ReExported hiding (command) import Options.Applicative as ReExported hiding (command)
import qualified Git import qualified Git
import Annex.Init import Annex.Init
import Config
import Utility.Daemon import Utility.Daemon
import Types.Transfer import Types.Transfer
import Types.ActionItem import Types.ActionItem
@ -120,10 +119,6 @@ commonChecks = [repoExists]
repoExists :: CommandCheck repoExists :: CommandCheck
repoExists = CommandCheck 0 ensureInitialized repoExists = CommandCheck 0 ensureInitialized
notDirect :: Command -> Command
notDirect = addCheck $ whenM isDirect $
giveup "You cannot run this command in a direct mode repository."
notBareRepo :: Command -> Command notBareRepo :: Command -> Command
notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $ notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
giveup "You cannot run this command in a bare repository." giveup "You cannot run this command in a bare repository."

12
Command/Add.hs
View file

@ -11,7 +11,6 @@ import Command
import Annex.Ingest import Annex.Ingest
import Logs.Location import Logs.Location
import Annex.Content import Annex.Content
import Annex.Content.Direct
import qualified Annex import qualified Annex
import qualified Annex.Queue import qualified Annex.Queue
import qualified Database.Keys import qualified Database.Keys
@ -73,8 +72,7 @@ seek o = startConcurrency commandStages $ do
go withFilesMaybeModified go withFilesMaybeModified
ifM versionSupportsUnlockedPointers ifM versionSupportsUnlockedPointers
( go withUnmodifiedUnlockedPointers ( go withUnmodifiedUnlockedPointers
, unlessM isDirect $ , go withFilesOldUnlocked
go withFilesOldUnlocked
) )
{- Pass file off to git-add. -} {- Pass file off to git-add. -}
@ -116,13 +114,7 @@ start file = do
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case ( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
Just s | isSymbolicLink s -> fixuplink key Just s | isSymbolicLink s -> fixuplink key
_ -> add _ -> add
, ifM isDirect , fixuplink key
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
Just s | isSymbolicLink s -> fixuplink key
_ -> ifM (goodContent key file)
( stop , add )
, fixuplink key
)
) )
fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the annexed symlink is present but not yet added to git -- the annexed symlink is present but not yet added to git

7
Command/AddUnused.hs
View file

@ -13,10 +13,9 @@ import Annex.Ingest
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
cmd :: Command cmd :: Command
cmd = notDirect $ cmd = command "addunused" SectionMaintenance
command "addunused" SectionMaintenance "add back unused files"
"add back unused files" (paramRepeating paramNumRange) (withParams seek)
(paramRepeating paramNumRange) (withParams seek)
seek :: CmdParams -> CommandSeek seek :: CmdParams -> CommandSeek
seek = withUnusedMaps start seek = withUnusedMaps start

2
Command/Adjust.hs
View file

@ -11,7 +11,7 @@ import Command
import Annex.AdjustedBranch import Annex.AdjustedBranch
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ noDaemonRunning $ cmd = notBareRepo $ noDaemonRunning $
command "adjust" SectionSetup "enter adjusted branch" command "adjust" SectionSetup "enter adjusted branch"
paramNothing (seek <$$> optParser) paramNothing (seek <$$> optParser)

2
Command/Fix.hs
View file

@ -25,7 +25,7 @@ import System.Posix.Files
#endif #endif
cmd :: Command cmd :: Command
cmd = notDirect $ noCommit $ withGlobalOptions [annexedMatchingOptions] $ cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $
command "fix" SectionMaintenance command "fix" SectionMaintenance
"fix up links to annexed content" "fix up links to annexed content"
paramPaths (withParams seek) paramPaths (withParams seek)

2
Command/FromKey.hs
View file

@ -19,7 +19,7 @@ import qualified Backend.URL
import Network.URI import Network.URI
cmd :: Command cmd :: Command
cmd = notDirect $ notBareRepo $ withGlobalOptions [jsonOptions] $ cmd = notBareRepo $ withGlobalOptions [jsonOptions] $
command "fromkey" SectionPlumbing "adds a file using a specific key" command "fromkey" SectionPlumbing "adds a file using a specific key"
(paramRepeating (paramPair paramKey paramPath)) (paramRepeating (paramPair paramKey paramPath))
(seek <$$> optParser) (seek <$$> optParser)

120
Command/Fsck.hs
View file

@ -15,8 +15,6 @@ import qualified Remote
import qualified Types.Backend import qualified Types.Backend
import qualified Backend import qualified Backend
import Annex.Content import Annex.Content
import qualified Annex.Content.Direct as Direct
import Annex.Direct
import Annex.Perms import Annex.Perms
import Annex.Link import Annex.Link
import Logs.Location import Logs.Location
@ -28,7 +26,6 @@ import Annex.NumCopies
import Annex.UUID import Annex.UUID
import Annex.ReplaceFile import Annex.ReplaceFile
import Utility.DataUnits import Utility.DataUnits
import Config
import Utility.HumanTime import Utility.HumanTime
import Utility.CopyFile import Utility.CopyFile
import Git.FilePath import Git.FilePath
@ -225,16 +222,15 @@ 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
direct <- isDirect
obj <- calcRepo $ gitAnnexLocation key obj <- calcRepo $ gitAnnexLocation key
present <- if not direct && isKeyUnlockedThin keystatus present <- if isKeyUnlockedThin keystatus
then liftIO (doesFileExist obj) then liftIO (doesFileExist obj)
else inAnnex key else inAnnex key
u <- getUUID u <- getUUID
{- Since we're checking that a key's object file is present, throw {- Since we're checking that a key's object file is present, throw
- in a permission fixup here too. -} - in a permission fixup here too. -}
when (present && not direct) $ do when present $ do
void $ tryIO $ case keystatus of void $ tryIO $ case keystatus of
KeyUnlockedThin -> thawContent obj KeyUnlockedThin -> thawContent obj
KeyLockedThin -> thawContent obj KeyLockedThin -> thawContent obj
@ -252,9 +248,7 @@ verifyLocationLog key keystatus ai = do
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 (keyVariety key)) ++ " key" warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key"
{- In direct mode, modified files will show up as not present, if not present
- but that is expected and not something to do anything about. -}
if direct && not present
then return True then return True
else verifyLocationLog' key ai present u (logChange key u) else verifyLocationLog' key ai present u (logChange key u)
@ -319,56 +313,38 @@ verifyRequiredContent _ _ = return True
{- Verifies the associated file records. -} {- Verifies the associated file records. -}
verifyAssociatedFiles :: Key -> KeyStatus -> FilePath -> Annex Bool verifyAssociatedFiles :: Key -> KeyStatus -> FilePath -> Annex Bool
verifyAssociatedFiles key keystatus file = do verifyAssociatedFiles key keystatus file = do
ifM isDirect (godirect, goindirect) when (isKeyUnlockedThin keystatus) $ do
return True
where
godirect = do
fs <- Direct.addAssociatedFile key file
forM_ fs $ \f ->
unlessM (liftIO $ doesFileExist f) $
void $ Direct.removeAssociatedFile key f
goindirect = when (isKeyUnlockedThin keystatus) $ do
f <- inRepo $ toTopFilePath file f <- inRepo $ toTopFilePath file
afs <- Database.Keys.getAssociatedFiles key afs <- Database.Keys.getAssociatedFiles key
unless (getTopFilePath f `elem` map getTopFilePath afs) $ unless (getTopFilePath f `elem` map getTopFilePath afs) $
Database.Keys.addAssociatedFile key f Database.Keys.addAssociatedFile key f
return True
verifyWorkTree :: Key -> FilePath -> Annex Bool verifyWorkTree :: Key -> FilePath -> Annex Bool
verifyWorkTree key file = do verifyWorkTree key file = do
ifM isDirect ( godirect, goindirect )
return True
where
{- Ensures that files whose content is available are in direct mode. -}
godirect = whenM (isJust <$> isAnnexLink file) $ do
v <- toDirectGen key file
case v of
Nothing -> noop
Just a -> do
showNote "fixing direct mode"
a
{- Make sure that a pointer file is replaced with its content, {- Make sure that a pointer file is replaced with its content,
- when the content is available. -} - when the content is available. -}
goindirect = do mk <- liftIO $ isPointerFile file
mk <- liftIO $ isPointerFile file case mk of
case mk of Just k | k == key -> whenM (inAnnex key) $ do
Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content"
showNote "fixing worktree content" replaceFile file $ \tmp -> do
replaceFile file $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file ifM (annexThin <$> Annex.getGitConfig)
ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex key tmp mode
( void $ linkFromAnnex key tmp mode , do
, do obj <- calcRepo $ gitAnnexLocation key
obj <- calcRepo $ gitAnnexLocation key void $ checkedCopyFile key obj tmp mode
void $ checkedCopyFile key obj tmp mode thawContent tmp
thawContent tmp )
) Database.Keys.storeInodeCaches key [file]
Database.Keys.storeInodeCaches key [file] _ -> return ()
_ -> return () return True
{- The size of the data for a key is checked against the size encoded in {- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available. - the key's metadata, if available.
- -
- Not checked when a file is unlocked, or in direct mode. - Not checked when a file is unlocked.
-} -}
checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool
checkKeySize _ KeyUnlockedThin _ = return True checkKeySize _ KeyUnlockedThin _ = return True
@ -439,28 +415,15 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
- thus when the user modifies the file, the object will be modified and - thus when the user modifies the file, the object will be modified and
- not pass the check, and we don't want to find an error in this case. - not pass the check, and we don't want to find an error in this case.
- So, skip the check if the key is unlocked and modified. - So, skip the check if the key is unlocked and modified.
-
- In direct mode this is not done if the file has clearly been modified,
- because modification of direct mode files is allowed. It's still done
- if the file does not appear modified, to catch disk corruption, etc.
-} -}
checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool
checkBackend backend key keystatus afile = go =<< isDirect checkBackend backend key keystatus afile = do
where content <- calcRepo $ gitAnnexLocation key
go False = do ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
content <- calcRepo $ gitAnnexLocation key ( nocheck
ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) , checkBackendOr badContent backend key content ai
( nocheck
, checkBackendOr badContent backend key content ai
)
go True = case afile of
AssociatedFile Nothing -> nocheck
AssociatedFile (Just f) -> checkdirect f
checkdirect file = ifM (Direct.goodContent key file)
( checkBackendOr' (badContentDirect file) backend key file ai
(Direct.goodContent key file)
, nocheck
) )
where
nocheck = return True nocheck = return True
ai = mkActionItem (key, afile) ai = mkActionItem (key, afile)
@ -475,7 +438,7 @@ checkBackendOr bad backend key file ai =
-- 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 (particularly in direct mode). -- verified.
checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool -> Annex Bool checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> 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
@ -546,14 +509,6 @@ badContent key = do
dest <- moveBad key dest <- moveBad key
return $ "moved to " ++ dest return $ "moved to " ++ dest
{- Bad content is left where it is, but we touch the file, so it'll be
- committed to a new key. -}
badContentDirect :: FilePath -> Key -> Annex String
badContentDirect file key = do
void $ liftIO $ catchMaybeIO $ touchFile file
logStatus key InfoMissing
return "left in place for you to examine"
{- Bad content is dropped from the remote. We have downloaded a copy {- Bad content is dropped from the remote. We have downloaded a copy
- from the remote to a temp file already (in some cases, it's just a - from the remote to a temp file already (in some cases, it's just a
- 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,
@ -714,16 +669,13 @@ isKeyUnlockedThin KeyPresent = False
isKeyUnlockedThin KeyMissing = False isKeyUnlockedThin KeyMissing = False
getKeyStatus :: Key -> Annex KeyStatus getKeyStatus :: Key -> Annex KeyStatus
getKeyStatus key = ifM isDirect getKeyStatus key = catchDefaultIO KeyMissing $ do
( return KeyUnlockedThin afs <- not . null <$> Database.Keys.getAssociatedFiles key
, catchDefaultIO KeyMissing $ do obj <- calcRepo $ gitAnnexLocation key
afs <- not . null <$> Database.Keys.getAssociatedFiles key multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj))
obj <- calcRepo $ gitAnnexLocation key return $ if multilink && afs
multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) then KeyUnlockedThin
return $ if multilink && afs else KeyPresent
then KeyUnlockedThin
else KeyPresent
)
getKeyFileStatus :: Key -> FilePath -> Annex KeyStatus getKeyFileStatus :: Key -> FilePath -> Annex KeyStatus
getKeyFileStatus key file = do getKeyFileStatus key file = do

8
Command/FuzzTest.hs
View file

@ -155,7 +155,6 @@ data FuzzAction
= FuzzAdd FuzzFile = FuzzAdd FuzzFile
| FuzzDelete FuzzFile | FuzzDelete FuzzFile
| FuzzMove FuzzFile FuzzFile | FuzzMove FuzzFile FuzzFile
| FuzzModify FuzzFile
| FuzzDeleteDir FuzzDir | FuzzDeleteDir FuzzDir
| FuzzMoveDir FuzzDir FuzzDir | FuzzMoveDir FuzzDir FuzzDir
| FuzzPause Delay | FuzzPause Delay
@ -166,7 +165,6 @@ instance Arbitrary FuzzAction where
[ (50, FuzzAdd <$> arbitrary) [ (50, FuzzAdd <$> arbitrary)
, (50, FuzzDelete <$> arbitrary) , (50, FuzzDelete <$> arbitrary)
, (10, FuzzMove <$> arbitrary <*> arbitrary) , (10, FuzzMove <$> arbitrary <*> arbitrary)
, (10, FuzzModify <$> arbitrary)
, (10, FuzzDeleteDir <$> arbitrary) , (10, FuzzDeleteDir <$> arbitrary)
, (10, FuzzMoveDir <$> arbitrary <*> arbitrary) , (10, FuzzMoveDir <$> arbitrary <*> arbitrary)
, (10, FuzzPause <$> arbitrary) , (10, FuzzPause <$> arbitrary)
@ -180,9 +178,6 @@ runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
rename src dest rename src dest
runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do
n <- getStdRandom random :: IO Int
appendFile f $ show n ++ "\n"
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
removeDirectoryRecursive d removeDirectoryRecursive d
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
@ -216,9 +211,6 @@ genFuzzAction = do
FuzzDeleteDir _ -> do FuzzDeleteDir _ -> do
d <- liftIO existingDir d <- liftIO existingDir
maybe genFuzzAction (return . FuzzDeleteDir) d maybe genFuzzAction (return . FuzzDeleteDir) d
FuzzModify _ -> do
f <- liftIO $ existingFile 0 ""
maybe genFuzzAction (return . FuzzModify) f
FuzzPause _ -> return tmpl FuzzPause _ -> return tmpl
existingFile :: Int -> FilePath -> IO (Maybe FuzzFile) existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)

10
Command/Info.hs
View file

@ -31,7 +31,6 @@ import Logs.Trust
import Logs.Location import Logs.Location
import Annex.NumCopies import Annex.NumCopies
import Remote import Remote
import Config
import Git.Config (boolConfig) import Git.Config (boolConfig)
import qualified Git.LsTree as LsTree import qualified Git.LsTree as LsTree
import Utility.Percentage import Utility.Percentage
@ -318,12 +317,9 @@ showStat s = maybe noop calc =<< s
repository_mode :: Stat repository_mode :: Stat
repository_mode = simpleStat "repository mode" $ lift $ repository_mode = simpleStat "repository mode" $ lift $
ifM isDirect ifM (fromRepo Git.repoIsLocalBare)
( return "direct" ( return "bare"
, ifM (fromRepo Git.repoIsLocalBare) , return "indirect"
( return "bare"
, return "indirect"
)
) )
repo_list :: TrustLevel -> Stat repo_list :: TrustLevel -> Stat

2
Command/Lock.hs
View file

@ -23,7 +23,7 @@ import Logs.Location
import Git.FilePath import Git.FilePath
cmd :: Command cmd :: Command
cmd = notDirect $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
command "lock" SectionCommon command "lock" SectionCommon
"undo unlock command" "undo unlock command"
paramPaths (withParams seek) paramPaths (withParams seek)

2
Command/Migrate.hs
View file

@ -20,7 +20,7 @@ import Logs.Web
import Utility.Metered import Utility.Metered
cmd :: Command cmd :: Command
cmd = notDirect $ withGlobalOptions [annexedMatchingOptions] $ cmd = withGlobalOptions [annexedMatchingOptions] $
command "migrate" SectionUtility command "migrate" SectionUtility
"switch data to different backend" "switch data to different backend"
paramPaths (withParams seek) paramPaths (withParams seek)

3
Command/Multicast.hs
View file

@ -27,7 +27,6 @@ import Utility.Hash
import Utility.Tmp import Utility.Tmp
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Utility.Process.Transcript import Utility.Process.Transcript
import Config
import Data.Char import Data.Char
import qualified Data.ByteString.Lazy.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as B8
@ -128,8 +127,6 @@ send ups fs = do
-- In a direct mode repository, the annex objects do not have -- In a direct mode repository, the annex objects do not have
-- the names of keys, and would have to be copied, which is too -- the names of keys, and would have to be copied, which is too
-- expensive. -- expensive.
whenM isDirect $
giveup "Sorry, multicast send cannot be done from a direct mode repository."
starting "sending files" (ActionItemOther Nothing) $ starting "sending files" (ActionItemOther Nothing) $
withTmpFile "send" $ \t h -> do withTmpFile "send" $ \t h -> do
fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs

87
Command/PreCommit.hs
View file

@ -10,11 +10,9 @@
module Command.PreCommit where module Command.PreCommit where
import Command import Command
import Config
import qualified Command.Add import qualified Command.Add
import qualified Command.Fix import qualified Command.Fix
import qualified Command.Smudge import qualified Command.Smudge
import Annex.Direct
import Annex.Hook import Annex.Hook
import Annex.Link import Annex.Link
import Annex.View import Annex.View
@ -38,50 +36,45 @@ cmd = command "pre-commit" SectionPlumbing
(withParams seek) (withParams seek)
seek :: CmdParams -> CommandSeek seek :: CmdParams -> CommandSeek
seek ps = lockPreCommitHook $ ifM isDirect seek ps = lockPreCommitHook $ do
( do ifM (not <$> versionSupportsUnlockedPointers <&&> liftIO Git.haveFalseIndex)
-- update direct mode mappings for committed files ( do
withWords (commandAction . startDirect) ps (fs, cleanup) <- inRepo $ Git.typeChangedStaged ps
runAnnexHook preCommitAnnexHook whenM (anyM isOldUnlocked fs) $
, do giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
ifM (not <$> versionSupportsUnlockedPointers <&&> liftIO Git.haveFalseIndex) void $ liftIO cleanup
( do , do
(fs, cleanup) <- inRepo $ Git.typeChangedStaged ps l <- workTreeItems ps
whenM (anyM isOldUnlocked fs) $ -- fix symlinks to files being committed
giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit." flip withFilesToBeCommitted l $ \f -> commandAction $
void $ liftIO cleanup maybe stop (Command.Fix.start Command.Fix.FixSymlinks f)
, do =<< isAnnexLink f
l <- workTreeItems ps ifM versionSupportsUnlockedPointers
-- fix symlinks to files being committed -- after a merge conflict or git
flip withFilesToBeCommitted l $ \f -> commandAction $ -- cherry-pick or stash, pointer
maybe stop (Command.Fix.start Command.Fix.FixSymlinks f) -- files in the worktree won't
=<< isAnnexLink f -- be populated, so populate them
ifM versionSupportsUnlockedPointers -- here
-- after a merge conflict or git ( Command.Smudge.updateSmudged
-- cherry-pick or stash, pointer -- When there's a false index,
-- files in the worktree won't -- restaging the files won't work.
-- be populated, so populate them . Restage =<< liftIO Git.haveFalseIndex
-- here -- inject unlocked files into the annex
( Command.Smudge.updateSmudged -- (not needed when repo version uses
-- When there's a false index, -- unlocked pointer files)
-- restaging the files won't work. , withFilesOldUnlockedToBeCommitted (commandAction . startInjectUnlocked) l
. Restage =<< liftIO Git.haveFalseIndex )
-- inject unlocked files into the annex )
-- (not needed when repo version uses
-- unlocked pointer files)
, withFilesOldUnlockedToBeCommitted (commandAction . startInjectUnlocked) l
)
)
runAnnexHook preCommitAnnexHook
-- committing changes to a view updates metadata
mv <- currentView
case mv of
Nothing -> noop
Just v -> withViewChanges
(addViewMetaData v)
(removeViewMetaData v)
)
runAnnexHook preCommitAnnexHook
-- committing changes to a view updates metadata
mv <- currentView
case mv of
Nothing -> noop
Just v -> withViewChanges
(addViewMetaData v)
(removeViewMetaData v)
startInjectUnlocked :: FilePath -> CommandStart startInjectUnlocked :: FilePath -> CommandStart
startInjectUnlocked f = startingCustomOutput (ActionItemOther Nothing) $ do startInjectUnlocked f = startingCustomOutput (ActionItemOther Nothing) $ do
@ -89,10 +82,6 @@ startInjectUnlocked f = startingCustomOutput (ActionItemOther Nothing) $ do
error $ "failed to add " ++ f ++ "; canceling commit" error $ "failed to add " ++ f ++ "; canceling commit"
next $ return True next $ return True
startDirect :: [String] -> CommandStart
startDirect _ = startingCustomOutput (ActionItemOther Nothing) $
next preCommitDirect
addViewMetaData :: View -> ViewedFile -> Key -> CommandStart addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $ addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
next $ changeMetaData k $ fromView v f next $ changeMetaData k $ fromView v f

9
Command/ReKey.hs
View file

@ -21,11 +21,10 @@ import Annex.InodeSentinal
import Utility.InodeCache import Utility.InodeCache
cmd :: Command cmd :: Command
cmd = notDirect $ cmd = command "rekey" SectionPlumbing
command "rekey" SectionPlumbing "change keys used for files"
"change keys used for files" (paramRepeating $ paramPair paramPath paramKey)
(paramRepeating $ paramPair paramPath paramKey) (seek <$$> optParser)
(seek <$$> optParser)
data ReKeyOptions = ReKeyOptions data ReKeyOptions = ReKeyOptions
{ reKeyThese :: CmdParams { reKeyThese :: CmdParams

2
Command/RegisterUrl.hs
View file

@ -15,7 +15,7 @@ import Command.FromKey (mkKey)
import qualified Remote import qualified Remote
cmd :: Command cmd :: Command
cmd = notDirect $ notBareRepo $ cmd = notBareRepo $
command "registerurl" command "registerurl"
SectionPlumbing "registers an url for a key" SectionPlumbing "registers an url for a key"
(paramPair paramKey paramUrl) (paramPair paramKey paramUrl)

44
Command/Status.hs
View file

@ -8,11 +8,7 @@
module Command.Status where module Command.Status where
import Command import Command
import Annex.CatFile
import Annex.Content.Direct
import Config
import Git.Status import Git.Status
import qualified Git.Ref
import Git.FilePath import Git.FilePath
cmd :: Command cmd :: Command
@ -42,10 +38,7 @@ seek o = withWords (commandAction . start o) (statusFiles o)
start :: StatusOptions -> [FilePath] -> CommandStart start :: StatusOptions -> [FilePath] -> CommandStart
start o locs = do start o locs = do
(l, cleanup) <- inRepo $ getStatus ps locs (l, cleanup) <- inRepo $ getStatus ps locs
getstatus <- ifM isDirect let getstatus = pure . simplifiedStatus
( return (maybe (pure Nothing) statusDirect . simplifiedStatus)
, return (pure . simplifiedStatus)
)
forM_ l $ \s -> maybe noop displayStatus =<< getstatus s forM_ l $ \s -> maybe noop displayStatus =<< getstatus s
ifM (liftIO cleanup) ifM (liftIO cleanup)
( stop ( stop
@ -71,38 +64,3 @@ displayStatus s = do
f <- liftIO $ relPathCwdToFile absf f <- liftIO $ relPathCwdToFile absf
unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $
liftIO $ putStrLn $ [c] ++ " " ++ f liftIO $ putStrLn $ [c] ++ " " ++ f
-- Git thinks that present direct mode files are typechanged.
-- (On crippled filesystems, git instead thinks they're modified.)
-- Check their content to see if they are modified or not.
statusDirect :: Status -> Annex (Maybe Status)
statusDirect (TypeChanged t) = statusDirect' t
statusDirect s@(Modified t) = ifM crippledFileSystem
( statusDirect' t
, pure (Just s)
)
statusDirect s = pure (Just s)
statusDirect' :: TopFilePath -> Annex (Maybe Status)
statusDirect' t = do
absf <- fromRepo $ fromTopFilePath t
f <- liftIO $ relPathCwdToFile absf
v <- liftIO (catchMaybeIO $ getFileStatus f)
case v of
Nothing -> return $ Just $ Deleted t
Just s
| not (isSymbolicLink s) ->
checkkey f s =<< catKeyFile f
| otherwise -> Just <$> checkNew f t
where
checkkey f s (Just k) = ifM (sameFileStatus k f s)
( return Nothing
, return $ Just $ Modified t
)
checkkey f _ Nothing = Just <$> checkNew f t
checkNew :: FilePath -> TopFilePath -> Annex Status
checkNew f t = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
( return (Modified t)
, return (Untracked t)
)

35
Command/Sync.hs
View file

@ -30,7 +30,6 @@ import qualified Annex
import qualified Annex.Branch import qualified Annex.Branch
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Annex.Direct
import Annex.Hook import Annex.Hook
import qualified Git.Command import qualified Git.Command
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
@ -250,7 +249,7 @@ merge currbranch mergeconfig resolvemergeoverride commitmode tomerge = case curr
ResolveMergeOverride False -> return False ResolveMergeOverride False -> return False
syncBranch :: Git.Branch -> Git.Branch syncBranch :: Git.Branch -> Git.Branch
syncBranch = Git.Ref.underBase "refs/heads/synced" . fromDirectBranch . fromAdjustedBranch syncBranch = Git.Ref.underBase "refs/heads/synced" . fromAdjustedBranch
remoteBranch :: Remote -> Git.Ref -> Git.Ref remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
@ -286,20 +285,14 @@ commit :: SyncOptions -> CommandStart
commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do
commitmessage <- maybe commitMsg return (messageOption o) commitmessage <- maybe commitMsg return (messageOption o)
Annex.Branch.commit =<< Annex.Branch.commitMessage Annex.Branch.commit =<< Annex.Branch.commitMessage
next $ ifM isDirect next $ do
( do showOutput
void stageDirect void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
void preCommitDirect [ Param "-a"
commitStaged Git.Branch.ManualCommit commitmessage , Param "-m"
, do , Param commitmessage
showOutput ]
void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit return True
[ Param "-a"
, Param "-m"
, Param commitmessage
]
return True
)
where where
shouldcommit = pure (commitOption o) shouldcommit = pure (commitOption o)
<||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit) <||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit)
@ -378,12 +371,6 @@ updateBranches (Just branch, madj) = do
-- Update the sync branch to match the new state of the branch -- Update the sync branch to match the new state of the branch
inRepo $ updateBranch (syncBranch branch) branch inRepo $ updateBranch (syncBranch branch) branch
-- In direct mode, we're operating on some special direct mode
-- branch, rather than the intended branch, so update the intended
-- branch.
whenM isDirect $
inRepo $ updateBranch (fromDirectBranch branch) branch
updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO () updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO ()
updateBranch syncbranch updateto g = updateBranch syncbranch updateto g =
unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch
@ -449,7 +436,7 @@ mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo
(mapM (merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit . remoteBranch remote) =<< getlist) (mapM (merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit . remoteBranch remote) =<< getlist)
tomerge = filterM (changed remote) tomerge = filterM (changed remote)
branchlist Nothing = [] branchlist Nothing = []
branchlist (Just branch) = [fromDirectBranch (fromAdjustedBranch branch), syncBranch branch] branchlist (Just branch) = [fromAdjustedBranch branch, syncBranch branch]
pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
pushRemote _o _remote (Nothing, _) = stop pushRemote _o _remote (Nothing, _) = stop
@ -540,7 +527,7 @@ pushBranch remote branch g = directpush `after` annexpush `after` syncpush
-- receive.denyCurrentBranch=updateInstead -- the user -- receive.denyCurrentBranch=updateInstead -- the user
-- will want to see that one. -- will want to see that one.
let p = flip Git.Command.gitCreateProcess g $ pushparams let p = flip Git.Command.gitCreateProcess g $ pushparams
[ Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch ] [ Git.fromRef $ Git.Ref.base $ fromAdjustedBranch branch ]
(transcript, ok) <- processTranscript' p Nothing (transcript, ok) <- processTranscript' p Nothing
when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $
hPutStr stderr transcript hPutStr stderr transcript

44
Command/Unannex.hs
View file

@ -8,11 +8,9 @@
module Command.Unannex where module Command.Unannex where
import Command import Command
import Config
import qualified Annex import qualified Annex
import Annex.Content import Annex.Content
import Annex.Perms import Annex.Perms
import Annex.Content.Direct
import Annex.Version import Annex.Version
import qualified Git.Command import qualified Git.Command
import qualified Git.Branch import qualified Git.Branch
@ -34,7 +32,7 @@ seek ps = wrapUnannex $
(withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps
wrapUnannex :: Annex a -> Annex a wrapUnannex :: Annex a -> Annex a
wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect) wrapUnannex a = ifM versionSupportsUnlockedPointers
( a ( a
{- Run with the pre-commit hook disabled, to avoid confusing {- Run with the pre-commit hook disabled, to avoid confusing
- behavior if an unannexed file is added back to git as - behavior if an unannexed file is added back to git as
@ -68,13 +66,10 @@ wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
start :: FilePath -> Key -> CommandStart start :: FilePath -> Key -> CommandStart
start file key = stopUnless (inAnnex key) $ start file key = stopUnless (inAnnex key) $
starting "unannex" (mkActionItem (key, file)) $ starting "unannex" (mkActionItem (key, file)) $
ifM isDirect perform file key
( performDirect file key
, performIndirect file key
)
performIndirect :: FilePath -> Key -> CommandPerform perform :: FilePath -> Key -> CommandPerform
performIndirect file key = do perform file key = do
liftIO $ removeFile file liftIO $ removeFile file
inRepo $ Git.Command.run inRepo $ Git.Command.run
[ Param "rm" [ Param "rm"
@ -84,10 +79,10 @@ performIndirect file key = do
, Param "--" , Param "--"
, File file , File file
] ]
next $ cleanupIndirect file key next $ cleanup file key
cleanupIndirect :: FilePath -> Key -> CommandCleanup cleanup :: FilePath -> Key -> CommandCleanup
cleanupIndirect file key = do cleanup file key = do
Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
src <- calcRepo $ gitAnnexLocation key src <- calcRepo $ gitAnnexLocation key
ifM (Annex.getState Annex.fast) ifM (Annex.getState Annex.fast)
@ -112,28 +107,3 @@ cleanupIndirect file key = do
( return True ( return True
, copyfrom src , copyfrom src
) )
performDirect :: FilePath -> Key -> CommandPerform
performDirect file key = do
-- --force is needed when the file is not committed
inRepo $ Git.Command.run
[ Param "rm"
, Param "--cached"
, Param "--force"
, Param "--quiet"
, Param "--"
, File file
]
next $ cleanupDirect file key
{- The direct mode file is not touched during unannex, so the content
- is already where it needs to be, so this does not need to do anything
- except remove it from the associated file map (which also updates
- the location log if this was the last copy), and, if this was the last
- associated file, remove the inode cache. -}
cleanupDirect :: FilePath -> Key -> CommandCleanup
cleanupDirect file key = do
fs <- removeAssociatedFile key file
when (null fs) $
removeInodeCache key
return True

11
Command/Undo.hs
View file

@ -9,7 +9,6 @@ module Command.Undo where
import Command import Command
import Config import Config
import Annex.Direct
import Annex.CatFile import Annex.CatFile
import Git.DiffTree import Git.DiffTree
import Git.FilePath import Git.FilePath
@ -37,9 +36,7 @@ seek ps = do
-- Committing staged changes before undo allows later -- Committing staged changes before undo allows later
-- undoing the undo. It would be nicer to only commit staged -- undoing the undo. It would be nicer to only commit staged
-- changes to the specified files, rather than all staged changes, -- changes to the specified files, rather than all staged changes.
-- but that is difficult to do; a partial git-commit can't be done
-- in direct mode.
void $ Command.Sync.commitStaged Git.Branch.ManualCommit void $ Command.Sync.commitStaged Git.Branch.ManualCommit
"commit before undo" "commit before undo"
@ -68,16 +65,10 @@ perform p = do
forM_ removals $ \di -> do forM_ removals $ \di -> do
f <- mkrel di f <- mkrel di
whenM isDirect $
maybe noop (`removeDirect` f)
=<< catKey (srcsha di)
liftIO $ nukeFile f liftIO $ nukeFile f
forM_ adds $ \di -> do forM_ adds $ \di -> do
f <- mkrel di f <- mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f] inRepo $ Git.run [Param "checkout", Param "--", File f]
whenM isDirect $
maybe noop (`toDirect` f)
=<< catKey (dstsha di)
next $ liftIO cleanup next $ liftIO cleanup

5
Command/Unlock.hs
View file

@ -25,9 +25,8 @@ editcmd :: Command
editcmd = mkcmd "edit" "same as unlock" editcmd = mkcmd "edit" "same as unlock"
mkcmd :: String -> String -> Command mkcmd :: String -> String -> Command
mkcmd n d = notDirect $ mkcmd n d = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
withGlobalOptions [jsonOptions, annexedMatchingOptions] $ command n SectionCommon d paramPaths (withParams seek)
command n SectionCommon d paramPaths (withParams seek)
seek :: CmdParams -> CommandSeek seek :: CmdParams -> CommandSeek
seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems ps seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems ps

2
Command/VAdd.hs
View file

@ -12,7 +12,7 @@ import Annex.View
import Command.View (checkoutViewBranch) import Command.View (checkoutViewBranch)
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ cmd = notBareRepo $
command "vadd" SectionMetaData command "vadd" SectionMetaData
"add subdirs to current view" "add subdirs to current view"
(paramRepeating "FIELD=GLOB") (paramRepeating "FIELD=GLOB")

2
Command/VCycle.hs
View file

@ -14,7 +14,7 @@ import Logs.View
import Command.View (checkoutViewBranch) import Command.View (checkoutViewBranch)
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ cmd = notBareRepo $
command "vcycle" SectionMetaData command "vcycle" SectionMetaData
"switch view to next layout" "switch view to next layout"
paramNothing (withParams seek) paramNothing (withParams seek)

2
Command/VFilter.hs
View file

@ -12,7 +12,7 @@ import Annex.View
import Command.View (paramView, checkoutViewBranch) import Command.View (paramView, checkoutViewBranch)
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ cmd = notBareRepo $
command "vfilter" SectionMetaData "filter current view" command "vfilter" SectionMetaData "filter current view"
paramView (withParams seek) paramView (withParams seek)

2
Command/VPop.hs
View file

@ -16,7 +16,7 @@ import Logs.View
import Command.View (checkoutViewBranch) import Command.View (checkoutViewBranch)
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ cmd = notBareRepo $
command "vpop" SectionMetaData "switch back to previous view" command "vpop" SectionMetaData "switch back to previous view"
paramNumber (withParams seek) paramNumber (withParams seek)

2
Command/View.hs
View file

@ -20,7 +20,7 @@ import Annex.View
import Logs.View import Logs.View
cmd :: Command cmd :: Command
cmd = notBareRepo $ notDirect $ cmd = notBareRepo $
command "view" SectionMetaData "enter a view branch" command "view" SectionMetaData "enter a view branch"
paramView (withParams seek) paramView (withParams seek)

14
Upgrade/V4.hs
View file

@ -8,16 +8,8 @@
module Upgrade.V4 where module Upgrade.V4 where
import Annex.Common import Annex.Common
import Config
import Annex.Direct
{- Direct mode only upgrade. v4 to v5 indirect update is a no-op -} {- Was only used for direct mode upgrade. v4 to v5 indirect update is a no-op,
- and direct mode is no longer supported, so nothing needs to be done. -}
upgrade :: Bool -> Annex Bool upgrade :: Bool -> Annex Bool
upgrade automatic = ifM isDirect upgrade _automatic = return True
( do
unless automatic $
showAction "v4 to v5"
setDirect True
return True
, return True
)

8
Upgrade/V5.hs
View file

@ -13,11 +13,11 @@ import Config
import Config.Smudge import Config.Smudge
import Annex.InodeSentinal import Annex.InodeSentinal
import Annex.Link import Annex.Link
import Annex.Direct
import Annex.Content import Annex.Content
import Annex.CatFile import Annex.CatFile
import Annex.WorkTree import Annex.WorkTree
import qualified Database.Keys import qualified Database.Keys
import qualified Annex.Direct as Direct
import qualified Annex.Content.Direct as Direct import qualified Annex.Content.Direct as Direct
import qualified Git import qualified Git
import qualified Git.LsFiles import qualified Git.LsFiles
@ -48,7 +48,7 @@ upgrade automatic = do
-- locking down files as they were added. In v6, it's used more -- locking down files as they were added. In v6, it's used more
-- extensively, so make sure it exists, since old repos that didn't -- extensively, so make sure it exists, since old repos that didn't
-- use direct mode may not have created it. -- use direct mode may not have created it.
unlessM (isDirect) $ unlessM isDirect $
createInodeSentinalFile True createInodeSentinalFile True
return True return True
@ -62,12 +62,12 @@ convertDirect automatic = do
{- Since upgrade from direct mode changes how files {- Since upgrade from direct mode changes how files
- are represented in git, by checking out an adjusted - are represented in git, by checking out an adjusted
- branch, commit any changes in the work tree first. -} - branch, commit any changes in the work tree first. -}
whenM stageDirect $ do whenM Direct.stageDirect $ do
unless automatic $ unless automatic $
showAction "committing first" showAction "committing first"
upgradeDirectCommit automatic upgradeDirectCommit automatic
"commit before upgrade to annex.version 6" "commit before upgrade to annex.version 6"
setDirect False Direct.setIndirect
cur <- fromMaybe (error "Somehow no branch is checked out") cur <- fromMaybe (error "Somehow no branch is checked out")
<$> inRepo Git.Branch.current <$> inRepo Git.Branch.current
upgradeDirectWorkTree upgradeDirectWorkTree