Added basic test infrastructure (#5)

openapi-diff.cabal

@@ -31,6 +31,7 @@ common common-options
   default-language:    Haskell2010
   build-depends:       base >= 4.12.0.0 && < 4.15
                      , aeson
+                     , deriving-aeson
                      , containers
                      , generic-monoid
                      , insert-ordered-containers
@@ -39,13 +40,18 @@ common common-options
                      , openapi3
                      , text
                      , transformers
+                     , yaml
+                     , attoparsec
 
   default-extensions: ConstraintKinds
                     , DataKinds
+                    , DeriveAnyClass
                     , DeriveFoldable
                     , DeriveFunctor
                     , DeriveGeneric
                     , DeriveTraversable
+                    , DerivingStrategies
+                    , DerivingVia
                     , DuplicateRecordFields
                     , FlexibleContexts
                     , FlexibleInstances
@@ -96,7 +102,19 @@ test-suite openapi-diff-test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             Spec.hs
-  build-depends:       openapi-diff
+  other-modules:
+    Spec.Golden.Report
+    Spec.Golden.Extra
+    Spec.Golden.ReportTree
+  build-depends:
+    , openapi-diff
+    , tasty-golden
+    , tasty
+    , bytestring
+    , aeson
+    , yaml
+    , directory
+    , filepath
   ghc-options:         -threaded
                        -rtsopts
                        -with-rtsopts=-N

src/OpenAPI/Checker/Report.hs

@@ -1,34 +1,58 @@
 module OpenAPI.Checker.Report where
 
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.Attoparsec.Text           as A
+import           Data.Functor
 import           Data.Map.Strict                as M
+import           Data.Maybe
 import           Data.Monoid.Generic
 import           Data.OpenApi.Internal
-import           Data.Semigroup.Generic
 import           Data.Text                      (Text)
-import           GHC.Generics                   (Generic)
+import           Deriving.Aeson.Stock
 import           OpenAPI.Checker.Validate.Monad
+import           Prelude                        as P
 
 printReport :: Report -> IO ()
 printReport = error "FIXME: printReport not implemented"
 
+class HasUnsupportedFeature x where
+  hasUnsupportedFeature :: x -> Bool
+
 data Report = Report
   { status :: Status
   , tree   :: ReportTree
-  } deriving (Eq, Ord, Show, Generic)
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake Report
+
+instance HasUnsupportedFeature Report 
+
+instance HasUnsupportedFeature x => HasUnsupportedFeature (Either e x) where
+  hasUnsupportedFeature (Left _) = False
+  hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
 
 data Status = Success | Fail Text
-  deriving (Eq, Ord, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake Status
 
 type Path = FilePath -- From the library
 
 newtype ReportTree = ReportTree
   { paths :: Map Path (Errorable PathItemTree)
-  } deriving (Eq, Ord, Show, Generic, Semigroup, Monoid)
+  }
+  deriving stock (Show, Generic)
+  deriving newtype (Eq, Ord, Semigroup, Monoid)
+  deriving (ToJSON, FromJSON) via Snake ReportTree
+
+instance HasUnsupportedFeature ReportTree 
 
 data PathItemTree = PathItemTree
   { operations :: Map OperationName (Errorable OperationTree)
   , server     :: Maybe (Errorable ServerTree)
-  } deriving (Eq, Ord, Show, Generic)
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake PathItemTree
 
 instance Semigroup PathItemTree where
   (<>) = genericMappend
@@ -44,10 +68,14 @@ instance Nested PathItemTree where
 data OperationName
   = Get | Put | Post | Delete | Options | Head | Patch | Trace
   deriving (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake OperationName
+  deriving anyclass (ToJSONKey, FromJSONKey)
 
 newtype OperationTree = OperationTree
   { parameters :: Map ParamKey (Errorable ParamTree)
-  } deriving (Eq, Ord, Show, Generic, Semigroup, Monoid)
+  }
+  deriving stock (Show, Generic)
+  deriving newtype (Eq, Ord, Semigroup, Monoid, FromJSON, ToJSON)
 
 instance Nested OperationTree where
   type Parent OperationTree = PathItemTree
@@ -55,10 +83,12 @@ instance Nested OperationTree where
   nest key p = PathItemTree (M.singleton key p) mempty
 
 data ServerTree = ServerTree
-  deriving (Eq, Ord, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake ServerTree
 
 data ParamTree = ParamTree
-  deriving (Eq, Ord, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (ToJSON, FromJSON) via Snake ParamTree
 
 instance Semigroup ParamTree where
   (<>) = error "Not implemented"
@@ -76,7 +106,10 @@ deriving instance Ord ParamLocation
 data ParamKey = ParamKey
   { name    :: Text
   , paramIn :: ParamLocation
-  } deriving (Eq, Ord, Show, Generic)
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (FromJSON, ToJSON) via Snake ParamKey
+  deriving anyclass (ToJSONKey, FromJSONKey)
 
 getParamKey :: Param -> ParamKey
 getParamKey p = ParamKey

test/README.md

@@ -0,0 +1,37 @@
+# Golden tests
+
+## The basics
+
+The `test/golden` directory contains a tree with golden tests. A test is a any nested directory with no folders nested inside it (i. e. tests can only be leaves in the file system):
+
+```
+id
+├── a.yaml
+├── b.yaml
+└── report.yaml
+```
+
+All of the files and their meaning are specified in code:
+
+
+```haskell
+tests :: IO TestTree
+tests =
+  goldenInputsTreeUniform
+    "Golden Reports"
+    "test/golden/common"
+    "report.yaml"
+    ("a.yaml", "b.yaml")
+    Yaml.decodeFileThrow
+    (uncurry reportCompat)
+```
+
+This test would read the files `a.yaml` and `b.yaml` using the `Yaml.decodeFileThrow` function, and pass the resulting tuple to `uncurry reportCompat`. The resul will be compared to `report.yaml`.
+
+## Supported feature tests
+
+If a test starts with either `x ` or `v `, the test is assumed to test the support of some OpenApi functionality. If the test begins `x ` it means that the feature is expected to be not supported, and the result will only be checked to have an "unsupported" flag set. If it starts with `v ` the test is expected to be supported and the result is compared to some file on disk.
+
+The result will be reflected in the generated compatibility matrix.
+
+If a test does not begin with either `x ` or `v `, then it is presumed to be a normal test and will not be reflected in the resulting compatibility matrix.

test/Spec.hs

@@ -1,5 +1,19 @@
 module Main (main) where
 
+import qualified Spec.Golden.Report
+import qualified Spec.Golden.ReportTree
+import Test.Tasty
 
 main :: IO ()
-main = putStrLn ("Test suite is not implemented" :: String)
+main = defaultMain =<< tests
+
+tests :: IO TestTree
+tests = do
+  goldenReport <- Spec.Golden.Report.tests
+  goldenReportTree <- Spec.Golden.ReportTree.tests
+  return $
+    testGroup
+      "Golden tests"
+      [ goldenReport,
+        goldenReportTree
+      ]

test/Spec/Golden/Extra.hs

@@ -0,0 +1,119 @@
+module Spec.Golden.Extra
+  ( getGoldenInputs,
+    getGoldenInputsUniform,
+    goldenInputsTree,
+    goldenInputsTreeUniform,
+  )
+where
+
+import Control.Lens
+import Control.Monad
+import Data.Aeson hiding (Result)
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Yaml as Yaml
+import OpenAPI.Checker.Report
+import System.Directory
+import System.FilePath
+import Test.Tasty
+import Test.Tasty.Golden
+import Test.Tasty.Providers
+
+data TestInput t
+  = TestInputNode TestName [TestInput t]
+  | TestInputLeaf TestName t FilePath
+  deriving (Functor)
+
+getGoldenInputs ::
+  (Each s t (FilePath, FilePath -> IO a) a) =>
+  TestName ->
+  FilePath ->
+  s ->
+  IO (TestInput t)
+getGoldenInputs name filepath inp = do
+  dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))
+  case dirs' of
+    -- A test
+    [] -> do
+      x <-
+        inp & each %%~ \(file, f) ->
+          f $ filepath </> file
+      return $ TestInputLeaf name x filepath
+    -- A test group
+    dirs ->
+      TestInputNode name
+        <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)
+
+getGoldenInputsUniform ::
+  (Each t h (FilePath, FilePath -> IO a) a) =>
+  (Each s t FilePath (FilePath, FilePath -> IO a)) =>
+  TestName ->
+  (FilePath -> IO a) ->
+  FilePath ->
+  s ->
+  IO (TestInput h)
+getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
+
+goldenInputsTree ::
+  (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x) =>
+  TestName ->
+  -- | Root path
+  FilePath ->
+  -- | Name of golden file
+  FilePath ->
+  s ->
+  (t -> x) ->
+  IO TestTree
+goldenInputsTree name filepath golden inp f = do
+  runTestInputTree golden f <$> getGoldenInputs name filepath inp
+
+runTestInputTree ::
+  (ToJSON x, HasUnsupportedFeature x) =>
+  FilePath ->
+  (t -> x) ->
+  TestInput t ->
+  TestTree
+runTestInputTree golden f (TestInputNode name rest) =
+  testGroup name (runTestInputTree golden f <$> rest)
+runTestInputTree golden f (TestInputLeaf name t path)
+  | testSupported name =
+    goldenVsStringDiff
+      name
+      (\ref new -> ["diff", "-u", ref, new])
+      (path </> golden)
+      (pure . BSL.fromStrict . Yaml.encode . f $ t)
+runTestInputTree _ f (TestInputLeaf name t _) =
+  reportResult name $
+    if hasUnsupportedFeature (f t)
+      then testPassed "Feature unsupported"
+      else testFailed "Unexpected feature support"
+
+reportResult :: TestName -> Result -> TestTree
+reportResult name result = singleTest name $ SimpleTestReporter result
+
+newtype SimpleTestReporter = SimpleTestReporter Result
+
+instance IsTest SimpleTestReporter where
+  run _ (SimpleTestReporter result) _ = return result
+  testOptions = mempty
+
+testSupported :: TestName -> Bool
+testSupported ('x' : ' ' : _) = False
+testSupported _ = True
+
+goldenInputsTreeUniform ::
+  ( Each t h (FilePath, FilePath -> IO a) a,
+    ToJSON x,
+    Each s t FilePath (FilePath, FilePath -> IO a),
+    HasUnsupportedFeature x
+  ) =>
+  String ->
+  -- | Root path
+  FilePath ->
+  -- | Name of golden file
+  FilePath ->
+  s ->
+  (FilePath -> IO a) ->
+  (h -> x) ->
+  IO TestTree
+goldenInputsTreeUniform name filepath golden inp h =
+  goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/Report.hs

