From 549f53e1630e7f1e41ffe3aaabf8e3f6b0139255 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 22:07:16 +0100 Subject: [PATCH 01/20] test: disable cabal-fmt for primer-service Unfortunately cabal-fmt does not yet support references to cabal sublibraries, breaking the source code checks. Support has been implemented, so hopefully we will be able to revert this commit when the next release of cabal-fmt is made. (This commit is preparation for adding some tests to primer-service that will require primer:primer-hedgehog.) --- flake.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/flake.nix b/flake.nix index 3f2c09d59..85613b794 100644 --- a/flake.nix +++ b/flake.nix @@ -531,6 +531,7 @@ "primer/test/outputs" "primer-service/test/outputs" ".buildkite/" + "primer-service/primer-service.cabal" ]; }; From 958cb2fb9504afe40a331ba4982e7aae3cd11f44 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Mon, 8 Aug 2022 21:54:46 +0100 Subject: [PATCH 02/20] test: SessionName ToJSON/ToSchema We bump the cabal-version to enable use of sublibrary references. --- primer-service/primer-service.cabal | 12 +++++++----- primer-service/test/Tests/OpenAPI.hs | 21 +++++++++++++++++++++ 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index 198f594c6..c048fdfa7 100644 --- a/primer-service/primer-service.cabal +++ b/primer-service/primer-service.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: primer-service version: 0.7.2.0 license: AGPL-3.0-or-later @@ -13,6 +13,7 @@ category: Web library exposed-modules: Primer.Client + Primer.OpenAPI Primer.Pagination Primer.Servant.API Primer.Servant.OpenAPI @@ -20,10 +21,7 @@ library Primer.Server hs-source-dirs: src - other-modules: - Primer.OpenAPI - Servant.OpenApi.OperationId - + other-modules: Servant.OpenApi.OperationId default-language: GHC2021 default-extensions: NoImplicitPrelude @@ -175,15 +173,19 @@ test-suite service-test , base , bytestring , hasql + , hedgehog ^>=1.1.1 + , openapi3 >=3.2 && <=3.3 , postgres-options ^>=0.2 , pretty-simple ^>=4.0.0 , primer + , primer:primer-hedgehog , primer-rel8 , primer-service , rel8 ^>=1.3 , tasty ^>=1.4.1 , tasty-discover ^>=4.2.4 , tasty-golden ^>=2.3.5 + , tasty-hedgehog ^>=1.2.0 , tasty-hunit ^>=0.10.0 , temporary ^>=1.3 , text diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 4e244689d..42f81fd98 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -2,8 +2,16 @@ module Tests.OpenAPI where import Foreword +import Data.Aeson (ToJSON) import Data.Aeson.Encode.Pretty (encodePretty) +import Data.OpenApi (ToSchema, validatePrettyToJSON) +import Hedgehog (Gen, annotate, failure, forAll) +import Hedgehog.Gen qualified as G +import Hedgehog.Range qualified as R +import Primer.Database (SessionName, safeMkSessionName) +import Primer.OpenAPI () import Primer.Server (openAPIInfo) +import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) @@ -21,3 +29,16 @@ test_golden = pure $ encodePretty openAPIInfo ] + +testToJSON :: (ToJSON a, ToSchema a, Show a) => Gen a -> Property +testToJSON g = property $ do + x <- forAll g + case validatePrettyToJSON x of + Nothing -> pure () + Just errs -> annotate errs >> failure + +genSessionName :: Gen SessionName +genSessionName = safeMkSessionName <$> G.text (R.linear 1 100) G.unicode + +tasty_SessionName :: Property +tasty_SessionName = testToJSON genSessionName From 87547c11b96b1ea81779c7eb6a09d31d1220862a Mon Sep 17 00:00:00 2001 From: Ben Price Date: Mon, 8 Aug 2022 22:02:50 +0100 Subject: [PATCH 03/20] test: ID ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 42f81fd98..fc219cd76 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -8,6 +8,7 @@ import Data.OpenApi (ToSchema, validatePrettyToJSON) import Hedgehog (Gen, annotate, failure, forAll) import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R +import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) import Primer.OpenAPI () import Primer.Server (openAPIInfo) @@ -42,3 +43,7 @@ genSessionName = safeMkSessionName <$> G.text (R.linear 1 100) G.unicode tasty_SessionName :: Property tasty_SessionName = testToJSON genSessionName + +-- NB: don't want to use genID, as that is just "next free ID" +tasty_ID :: Property +tasty_ID = testToJSON $ ID <$> G.int (R.linear 0 1000) From 07f84a186ea093da7c2e30e5bbdd54fcd53268db Mon Sep 17 00:00:00 2001 From: Ben Price Date: Mon, 8 Aug 2022 22:05:52 +0100 Subject: [PATCH 04/20] test: Name ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index fc219cd76..ee786f5d9 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -10,6 +10,7 @@ import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) +import Primer.Gen.Core.Raw (evalExprGen, genName) import Primer.OpenAPI () import Primer.Server (openAPIInfo) import Tasty (Property, property) @@ -47,3 +48,6 @@ tasty_SessionName = testToJSON genSessionName -- NB: don't want to use genID, as that is just "next free ID" tasty_ID :: Property tasty_ID = testToJSON $ ID <$> G.int (R.linear 0 1000) + +tasty_Name :: Property +tasty_Name = testToJSON $ evalExprGen 0 genName From 6d38e5367a4f262b4e40190941792d0a85822833 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 22:18:41 +0100 Subject: [PATCH 05/20] refactor: Primer.OpenAPI imports Foreword Instead of importing modules just for common types (e.g. Text), we simply pull in Foreword, which includes most commonly used identifiers. --- primer-service/src/Primer/OpenAPI.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 2998fa91c..8d6fe18fc 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/primer-service/src/Primer/OpenAPI.hs @@ -6,13 +6,13 @@ module Primer.OpenAPI ( ) where import Data.OpenApi (ToSchema) -import Data.Text (Text) -import Data.Typeable (Typeable) import Primer.API (Def, Module, NodeBody, NodeFlavor, Prog, Tree) import Primer.Core (GlobalName, ID (..), LVarName, ModuleName) import Primer.Database (Session, SessionName) import Primer.Name (Name) +import Foreword + -- $orphanInstances -- -- We define some OpenApi orphan instances in primer-service, to avoid From d0c46503fe9e86be8e2900be9139460875a72c5b Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 16:12:59 +0100 Subject: [PATCH 06/20] fix: ModuleName ToJSON/ToSchema consistency --- primer-service/src/Primer/OpenAPI.hs | 2 +- primer-service/test/Tests/OpenAPI.hs | 5 ++++- .../test/outputs/OpenAPI/openapi.json | 21 +++++-------------- 3 files changed, 10 insertions(+), 18 deletions(-) diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 8d6fe18fc..766dc172d 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/primer-service/src/Primer/OpenAPI.hs @@ -39,6 +39,6 @@ instance ToSchema Tree instance ToSchema NodeBody instance ToSchema NodeFlavor instance ToSchema Def -instance ToSchema ModuleName +deriving via NonEmpty Name instance ToSchema ModuleName instance ToSchema Module instance ToSchema Prog diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index ee786f5d9..b8e885e5d 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -10,7 +10,7 @@ import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) -import Primer.Gen.Core.Raw (evalExprGen, genName) +import Primer.Gen.Core.Raw (evalExprGen, genModuleName, genName) import Primer.OpenAPI () import Primer.Server (openAPIInfo) import Tasty (Property, property) @@ -51,3 +51,6 @@ tasty_ID = testToJSON $ ID <$> G.int (R.linear 0 1000) tasty_Name :: Property tasty_Name = testToJSON $ evalExprGen 0 genName + +tasty_ModuleName :: Property +tasty_ModuleName = testToJSON $ evalExprGen 0 genModuleName diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index bb196791b..dc3ca6241 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/primer-service/test/outputs/OpenAPI/openapi.json @@ -31,7 +31,11 @@ "type": "boolean" }, "modname": { - "$ref": "#/components/schemas/ModuleName" + "items": { + "type": "string" + }, + "minItems": 1, + "type": "array" }, "types": { "items": { @@ -48,21 +52,6 @@ ], "type": "object" }, - "ModuleName": { - "properties": { - "unModuleName": { - "items": { - "type": "string" - }, - "minItems": 1, - "type": "array" - } - }, - "required": [ - "unModuleName" - ], - "type": "object" - }, "NodeBody": { "oneOf": [ { From c235bbe8f9564c00d51c4ebefe030cac0cb1ab15 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 3 Aug 2022 13:54:22 +0100 Subject: [PATCH 07/20] feat: ToSchema instance for CustomJSON --- primer-service/primer-service.cabal | 1 + primer-service/src/Primer/OpenAPI.hs | 13 ++++++++++++- primer/primer.cabal | 6 ++---- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index c048fdfa7..29bc6ba4d 100644 --- a/primer-service/primer-service.cabal +++ b/primer-service/primer-service.cabal @@ -38,6 +38,7 @@ library build-depends: , aeson >=2.0 && <=2.1 , base >=4.12 && <=4.17 + , deriving-aeson >=0.2 && <=0.3 , exceptions >=0.10.4 && <=0.11 , http-client ^>=0.7.13 , http-media >=0.8 && <=0.9 diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 766dc172d..cdd698fb6 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/primer-service/src/Primer/OpenAPI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Primer.OpenAPI ( @@ -5,10 +6,13 @@ module Primer.OpenAPI ( -- $orphanInstances ) where -import Data.OpenApi (ToSchema) +import Data.OpenApi (ToSchema (declareNamedSchema), fromAesonOptions, genericDeclareNamedSchema) +import Data.OpenApi.Internal.Schema (GToSchema) +import Deriving.Aeson (AesonOptions (aesonOptions)) import Primer.API (Def, Module, NodeBody, NodeFlavor, Prog, Tree) import Primer.Core (GlobalName, ID (..), LVarName, ModuleName) import Primer.Database (Session, SessionName) +import Primer.JSON (CustomJSON) import Primer.Name (Name) import Foreword @@ -20,6 +24,13 @@ import Foreword -- build primer with ghcjs, because openapi3 transitively depends on network, -- which ghcjs currently cannot build. +-- Suitable for deriving via, when the ToJSON instance is via PrimerJSON +instance + (Typeable a, Generic a, GToSchema (Rep a), Typeable os, Typeable ks, AesonOptions os) => + ToSchema (CustomJSON (os :: ks) a) + where + declareNamedSchema _ = genericDeclareNamedSchema (fromAesonOptions (aesonOptions @os)) (Proxy @a) + instance ToSchema SessionName instance ToSchema Session diff --git a/primer/primer.cabal b/primer/primer.cabal index 10f4db3cc..1578a0de7 100644 --- a/primer/primer.cabal +++ b/primer/primer.cabal @@ -29,6 +29,7 @@ library Primer.Eval Primer.EvalFull Primer.Examples + Primer.JSON Primer.Module Primer.Name Primer.Name.Fresh @@ -46,10 +47,7 @@ library Primer.ZipperCxt hs-source-dirs: src - other-modules: - Control.Monad.NestedError - Primer.JSON - + other-modules: Control.Monad.NestedError default-language: GHC2021 default-extensions: NoImplicitPrelude From 269f64420c0b3c59db04f90f6eecd878c42bc1ea Mon Sep 17 00:00:00 2001 From: Ben Price Date: Mon, 8 Aug 2022 22:12:50 +0100 Subject: [PATCH 08/20] fix: GlobalNames ToJSON/ToSchema consistency Note that the old instance (via `Name`) was nonsense: `GlobalName`s and `Name`s are not serialised the same (one is a record, the other is a string)! The instance compiled even though `GlobalName` is not `Coercible` with `Name` since GHC only requires that the corresponding methods of the two instances are `Coercible. Since `ToSchema a` only uses `a` via `Proxy`, this is true for any choices of `a`. --- primer-service/src/Primer/OpenAPI.hs | 25 ++++++++++++++----- primer-service/test/Tests/OpenAPI.hs | 18 ++++++++++++- .../test/outputs/OpenAPI/openapi.json | 23 +++++++++++++++-- primer/gen/Primer/Gen/Core/Raw.hs | 8 +++++- 4 files changed, 64 insertions(+), 10 deletions(-) diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index cdd698fb6..3b2434e3c 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/primer-service/src/Primer/OpenAPI.hs @@ -7,12 +7,18 @@ module Primer.OpenAPI ( ) where import Data.OpenApi (ToSchema (declareNamedSchema), fromAesonOptions, genericDeclareNamedSchema) -import Data.OpenApi.Internal.Schema (GToSchema) +import Data.OpenApi.Internal.Schema (GToSchema, rename) import Deriving.Aeson (AesonOptions (aesonOptions)) import Primer.API (Def, Module, NodeBody, NodeFlavor, Prog, Tree) -import Primer.Core (GlobalName, ID (..), LVarName, ModuleName) +import Primer.Core ( + GlobalName, + GlobalNameKind (ADefName, ATyCon, AValCon), + ID (..), + LVarName, + ModuleName, + ) import Primer.Database (Session, SessionName) -import Primer.JSON (CustomJSON) +import Primer.JSON (CustomJSON, PrimerJSON) import Primer.Name (Name) import Foreword @@ -42,9 +48,16 @@ deriving newtype instance ToSchema ID -- This instance works because the parameter has a phantom role! deriving via Text instance (ToSchema Name) --- For GlobalName and LVarName, we must derive ToSchema via Name, --- as that is how the To/FromJSON instances are derived -deriving via Name instance Typeable k => ToSchema (GlobalName k) +-- For GlobalNames, we know the tag is just phantom type information +-- and they all serialise in the same way. We collapse the distinction +-- at the openapi level, so api consumers do not have to deal with +-- three identical types. Note that our openapi interface is a +-- simplified view, so this collapse is in the correct spirit. +instance ToSchema (GlobalName 'ADefName) where + declareNamedSchema _ = rename (Just "GlobalName") <$> declareNamedSchema (Proxy @(PrimerJSON (GlobalName 'ADefName))) +deriving via GlobalName 'ADefName instance ToSchema (GlobalName 'ATyCon) +deriving via GlobalName 'ADefName instance ToSchema (GlobalName 'AValCon) + deriving via Name instance (ToSchema LVarName) instance ToSchema Tree instance ToSchema NodeBody diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index b8e885e5d..5f9259f86 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -10,7 +10,14 @@ import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) -import Primer.Gen.Core.Raw (evalExprGen, genModuleName, genName) +import Primer.Gen.Core.Raw ( + evalExprGen, + genGVarName, + genModuleName, + genName, + genTyConName, + genValConName, + ) import Primer.OpenAPI () import Primer.Server (openAPIInfo) import Tasty (Property, property) @@ -54,3 +61,12 @@ tasty_Name = testToJSON $ evalExprGen 0 genName tasty_ModuleName :: Property tasty_ModuleName = testToJSON $ evalExprGen 0 genModuleName + +tasty_TyConName :: Property +tasty_TyConName = testToJSON $ evalExprGen 0 genTyConName + +tasty_ValConName :: Property +tasty_ValConName = testToJSON $ evalExprGen 0 genValConName + +tasty_GVarName :: Property +tasty_GVarName = testToJSON $ evalExprGen 0 genGVarName diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index dc3ca6241..d54c7796c 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/primer-service/test/outputs/OpenAPI/openapi.json @@ -4,7 +4,7 @@ "Def": { "properties": { "name": { - "type": "string" + "$ref": "#/components/schemas/GlobalName" }, "term": { "$ref": "#/components/schemas/Tree" @@ -19,6 +19,25 @@ ], "type": "object" }, + "GlobalName": { + "properties": { + "baseName": { + "type": "string" + }, + "qualifiedModule": { + "items": { + "type": "string" + }, + "minItems": 1, + "type": "array" + } + }, + "required": [ + "qualifiedModule", + "baseName" + ], + "type": "object" + }, "Module": { "properties": { "defs": { @@ -39,7 +58,7 @@ }, "types": { "items": { - "type": "string" + "$ref": "#/components/schemas/GlobalName" }, "type": "array" } diff --git a/primer/gen/Primer/Gen/Core/Raw.hs b/primer/gen/Primer/Gen/Core/Raw.hs index 3adfcb8aa..66df3d302 100644 --- a/primer/gen/Primer/Gen/Core/Raw.hs +++ b/primer/gen/Primer/Gen/Core/Raw.hs @@ -13,6 +13,8 @@ module Primer.Gen.Core.Raw ( genLVarName, genTyVarName, genTyConName, + genValConName, + genGVarName, genKind, genType, genExpr, @@ -28,6 +30,7 @@ import Primer.Core ( CaseBranch' (CaseBranch), Expr, Expr' (..), + GVarName, ID (..), Kind (..), LVarName, @@ -110,7 +113,10 @@ genLocalVar :: ExprGen Expr genLocalVar = Var <$> genMeta <*> (LocalVarRef <$> genLVarName) genGlobalVar :: ExprGen Expr -genGlobalVar = Var <$> genMeta <*> ((\m n -> GlobalVarRef $ qualifyName m n) <$> genModuleName <*> genName) +genGlobalVar = Var <$> genMeta <*> (GlobalVarRef <$> genGVarName) + +genGVarName :: ExprGen GVarName +genGVarName = qualifyName <$> genModuleName <*> genName genLet :: ExprGen Expr genLet = Let <$> genMeta <*> genLVarName <*> genExpr <*> genExpr From 600d096d2177c6138f4f2f9f656649ca808167a9 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 23:27:37 +0100 Subject: [PATCH 09/20] test: LVarName ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 5f9259f86..eba502830 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -13,6 +13,7 @@ import Primer.Database (SessionName, safeMkSessionName) import Primer.Gen.Core.Raw ( evalExprGen, genGVarName, + genLVarName, genModuleName, genName, genTyConName, @@ -70,3 +71,6 @@ tasty_ValConName = testToJSON $ evalExprGen 0 genValConName tasty_GVarName :: Property tasty_GVarName = testToJSON $ evalExprGen 0 genGVarName + +tasty_LVarName :: Property +tasty_LVarName = testToJSON genLVarName From 96f89bdafe391fd28b86b2cc7ed3d3bd1bdb2b1d Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 23:41:40 +0100 Subject: [PATCH 10/20] test: Tree ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index eba502830..c989ab4a3 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -8,15 +8,18 @@ import Data.OpenApi (ToSchema, validatePrettyToJSON) import Hedgehog (Gen, annotate, failure, forAll) import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R +import Primer.API (Tree, viewTreeExpr, viewTreeType) import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) import Primer.Gen.Core.Raw ( evalExprGen, + genExpr, genGVarName, genLVarName, genModuleName, genName, genTyConName, + genType, genValConName, ) import Primer.OpenAPI () @@ -74,3 +77,14 @@ tasty_GVarName = testToJSON $ evalExprGen 0 genGVarName tasty_LVarName :: Property tasty_LVarName = testToJSON genLVarName + +tasty_Tree :: Property +tasty_Tree = testToJSON genTree + +-- We only test the trees which we create by viewing either a Type or Expr +genTree :: Gen Tree +genTree = + G.choice + [ viewTreeExpr <$> evalExprGen 0 genExpr + , viewTreeType <$> evalExprGen 0 genType + ] From 471c7cb9e8baa1806a218869e6641ddd0682e811 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 23:47:04 +0100 Subject: [PATCH 11/20] test: NodeBody ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 16 +++++++++++++++- primer/src/Primer/API.hs | 2 +- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index c989ab4a3..875567795 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -8,7 +8,12 @@ import Data.OpenApi (ToSchema, validatePrettyToJSON) import Hedgehog (Gen, annotate, failure, forAll) import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R -import Primer.API (Tree, viewTreeExpr, viewTreeType) +import Primer.API ( + NodeBody (BoxBody, NoBody, TextBody), + Tree, + viewTreeExpr, + viewTreeType, + ) import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) import Primer.Gen.Core.Raw ( @@ -88,3 +93,12 @@ genTree = [ viewTreeExpr <$> evalExprGen 0 genExpr , viewTreeType <$> evalExprGen 0 genType ] + +tasty_NodeBody :: Property +tasty_NodeBody = + testToJSON $ + G.choice + [ TextBody <$> G.text (R.linear 1 20) G.unicode + , BoxBody <$> genTree + , pure NoBody + ] diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 9d2b950d4..43f74222a 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -24,7 +24,7 @@ module Primer.API ( listSessions, getVersion, Tree, - NodeBody, + NodeBody (..), NodeFlavor, Prog, Module, From 5de01213f95a233776ae05402b5d867ca96c26f2 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 9 Aug 2022 23:49:55 +0100 Subject: [PATCH 12/20] test: NodeFlavor ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 4 ++++ primer/src/Primer/API.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 875567795..ac51b0f7e 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -10,6 +10,7 @@ import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.API ( NodeBody (BoxBody, NoBody, TextBody), + NodeFlavor, Tree, viewTreeExpr, viewTreeType, @@ -102,3 +103,6 @@ tasty_NodeBody = , BoxBody <$> genTree , pure NoBody ] + +tasty_NodeFlavor :: Property +tasty_NodeFlavor = testToJSON $ G.enumBounded @_ @NodeFlavor diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 43f74222a..46bd739ed 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -433,7 +433,7 @@ data NodeFlavor | FlavorPatternCon | FlavorPatternBind | FlavorPatternApp - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Enum, Bounded) deriving (ToJSON) via PrimerJSON NodeFlavor -- | This type is the API's view of a 'App.Prog' From 9a43db4c9378b8ee342bd9fa970eaaf37980dac9 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 00:05:25 +0100 Subject: [PATCH 13/20] test: Def ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 20 +++++++++++++++----- primer/gen/Primer/Gen/Core/Raw.hs | 1 + primer/src/Primer/API.hs | 4 ++-- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index ac51b0f7e..a9c511d54 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -9,6 +9,7 @@ import Hedgehog (Gen, annotate, failure, forAll) import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.API ( + Def (Def), NodeBody (BoxBody, NoBody, TextBody), NodeFlavor, Tree, @@ -18,6 +19,7 @@ import Primer.API ( import Primer.Core (ID (ID)) import Primer.Database (SessionName, safeMkSessionName) import Primer.Gen.Core.Raw ( + ExprGen, evalExprGen, genExpr, genGVarName, @@ -89,11 +91,13 @@ tasty_Tree = testToJSON genTree -- We only test the trees which we create by viewing either a Type or Expr genTree :: Gen Tree -genTree = - G.choice - [ viewTreeExpr <$> evalExprGen 0 genExpr - , viewTreeType <$> evalExprGen 0 genType - ] +genTree = evalExprGen 0 $ G.choice [genExprTree, genTypeTree] + +genExprTree :: ExprGen Tree +genExprTree = viewTreeExpr <$> genExpr + +genTypeTree :: ExprGen Tree +genTypeTree = viewTreeType <$> genType tasty_NodeBody :: Property tasty_NodeBody = @@ -106,3 +110,9 @@ tasty_NodeBody = tasty_NodeFlavor :: Property tasty_NodeFlavor = testToJSON $ G.enumBounded @_ @NodeFlavor + +genDef :: ExprGen Def +genDef = Def <$> genGVarName <*> genExprTree <*> G.maybe genTypeTree + +tasty_Def :: Property +tasty_Def = testToJSON $ evalExprGen 0 genDef diff --git a/primer/gen/Primer/Gen/Core/Raw.hs b/primer/gen/Primer/Gen/Core/Raw.hs index 66df3d302..5ae862a4e 100644 --- a/primer/gen/Primer/Gen/Core/Raw.hs +++ b/primer/gen/Primer/Gen/Core/Raw.hs @@ -5,6 +5,7 @@ -- -- For generating well-typed terms, see "Primer.Gen.Core.Typed". module Primer.Gen.Core.Raw ( + ExprGen, runExprGen, evalExprGen, genID, diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 46bd739ed..e87174a17 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -28,7 +28,7 @@ module Primer.API ( NodeFlavor, Prog, Module, - Def, + Def (Def), getProgram, getProgram', getSessionName, @@ -467,7 +467,7 @@ data Def = Def , term :: Maybe Tree -- ^ definitions with no associated tree are primitives } - deriving (Generic) + deriving (Generic, Show) deriving (ToJSON) via PrimerJSON Def viewProg :: App.Prog -> Prog From 10a62e55b14b413921d8d8fc6a427380ec1d99d3 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 00:10:44 +0100 Subject: [PATCH 14/20] test: Module ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 12 ++++++++++++ primer/src/Primer/API.hs | 4 ++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index a9c511d54..4e66582f4 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -10,6 +10,7 @@ import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R import Primer.API ( Def (Def), + Module (Module), NodeBody (BoxBody, NoBody, TextBody), NodeFlavor, Tree, @@ -116,3 +117,14 @@ genDef = Def <$> genGVarName <*> genExprTree <*> G.maybe genTypeTree tasty_Def :: Property tasty_Def = testToJSON $ evalExprGen 0 genDef + +genModule :: ExprGen Module +genModule = + Module + <$> genModuleName + <*> G.bool + <*> G.list (R.linear 0 3) genTyConName + <*> G.list (R.linear 0 3) genDef + +tasty_Module :: Property +tasty_Module = testToJSON $ evalExprGen 0 genModule diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index e87174a17..a6ecee603 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -27,7 +27,7 @@ module Primer.API ( NodeBody (..), NodeFlavor, Prog, - Module, + Module (Module), Def (Def), getProgram, getProgram', @@ -456,7 +456,7 @@ data Module = Module -- corresponding value". defs :: [Def] } - deriving (Generic) + deriving (Generic, Show) deriving (ToJSON) via PrimerJSON Module -- | This type is the api's view of a 'Primer.Core.Def' From 048379ebbc117d5d1ab8420bcffa2e76710ce959 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 00:12:24 +0100 Subject: [PATCH 15/20] test: Prog ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 4 ++++ primer/src/Primer/API.hs | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 4e66582f4..69f5a7aa4 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -13,6 +13,7 @@ import Primer.API ( Module (Module), NodeBody (BoxBody, NoBody, TextBody), NodeFlavor, + Prog (Prog), Tree, viewTreeExpr, viewTreeType, @@ -128,3 +129,6 @@ genModule = tasty_Module :: Property tasty_Module = testToJSON $ evalExprGen 0 genModule + +tasty_Prog :: Property +tasty_Prog = testToJSON $ evalExprGen 0 $ Prog <$> G.list (R.linear 0 3) genModule diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index a6ecee603..da9374ccf 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -26,7 +26,7 @@ module Primer.API ( Tree, NodeBody (..), NodeFlavor, - Prog, + Prog (Prog), Module (Module), Def (Def), getProgram, @@ -441,7 +441,7 @@ data NodeFlavor newtype Prog = Prog { modules :: [Module] } - deriving (Generic) + deriving (Generic, Show) deriving (ToJSON) via PrimerJSON Prog -- | This type is the API's view of a 'Module.Module' From 17a8e7060d63622ed0d7f38038a35984f4e77131 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 11 Aug 2022 17:59:35 +0100 Subject: [PATCH 16/20] test: Session ToJSON/ToSchema --- primer-service/test/Tests/OpenAPI.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 69f5a7aa4..fd94ffb04 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -5,6 +5,7 @@ import Foreword import Data.Aeson (ToJSON) import Data.Aeson.Encode.Pretty (encodePretty) import Data.OpenApi (ToSchema, validatePrettyToJSON) +import Data.UUID (UUID, fromWords64) import Hedgehog (Gen, annotate, failure, forAll) import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R @@ -19,7 +20,7 @@ import Primer.API ( viewTreeType, ) import Primer.Core (ID (ID)) -import Primer.Database (SessionName, safeMkSessionName) +import Primer.Database (Session (Session), SessionName, safeMkSessionName) import Primer.Gen.Core.Raw ( ExprGen, evalExprGen, @@ -66,6 +67,15 @@ genSessionName = safeMkSessionName <$> G.text (R.linear 1 100) G.unicode tasty_SessionName :: Property tasty_SessionName = testToJSON genSessionName +genUUID :: Gen UUID +genUUID = fromWords64 <$> G.word64 R.linearBounded <*> G.word64 R.linearBounded + +genSession :: Gen Session +genSession = Session <$> genUUID <*> genSessionName + +tasty_Session :: Property +tasty_Session = testToJSON genSession + -- NB: don't want to use genID, as that is just "next free ID" tasty_ID :: Property tasty_ID = testToJSON $ ID <$> G.int (R.linear 0 1000) From 01367e83acef3c1c648604120a9e2ab9d918dddd Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 10:59:56 +0100 Subject: [PATCH 17/20] test: Positive ToJSON/ToSchema --- primer-service/src/Primer/Pagination.hs | 2 +- primer-service/test/Tests/OpenAPI.hs | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/primer-service/src/Primer/Pagination.hs b/primer-service/src/Primer/Pagination.hs index d03aafa18..9d7f059e1 100644 --- a/primer-service/src/Primer/Pagination.hs +++ b/primer-service/src/Primer/Pagination.hs @@ -59,7 +59,7 @@ import Servant.OpenApi (HasOpenApi (toOpenApi)) -- @getPositive x > 0@ is always true (because the only way to create one is -- via the 'mkPositive' smart constructor. newtype Positive = Pos {getPositive :: Int} - deriving (Eq, Ord) + deriving (Eq, Ord, Show) deriving newtype (FromJSON, ToJSON) mkPositive :: Int -> Maybe Positive diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index fd94ffb04..1a797d555 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -34,6 +34,7 @@ import Primer.Gen.Core.Raw ( genValConName, ) import Primer.OpenAPI () +import Primer.Pagination (Positive, mkPositive) import Primer.Server (openAPIInfo) import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) @@ -142,3 +143,9 @@ tasty_Module = testToJSON $ evalExprGen 0 genModule tasty_Prog :: Property tasty_Prog = testToJSON $ evalExprGen 0 $ Prog <$> G.list (R.linear 0 3) genModule + +genPositive :: Gen Positive +genPositive = G.just $ mkPositive <$> G.int (R.linear 1 1000) + +tasty_Positive :: Property +tasty_Positive = testToJSON genPositive From ee55ad2999a845c31c8fdaef8ac4441a1e2acf74 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 11:14:40 +0100 Subject: [PATCH 18/20] test: NonNeg ToJSON/ToSchema --- primer-service/src/Primer/Pagination.hs | 10 ++++++++-- primer-service/test/Tests/OpenAPI.hs | 8 +++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/primer-service/src/Primer/Pagination.hs b/primer-service/src/Primer/Pagination.hs index 9d7f059e1..d2008d1c2 100644 --- a/primer-service/src/Primer/Pagination.hs +++ b/primer-service/src/Primer/Pagination.hs @@ -20,8 +20,10 @@ module Primer.Pagination ( thisPage, nextPage, lastPage, - getNonNeg, items, + getNonNeg, + NonNeg, + mkNonNeg, ) where import Foreword @@ -137,7 +139,7 @@ instance ToSchema a => ToSchema (Paginated a) -- Used solely for nice bounds in schema newtype NonNeg = NonNeg Int - deriving newtype (FromJSON, ToJSON) + deriving newtype (FromJSON, ToJSON, Show) instance ToParamSchema NonNeg where toParamSchema _ = toParamSchema (Proxy @Int) & #minimum ?~ 0 instance ToSchema NonNeg where @@ -146,6 +148,10 @@ instance ToSchema NonNeg where getNonNeg :: NonNeg -> Int getNonNeg (NonNeg i) = i +-- For testing purposes +mkNonNeg :: Int -> Maybe NonNeg +mkNonNeg a = if a >= 0 then Just (NonNeg a) else Nothing + data PaginatedMeta = PM { totalItems :: NonNeg , pageSize :: Positive diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 1a797d555..54f9dbaa5 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -34,7 +34,7 @@ import Primer.Gen.Core.Raw ( genValConName, ) import Primer.OpenAPI () -import Primer.Pagination (Positive, mkPositive) +import Primer.Pagination (NonNeg, Positive, mkNonNeg, mkPositive) import Primer.Server (openAPIInfo) import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) @@ -149,3 +149,9 @@ genPositive = G.just $ mkPositive <$> G.int (R.linear 1 1000) tasty_Positive :: Property tasty_Positive = testToJSON genPositive + +genNonNeg :: Gen NonNeg +genNonNeg = G.just $ mkNonNeg <$> G.int (R.linear 0 1000) + +tasty_NonNeg :: Property +tasty_NonNeg = testToJSON genNonNeg From f6f873b463c66f6be3b4f7a4be48456b831708a7 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 11:34:29 +0100 Subject: [PATCH 19/20] test: PaginatedMeta ToJSON/ToSchema --- primer-service/src/Primer/Pagination.hs | 3 ++- primer-service/test/Tests/OpenAPI.hs | 25 ++++++++++++++++++++++++- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/primer-service/src/Primer/Pagination.hs b/primer-service/src/Primer/Pagination.hs index d2008d1c2..7ad2a9db2 100644 --- a/primer-service/src/Primer/Pagination.hs +++ b/primer-service/src/Primer/Pagination.hs @@ -13,6 +13,7 @@ module Primer.Pagination ( pagedDefaultClamp, -- the following are exposed for testing meta, + PaginatedMeta (PM), totalItems, pageSize, firstPage, @@ -161,7 +162,7 @@ data PaginatedMeta = PM , nextPage :: Maybe Positive , lastPage :: Positive } - deriving (Generic) + deriving (Generic, Show) instance FromJSON PaginatedMeta instance ToJSON PaginatedMeta instance ToSchema PaginatedMeta diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 54f9dbaa5..3c27f0383 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -34,7 +34,7 @@ import Primer.Gen.Core.Raw ( genValConName, ) import Primer.OpenAPI () -import Primer.Pagination (NonNeg, Positive, mkNonNeg, mkPositive) +import Primer.Pagination (NonNeg, PaginatedMeta (..), Positive, mkNonNeg, mkPositive) import Primer.Server (openAPIInfo) import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) @@ -155,3 +155,26 @@ genNonNeg = G.just $ mkNonNeg <$> G.int (R.linear 0 1000) tasty_NonNeg :: Property tasty_NonNeg = testToJSON genNonNeg + +genPaginatedMeta :: Gen PaginatedMeta +genPaginatedMeta = do + ti <- genNonNeg + ps <- genPositive + fp <- genPositive + pp <- G.maybe genPositive + tp <- genPositive + np <- G.maybe genPositive + lp <- genPositive + pure $ + PM + { totalItems = ti + , pageSize = ps + , firstPage = fp + , prevPage = pp + , thisPage = tp + , nextPage = np + , lastPage = lp + } + +tasty_PaginatedMeta :: Property +tasty_PaginatedMeta = testToJSON genPaginatedMeta From 8c6ce4fd7c08e73cbe548897162afdeeb09cb58c Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 10 Aug 2022 11:58:57 +0100 Subject: [PATCH 20/20] test: Paginated ToJSON/ToSchema --- primer-service/src/Primer/Pagination.hs | 25 ++++++++++++++++++------- primer-service/test/Tests/OpenAPI.hs | 5 ++++- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/primer-service/src/Primer/Pagination.hs b/primer-service/src/Primer/Pagination.hs index 7ad2a9db2..cf3aa80bd 100644 --- a/primer-service/src/Primer/Pagination.hs +++ b/primer-service/src/Primer/Pagination.hs @@ -6,13 +6,13 @@ module Primer.Pagination ( PaginationParams, Pagination (..), - Paginated, + -- Constructor and field accessors of Pagination exported for testing + Paginated (..), -- 'Positive' is abstract. Do not export its constructor. Positive (getPositive), mkPositive, pagedDefaultClamp, -- the following are exposed for testing - meta, PaginatedMeta (PM), totalItems, pageSize, @@ -21,7 +21,6 @@ module Primer.Pagination ( thisPage, nextPage, lastPage, - items, getNonNeg, NonNeg, mkNonNeg, @@ -36,7 +35,9 @@ import Optics ((?~)) import Primer.Database ( OffsetLimit (OL, limit, offset), Page (Page, pageContents, total), + Session, ) +import Primer.OpenAPI () import Servant ( DefaultErrorFormatters, ErrorFormatters, @@ -132,11 +133,21 @@ data Paginated a = Paginated { meta :: PaginatedMeta , items :: [a] } - deriving (Generic) + deriving (Generic, Show) -instance ToJSON a => ToJSON (Paginated a) -instance FromJSON a => FromJSON (Paginated a) -instance ToSchema a => ToSchema (Paginated a) +-- We may well need more instances than just Paginated Session in the future. +-- However, giving polymorphic `instance To... (Paginated a)` can generate +-- a schema inconsistent with the ToJSON for some 'a'. +-- This happens because aeson and openapi3 differ in their special handling +-- for lists (e.g. to serialise strings as strings rather than arrays of +-- characters). In particular the instance for 'Paginated Char' is broken. +-- See https://github.com/biocad/openapi3/issues/58 +-- We prefer to explicitly list the particular instances we need, rather +-- than having a known broken polymorphic instance, even if we expect to +-- never hit the broken case. +instance ToJSON (Paginated Session) +instance FromJSON (Paginated Session) +instance ToSchema (Paginated Session) -- Used solely for nice bounds in schema newtype NonNeg = NonNeg Int diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 3c27f0383..26a06c149 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -34,7 +34,7 @@ import Primer.Gen.Core.Raw ( genValConName, ) import Primer.OpenAPI () -import Primer.Pagination (NonNeg, PaginatedMeta (..), Positive, mkNonNeg, mkPositive) +import Primer.Pagination (NonNeg, Paginated (Paginated), PaginatedMeta (..), Positive, mkNonNeg, mkPositive) import Primer.Server (openAPIInfo) import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) @@ -178,3 +178,6 @@ genPaginatedMeta = do tasty_PaginatedMeta :: Property tasty_PaginatedMeta = testToJSON genPaginatedMeta + +tasty_Paginated :: Property +tasty_Paginated = testToJSON $ Paginated <$> genPaginatedMeta <*> G.list (R.linear 0 10) genSession