Added server checking (#42)

* Added server checking

* Updated test

* Made things work after rebase

.hlint.yaml

@@ -0,0 +1 @@
+- ignore: { name: Redundant pure }

src/OpenAPI/Checker/Subtree.hs

@@ -5,6 +5,7 @@ module OpenAPI.Checker.Subtree
   , CompatFormula'
   , CompatFormula
   , ProdCons (..)
+  , anyOfSubtreeAt
   , HasUnsupportedFeature (..)
   , swapProdCons
   , SubtreeCheckIssue (..)
@@ -13,6 +14,7 @@ module OpenAPI.Checker.Subtree
   , anyOfAt
   , issueAtTrace
   , issueAt
+  , tracedIssue
   , memo
   )
 where
@@ -64,6 +66,7 @@ newtype CompatM a = CompatM
     )
 
 type CompatFormula' f r = Compose CompatM (FormulaF f r)
+
 type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi
 
 class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
@@ -144,6 +147,12 @@ issueAt
   -> CompatFormula' SubtreeCheckIssue r a
 issueAt x = issueAtTrace (ask x)
 
+tracedIssue
+  :: (Subtree t, ComonadEnv (Trace r t) w)
+  => w (CheckIssue t)
+  -> CompatFormula' SubtreeCheckIssue r a
+tracedIssue x = issueAtTrace (ask x) (extract x)
+
 anyOfM
   :: Subtree t
   => Trace r t
@@ -161,6 +170,15 @@ anyOfAt
   -> CompatFormula' SubtreeCheckIssue r a
 anyOfAt x = anyOfM (ask x)
 
+anyOfSubtreeAt
+  :: (Subtree t, ComonadEnv (Trace r t) w)
+  => w x
+  -> CheckIssue t
+  -> [CompatFormula' SubtreeCheckIssue r a]
+  -> CompatFormula' SubtreeCheckIssue r a
+anyOfSubtreeAt _ _ [x] = x
+anyOfSubtreeAt f i fs = anyOfAt f i fs
+
 fixpointKnot
   :: MonadState (MemoState VarRef) m
   => KnotTier (FormulaF f r ()) VarRef m
@@ -175,5 +193,5 @@ memo
   :: (Typeable r, Subtree t)
   => (ProdCons (Traced r t) -> CompatFormula ())
   -> (ProdCons (Traced r t) -> CompatFormula ())
-memo f pc  = Compose $ do
+memo f pc = Compose $ do
   memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Trace.hs

@@ -10,6 +10,7 @@ module OpenAPI.Checker.Trace
   , AnItem (..)
   , step
   , Traced
+  , Traced'
   , traced
 
     -- * Reexports
@@ -120,7 +121,9 @@ instance Typeable r => Ord (AnItem f r) where
           Root -> compare (someTypeRep xs) (someTypeRep ys)
           Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
 
-type Traced r a = Env (Trace r a) a
+type Traced r a = Traced' r a a
 
-traced :: Trace r a -> a -> Traced r a
+type Traced' r a b = Env (Trace r a) b
+
+traced :: Trace r a -> b -> Traced' r a b
 traced = env

src/OpenAPI/Checker/Validate/OpenApi.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- Not compiles without
+-- Does not compiles otherwise
+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
 
 module OpenAPI.Checker.Validate.OpenApi
   (
@@ -30,6 +31,7 @@ instance Subtree OpenApi where
          `HCons` (_componentsResponses <$> cs)
          `HCons` (_componentsHeaders <$> cs)
          `HCons` (_componentsSchemas <$> cs)
+         `HCons` (_openApiServers . extract <$> prodCons)
          `HCons` HNil)
       (tracedPaths <$> prodCons)
 

src/OpenAPI/Checker/Validate/Operation.hs

@@ -25,6 +25,7 @@ import OpenAPI.Checker.Validate.PathFragment
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.RequestBody
 import OpenAPI.Checker.Validate.Responses ()
+import OpenAPI.Checker.Validate.Server ()
 
 data MatchedOperation = MatchedOperation
   { operation :: !Operation
@@ -59,11 +60,16 @@ tracedSecurity oper =
   | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
   ]
 
-tracedServers :: Traced r MatchedOperation -> [Traced r Server]
-tracedServers oper =
-  [ traced (ask oper >>> step (OperationServerStep i)) x
-  | (i, x) <- zip [0..] $ _operationServers . operation $ extract oper
-  ]
+-- FIXME: https://github.com/typeable/openapi-diff/issues/28
+tracedServers
+  :: [Server] -- ^ Servers from env
+  -> Traced r MatchedOperation
+  -> Traced r [Server]
+tracedServers env oper =
+  traced (ask oper >>> step OperationServersStep) $
+    case _operationServers . operation $ extract oper of
+      [] -> env
+      ss -> ss
 
 instance Subtree MatchedOperation where
   type CheckEnv MatchedOperation =
@@ -73,6 +79,7 @@ instance Subtree MatchedOperation where
      , ProdCons (Definitions Response)
      , ProdCons (Definitions Header)
      , ProdCons (Definitions Schema)
+     , ProdCons [Server]
      ]
   data CheckIssue MatchedOperation
     = OperationMissing OperationMethod