@@ -0,0 +1,19 @@
+module Spec.Golden.Report
+  ( tests,
+  )
+where
+
+import qualified Data.Yaml as Yaml
+import OpenAPI.Checker.Validate
+import Spec.Golden.Extra
+import Test.Tasty
+
+tests :: IO TestTree
+tests =
+  goldenInputsTreeUniform
+    "Golden Reports"
+    "test/golden/common"
+    "report.yaml"
+    ("a.yaml", "b.yaml")
+    Yaml.decodeFileThrow
+    (uncurry reportCompat)

test/Spec/Golden/ReportTree.hs

@@ -0,0 +1,19 @@
+module Spec.Golden.ReportTree
+  ( tests,
+  )
+where
+
+import qualified Data.Yaml as Yaml
+import OpenAPI.Checker.Validate
+import Spec.Golden.Extra
+import Test.Tasty
+
+tests :: IO TestTree
+tests =
+  goldenInputsTreeUniform
+    "Golden ReportTrees"
+    "test/golden/common"
+    "report-tree.yaml"
+    ("a.yaml", "b.yaml")
+    Yaml.decodeFileThrow
+    (uncurry forwardCompatible)

test/golden/common/id/a.yaml

@@ -0,0 +1,111 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Swagger Petstore
+  license:
+    name: MIT
+servers:
+  - url: http://petstore.swagger.io/v1
+paths:
+  /pets:
+    get:
+      summary: List all pets
+      operationId: listPets
+      tags:
+        - pets
+      parameters:
+        - name: limit
+          in: query
+          description: How many items to return at one time (max 100)
+          required: false
+          schema:
+            type: integer
+            format: int32
+      responses:
+        '200':
+          description: A paged array of pets
+          headers:
+            x-next:
+              description: A link to the next page of responses
+              schema:
+                type: string
+          content:
+            application/json:    
+              schema:
+                $ref: "#/components/schemas/Pets"
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+    post:
+      summary: Create a pet
+      operationId: createPets
+      tags:
+        - pets
+      responses:
+        '201':
+          description: Null response
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+  /pets/{petId}:
+    get:
+      summary: Info for a specific pet
+      operationId: showPetById
+      tags:
+        - pets
+      parameters:
+        - name: petId
+          in: path
+          required: true
+          description: The id of the pet to retrieve
+          schema:
+            type: string
+      responses:
+        '200':
+          description: Expected response to a valid request
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Pet"
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+components:
+  schemas:
+    Pet:
+      type: object
+      required:
+        - id
+        - name
+      properties:
+        id:
+          type: integer
+          format: int64
+        name:
+          type: string
+        tag:
+          type: string
+    Pets:
+      type: array
+      items:
+        $ref: "#/components/schemas/Pet"
+    Error:
+      type: object
+      required:
+        - code
+        - message
+      properties:
+        code:
+          type: integer
+          format: int32
+        message:
+          type: string

