From 4723505eb13ded1ea9ae3a4468482adcb941802e Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 21 Mar 2019 18:14:09 +0100 Subject: [PATCH 1/2] add 'validateEveryJSON' from servant-swagger to control that API types we generate are actually compliant with the spec --- cardano-wallet.cabal | 5 + specifications/api/swagger.yaml | 236 +++++++++++----------- src/Cardano/Wallet/Api.hs | 2 +- test/unit/Cardano/Wallet/Api/TypesSpec.hs | 44 +++- 4 files changed, 167 insertions(+), 120 deletions(-) diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index c9de37c8afd..d9e4823e232 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -107,18 +107,23 @@ test-suite unit , containers , deepseq , exceptions + , file-embed , fmt , generic-arbitrary + , lens , hspec , hspec-golden-aeson , memory , process , QuickCheck , quickcheck-instances + , servant-swagger + , swagger2 , text , time-units , transformers , uuid-types + , yaml type: exitcode-stdio-1.0 hs-source-dirs: diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index 69334aad949..9b7ff76d959 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -370,127 +370,128 @@ networkInformationSoftwareUpdate: &networkInformationSoftwareUpdate ############################################################################# # # -# RESOURCES # +# DEFINITIONS # # # ############################################################################# -address: &address - type: object - required: - - id - - state - properties: - id: *addressId - state: *addressState - -networkInformation: &networkInformation - type: object - required: - - blockchainHeight - - localHeight - - ntpStatus - - software_update - - syncProgress - - tip - properties: - blockchainHeight: *networkInformationBlockchainHeight - localHeight: *networkInformationLocalHeight - ntpStatus: *networkInformationNtpStatus - software_update: *networkInformationSoftwareUpdate - syncProgress: *networkInformationSyncProgress - tip: *networkInformationTip - -stakePool: &stakePool - type: object - required: - - id - - ticker - - metrics - - profit_margin - properties: - id: *stakePoolId - ticker: *stakePoolTicker - metrics: *stakePoolMetrics - profit_margin: *stakePoolProfitMargin +definitions: + Address: &address + type: object + required: + - id + - state + properties: + id: *addressId + state: *addressState -transaction: &transaction - type: object - required: - - id - - amount - - depth - - direction - - inputs - - outputs - - status - properties: - id: *transactionId - amount: *transactionAmount - inserted_at: *transactionInsertedAt - depth: *transactionDepth - direction: *transactionDirection - inputs: *transactionInputs - outputs: *transactionOutputs - status: *transactionStatus - -wallet: &wallet - type: object - required: - - id - - address_pool_gap - - balance - - delegation - - name - - passphrase - - state - properties: - id: *walletId - address_pool_gap: *walletAddressPoolGap - balance: *walletBalance - delegation: *walletDelegation - name: *walletName - passphrase: *walletPassphraseInfo - state: *walletState + NetworkInformation: &networkInformation + type: object + required: + - blockchainHeight + - localHeight + - ntpStatus + - software_update + - syncProgress + - tip + properties: + blockchainHeight: *networkInformationBlockchainHeight + localHeight: *networkInformationLocalHeight + ntpStatus: *networkInformationNtpStatus + software_update: *networkInformationSoftwareUpdate + syncProgress: *networkInformationSyncProgress + tip: *networkInformationTip + + StakePool: &stakePool + type: object + required: + - id + - ticker + - metrics + - profit_margin + properties: + id: *stakePoolId + ticker: *stakePoolTicker + metrics: *stakePoolMetrics + profit_margin: *stakePoolProfitMargin -walletUTxOsStatistics: &walletUTxOsStatistics - type: object - required: - - total - - scale - - distribution - properties: - total: *amount - scale: - type: string - enum: - - log10 - distribution: - type: object - additionalProperties: - type: integer - example: - total: - quantity: 42000000 - unit: lovelace - scale: log10 - distribution: - 10: 1 - 100: 0 - 1000: 8 - 10000: 14 - 100000: 32 - 1000000: 3 - 10000000: 0 - 100000000: 12 - 1000000000: 0 - 10000000000: 0 - 100000000000: 0 - 1000000000000: 0 - 10000000000000: 0 - 100000000000000: 0 - 1000000000000000: 0 - 10000000000000000: 0 - 45000000000000000: 0 + Transaction: &transaction + type: object + required: + - id + - amount + - depth + - direction + - inputs + - outputs + - status + properties: + id: *transactionId + amount: *transactionAmount + inserted_at: *transactionInsertedAt + depth: *transactionDepth + direction: *transactionDirection + inputs: *transactionInputs + outputs: *transactionOutputs + status: *transactionStatus + + Wallet: &wallet + type: object + required: + - id + - address_pool_gap + - balance + - delegation + - name + - passphrase + - state + properties: + id: *walletId + address_pool_gap: *walletAddressPoolGap + balance: *walletBalance + delegation: *walletDelegation + name: *walletName + passphrase: *walletPassphraseInfo + state: *walletState + + WalletUTxOsStatistics: &walletUTxOsStatistics + type: object + required: + - total + - scale + - distribution + properties: + total: *amount + scale: + type: string + enum: + - log10 + distribution: + type: object + additionalProperties: + type: integer + example: + total: + quantity: 42000000 + unit: lovelace + scale: log10 + distribution: + 10: 1 + 100: 0 + 1000: 8 + 10000: 14 + 100000: 32 + 1000000: 3 + 10000000: 0 + 100000000: 12 + 1000000000: 0 + 10000000000: 0 + 100000000000: 0 + 1000000000000: 0 + 10000000000000: 0 + 100000000000000: 0 + 1000000000000000: 0 + 10000000000000000: 0 + 45000000000000000: 0 ############################################################################# @@ -588,7 +589,8 @@ parametersQuitStakePool: ¶metersQuitStakePool responsesErr: &responsesErr type: object - required: message + required: + - message properties: message: type: string diff --git a/src/Cardano/Wallet/Api.hs b/src/Cardano/Wallet/Api.hs index f5f9e628a1a..7a7a3080318 100644 --- a/src/Cardano/Wallet/Api.hs +++ b/src/Cardano/Wallet/Api.hs @@ -17,7 +17,7 @@ type Api = DeleteWallet :<|> GetWallet :<|> ListWallets type DeleteWallet = "wallets" :> Capture "walletId" WalletId - :> Delete '[JSON] NoContent + :> Delete '[] NoContent type GetWallet = "wallets" :> Capture "walletId" WalletId diff --git a/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 1d614cd8122..5c8e5ba8320 100644 --- a/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,6 +13,8 @@ import Prelude import Cardano.Wallet ( mkWalletName, walletNameMaxLength, walletNameMinLength ) +import Cardano.Wallet.Api + ( api ) import Cardano.Wallet.Api.Types ( AddressPoolGap , ApiT (..) @@ -24,20 +27,28 @@ import Cardano.Wallet.Api.Types , WalletPassphraseInfo (..) , WalletState (..) ) +import Control.Lens + ( at, (^.) ) import Control.Monad ( replicateM ) import Data.Aeson ( FromJSON, ToJSON ) import Data.Either ( rights ) +import Data.FileEmbed + ( embedFile ) import Data.Quantity ( Percentage, Quantity (..) ) +import Data.Swagger + ( NamedSchema (..), Swagger, ToSchema (..), definitions ) import Data.Typeable ( Typeable ) import Data.Word ( Word32, Word8 ) import Numeric.Natural ( Natural ) +import Servant.Swagger.Test + ( validateEveryToJSON ) import Test.Aeson.GenericSpecs ( GoldenDirectoryOption (CustomDirectoryName) , Proxy (Proxy) @@ -49,7 +60,7 @@ import Test.Aeson.GenericSpecs , useModuleNameAsSubDirectory ) import Test.Hspec - ( Spec, describe ) + ( Spec, describe, runIO ) import Test.QuickCheck ( Arbitrary (..), arbitraryBoundedEnum, arbitraryPrintableChar, choose ) import Test.QuickCheck.Arbitrary.Generic @@ -59,6 +70,7 @@ import Test.QuickCheck.Instances.Time import qualified Data.Text as T import qualified Data.UUID.Types as UUID +import qualified Data.Yaml as Yaml spec :: Spec spec = do @@ -75,7 +87,9 @@ spec = do roundtripAndGolden $ Proxy @ (ApiT WalletPassphraseInfo) roundtripAndGolden $ Proxy @ (ApiT WalletState) --- | Run JSON roundtrip & golden tests + describe "api matches the swagger specification" $ + validateEveryToJSON api + -- -- Golden tests files are generated automatically on first run. On later runs -- we check that the format stays the same. The golden files should be tracked @@ -164,3 +178,29 @@ instance Arbitrary WalletState where instance Arbitrary a => Arbitrary (ApiT a) where arbitrary = ApiT <$> arbitrary shrink = fmap ApiT . shrink . getApiT + + +{------------------------------------------------------------------------------- + ToSchema Instances +-------------------------------------------------------------------------------} + +specification :: Swagger +specification = + unsafeDecode bytes + where + unsafeDecode = + either + ( error + . ("Whoops! Failed to parse or find the api specification document: " <>) + . show + ) + id + . Yaml.decodeEither' + bytes = $(embedFile "specifications/api/swagger.yaml") + +instance ToSchema Wallet where + declareNamedSchema _ = case specification ^. definitions . at "Wallet" of + Nothing -> + error "unable to find the definition for 'Wallet' in the spec" + Just schema -> + return $ NamedSchema (Just "Wallet") schema From 25d5c9e8b6c70d0650c83188944c0896bb54a504 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 21 Mar 2019 20:04:02 +0100 Subject: [PATCH 2/2] implement a 'validateEveryPath' to add extra guarantees on our compliance with the API specification --- cardano-wallet.cabal | 3 +- test/unit/Cardano/Wallet/Api/TypesSpec.hs | 145 +++++++++++++++++++--- 2 files changed, 131 insertions(+), 17 deletions(-) diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index d9e4823e232..9edcf1e6a6b 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -110,13 +110,14 @@ test-suite unit , file-embed , fmt , generic-arbitrary - , lens , hspec , hspec-golden-aeson + , lens , memory , process , QuickCheck , quickcheck-instances + , servant-server , servant-swagger , swagger2 , text diff --git a/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 5c8e5ba8320..774aab8ef30 100644 --- a/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -1,10 +1,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Wallet.Api.TypesSpec (spec) where @@ -28,7 +32,7 @@ import Cardano.Wallet.Api.Types , WalletState (..) ) import Control.Lens - ( at, (^.) ) + ( Lens', at, (^.) ) import Control.Monad ( replicateM ) import Data.Aeson @@ -37,16 +41,34 @@ import Data.Either ( rights ) import Data.FileEmbed ( embedFile ) +import Data.Maybe + ( isJust ) import Data.Quantity ( Percentage, Quantity (..) ) import Data.Swagger - ( NamedSchema (..), Swagger, ToSchema (..), definitions ) + ( NamedSchema (..) + , Operation + , PathItem (..) + , Swagger + , ToSchema (..) + , definitions + , delete + , get + , patch + , paths + , post + , put + ) import Data.Typeable ( Typeable ) import Data.Word ( Word32, Word8 ) +import GHC.TypeLits + ( KnownSymbol, symbolVal ) import Numeric.Natural ( Natural ) +import Servant + ( (:<|>), (:>), Capture, StdMethod (..), Verb ) import Servant.Swagger.Test ( validateEveryToJSON ) import Test.Aeson.GenericSpecs @@ -60,7 +82,7 @@ import Test.Aeson.GenericSpecs , useModuleNameAsSubDirectory ) import Test.Hspec - ( Spec, describe, runIO ) + ( Spec, describe, it ) import Test.QuickCheck ( Arbitrary (..), arbitraryBoundedEnum, arbitraryPrintableChar, choose ) import Test.QuickCheck.Arbitrary.Generic @@ -75,11 +97,10 @@ import qualified Data.Yaml as Yaml spec :: Spec spec = do describe - ("can perform roundtrip JSON serialization & deserialization, " <> - "and match existing golden files") $ do + "can perform roundtrip JSON serialization & deserialization, \ + \and match existing golden files" $ do roundtripAndGolden $ Proxy @ Wallet roundtripAndGolden $ Proxy @ (ApiT AddressPoolGap) - roundtripAndGolden $ Proxy @ (ApiT WalletBalance) roundtripAndGolden $ Proxy @ (ApiT (WalletDelegation (ApiT PoolId))) roundtripAndGolden $ Proxy @ (ApiT WalletId) roundtripAndGolden $ Proxy @ (ApiT WalletName) @@ -87,9 +108,16 @@ spec = do roundtripAndGolden $ Proxy @ (ApiT WalletPassphraseInfo) roundtripAndGolden $ Proxy @ (ApiT WalletState) - describe "api matches the swagger specification" $ + describe + "verify that every type used with JSON content type in a servant API \ + \has compatible ToJSON and ToSchema instances using validateToJSON." $ validateEveryToJSON api + describe + "verify that every path specified by the servant server matches an \ + \existing path in the specification" $ + validateEveryPath api + -- -- Golden tests files are generated automatically on first run. On later runs -- we check that the format stays the same. The golden files should be tracked @@ -181,26 +209,111 @@ instance Arbitrary a => Arbitrary (ApiT a) where {------------------------------------------------------------------------------- - ToSchema Instances + Specification / Servant-Swagger Machinery + + Below is a bit of complicated API-Level stuff in order to achieve two things: + + 1/ Verify that every response from the API that actually has a JSON content + type returns a JSON instance that matches the JSON format described by the + specification (field names should be the same, and constraints on values as + well). + For this, we need three things: + - ToJSON instances on all those types, it's a given with the above + - Arbitrary instances on all those types, that reflect as much as + possible, all possible values of those types. Also given by using + 'genericArbitrary' whenever possible. + - ToSchema instances which tells how do a given type should be + represented. + The trick is for the later point. In a "classic" scenario, we would have + defined the `ToSchema` instances directly in Haskell on our types, which + eventually becomes a real pain to maintain. Instead, we have written the + spec by hand, and we want to check that our implementation matches it. + So, we "emulate" the 'ToSchema' instance by: + - Parsing the specification file (which is embedded at compile-time) + - Creating missing 'ToSchema' by doing lookups in that global schema + + 2/ The above verification is rather weak, because it just controls the return + types of endpoints, but not that those endpoints are somewhat valid. Thus, + we've also built another check 'validateEveryPath' which crawls our servant + API type, and checks whether every path we have in our API appears in the + specification. It does it by defining a few recursive type-classes to + crawl the API, and for each endpoint: + - construct the corresponding path (with verb) + - build an HSpec scenario which checks whether the path is present + This seemingly means that the identifiers we use in our servant paths (in + particular, those for path parameters) should exactly match the specs. + -------------------------------------------------------------------------------} +-- | Specification file, embedded at compile-time and decoded right away specification :: Swagger specification = unsafeDecode bytes where - unsafeDecode = - either - ( error - . ("Whoops! Failed to parse or find the api specification document: " <>) - . show - ) - id - . Yaml.decodeEither' bytes = $(embedFile "specifications/api/swagger.yaml") + unsafeDecode = either ( error . (msg <>) . show) id . Yaml.decodeEither' + msg = "Whoops! Failed to parse or find the api specification document: " +-- | Ad-hoc 'ToSchema' instance for the 'Wallet' definition, we simply look it +-- up from the specification. instance ToSchema Wallet where declareNamedSchema _ = case specification ^. definitions . at "Wallet" of Nothing -> error "unable to find the definition for 'Wallet' in the spec" Just schema -> return $ NamedSchema (Just "Wallet") schema + +-- | Verify that all servant endpoints are present and match the specification +class ValidateEveryPath api where + validateEveryPath :: Proxy api -> Spec + +instance {-# OVERLAPS #-} HasPath a => ValidateEveryPath a where + validateEveryPath proxy = do + let (verb, path) = getPath proxy + it (show verb <> " " <> path <> " exists in specification") $ do + case specification ^. paths . at path of + Just item | isJust (item ^. atMethod verb) -> return @IO () + _ -> fail "couldn't find path in specification" + +instance (HasPath a, ValidateEveryPath b) => ValidateEveryPath (a :<|> b) where + validateEveryPath _ = do + validateEveryPath (Proxy @a) + validateEveryPath (Proxy @b) + +-- | Extract the path of a given endpoint, in a format that is swagger-friendly +class HasPath api where + getPath :: Proxy api -> (StdMethod, String) + +instance (Method m) => HasPath (Verb m s ct a) where + getPath _ = (method (Proxy @m), "") + +instance (KnownSymbol path, HasPath sub) => HasPath (path :> sub) where + getPath _ = + let (verb, sub) = getPath (Proxy @sub) + in (verb, "/" <> symbolVal (Proxy :: Proxy path) <> sub) + +instance (KnownSymbol param, HasPath sub) => HasPath (Capture param t :> sub) + where + getPath _ = + let (verb, sub) = getPath (Proxy @sub) + in (verb, "/{" <> symbolVal (Proxy :: Proxy param) <> "}" <> sub) + +-- 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 :/ +instance Method 'GET where method _ = GET +instance Method 'POST where method _ = POST +instance Method 'PUT where method _ = PUT +instance Method 'DELETE where method _ = DELETE +instance Method 'PATCH where method _ = PATCH +class Method (m :: StdMethod) where + method :: Proxy m -> StdMethod + +atMethod :: StdMethod -> Lens' PathItem (Maybe Operation) +atMethod = \case + GET -> get + POST -> post + PUT -> put + DELETE -> delete + PATCH -> patch + m -> error $ "atMethod: unsupported method: " <> show m