test: ToJSON/ToSchema instances agree

flake.nix

@@ -531,6 +531,7 @@
             "primer/test/outputs"
             "primer-service/test/outputs"
             ".buildkite/"
+            "primer-service/primer-service.cabal"
           ];
         };
 

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,17 +13,15 @@ category:      Web
 library
   exposed-modules:
     Primer.Client
+    Primer.OpenAPI
     Primer.Pagination
     Primer.Servant.API
     Primer.Servant.OpenAPI
     Primer.Servant.Types
     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

primer-service/src/Primer/OpenAPI.hs

@@ -1,25 +1,42 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Primer.OpenAPI (
   -- * Orphan instances
   -- $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
 -- pulling in the openapi3 dependency into primer core. This is necessary to
 -- 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

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