Fix using lookupkey inside a subdirectory

Caused by dirContains ".." "foo" being incorrectly False.

Also added a test of dirContains, which includes all the previous bug fixes
I could find and some obvious cases.

Reversion in version 8.20211011

Sponsored-by: Brett Eisenberg on Patreon

CHANGELOG

@@ -20,6 +20,8 @@ git-annex (8.20211012) UNRELEASED; urgency=medium
   * Avoid a some sqlite crashes on Windows SubSystem for Linux (WSL).
   * Fix bug that caused stale git-annex branch information to read
     when annex.private or remote.name.annex-private is set.
+  * Fix using lookupkey inside a subdirectory.
+    (Reversion in version 8.20211011)
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 Oct 2021 14:09:13 -0400
 

Test.hs

@@ -194,6 +194,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $
 	, testProperty "prop_upFrom_basics" Utility.Path.Tests.prop_upFrom_basics
 	, testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.Tests.prop_relPathDirToFileAbs_basics
 	, testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.Tests.prop_relPathDirToFileAbs_regressionTest
+	, testProperty "prop_dirContains_regressionTest" Utility.Path.Tests.prop_dirContains_regressionTest
 	, testProperty "prop_cost_sane" Config.Cost.prop_cost_sane
 	, testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane
 	, testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane

Utility/Path.hs

@@ -97,6 +97,7 @@ dirContains a b = a == b
 	|| a' == b'
 	|| (a'' `B.isPrefixOf` b' && avoiddotdotb)
 	|| a' == "." && normalise ("." </> b') == b' && nodotdot b'
+	|| dotdotcontains
   where
 	a' = norm a
 	a'' = addTrailingPathSeparator a'
@@ -115,9 +116,27 @@ dirContains a b = a == b
 	 -}
 	avoiddotdotb = nodotdot $ B.drop (B.length a'') b'
 
-	nodotdot p = all
-		(\s -> dropTrailingPathSeparator s /= "..")
-		(splitPath p)
+	nodotdot p = all (not . isdotdot) (splitPath p)
+	
+	isdotdot s = dropTrailingPathSeparator s == ".."
+
+	{- This handles the case where a is ".." or "../.." etc,
+	 - and b is "foo" or "../foo" etc. The rule is that when
+	 - a is entirely ".." components, b is under it when it starts
+	 - with fewer ".." components. 
+	 - 
+	 - Due to the use of norm, cases like "../../foo/../../" get
+	 - converted to eg "../../../" and so do not need to be handled
+	 - specially here.
+	 -}
+	dotdotcontains
+		| isAbsolute b' = False
+		| otherwise = 
+			let aps = splitPath a'
+			    bps = splitPath b'
+			in if all isdotdot aps
+				then length (takeWhile isdotdot bps) < length aps
+				else False
 
 {- Given an original list of paths, and an expanded list derived from it,
  - which may be arbitrarily reordered, generates a list of lists, where

Utility/Path/Tests.hs

@@ -14,6 +14,7 @@ module Utility.Path.Tests (
 	prop_upFrom_basics,
 	prop_relPathDirToFileAbs_basics,
 	prop_relPathDirToFileAbs_regressionTest,
+	prop_dirContains_regressionTest,
 ) where
 
 import System.FilePath.ByteString
@@ -62,3 +63,18 @@ prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
 		relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
 			(joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
 				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+
+prop_dirContains_regressionTest :: Bool
+prop_dirContains_regressionTest = and
+	[ not $ dirContains "." ".."
+	, not $ dirContains ".." "../.."
+	, dirContains "." "foo"
+	, dirContains "." "."
+	, dirContains ".." ".."
+	, dirContains "../.." "../.."
+	, dirContains "." "./foo"
+	, dirContains ".." "../foo"
+	, dirContains "../.." "../foo"
+	, dirContains "../.." "../../foo"
+	, not $ dirContains "../.." "../../.."
+	]

doc/bugs/lookupkey_does_not_work_from_subdirectory.mdwn

@@ -19,3 +19,5 @@ git-annex lookupkey latex/lshort.pdf  # Succeeds
 8.20211011 on macOS 11.6
 
 [[!meta author=jwodder]]
+
+> [[fixed|done]] --[[Joey]]