Split host tests by component ownership

test/Nuthatch/Test/Path.hs

@@ -0,0 +1,79 @@
+module Nuthatch.Test.Path
+  ( tests
+  ) where
+
+import           Data.Either (isLeft)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Hedgehog
+  ( Gen
+  , Property
+  , assert
+  , forAll
+  , property
+  , (===)
+  )
+import qualified Hedgehog.Gen as Gen
+import           Nuthatch.Paths
+  ( buildObjectKey
+  , encodeUserId
+  , listCacheAncestorPrefixes
+  )
+import           Nuthatch.Test.PathFixture
+import           Nuthatch.Types
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.HUnit ((@?=), testCase)
+import           Test.Tasty.Hedgehog (testProperty)
+
+tests :: TestTree
+tests = testGroup "canonical paths"
+  [ testProperty "valid paths parse and render without rewriting" propPathRoundTrip
+  , testProperty "invalid paths are rejected" propInvalidPaths
+  , testProperty "constructed object keys remain under their root" propRootConfinement
+  , testCase "nested cache ancestors include every containing listing" $
+      listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
+        @?= ["", "docs", "docs/a"]
+  , testCase "root files invalidate the root listing" $
+      listCacheAncestorPrefixes (RelativePath "file.txt") @?= [""]
+  ]
+
+newtype InvalidPath = InvalidPath { getInvalidPath :: Text }
+  deriving stock (Show)
+
+genInvalidPath :: Gen InvalidPath
+genInvalidPath = do
+  ValidPath valid <- genValidPath
+  InvalidPath <$> Gen.element
+    [ ""
+    , "/" <> valid
+    , valid <> "/"
+    , valid <> "//tail"
+    , valid <> "/../tail"
+    , valid <> "/./tail"
+    , valid <> "/back\\slash"
+    , valid <> "/control\NUL"
+    , "e\x0301"
+    ]
+
+propPathRoundTrip :: Property
+propPathRoundTrip = property $ do
+  ValidPath raw <- forAll genValidPath
+  validateRelativePath raw === Right (RelativePath raw)
+
+propInvalidPaths :: Property
+propInvalidPaths = property $ do
+  InvalidPath raw <- forAll genInvalidPath
+  assert (isLeft (validateRelativePath raw))
+
+propRootConfinement :: Property
+propRootConfinement = property $ do
+  ValidPath raw <- forAll genValidPath
+  let path = RelativePath raw
+      uid = encodeUserId "https://issuer.example" "subject"
+      personalPrefix = "users/" <> unUserId uid <> "/"
+      personalKey = unObjectKey (buildObjectKey Personal uid path)
+      sharedKey = unObjectKey (buildObjectKey Shared uid path)
+  assert (personalPrefix `T.isPrefixOf` personalKey)
+  assert ("shared/" `T.isPrefixOf` sharedKey)
+  assert (not ("shared/" `T.isPrefixOf` personalKey))
+  assert (not ("users/" `T.isPrefixOf` sharedKey))