summaryrefslogtreecommitdiff
path: root/Annex/Direct.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Annex/Direct.hs')
-rw-r--r--Annex/Direct.hs95
1 files changed, 82 insertions, 13 deletions
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index d2e2cdc00..d4b73860e 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -8,14 +8,19 @@
module Annex.Direct where
import Common.Annex
+import qualified Annex
import qualified Git
import qualified Git.LsFiles
import qualified Git.Merge
import qualified Git.DiffTree as DiffTree
+import qualified Git.Config
+import qualified Git.Ref
+import qualified Git.Branch
import Git.Sha
+import Git.FilePath
import Git.Types
+import Config
import Annex.CatFile
-import Utility.FileMode
import qualified Annex.Queue
import Logs.Location
import Backend
@@ -45,8 +50,8 @@ stageDirect = do
{- Determine what kind of modified or deleted file this is, as
- efficiently as we can, by getting any key that's associated
- with it in git, as well as its stat info. -}
- go (file, Just sha) = do
- shakey <- catKey sha
+ go (file, Just sha, Just mode) = do
+ shakey <- catKey sha mode
mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
filekey <- isAnnexLink file
case (shakey, filekey, mstat, toInodeCache =<< mstat) of
@@ -123,6 +128,8 @@ addDirect file cache = do
-}
mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool
mergeDirect d branch g = do
+ whenM (doesDirectoryExist d) $
+ removeDirectoryRecursive d
createDirectoryIfMissing True d
let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
Git.Merge.mergeNonInteractive branch g'
@@ -135,23 +142,22 @@ mergeDirect d branch g = do
mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
mergeDirectCleanup d oldsha newsha = do
(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
- forM_ items updated
+ makeabs <- flip fromTopFilePath <$> gitRepo
+ forM_ items (updated makeabs)
void $ liftIO cleanup
liftIO $ removeDirectoryRecursive d
where
- updated item = do
+ updated makeabs item = do
+ let f = makeabs (DiffTree.file item)
void $ tryAnnex $
- go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+ go f DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
void $ tryAnnex $
- go DiffTree.dstsha DiffTree.dstmode movein movein_raw
+ go f DiffTree.dstsha DiffTree.dstmode movein movein_raw
where
- go getsha getmode a araw
+ go f getsha getmode a araw
| getsha item == nullSha = noop
- | isSymLink (getmode item) =
- maybe (araw f) (\k -> void $ a k f)
- =<< catKey (getsha item)
- | otherwise = araw f
- f = DiffTree.file item
+ | otherwise = maybe (araw f) (\k -> void $ a k f)
+ =<< catKey (getsha item) (getmode item)
moveout = removeDirect
@@ -230,3 +236,66 @@ changedDirect oldk f = do
locs <- removeAssociatedFile oldk f
whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
logStatus oldk InfoMissing
+
+{- Enable/disable direct mode. -}
+setDirect :: Bool -> Annex ()
+setDirect wantdirect = do
+ if wantdirect
+ then do
+ switchHEAD
+ setbare
+ else do
+ setbare
+ switchHEADBack
+ setConfig (annexConfig "direct") val
+ Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
+ where
+ val = Git.Config.boolConfig wantdirect
+ setbare = setConfig (ConfigKey Git.Config.coreBare) val
+
+{- 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 split "/" $ show orighead of
+ ("refs":"heads":"annex":"direct":_) -> orighead
+ ("refs":"heads":rest) ->
+ Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+ _ -> Ref $ "refs/heads/" ++ show (Git.Ref.base orighead)
+
+{- Converts a directBranch back to the original branch.
+ -
+ - Any other ref is left unchanged.
+ -}
+fromDirectBranch :: Ref -> Ref
+fromDirectBranch directhead = case split "/" $ show directhead of
+ ("refs":"heads":"annex":"direct":rest) ->
+ Ref $ "refs/heads/" ++ intercalate "/" rest
+ _ -> 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 newhead)
+ =<< inRepo (Git.Ref.sha orighead)
+ inRepo $ Git.Branch.checkout newhead
+
+switchHEADBack :: Annex ()
+switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+ where
+ switch currhead = do
+ let orighead = fromDirectBranch currhead
+ v <- inRepo $ Git.Ref.sha currhead
+ case v of
+ Just headsha
+ | orighead /= currhead -> do
+ inRepo $ Git.Branch.update orighead headsha
+ inRepo $ Git.Branch.checkout orighead
+ inRepo $ Git.Branch.delete currhead
+ _ -> inRepo $ Git.Branch.checkout orighead