Add roundtripAndGoldenPerType $ Proxy @Api

Tests all Aeson instances in the Api automatically.

src/Cardano/Wallet/Api.hs

@@ -4,7 +4,7 @@
 module Cardano.Wallet.Api where
 
 import Cardano.Wallet.Api.Types
-    ( Wallet, WalletId )
+    ( ApiT, Wallet, WalletId )
 import Data.Proxy
     ( Proxy (..) )
 import Servant.API
@@ -16,11 +16,11 @@ api = Proxy
 type Api = DeleteWallet :<|> GetWallet :<|> ListWallets
 
 type DeleteWallet = "wallets"
-    :> Capture "walletId" WalletId
+    :> Capture "walletId" (ApiT WalletId)
     :> Delete '[] NoContent
 
 type GetWallet = "wallets"
-    :> Capture "walletId" WalletId
+    :> Capture "walletId" (ApiT WalletId)
     :> Get '[JSON] Wallet
 
 type ListWallets = "wallets"

test/unit/Cardano/Wallet/Api/TypesSpec.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -16,7 +18,7 @@ module Cardano.Wallet.Api.TypesSpec (spec) where
 import Prelude
 
 import Cardano.Wallet.Api
-    ( api )
+    ( Api, api )
 import Cardano.Wallet.Api.Types
     ( AddressPoolGap
     , ApiT (..)
@@ -34,7 +36,7 @@ import Cardano.Wallet.Primitive.Model
 import Control.Lens
     ( Lens', at, (^.) )
 import Control.Monad
-    ( replicateM )
+    ( mapM_, replicateM )
 import Data.Aeson
     ( FromJSON, ToJSON )
 import Data.Either
@@ -45,6 +47,8 @@ import Data.Maybe
     ( isJust )
 import Data.Quantity
     ( Percentage, Quantity (..) )
+import Data.Set
+    ( Set )
 import Data.Swagger
     ( NamedSchema (..)
     , Operation
@@ -60,15 +64,15 @@ import Data.Swagger
     , put
     )
 import Data.Typeable
-    ( Typeable )
+    ( TypeRep, Typeable )
 import Data.Word
     ( Word32, Word8 )
 import GHC.TypeLits
     ( KnownSymbol, symbolVal )
 import Numeric.Natural
     ( Natural )
 import Servant
-    ( (:<|>), (:>), Capture, StdMethod (..), Verb )
+    ( (:<|>), (:>), Capture, NoContent, StdMethod (..), Verb )
 import Servant.Swagger.Test
     ( validateEveryToJSON )
 import Test.Aeson.GenericSpecs
@@ -82,15 +86,17 @@ import Test.Aeson.GenericSpecs
     , useModuleNameAsSubDirectory
     )
 import Test.Hspec
-    ( Spec, describe, it )
+    ( Spec, describe, it, runIO )
 import Test.QuickCheck
     ( Arbitrary (..), arbitraryBoundedEnum, arbitraryPrintableChar, choose )
 import Test.QuickCheck.Arbitrary.Generic
     ( genericArbitrary, genericShrink )
 import Test.QuickCheck.Instances.Time
     ()
 
+import qualified Data.Set as Set
 import qualified Data.Text as T
+import qualified Data.Typeable
 import qualified Data.UUID.Types as UUID
 import qualified Data.Yaml as Yaml
 
@@ -99,10 +105,14 @@ spec = do
     describe
         "can perform roundtrip JSON serialization & deserialization, \
         \and match existing golden files" $ do
-            roundtripAndGolden $ Proxy @ Wallet
+        describe "...for every type used in the Api" $ do
+            let s = roundtripAndGoldenPerType $ Proxy @Api
+            runIO $ print (Set.map typeRep s)
+            run s
+
+        describe "...and for these additional types" $ do
             roundtripAndGolden $ Proxy @ (ApiT AddressPoolGap)
             roundtripAndGolden $ Proxy @ (ApiT (WalletDelegation (ApiT PoolId)))
-            roundtripAndGolden $ Proxy @ (ApiT WalletId)
             roundtripAndGolden $ Proxy @ (ApiT WalletName)
             roundtripAndGolden $ Proxy @ (ApiT WalletBalance)
             roundtripAndGolden $ Proxy @ (ApiT WalletPassphraseInfo)
@@ -298,6 +308,82 @@ instance (KnownSymbol param, HasPath sub) => HasPath (Capture param t :> sub)
         let (verb, sub) = getPath (Proxy @sub)
         in (verb, "/{" <> symbolVal (Proxy :: Proxy param) <> "}" <> sub)
 
+
+
+{-------------------------------------------------------------------------------
+               roundtripAndGolden for an entire Api type
+-------------------------------------------------------------------------------}
+
+run :: Set AesonTestCase ->  Spec
+run s = mapM_ typeSpec $ Set.toList s
+
+
+aesonTestCase :: Checkable a => Proxy a -> AesonTestCase
+aesonTestCase proxy =
+    AesonTestCase
+    { typeRep = Data.Typeable.typeRep proxy
+    , typeSpec = roundtripAndGolden proxy
+    }
+
+data AesonTestCase = AesonTestCase
+    { typeRep :: TypeRep
+    , typeSpec :: Spec
+    }
+
+instance Eq AesonTestCase where
+    a == b = (typeRep a) == (typeRep b)
+
+instance Ord AesonTestCase where
+    compare a b = compare (typeRep a) (typeRep b)
+
+class JsonTestable api where
+    roundtripAndGoldenPerType :: Proxy api -> Set AesonTestCase
+
+type Checkable a = (Typeable a, Arbitrary a, ToJSON a, FromJSON a)
+
+-- | Run tests on the return-type
+instance {-# OVERLAPS #-} (Checkable a, Method m)
+    => JsonTestable (Verb m s ct a) where
+    roundtripAndGoldenPerType _ =
+        Set.singleton $ aesonTestCase $ Proxy @a
+
+instance {-# OVERLAPS #-} (Checkable a, Method m)
+    => JsonTestable (Verb m s ct [a]) where
+    roundtripAndGoldenPerType _ =
+        Set.singleton $ aesonTestCase $ Proxy @a
+
+-- | Run tests on captured types
+instance (JsonTestable b, JsonTestable t, KnownSymbol param)
+    => JsonTestable (Capture param t :> b) where
+    roundtripAndGoldenPerType _ =
+        Set.union
+            (roundtripAndGoldenPerType $ Proxy @t)
+            (roundtripAndGoldenPerType $ Proxy @b)
+
+instance {-# OVERLAPS #-} (Checkable a) => JsonTestable (a) where
+    roundtripAndGoldenPerType _ =
+        Set.singleton $ aesonTestCase $ Proxy @a
+
+instance {-# OVERLAPS #-} (Checkable a) => JsonTestable ([a]) where
+    roundtripAndGoldenPerType _ = do
+        Set.singleton $ aesonTestCase $ Proxy @a
+
+-- | Don't run tests on NoContent
+instance Method m => JsonTestable (Verb m s ct NoContent) where
+    roundtripAndGoldenPerType _ = Set.empty
+
+instance (JsonTestable b, KnownSymbol a) => JsonTestable (a :> b) where
+     roundtripAndGoldenPerType _ = do
+        roundtripAndGoldenPerType (Proxy @b)
+
+instance (JsonTestable a, JsonTestable b) => JsonTestable (a :<|> b) where
+     roundtripAndGoldenPerType _ = do
+        Set.union
+            (roundtripAndGoldenPerType $ Proxy @a)
+            (roundtripAndGoldenPerType $ Proxy @b)
+
+
+
 -- A way to demote 'StdMethod' back to the world of values. Servant provides a
 -- 'reflectMethod' that does just that, but demote types to raw 'ByteString' for
 -- an unknown reason :/