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" ]; }; diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index 198f594c6..29bc6ba4d 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 @@ -40,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 @@ -175,15 +174,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/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 2998fa91c..3b2434e3c 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,14 +6,23 @@ module Primer.OpenAPI ( -- $orphanInstances ) where -import Data.OpenApi (ToSchema) -import Data.Text (Text) -import Data.Typeable (Typeable) +import Data.OpenApi (ToSchema (declareNamedSchema), fromAesonOptions, genericDeclareNamedSchema) +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, PrimerJSON) import Primer.Name (Name) +import Foreword + -- $orphanInstances -- -- We define some OpenApi orphan instances in primer-service, to avoid @@ -20,6 +30,13 @@ import Primer.Name (Name) -- 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 @@ -31,14 +48,21 @@ 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 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/src/Primer/Pagination.hs b/primer-service/src/Primer/Pagination.hs index d03aafa18..cf3aa80bd 100644 --- a/primer-service/src/Primer/Pagination.hs +++ b/primer-service/src/Primer/Pagination.hs @@ -6,13 +6,14 @@ 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, firstPage, @@ -21,7 +22,8 @@ module Primer.Pagination ( nextPage, lastPage, getNonNeg, - items, + NonNeg, + mkNonNeg, ) where import Foreword @@ -33,7 +35,9 @@ import Optics ((?~)) import Primer.Database ( OffsetLimit (OL, limit, offset), Page (Page, pageContents, total), + Session, ) +import Primer.OpenAPI () import Servant ( DefaultErrorFormatters, ErrorFormatters, @@ -59,7 +63,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 @@ -129,15 +133,25 @@ data Paginated a = Paginated { meta :: PaginatedMeta , items :: [a] } - deriving (Generic) - -instance ToJSON a => ToJSON (Paginated a) -instance FromJSON a => FromJSON (Paginated a) -instance ToSchema a => ToSchema (Paginated a) + deriving (Generic, Show) + +-- 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 - 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 +160,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 @@ -155,7 +173,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 4e244689d..26a06c149 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -2,8 +2,41 @@ module Tests.OpenAPI where 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 +import Primer.API ( + Def (Def), + Module (Module), + NodeBody (BoxBody, NoBody, TextBody), + NodeFlavor, + Prog (Prog), + Tree, + viewTreeExpr, + viewTreeType, + ) +import Primer.Core (ID (ID)) +import Primer.Database (Session (Session), SessionName, safeMkSessionName) +import Primer.Gen.Core.Raw ( + ExprGen, + evalExprGen, + genExpr, + genGVarName, + genLVarName, + genModuleName, + genName, + genTyConName, + genType, + genValConName, + ) +import Primer.OpenAPI () +import Primer.Pagination (NonNeg, Paginated (Paginated), PaginatedMeta (..), Positive, mkNonNeg, mkPositive) import Primer.Server (openAPIInfo) +import Tasty (Property, property) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) @@ -21,3 +54,130 @@ 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 + +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) + +tasty_Name :: Property +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 + +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 = evalExprGen 0 $ G.choice [genExprTree, genTypeTree] + +genExprTree :: ExprGen Tree +genExprTree = viewTreeExpr <$> genExpr + +genTypeTree :: ExprGen Tree +genTypeTree = viewTreeType <$> genType + +tasty_NodeBody :: Property +tasty_NodeBody = + testToJSON $ + G.choice + [ TextBody <$> G.text (R.linear 1 20) G.unicode + , BoxBody <$> genTree + , pure NoBody + ] + +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 + +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 + +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 + +genNonNeg :: Gen NonNeg +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 + +tasty_Paginated :: Property +tasty_Paginated = testToJSON $ Paginated <$> genPaginatedMeta <*> G.list (R.linear 0 10) genSession diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index bb196791b..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": { @@ -31,11 +50,15 @@ "type": "boolean" }, "modname": { - "$ref": "#/components/schemas/ModuleName" + "items": { + "type": "string" + }, + "minItems": 1, + "type": "array" }, "types": { "items": { - "type": "string" + "$ref": "#/components/schemas/GlobalName" }, "type": "array" } @@ -48,21 +71,6 @@ ], "type": "object" }, - "ModuleName": { - "properties": { - "unModuleName": { - "items": { - "type": "string" - }, - "minItems": 1, - "type": "array" - } - }, - "required": [ - "unModuleName" - ], - "type": "object" - }, "NodeBody": { "oneOf": [ { diff --git a/primer/gen/Primer/Gen/Core/Raw.hs b/primer/gen/Primer/Gen/Core/Raw.hs index 3adfcb8aa..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, @@ -13,6 +14,8 @@ module Primer.Gen.Core.Raw ( genLVarName, genTyVarName, genTyConName, + genValConName, + genGVarName, genKind, genType, genExpr, @@ -28,6 +31,7 @@ import Primer.Core ( CaseBranch' (CaseBranch), Expr, Expr' (..), + GVarName, ID (..), Kind (..), LVarName, @@ -110,7 +114,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 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 diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 9d2b950d4..da9374ccf 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -24,11 +24,11 @@ module Primer.API ( listSessions, getVersion, Tree, - NodeBody, + NodeBody (..), NodeFlavor, - Prog, - Module, - Def, + Prog (Prog), + Module (Module), + Def (Def), getProgram, getProgram', getSessionName, @@ -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' @@ -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' @@ -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' @@ -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