@@ -165,9 +172,13 @@ instance Subtree MatchedOperation where
             $ HCons (swapProdCons schemaDefs) HNil
           resps = tracedResponses <$> prodCons
         checkCompatibility respEnv $ swapProdCons resps
+      -- FIXME: https://github.com/typeable/openapi-diff/issues/27
       checkCallbacks = pure () -- (error "FIXME: not implemented")
+      -- FIXME: https://github.com/typeable/openapi-diff/issues/28
       checkOperationSecurity = pure () -- (error "FIXME: not implemented")
-      checkServers = pure () -- (error "FIXME: not implemented")
+      checkServers =
+        checkCompatibility env $
+          tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
       bodyDefs = getH @(ProdCons (Definitions RequestBody)) env
       respDefs = getH @(ProdCons (Definitions Response)) env
       headerDefs =  getH @(ProdCons (Definitions Header)) env
@@ -212,6 +223,8 @@ instance Steppable MatchedOperation SecurityRequirement where
   data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
     deriving (Eq, Ord, Show)
 
-instance Steppable MatchedOperation Server where
-  data Step MatchedOperation Server = OperationServerStep Int
+instance Steppable MatchedOperation [Server] where
+  data Step MatchedOperation [Server] 
+    = OperationServersStep 
+    | EnvServerStep
     deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs

@@ -47,6 +47,7 @@ instance Subtree ProcessedPathItems where
        , ProdCons (Definitions Response)
        , ProdCons (Definitions Header)
        , ProdCons (Definitions Schema)
+       , ProdCons [Server]
        ]
   data CheckIssue ProcessedPathItems
     = NoPathsMatched FilePath
@@ -132,6 +133,7 @@ instance Subtree MatchedPathItem where
      , ProdCons (Definitions Response)
      , ProdCons (Definitions Header)
      , ProdCons (Definitions Schema)
+     , ProdCons [Server]
      ]
   data CheckIssue MatchedPathItem
     deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Server.hs

@@ -1,15 +1,129 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.Server
-  ( CheckIssue(..)
-  ) where
+  ( CheckIssue (..)
+  )
+where
 
+import Control.Applicative
+import Control.Comonad
+import Control.Monad
+import Data.Attoparsec.Text
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.Functor
+import Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.HashSet.InsOrd as IOHS
+import Data.Maybe
 import Data.OpenApi
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Traversable
 import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
+import Prelude as P
 
-instance Subtree Server where
-  type CheckEnv Server = '[]
-  data CheckIssue Server
-    = ServerNotConsumed
+tracedParsedServerUrlParts
+  :: Traced' r [Server] Server
+  -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)
+tracedParsedServerUrlParts s =
+  let rawURL = _serverUrl $ extract s
+      parsedUrl = parseServerUrl rawURL
+      serverVariables = _serverVariables $ extract s
+   in traced (ask s >>> step (ServerStep rawURL)) $
+        parsedUrl
+          & (traverse . traverse)
+            (\var -> case IOHM.lookup var serverVariables of
+               Nothing -> Left VariableNotDefined
+               Just x -> Right x)
+
+instance Subtree [Server] where
+  type CheckEnv [Server] = '[]
+  data CheckIssue [Server]
     deriving (Eq, Ord, Show)