test/golden/common/id/b.yaml

@@ -0,0 +1,111 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Swagger Petstore
+  license:
+    name: MIT
+servers:
+  - url: http://petstore.swagger.io/v1
+paths:
+  /pets:
+    get:
+      summary: List all pets
+      operationId: listPets
+      tags:
+        - pets
+      parameters:
+        - name: limit
+          in: query
+          description: How many items to return at one time (max 100)
+          required: false
+          schema:
+            type: integer
+            format: int32
+      responses:
+        '200':
+          description: A paged array of pets
+          headers:
+            x-next:
+              description: A link to the next page of responses
+              schema:
+                type: string
+          content:
+            application/json:    
+              schema:
+                $ref: "#/components/schemas/Pets"
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+    post:
+      summary: Create a pet
+      operationId: createPets
+      tags:
+        - pets
+      responses:
+        '201':
+          description: Null response
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+  /pets/{petId}:
+    get:
+      summary: Info for a specific pet
+      operationId: showPetById
+      tags:
+        - pets
+      parameters:
+        - name: petId
+          in: path
+          required: true
+          description: The id of the pet to retrieve
+          schema:
+            type: string
+      responses:
+        '200':
+          description: Expected response to a valid request
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Pet"
+        default:
+          description: unexpected error
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Error"
+components:
+  schemas:
+    Pet:
+      type: object
+      required:
+        - id
+        - name
+      properties:
+        id:
+          type: integer
+          format: int64
+        name:
+          type: string
+        tag:
+          type: string
+    Pets:
+      type: array
+      items:
+        $ref: "#/components/schemas/Pet"
+    Error:
+      type: object
+      required:
+        - code
+        - message
+      properties:
+        code:
+          type: integer
+          format: int32
+        message:
+          type: string