adjust: Add --fix adjustment, which is useful when the git directory is in a nonstandard place.

2 files changed, 63 insertions, 24 deletions

diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index bebb5c77c..a61df7d62 100644
--- a/Annex/AdjustedBranch.hs
+++ b/Annex/AdjustedBranch.hs
@@ -57,6 +57,8 @@ import qualified Data.Map as M
 data Adjustment
 	= UnlockAdjustment
 	| LockAdjustment
+	| FixAdjustment
+	| UnFixAdjustment
 	| HideMissingAdjustment
 	| ShowMissingAdjustment
 	deriving (Show, Eq)
@@ -66,32 +68,16 @@ reverseAdjustment UnlockAdjustment = LockAdjustment
 reverseAdjustment LockAdjustment = UnlockAdjustment
 reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
 reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+reverseAdjustment FixAdjustment = UnFixAdjustment
+reverseAdjustment UnFixAdjustment = FixAdjustment
 
 {- How to perform various adjustments to a TreeItem. -}
 adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
-adjustTreeItem UnlockAdjustment ti@(TreeItem f m s)
-	| toBlobType m == Just SymlinkBlob = do
-		mk <- catKey s
-		case mk of
-			Just k -> do
-				Database.Keys.addAssociatedFile k f
-				Just . TreeItem f (fromBlobType FileBlob)
-					<$> hashPointerFile k
-			Nothing -> return (Just ti)
-	| otherwise = return (Just ti)
-adjustTreeItem LockAdjustment ti@(TreeItem f m s)
-	| toBlobType m /= Just SymlinkBlob = do
-		mk <- catKey s
-		case mk of
-			Just k -> do
-				absf <- inRepo $ \r -> absPath $
-					fromTopFilePath f r
-				linktarget <- calcRepo $ gitAnnexLink absf k
-				Just . TreeItem f (fromBlobType SymlinkBlob)
-					<$> hashSymlink linktarget
-			Nothing -> return (Just ti)
-	| otherwise = return (Just ti)
-adjustTreeItem HideMissingAdjustment ti@(TreeItem _ _ s) = do
+adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust
+adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink
+adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust
+adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust
+adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) -> do
 	mk <- catKey s
 	case mk of
 		Just k -> ifM (inAnnex k)
@@ -99,7 +85,40 @@ adjustTreeItem HideMissingAdjustment ti@(TreeItem _ _ s) = do
 			, return Nothing
 			)
 		Nothing -> return (Just ti)
-adjustTreeItem ShowMissingAdjustment ti = return (Just ti)
+adjustTreeItem ShowMissingAdjustment = noAdjust
+
+ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a
+ifSymlink issymlink notsymlink ti@(TreeItem _f m _s)
+	| toBlobType m == Just SymlinkBlob = issymlink ti
+	| otherwise = notsymlink ti
+
+noAdjust :: TreeItem -> Annex (Maybe TreeItem)
+noAdjust = return . Just
+
+adjustToPointer :: TreeItem -> Annex (Maybe TreeItem)
+adjustToPointer ti@(TreeItem f _m s) = do
+	mk <- catKey s
+	case mk of
+		Just k -> do
+			Database.Keys.addAssociatedFile k f
+			Just . TreeItem f (fromBlobType FileBlob)
+				<$> hashPointerFile k
+		Nothing -> return (Just ti)
+
+adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink = adjustToSymlink' gitAnnexLink
+
+adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = do
+	mk <- catKey s
+	case mk of
+		Just k -> do
+			absf <- inRepo $ \r -> absPath $
+				fromTopFilePath f r
+			linktarget <- calcRepo $ gitannexlink absf k
+			Just . TreeItem f (fromBlobType SymlinkBlob)
+				<$> hashSymlink linktarget
+		Nothing -> return (Just ti)
 
 type OrigBranch = Branch
 newtype AdjBranch = AdjBranch { adjBranch :: Branch }
@@ -123,11 +142,15 @@ serialize UnlockAdjustment = "unlocked"
 serialize LockAdjustment = "locked"
 serialize HideMissingAdjustment = "present"
 serialize ShowMissingAdjustment = "showmissing"
+serialize FixAdjustment = "fixed"
+serialize UnFixAdjustment = "unfixed"
 
 deserialize :: String -> Maybe Adjustment
 deserialize "unlocked" = Just UnlockAdjustment
 deserialize "locked" = Just UnlockAdjustment
 deserialize "present" = Just HideMissingAdjustment
+deserialize "fixed" = Just FixAdjustment
+deserialize "unfixed" = Just UnFixAdjustment
 deserialize _ = Nothing
 
 originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
diff --git a/Annex/Locations.hs b/Annex/Locations.hs
index bdd603d94..a19560682 100644
--- a/Annex/Locations.hs
+++ b/Annex/Locations.hs
@@ -15,6 +15,7 @@ module Annex.Locations (
 	gitAnnexLocation,
 	gitAnnexLocationDepth,
 	gitAnnexLink,
+	gitAnnexLinkCanonical,
 	gitAnnexContentLock,
 	gitAnnexMapping,
 	gitAnnexInodeCache,
@@ -80,6 +81,7 @@ import Types.UUID
 import Types.GitConfig
 import Types.Difference
 import qualified Git
+import qualified Git.Types as Git
 import Git.FilePath
 import Annex.DirHashes
 import Annex.Fixup
@@ -182,6 +184,20 @@ gitAnnexLink file key r config = do
 		| otherwise = Git.localGitDir r
 	whoops = error $ "unable to normalize " ++ file
 
+{- Calculates a symlink target as would be used in a typical git
+ - repository, with .git in the top of the work tree. -}
+gitAnnexLinkCanonical :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config'
+  where
+	r' = case r of
+		Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } ->
+			r { Git.location = l { Git.gitdir = wt </> ".git" } }
+		_ -> r
+	config' = config
+		{ annexCrippledFileSystem = False
+		, coreSymlinks = True
+		}
+
 {- File used to lock a key's content. -}
 gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath
 gitAnnexContentLock key r config = do