-  checkCompatibility = undefined
+  checkCompatibility env pcServer = do
+    let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
+          pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence
+        bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b)
+        bicosequence x = case extract x of
+          Left e -> Left $ x $> e
+          Right a -> Right $ x $> a
+        throwAllErrors = traverse_ tracedIssue
+    throwAllErrors pErrs
+    throwAllErrors cErrs
+    for_ pUrls $ \cUrl -> do
+      let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls
+      anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)
+    pure ()
+
+type ProcessedServer = [ServerUrlPart ServerVariable]
+
+-- | Nothing means "open variable" – can have any value
+unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
+unifyPart (ServerUrlVariable v) = _serverVariableEnum v
+unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
+
+zipAll :: [a] -> [b] -> Maybe [(a, b)]
+zipAll [] [] = Just []
+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
+zipAll (_ : _) [] = Nothing
+zipAll [] (_ : _) = Nothing
+
+staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
+staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
+staticCompatiblePart _ _ = True
+
+staticCompatible :: [ServerUrlPart x] -> [ServerUrlPart x] -> Bool
+staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll a b
+
+data ServerUrlPart var
+  = ServerUrlVariable var
+  | ServerUrlConstant Text
+  deriving stock (Show, Functor, Foldable, Traversable)
+
+-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
+-- FIXME: https://github.com/typeable/openapi-diff/issues/46
+--
+-- NOTE: syntax is defined vaguely in the spec.
+parseServerUrl :: Text -> [ServerUrlPart Text]
+-- There really is no way it can fail
+parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput)
+  where
+    serverUrlParser :: Parser [ServerUrlPart Text]
+    serverUrlParser = many $ do
+      variableUrlParser <|> do
+        a <- anyChar
+        aa <- takeTill (== '{')
+        return (ServerUrlConstant $ T.cons a aa)
+
+    variableUrlParser :: Parser (ServerUrlPart Text)
+    variableUrlParser = do
+      char '{'
+      res <- takeTill (== '}')
+      char '}'
+      return $ ServerUrlVariable res
+
+instance Steppable [Server] ProcessedServer where
+  data Step [Server] ProcessedServer = ServerStep Text
+    deriving (Eq, Ord, Show)
+
+instance Subtree ProcessedServer where
+  type CheckEnv ProcessedServer = '[]
+  data CheckIssue ProcessedServer
+    = VariableNotDefined
+    | ServerNotMatched
+    | EnumValueNotConsumed Int Text
+    | ConsumerNotOpen Int
+    deriving (Eq, Ord, Show)
+  checkCompatibility _ pc@(ProdCons p _) =
+    -- traversing here is fine because we have already filtered for length
+    for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
+      (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v)
+      -- Consumer can consume anything
+      (_, Nothing) -> pure ()
+      -- Producer can produce anythings, but consumer has a finite enum ;(
+      (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)
+    where
+      zipProdCons :: ProdCons [a] -> [(a, a)]
+      zipProdCons (ProdCons x y) = zip x y

test/golden/common/servers/a.yaml

@@ -0,0 +1,38 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Swagger Petstore
+servers:
+  - url: http://petstore.swagger.io/v1
+    variables:
+      variableThatDoesntDoAnything:
+        default: a
+        enum:
+          - a
+          - bbb
+  - url: http://missing.url
+  - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}
+    variables:
+      x:
+        default: a
+        enum:
+          - a
+          - b
+          - c
+      y:
+        default: aa
+        enum:
+          - a
+          - aa
+          - aaa
+      openVariable1:
+        default: henlo
+      openVariable2:
+        default: henlo
+paths:
+  /pets:
+    get:
+      responses:
+        "200":
+          description: A paged array of pets
+components: {}

test/golden/common/servers/b.yaml

@@ -0,0 +1,34 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Swagger Petstore
+servers:
+  - url: http://petstore.swagger.io/v1
+  - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}
+    variables:
+      x:
+        default: a
+        enum:
+          - b
+          - c
+      y:
+        default: aa
+        enum:
+          - a
+          - aa
+          - aaa
+          - bbb
+      openVariable1:
+        default: henlo
+      openVariable2:
+        default: henlo
+        enum:
+          - a
+          - aaa
+paths:
+  /pets:
+    get:
+      responses:
+        "200":
+          description: A paged array of pets
+components: {}

test/golden/common/servers/trace-tree.yaml

@@ -0,0 +1,9 @@
+Left:
+  OpenApiPathsStep:
+    MatchedPathStep "/pets":
+      OperationMethodStep GetMethod:
+        OperationServersStep:
+          ServerStep "http://missing.url": ServerNotMatched
+          ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":
+          - EnumValueNotConsumed 1 "a"
+          - ConsumerNotOpen 7