Path fragments and OpenApi (#22)

* wip

* Things are now becoming fun

* Cleaned things up a bit

* Moved things around

* Added some comments

* Sorted imports

* Cleaned things up

* Switched to google formatting

* Fixed some of the comments

* updated gitignore

* Use list comprehension

* Removed catTrace

* Fixed yet more comments

.gitignore

@@ -1,2 +1,3 @@
 .stack-work
 TAGS
+.vscode

openapi-diff.cabal

@@ -31,22 +31,24 @@ common common-options
   default-language:    Haskell2010
   build-depends:       base >= 4.12.0.0 && < 4.15
                      , aeson
-                     , deriving-aeson
+                     , attoparsec
                      , containers
+                     , deriving-aeson
+                     , generic-data
                      , generic-monoid
                      , insert-ordered-containers
                      , lens
                      , mtl
                      , openapi3
+                     , optparse-applicative
+                     , tagged
                      , text
                      , transformers
-                     , yaml
-                     , attoparsec
-                     , optparse-applicative
                      , typerep-map
-                     , tagged
+                     , yaml
 
-  default-extensions: BangPatterns
+  default-extensions: ApplicativeDo
+                    , BangPatterns
                     , ConstraintKinds
                     , DataKinds
                     , DeriveAnyClass
@@ -57,6 +59,7 @@ common common-options
                     , DerivingStrategies
                     , DerivingVia
                     , DuplicateRecordFields
+                    , EmptyDataDeriving
                     , FlexibleContexts
                     , FlexibleInstances
                     , FunctionalDependencies
@@ -86,8 +89,12 @@ library
   import:              common-options
   hs-source-dirs:      src
   exposed-modules:  OpenAPI.Checker.Aux
+                  , Data.HList
                   , OpenAPI.Checker.Formula
                   , OpenAPI.Checker.Memo
+                  , OpenAPI.Checker.Options
+                  , OpenAPI.Checker.Orphans
+                  , OpenAPI.Checker.References
                   , OpenAPI.Checker.Report
                   , OpenAPI.Checker.Run
                   , OpenAPI.Checker.Subtree
@@ -96,8 +103,10 @@ library
                   , OpenAPI.Checker.Validate
                   , OpenAPI.Checker.Validate.Dereference
                   , OpenAPI.Checker.Validate.Monad
-                  , OpenAPI.Checker.Options
-                  , Data.HList
+                  , OpenAPI.Checker.Validate.OpenApi
+                  , OpenAPI.Checker.Validate.Operation
+                  , OpenAPI.Checker.Validate.Param
+                  , OpenAPI.Checker.Validate.PathFragment
 
 executable openapi-diff
   import:              common-options

src/Data/HList.hs

@@ -1,8 +1,9 @@
 module Data.HList
-  ( Has,
-    HasAll,
-    getH,
-    HList (..),
+  ( Has
+  , HasAll
+  , getH
+  , HList (..)
+  , singletonH
   )
 where
 
@@ -33,7 +34,10 @@ instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False wh
   getH (HCons _ xs) = getH xs
 
 instance
-  TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>
-  Has' x '[] 'False
+  TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")
+  => Has' x '[] 'False
   where
   getH HNil = undefined
+
+singletonH :: a -> HList '[a]
+singletonH a = a `HCons` HNil

src/OpenAPI/Checker/Formula.hs

@@ -42,7 +42,7 @@ mkApply f x h = Apply f x h
 mkSelectFirst :: [SomeFormulaF b] -> AnItem f r -> (b -> a) -> FormulaF f r a
 mkSelectFirst fs allE h = case foldMap check fs of
   (First (Just x), _) -> Result (h x)
-  (First Nothing, (x:xs)) -> SelectFirst (x NE.:| xs) allE h
+  (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h
   (First Nothing, []) -> Errors $ T.singleton allE
   where
     check (SomeFormulaF (Result x)) = (First (Just x), mempty)

src/OpenAPI/Checker/Orphans.hs

@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Orphans (Step (..)) where
+
+import Data.OpenApi
+import Data.Typeable
+import OpenAPI.Checker.Trace
+
+deriving newtype instance Ord Reference
+
+instance Typeable a => Steppable (Referenced a) a where
+  data Step (Referenced a) a
+    = InlineStep
+    | ReferencedStep Reference
+    deriving (Eq, Ord)

src/OpenAPI/Checker/References.hs

@@ -0,0 +1,24 @@
+module OpenAPI.Checker.References
+  ( TracedReferences
+  , dereferenceTraced
+  )
+where
+
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.Map (Map)
+import Data.Maybe
+import Data.OpenApi
+import Data.Typeable
+import OpenAPI.Checker.Orphans
+import OpenAPI.Checker.Trace
+
+type TracedReferences root a = Map Reference (Traced root a)
+
+dereferenceTraced
+  :: Typeable a
+  => Definitions a
+  -> Referenced a
+  -> Traced (Referenced a) a
+dereferenceTraced _ (Inline a) = Traced (step InlineStep) a
+dereferenceTraced defs (Ref r@(Reference ref)) =
+  Traced (step $ ReferencedStep r) (fromJust $ IOHM.lookup ref defs)

src/OpenAPI/Checker/Subtree.hs

@@ -1,16 +1,19 @@
 module OpenAPI.Checker.Subtree
-  ( APIStep(..)
-  , Subtree(..)
-  , CompatM(..)
+  ( APIStep (..)
+  , Subtree (..)
+  , CompatM (..)
   , CompatFormula
+  , ProdCons (..)
   , runCompatFormula
   , localM
-  , local'
+  , localTrace
   , anyOfM
+  , anyOfAt
   , issueAtTrace
   , issueAt
   , memo
-  ) where
+  )
+where
 
 import Control.Monad.Identity
 import Control.Monad.Reader
@@ -26,57 +29,67 @@ import OpenAPI.Checker.Memo
 import OpenAPI.Checker.Trace
 import qualified OpenAPI.Checker.TracePrefixTree as T
 
-class (Subtree a, Subtree b, Steppable a b)
-  => APIStep (a :: Type) (b :: Type) where
+class
+  (Subtree a, Subtree b, Steppable a b) =>
+  APIStep (a :: Type) (b :: Type)
+  where
   describeStep :: Step a b -> Text
 
 data ProdCons a = ProdCons
   { producer :: a
   , consumer :: a
-  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+  }
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
 
 instance Applicative ProdCons where
   pure x = ProdCons x x
   ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
 
 newtype CompatM t a = CompatM
-  { unCompatM ::
-    ReaderT (ProdCons (Trace OpenApi t))
-      (StateT (MemoState VarRef) Identity) a
-  } deriving newtype
-    ( Functor, Applicative, Monad
+  { unCompatM
+    :: ReaderT
+           (ProdCons (Trace OpenApi t))
+           (StateT (MemoState VarRef) Identity)
+           a
+  }
+  deriving newtype
+    ( Functor
+    , Applicative
+    , Monad
     , MonadReader (ProdCons (Trace OpenApi t))
     , MonadState (MemoState VarRef)
     )
 
 type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
 
-class (Typeable t, Ord t, Ord (CheckIssue t)) => Subtree (t :: Type) where
-  type family CheckEnv t :: [Type]
-  data family CheckIssue t :: Type
+class (Typeable t, Ord (CheckIssue t)) => Subtree (t :: Type) where
+  type CheckEnv t :: [Type]
+  data CheckIssue t :: Type
+
   -- | If we ever followed a reference, reroute the path through "components"
   normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
+
   checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
 
 runCompatFormula
   :: ProdCons (Trace OpenApi t)
   -> Compose (CompatM t) (FormulaF f r) a
   -> Either (T.TracePrefixTree f r) a
-runCompatFormula env (Compose f)
-  = calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
+runCompatFormula env (Compose f) =
+  calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
 
 localM
   :: ProdCons (Trace a b)
   -> CompatM b x
   -> CompatM a x
-localM xs (CompatM k) = 
-  CompatM $ ReaderT $ \env -> runReaderT k (catTrace <$> env <*> xs)
+localM xs (CompatM k) =
+  CompatM $ ReaderT $ \env -> runReaderT k ((>>>) <$> env <*> xs)
 
-local'
+localTrace
   :: ProdCons (Trace a b)
   -> Compose (CompatM b) (FormulaF f r) x
   -> Compose (CompatM a) (FormulaF f r) x
-local' xs (Compose h) = Compose (localM xs h)
+localTrace xs (Compose h) = Compose (localM xs h)
 
 issueAtTrace
   :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
@@ -93,20 +106,32 @@ issueAt f issue = Compose $ do
 
 anyOfM
   :: Ord (f t)
-  => Trace r t -> f t
+  => Trace r t
+  -> f t
   -> [Compose (CompatM t) (FormulaF f r) a]
   -> Compose (CompatM t) (FormulaF f r) a
-anyOfM xs issue fs
-  = Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
+anyOfM xs issue fs =
+  Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
+
+anyOfAt
+  :: Subtree t
+  => (forall x. ProdCons x -> x)
+  -> CheckIssue t
+  -> [CompatFormula t a]
+  -> CompatFormula t a
+anyOfAt f issue fs = Compose $ do
+  xs <- asks f
+  (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
 
 fixpointKnot
   :: MonadState (MemoState VarRef) m
   => KnotTier (FormulaF f r ()) VarRef m
-fixpointKnot = KnotTier
-  { onKnotFound = modifyMemoNonce succ
-  , onKnotUsed = \i -> pure $ variable i
-  , tieKnot = \i x -> pure $ maxFixpoint i x
-  }
+fixpointKnot =
+  KnotTier
+    { onKnotFound = modifyMemoNonce succ
+    , onKnotUsed = \i -> pure $ variable i
+    , tieKnot = \i x -> pure $ maxFixpoint i x
+    }
 
 memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
 memo (Compose f) = Compose $ do

src/OpenAPI/Checker/Trace.hs

@@ -1,26 +1,38 @@
 -- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a
 -- collection of datatypes that "contain" eachother in some form of tree
 -- structure.
-
 module OpenAPI.Checker.Trace
-  ( Steppable(..)
-  , Trace(..)
-  , catTrace
-  , DiffTrace(..)
+  ( Steppable (..)
+  , Trace (..)
+  , DiffTrace (..)
   , catDiffTrace
   , _DiffTrace
-  , AnItem(..)
-  ) where
+  , AnItem (..)
+  , step
+  , Traced (..)
+  , mapTraced
+  , retrace
+  , deTraced
 
+    -- * Reexports
+  , (>>>)
+  , (<<<)
+  )
+where
+
+import Control.Category
 import Control.Lens
 import Data.Kind
 import Data.Type.Equality
 import Type.Reflection
+import Prelude hiding ((.))
 
-class (Typeable a, Typeable b, Ord (Step a b))
-  => Steppable (a :: k) (b :: k) where
+class
+  (Typeable a, Typeable b, Ord (Step a b)) =>
+  Steppable (a :: k) (b :: k)
+  where
   -- | How to get from an @a@ node to a @b@ node
-  data family Step (a :: k) (b :: k) :: Type
+  data Step (a :: k) (b :: k) :: Type
 
 -- | How to get from an @a@ node to a @b@ node in possibly multiple steps. Like
 -- a list, but indexed. The list is in reverse because in practice we append
@@ -28,8 +40,17 @@ class (Typeable a, Typeable b, Ord (Step a b))
 data Trace (a :: k) (b :: k) where
   Root :: Trace a a
   Snoc :: Steppable b c => Trace a b -> !(Step b c) -> Trace a c
+
 infixl 5 `Snoc`
 
+step :: Steppable a b => Step a b -> Trace a b
+step s = Root `Snoc` s
+
+instance Category Trace where
+  id = Root
+  Root . xs = xs
+  (Snoc ys y) . xs = Snoc (ys . xs) y
+
 typeRepRHS :: Typeable b => Trace a b -> TypeRep b
 typeRepRHS _ = typeRep
 
@@ -46,24 +67,19 @@ instance TestEquality (Trace a) where
 instance Eq (Trace a b) where
   Root == Root = True
   Snoc xs x == Snoc ys y
-    | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys)
-    = xs == ys && x == y
+    | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys) =
+      xs == ys && x == y
   _ == _ = False
 
 instance Ord (Trace a b) where
   compare Root Root = EQ
   compare Root (Snoc _ _) = LT
   compare (Snoc _ _) Root = GT
-  compare (Snoc xs x) (Snoc ys y)
-    = case testEquality (typeRepRHS xs) (typeRepRHS ys) of
+  compare (Snoc xs x) (Snoc ys y) =
+    case testEquality (typeRepRHS xs) (typeRepRHS ys) of
       Just Refl -> compare xs ys <> compare x y
       Nothing -> compare (someTypeRep xs) (someTypeRep ys)
 
-catTrace :: Trace a b -> Trace b c -> Trace a c
-catTrace xs Root = xs
-catTrace xs (Snoc ys y) = Snoc (catTrace xs ys) y
-infixl 5 `catTrace`
-
 -- | Like a differece list, but indexed.
 newtype DiffTrace (a :: k) (b :: k)
   = DiffTrace (forall c. Trace c a -> Trace c b)
@@ -72,30 +88,42 @@ catDiffTrace :: DiffTrace a b -> DiffTrace b c -> DiffTrace a c
 catDiffTrace (DiffTrace f) (DiffTrace g) = DiffTrace (g . f)
 
 _DiffTrace :: Iso (DiffTrace a b) (DiffTrace c d) (Trace a b) (Trace c d)
-_DiffTrace = dimap (\(DiffTrace f) -> f Root)
-  $ fmap $ \xs -> DiffTrace (`catTrace` xs)
+_DiffTrace = dimap (\(DiffTrace f) -> f Root) $
+  fmap $ \xs -> DiffTrace (>>> xs)
 
 -- | An item related to some path relative to the root @r@.
 data AnItem (f :: k -> Type) (r :: k) where
   AnItem :: Ord (f a) => Trace r a -> !(f a) -> AnItem f r
-  -- the Ord is yuck but we need it and it should be fine in monomorphic cases
+
+-- the Ord is yuck but we need it and it should be fine in monomorphic cases
 
 instance Eq (AnItem f r) where
   AnItem xs fx == AnItem ys fy
-    | Just Refl <- testEquality xs ys
-    = xs == ys && fx == fy
+    | Just Refl <- testEquality xs ys =
+      xs == ys && fx == fy
   _ == _ = False
 
 instance Typeable r => Ord (AnItem f r) where
-  compare (AnItem xs fx) (AnItem ys fy)
-    = case testEquality xs ys of
+  compare (AnItem xs fx) (AnItem ys fy) =
+    case testEquality xs ys of
       Just Refl -> compare xs ys <> compare fx fy
       Nothing -> case xs of
-        Root     -> case ys of
-          Root     -> compare (someTypeRep xs) (someTypeRep ys)
+        Root -> case ys of
+          Root -> compare (someTypeRep xs) (someTypeRep ys)
           Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
         Snoc _ _ -> case ys of
-          Root     -> compare (someTypeRep xs) (someTypeRep ys)
+          Root -> compare (someTypeRep xs) (someTypeRep ys)
           Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
 
+data Traced r a = Traced {getTrace :: Trace r a, getTraced :: a}
+
+mapTraced :: (Trace r a -> Trace r b) -> (a -> b) -> Traced r a -> Traced r b
+mapTraced f g (Traced t a) = Traced (f t) (g a)
+
+retrace :: (Trace r a -> Trace r' a) -> Traced r a -> Traced r' a
+retrace f (Traced t a) = Traced (f t) a
+
+deTraced :: Traced r a -> (Trace r a, a)
+deTraced (Traced a b) = (a, b)
+
 -- type APath = AnItem Proxy

src/OpenAPI/Checker/Validate/OpenApi.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.OpenApi
+  (
+  )
+where
+
+import Data.Foldable
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.Maybe
+import Data.OpenApi
+import Generic.Data
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Validate.Operation
+import OpenAPI.Checker.Validate.PathFragment
+
+instance Subtree OpenApi where
+  type CheckEnv OpenApi = '[]
+  data CheckIssue OpenApi = NoPathsMatched | WrongNumberOfFragments
+    deriving (Eq, Ord)
+  normalizeTrace = undefined
+  checkCompatibility _ prodCons = do
+    let ProdCons {producer = p, consumer = c} = processOpenApi <$> prodCons
+    sequenceA_
+      [ anyOfAt
+        producer
+        NoPathsMatched
+        [ localTrace (step <$> ProdCons pSPath cSPath) $ do
+          -- make sure every path fragment is compatible
+          sequenceA_
+            [ localTrace (pure . step $ PathFragmentStep i) $
+              checkCompatibility (singletonH $ ProdCons pPathFragmentParams cPathFragmentParams) pair
+            | (i, pair) <- zip [0 ..] pathFragments
+            ]
+          -- make sure the operation is compatible.
+          localTrace (pure . step $ getter stepProcessedPathItem) $
+            checkCompatibility HNil $ ProdCons pOperation cOperation
+          pure ()
+        | (cSPath, cPath, cPathItem) <- c
+        , -- ... and try to match it with every endpoint in the consumer.
+        --
+        -- This is required because the meaning of path fragments can change on
+        -- a per-method basis even within the same 'PathItem'
+        --
+        -- Here we only need to look for the method that the current producer
+        -- endpoint is using.
+        (cParams, cOperation) <- maybeToList $ getter cPathItem
+        , let cPathFragmentParams = retrace (step PathFragmentParentStep >>>) <$> cParams
+        , -- make sure the paths are the same length
+        pathFragments <- maybeToList $ zipAllWith ProdCons pPath cPath
+        ]
+      | (pSPath, pPath, pPathItem) <- p
+      , -- look at every endpoint in the producer ...
+      (ProcessedPathItemGetter getter, (pParams, pOperation)) <-
+        toList (fmap . (,) <$> processedPathItemGetters <*> pPathItem) >>= maybeToList
+      , let pPathFragmentParams = retrace (step PathFragmentParentStep >>>) <$> pParams
+      ]
+
+zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
+zipAllWith _ [] [] = Just []
+zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
+zipAllWith _ (_ : _) [] = Nothing
+zipAllWith _ [] (_ : _) = Nothing
+
+processOpenApi
+  :: OpenApi
+  -> [ ( Step OpenApi PathItem
+       , [PathFragment]
+       , ForeachOperation (Maybe (TracedReferences PathItem Param, Operation))
+       )
+     ]
+processOpenApi o = do
+  let cs = _openApiComponents o
+  (pathS, pathItem) <- IOHM.toList . _openApiPaths $ o
+  let path = parsePath pathS
+      componentParams = _componentsParameters cs
+      commonPathParams =
+        retrace (step PathItemParametersStep >>>)
+          <$> getPathParamRefs componentParams (_pathItemParameters pathItem)
+      processOperation (s :: Step PathItem Operation) op =
+        let operationParams =
+              retrace (Root `Snoc` s `Snoc` OperationParametersStep >>>)
+                <$> getPathParamRefs componentParams (_operationParameters op)
+            pathParams =
+              operationParams <> commonPathParams
+         in (pathParams, op)
+  pure
+    ( PathStep pathS
+    , path
+    , fmap . processOperation
+        <$> stepProcessedPathItem
+        <*> ForeachOperation
+          { processedPathItemGet = _pathItemGet pathItem
+          , processedPathItemPut = _pathItemPut pathItem
+          , processedPathItemPost = _pathItemPost pathItem
+          , processedPathItemDelete = _pathItemDelete pathItem
+          , processedPathItemOptions = _pathItemOptions pathItem
+          , processedPathItemHead = _pathItemHead pathItem
+          , processedPathItemPatch = _pathItemPatch pathItem
+          , processedPathItemTrace = _pathItemTrace pathItem
+          }
+    )
+
+instance Steppable OpenApi PathItem where
+  data Step OpenApi PathItem = PathStep FilePath
+    deriving (Eq, Ord)
+
+instance Steppable PathItem PathFragment where
+  data Step PathItem PathFragment
+    = -- | The index of the path item
+      PathFragmentStep Int
+    deriving (Eq, Ord)
+
+instance Steppable PathFragment PathItem where
+  data Step PathFragment PathItem = PathFragmentParentStep
+    deriving (Eq, Ord)
+
+instance Steppable PathItem (Referenced Param) where
+  data Step PathItem (Referenced Param) = PathItemParametersStep
+    deriving (Eq, Ord)
+
+instance Steppable Operation (Referenced Param) where
+  data Step Operation (Referenced Param) = OperationParametersStep
+    deriving (Eq, Ord)
+
+data ForeachOperation a = ForeachOperation
+  { processedPathItemGet :: a
+  , processedPathItemPut :: a
+  , processedPathItemPost :: a
+  , processedPathItemDelete :: a
+  , processedPathItemOptions :: a
+  , processedPathItemHead :: a
+  , processedPathItemPatch :: a
+  , processedPathItemTrace :: a
+  }
+  deriving stock (Functor, Generic1)
+  deriving (Applicative, Foldable) via Generically1 ForeachOperation
+
+newtype ProcessedPathItemGetter = ProcessedPathItemGetter (forall a. ForeachOperation a -> a)
+
+processedPathItemGetters :: ForeachOperation ProcessedPathItemGetter
+processedPathItemGetters =
+  ForeachOperation
+    { processedPathItemGet = ProcessedPathItemGetter processedPathItemGet
+    , processedPathItemPut = ProcessedPathItemGetter processedPathItemPut
+    , processedPathItemPost = ProcessedPathItemGetter processedPathItemPost
+    , processedPathItemDelete = ProcessedPathItemGetter processedPathItemDelete
+    , processedPathItemOptions = ProcessedPathItemGetter processedPathItemOptions
+    , processedPathItemHead = ProcessedPathItemGetter processedPathItemHead
+    , processedPathItemPatch = ProcessedPathItemGetter processedPathItemPatch
+    , processedPathItemTrace = ProcessedPathItemGetter processedPathItemTrace
+    }
+
+stepProcessedPathItem :: ForeachOperation (Step PathItem Operation)
+stepProcessedPathItem =
+  ForeachOperation
+    { processedPathItemGet = GetStep
+    , processedPathItemPut = PutStep
+    , processedPathItemPost = PostStep
+    , processedPathItemDelete = DeleteStep
+    , processedPathItemOptions = OptionsStep
+    , processedPathItemHead = HeadStep
+    , processedPathItemPatch = PatchStep
+    , processedPathItemTrace = TraceStep
+    }

src/OpenAPI/Checker/Validate/Operation.hs

@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Operation (Step (..)) where
+
+import Data.OpenApi
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
+
+instance Subtree Operation where
+  type CheckEnv Operation = '[]
+  data CheckIssue Operation
+    deriving (Eq, Ord)
+  normalizeTrace = undefined
+  checkCompatibility = undefined
+
+instance Steppable PathItem Operation where
+  data Step PathItem Operation
+    = GetStep
+    | PutStep
+    | PostStep
+    | DeleteStep
+    | OptionsStep
+    | HeadStep
+    | PatchStep
+    | TraceStep
+    deriving (Eq, Ord)

src/OpenAPI/Checker/Validate/Param.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Param () where
+
+import Data.OpenApi
+import OpenAPI.Checker.Subtree
+
+instance Subtree Param where
+  type CheckEnv Param = '[]
+  data CheckIssue Param
+    deriving (Eq, Ord)
+  normalizeTrace = undefined
+  checkCompatibility = undefined

src/OpenAPI/Checker/Validate/PathFragment.hs

@@ -0,0 +1,103 @@
+module OpenAPI.Checker.Validate.PathFragment
+  ( PathParamRefs
+  , TracedReferences
+  , getPathParamRefs
+  , parsePath
+  , PathFragment (..)
+  )
+where
+
+import Control.Lens
+import Control.Monad.Reader
+import qualified Data.Aeson as A
+import Data.HList
+import qualified Data.List.NonEmpty as NE
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.OpenApi
+import Data.Text (Text)
+import qualified Data.Text as T
+import OpenAPI.Checker.References
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Validate.Param ()
+
+getPathParamRefs
+  :: Definitions Param
+  -> [Referenced Param]
+  -> Map Reference (Traced (Referenced Param) Param)
+getPathParamRefs defs xs =
+  M.fromList $ do
+    x <- xs
+    let (Traced t param) = dereferenceTraced defs x
+    guard (_paramIn param == ParamPath)
+    return (Reference $ _paramName param, Traced t param)
+
+-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
+-- https://github.com/typeable/openapi-diff/issues/23
+parsePath :: FilePath -> [PathFragment]
+parsePath = fmap partition . T.splitOn "/" . T.pack
+  where
+    partition :: Text -> PathFragment
+    partition t
+      | Just ('{', rest) <- T.uncons t
+        , Just (ref, '}') <- T.unsnoc rest =
+        DynamicPath $ Reference ref
+    partition t = StaticPath t
+
+data PathFragment
+  = StaticPath Text
+  | DynamicPath Reference
+  deriving stock (Eq, Ord)
+
+instance Steppable PathFragment Param where
+  data Step PathFragment Param = StaticPathParam
+    deriving (Eq, Ord)
+
+type PathParamRefs = TracedReferences PathFragment Param
+
+instance Subtree PathFragment where
+  type CheckEnv PathFragment = '[ProdCons PathParamRefs]
+  data CheckIssue PathFragment = PathFragmentsDontMatch Text Text
+    deriving (Eq, Ord)
+
+  normalizeTrace = undefined
+
+  -- This case isn't strictly needed. It is here for optimization.
+  checkCompatibility _ ProdCons {producer = (StaticPath x), consumer = (StaticPath y)} =
+    if x == y
+      then pure ()
+      else issueAt consumer (PathFragmentsDontMatch x y)
+  checkCompatibility env prodCons = do
+    let (t, param) =
+          fsplit . fmap deTraced $
+            dePathFragment
+              <$> (singletonH <$> getH @(ProdCons PathParamRefs) env)
+              <*> prodCons
+    localTrace t $ checkCompatibility env param
+
+-- | A clearer name for 'NE.unzip' that can be used without qualifying it.
+fsplit :: Functor f => f (a, b) -> (f a, f b)
+fsplit = NE.unzip
+
+dePathFragment :: Has PathParamRefs xs => HList xs -> PathFragment -> Traced PathFragment Param
+dePathFragment (getH @PathParamRefs -> params) = \case
+  (StaticPath s) ->
+    Traced (step StaticPathParam) $
+      mempty
+        { _paramRequired = Just True
+        , _paramIn = ParamPath
+        , _paramAllowEmptyValue = Just False
+        , _paramAllowReserved = Just False
+        , _paramSchema = Just $ Inline $ staticStringSchema s
+        }
+  (DynamicPath ref) -> M.lookup ref params & fromMaybe (error $ show ref <> " not found.")
+
+staticStringSchema :: Text -> Schema
+staticStringSchema t =
+  mempty
+    { _schemaNullable = Just False
+    , _schemaType = Just OpenApiString
+    , _schemaEnum = Just [A.String t]
+    }