Add tests, rewrite PathMap

package.yaml

@@ -56,7 +56,6 @@ library:
   dependencies:
     - aeson
     - bytestring
-    - containers
     - filepath
     - http-media
     - http-types

src/Network/Wai/Middleware/OpenApi/PathMap.hs

@@ -6,34 +6,54 @@ module Network.Wai.Middleware.OpenApi.PathMap
 
 import Prelude hiding (lookup)
 
+import Control.Applicative ((<|>))
 import Control.Lens ((^?))
+import Control.Monad (guard)
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS8
-import Data.HashMap.Strict.InsOrd qualified as IHashMap
-import Data.Map.Strict (Map)
-import Data.Map.Strict qualified as Map
+import Data.Function (on)
+import Data.HashMap.Strict.InsOrd qualified as IOHM
+import Data.List (find)
+import Data.List.NonEmpty (nonEmpty)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe (fromMaybe)
 import Data.OpenApi (OpenApi, PathItem)
 import Data.OpenApi qualified as OpenApi
 import System.FilePath.Posix qualified as Posix
 
 newtype PathMap = PathMap
-  { unwrap :: Map TemplatedPath PathItem
+  { unwrap :: [(TemplatedPath, PathItem)]
   }
 
 fromOpenApi :: OpenApi -> PathMap
 fromOpenApi spec =
   PathMap $ case spec ^? OpenApi.paths of
-    Nothing -> Map.empty
-    Just ps -> Map.fromList $ map (first toTemplatedPath) $ IHashMap.toList ps
+    Nothing -> []
+    Just ps -> map (first toTemplatedPath) $ IOHM.toList ps
 
 lookup :: ByteString -> PathMap -> Maybe PathItem
-lookup p pm = Map.lookup (toTemplatedPath $ BS8.unpack p) pm.unwrap
+lookup bs pm =
+  fmap snd $ find (matchExact tp . fst) ps <|> find (matchTemplated tp . fst) ps
+ where
+  tp = toTemplatedPath $ BS8.unpack bs
+  ps = pm.unwrap
+
+matchExact :: TemplatedPath -> TemplatedPath -> Bool
+matchExact = matchComponents (==) `on` (.unwrap)
+
+matchTemplated :: TemplatedPath -> TemplatedPath -> Bool
+matchTemplated = matchComponents go `on` (.unwrap)
+ where
+  go = curry $ \case
+    (Exact l, Exact r) -> l == r
+    (ParameterValue, _) -> True
+    (_, ParameterValue) -> True
 
 newtype TemplatedPath = TemplatedPath
-  { _unwrap :: [TemplatedPathComponent]
+  { unwrap :: [TemplatedPathComponent]
   }
-  deriving stock (Eq, Ord)
+  deriving stock (Eq)
 
 toTemplatedPath :: FilePath -> TemplatedPath
 toTemplatedPath =
@@ -44,16 +64,20 @@ toTemplatedPath =
 data TemplatedPathComponent
   = Exact FilePath
   | ParameterValue
-
-instance Eq TemplatedPathComponent where
-  Exact l == Exact r = l == r
-  _ == _ = True
-
-instance Ord TemplatedPathComponent where
-  compare (Exact l) (Exact r) = compare l r
-  compare _ _ = EQ
+  deriving stock (Eq)
 
 toTemplatedPathComponent :: FilePath -> TemplatedPathComponent
-toTemplatedPathComponent s
-  | not (null s) && head s == '{' && last s == '}' = ParameterValue
-  | otherwise = Exact s
+toTemplatedPathComponent s = fromMaybe (Exact s) $ do
+  ne <- nonEmpty s
+  guard $ NE.head ne == '{'
+  guard $ NE.last ne == '}'
+  pure ParameterValue
+
+matchComponents
+  :: (TemplatedPathComponent -> TemplatedPathComponent -> Bool)
+  -> [TemplatedPathComponent]
+  -> [TemplatedPathComponent]
+  -> Bool
+matchComponents f as bs
+  | length as /= length bs = False
+  | otherwise = and $ zipWith f as bs

tests/Network/Wai/Middleware/OpenApi/PathMapSpec.hs

@@ -0,0 +1,91 @@
+module Network.Wai.Middleware.OpenApi.PathMapSpec
+  ( spec
+  ) where
+
+import Prelude
+
+import Control.Arrow ((&&&))
+import Control.Lens ((&), (.~), (?~))
+import Data.HashMap.Strict.InsOrd qualified as IOHM
+import Data.OpenApi (OpenApi, PathItem)
+import Data.OpenApi qualified as OpenApi
+import Data.Text (pack)
+import Network.Wai.Middleware.OpenApi.PathMap qualified as PathMap
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "lookup" $ do
+    specify "OpenApi precedence example" $ do
+      let pathMap =
+            PathMap.fromOpenApi $
+              testOpenApi
+                [ "/pets/{petId}"
+                , "/pets/mine"
+                ]
+
+      PathMap.lookup "/pets/42" pathMap
+        `shouldBe` Just (testPathItem "/pets/{petId}")
+
+      PathMap.lookup "/pets/mine" pathMap
+        `shouldBe` Just (testPathItem "/pets/mine")
+
+    specify "Chris' example" $ do
+      let pathMap =
+            PathMap.fromOpenApi $
+              testOpenApi
+                [ "/book/{bookId}/cover"
+                , "/book/{bookId}/text"
+                , "/{resource}/{resourceId}/text"
+                , "/{resource}/{resourceId}/ratings"
+                ]
+
+      PathMap.lookup "/book/5/text" pathMap
+        `shouldBe` Just (testPathItem "/book/{bookId}/text")
+
+      PathMap.lookup "/article/5/text" pathMap
+        `shouldBe` Just (testPathItem "/{resource}/{resourceId}/text")
+
+      -- Chris says s/b Nothing
+      -- Spec says s/b (4)
+      -- Naive implementation, apparently, agrees with spec
+      PathMap.lookup "/book/5/ratings" pathMap
+        `shouldBe` Just (testPathItem "/{resource}/{resourceId}/ratings")
+
+    -- These tests are to show what happens, but the spec says its ambiguous so
+    -- if we do something to the implementation that breaks these, that's OK.
+    context "ambiguous according to spec" $ do
+      specify "books" $ do
+        let pathMap =
+              PathMap.fromOpenApi $
+                testOpenApi
+                  [ "/{entity}/me"
+                  , "/books/{id}"
+                  ]
+
+        PathMap.lookup "/books/5" pathMap
+          `shouldBe` Just (testPathItem "/books/{id}")
+
+        PathMap.lookup "/books/me" pathMap
+          `shouldBe` Just (testPathItem "/{entity}/me")
+
+      specify "pet-stores" $ do
+        let pathMap =
+              PathMap.fromOpenApi $
+                testOpenApi
+                  [ "/pet-stores/{petStoreId}/pets/mine"
+                  , "/pet-stores/{petStoreId}/pets/{petId}"
+                  ]
+
+        PathMap.lookup "/pet-stores/5/pets/3" pathMap
+          `shouldBe` Just (testPathItem "/pet-stores/{petStoreId}/pets/{petId}")
+
+        PathMap.lookup "/pet-stores/5/pets/mine" pathMap
+          `shouldBe` Nothing
+          `shouldBe` Just (testPathItem "/pet-stores/{petStoreId}/pets/mine")
+
+testOpenApi :: [String] -> OpenApi
+testOpenApi ps = mempty & OpenApi.paths .~ IOHM.fromList (map (id &&& testPathItem) ps)
+
+testPathItem :: String -> PathItem
+testPathItem p = mempty & OpenApi.summary ?~ pack p

wai-middleware-openapi.cabal

@@ -49,7 +49,6 @@ library
       aeson
     , base <5
     , bytestring
-    , containers
     , filepath
     , http-media
     , http-types
@@ -69,6 +68,7 @@ test-suite spec
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Network.Wai.Middleware.OpenApi.PathMapSpec
       Network.Wai.Middleware.OpenApiSpec
       TestApp
       Paths_wai_middleware_openapi