From 8899c1f9ccec73b75c9b7446fed1595c362ff7a9 Mon Sep 17 00:00:00 2001 From: Ante Kegalj Date: Thu, 28 Jun 2018 12:40:00 +0200 Subject: [PATCH] Akegalj/co 319/swagger account index (#3086) * [CO-319] Fix account index swagger example * [CO-319] Add roundtrip tests * [CO-319] Fix recursive buildable instances * [CO-319] Use strongly typed error * [CO-319] Remove duplication in 'renderAccountIndexError' * [CO-319] Distangle V1/Errors This makes it now possible to import V1/Errors from the V1/Types module and leverage errors from this module. One thing is still unclear to me: Why Errors isn't defined in V1/Types already? There's a circular dependency between V1/Response and V1/Types if we go this way, as well as between V1/Migration and V1/Types. Nevertheless, it would make sense to have three data-types here: - WalletError (defined in V1/Types) - MigrationError (defined in V1/Types) - JSONParsingError (defined in Response) This way, we could remove the conflicting constructor from WalletError and remove the need for an extra module here. It will also makes thing clearer * [CO-319] Make V1/Error part of V1/Types To realize this, we had to extract JSONValidationFailed and MigrationFailed constructor from WalletError. They're now defined as constructor in different data-types (resp. JSONValidationError and MigrationError). * [CO-319] Solve rebase conflicts * [CO-319] Correctly format (jsend) newtype errors This is rather ugly and could probably be achieved nicely with a better understanding of the Generics.SOP library. As far as I could tell, there's no easy way to retrieve 'Tag' for single constructor (cf: 'For a datatype with a single constructor we do not need to tag values with their constructor; but for a datatype with multiple constructors we do. ') --- wallet-new/cardano-sl-wallet-new.cabal | 3 +- wallet-new/integration/TransactionSpecs.hs | 8 +- wallet-new/integration/WalletSpecs.hs | 2 +- wallet-new/src/Cardano/Wallet/API/Response.hs | 68 +++- .../src/Cardano/Wallet/API/V1/Errors.hs | 259 ++------------- .../src/Cardano/Wallet/API/V1/Generic.hs | 53 ++- .../src/Cardano/Wallet/API/V1/Headers.hs | 11 + .../Wallet/API/V1/LegacyHandlers/Addresses.hs | 1 - .../API/V1/LegacyHandlers/Transactions.hs | 21 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 3 +- .../Cardano/Wallet/API/V1/Migration/Types.hs | 98 ++++-- .../src/Cardano/Wallet/API/V1/Swagger.hs | 78 +++-- .../Cardano/Wallet/API/V1/Swagger/Example.hs | 4 +- wallet-new/src/Cardano/Wallet/API/V1/Types.hs | 305 ++++++++++++++++-- wallet-new/src/Cardano/Wallet/Client.hs | 9 +- .../src/Cardano/Wallet/Server/Plugins.hs | 17 +- wallet-new/test/MarshallingSpec.hs | 36 ++- 17 files changed, 597 insertions(+), 379 deletions(-) create mode 100644 wallet-new/src/Cardano/Wallet/API/V1/Headers.hs diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 10dfb1b0482..4eeacb31275 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -39,9 +39,10 @@ library Cardano.Wallet.API.V1 Cardano.Wallet.API.V1.Accounts Cardano.Wallet.API.V1.Addresses - Cardano.Wallet.API.V1.Errors Cardano.Wallet.API.V1.Generic + Cardano.Wallet.API.V1.Errors Cardano.Wallet.API.V1.Handlers + Cardano.Wallet.API.V1.Headers Cardano.Wallet.API.V1.Info Cardano.Wallet.API.V1.LegacyHandlers Cardano.Wallet.API.V1.LegacyHandlers.Accounts diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index 008b3010cbc..ad9871143c8 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -5,14 +5,14 @@ module TransactionSpecs (transactionSpecs) where import Universum hiding (log) -import Cardano.Wallet.API.V1.Errors hiding (describe) import Cardano.Wallet.Client.Http +import Control.Concurrent (threadDelay) import Control.Lens -import qualified Pos.Core as Core import Test.Hspec - -import Control.Concurrent (threadDelay) import Text.Show.Pretty (ppShow) + +import qualified Pos.Core as Core + import Util {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index e4def66325d..7542869192f 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -5,8 +5,8 @@ module WalletSpecs (walletSpecs) where import Universum +import Cardano.Wallet.API.V1.Types (WalletError (WalletAlreadyExists)) import Cardano.Wallet.Client.Http -import Cardano.Wallet.API.V1.Errors (WalletError (WalletAlreadyExists)) import Control.Lens import Test.Hspec diff --git a/wallet-new/src/Cardano/Wallet/API/Response.hs b/wallet-new/src/Cardano/Wallet/API/Response.hs index af04b1eb877..fdcc0fb4c30 100644 --- a/wallet-new/src/Cardano/Wallet/API/Response.hs +++ b/wallet-new/src/Cardano/Wallet/API/Response.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} module Cardano.Wallet.API.Response ( Metadata (..) , ResponseStatus(..) , WalletResponse(..) + , JSONValidationError(..) -- * Generating responses for collections , respondWith -- * Generating responses for single resources @@ -13,33 +15,37 @@ module Cardano.Wallet.API.Response ( ) where import Prelude -import Universum (Buildable, decodeUtf8, toText, (<>)) +import Universum (Buildable, Exception, Text, decodeUtf8, toText, (<>)) +import Cardano.Wallet.API.Indices (Indexable', IxSet') +import Cardano.Wallet.API.Request (RequestParams (..)) +import Cardano.Wallet.API.Request.Filter (FilterOperations (..)) +import Cardano.Wallet.API.Request.Pagination (Page (..), PaginationMetadata (..), + PaginationParams (..), PerPage (..)) +import Cardano.Wallet.API.Request.Sort (SortOperations (..)) +import Cardano.Wallet.API.Response.Filter.IxSet as FilterBackend import Cardano.Wallet.API.Response.JSend (ResponseStatus (..)) +import Cardano.Wallet.API.Response.Sort.IxSet as SortBackend +import Cardano.Wallet.API.V1.Errors (ToServantError (..)) +import Cardano.Wallet.API.V1.Generic (gparseJsend, gtoJsend) import Control.Lens import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.TH -import qualified Data.Char as Char import Data.Swagger as S -import qualified Data.Text.Buildable import Data.Typeable import Formatting (bprint, build, (%)) +import Generics.SOP.TH (deriveGeneric) import GHC.Generics (Generic) -import qualified Serokell.Aeson.Options as Serokell +import Servant (err400) import Servant.API.ContentTypes (Accept (..), JSON, MimeRender (..), MimeUnrender (..), OctetStream) import Test.QuickCheck -import Cardano.Wallet.API.Indices (Indexable', IxSet') -import Cardano.Wallet.API.Request (RequestParams (..)) -import Cardano.Wallet.API.Request.Filter (FilterOperations (..)) -import Cardano.Wallet.API.Request.Pagination (Page (..), PaginationMetadata (..), - PaginationParams (..), PerPage (..)) -import Cardano.Wallet.API.Request.Sort (SortOperations (..)) -import Cardano.Wallet.API.Response.Filter.IxSet as FilterBackend -import Cardano.Wallet.API.Response.Sort.IxSet as SortBackend -import Cardano.Wallet.API.V1.Errors (WalletError (JSONValidationFailed)) +import qualified Data.Char as Char +import qualified Data.Text.Buildable +import qualified Serokell.Aeson.Options as Serokell + -- | Extra information associated with an HTTP response. data Metadata = Metadata @@ -136,7 +142,7 @@ respondWith :: (Monad m, Indexable' a) -> m (WalletResponse [a]) respondWith RequestParams{..} fops sorts generator = do (theData, paginationMetadata) <- paginate rpPaginationParams . sortData sorts . applyFilters fops <$> generator - return $ WalletResponse { + return WalletResponse { wrData = theData , wrStatus = SuccessStatus , wrMeta = Metadata paginationMetadata @@ -182,3 +188,37 @@ instance Accept ValidJSON where instance ToJSON a => MimeRender ValidJSON a where mimeRender _ = mimeRender (Proxy @ JSON) + + +-- +-- Error from parsing / validating JSON inputs +-- + +newtype JSONValidationError + = JSONValidationFailed Text + deriving (Show, Eq) + +deriveGeneric ''JSONValidationError + +instance ToJSON JSONValidationError where + toJSON = gtoJsend ErrorStatus + +instance FromJSON JSONValidationError where + parseJSON = gparseJsend + +instance Exception JSONValidationError + +instance Arbitrary JSONValidationError where + arbitrary = oneof + [ pure $ JSONValidationFailed "JSON validation failed." + ] + +instance Buildable JSONValidationError where + build = \case + JSONValidationFailed _ -> + bprint "Couldn't decode a JSON input." + +instance ToServantError JSONValidationError where + declareServantError = \case + JSONValidationFailed _ -> + err400 diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Errors.hs b/wallet-new/src/Cardano/Wallet/API/V1/Errors.hs index f6044fc4bc5..78352ca4bf5 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Errors.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Errors.hs @@ -1,246 +1,27 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Cardano.Wallet.API.V1.Errors where import Universum -import Data.Aeson -import Data.List.NonEmpty (NonEmpty ((:|))) -import Generics.SOP.TH (deriveGeneric) -import qualified Network.HTTP.Types as HTTP -import Servant -import Test.QuickCheck (Arbitrary (..), oneof) - -import qualified Pos.Client.Txp.Util as TxError -import qualified Pos.Core as Core -import qualified Pos.Crypto.Hashing as Crypto -import qualified Pos.Data.Attributes as Core - -import Cardano.Wallet.API.Response.JSend (ResponseStatus (ErrorStatus)) -import Cardano.Wallet.API.V1.Generic (gparseJsend, gtoJsend) -import Cardano.Wallet.API.V1.Types (SyncPercentage, SyncProgress (..), V1 (..), WalletId, - exampleWalletId, mkEstimatedCompletionTime, - mkSyncPercentage, mkSyncThroughput) - --- --- Error handling --- - --- | Type representing any error which might be thrown by wallet. --- --- Errors are represented in JSON in the JSend format (): --- ``` --- { --- "status": "error" --- "message" : , --- "diagnostic" : --- } --- ``` --- where `` is a string containing name of error's constructor (e. g. `NotEnoughMoney`), --- and `` is an object containing additional error data. --- Additional data contains constructor fields, field names are record field names without --- a `we` prefix, e. g. for `OutputIsRedeem` error "diagnostic" field will be the following: --- ``` --- { --- "address" :
--- } --- ``` --- --- Additional data in constructor should be represented as record fields. --- Otherwise TemplateHaskell will raise an error. --- --- If constructor does not have additional data (like in case of `WalletNotFound` error), --- then "diagnostic" field will be empty object. --- --- TODO: change fields' types to actual Cardano core types, like `Coin` and `Address` -data WalletError = - NotEnoughMoney { weNeedMore :: !Int } - | OutputIsRedeem { weAddress :: !(V1 Core.Address) } - | MigrationFailed { weDescription :: !Text } - | JSONValidationFailed { weValidationError :: !Text } - | UnknownError { weMsg :: !Text } - | InvalidAddressFormat { weMsg :: !Text } - | WalletNotFound - -- FIXME(akegalj): https://iohk.myjetbrains.com/youtrack/issue/CSL-2496 - | WalletAlreadyExists { weWalletId :: WalletId } - | AddressNotFound - | TxFailedToStabilize - | TxRedemptionDepleted - | TxSafeSignerNotFound { weAddress :: V1 Core.Address } - | MissingRequiredParams { requiredParams :: NonEmpty (Text, Text) } - | WalletIsNotReadyToProcessPayments { weStillRestoring :: SyncProgress } - -- ^ The @Wallet@ where a @Payment@ is being originated is not fully - -- synced (its 'WalletSyncState' indicates it's either syncing or - -- restoring) and thus cannot accept new @Payment@ requests. - | NodeIsStillSyncing { wenssStillSyncing :: SyncPercentage } - -- ^ The backend couldn't process the incoming request as the underlying - -- node is still syncing with the blockchain. - deriving (Show, Eq) - -convertTxError :: TxError.TxError -> WalletError -convertTxError err = case err of - TxError.NotEnoughMoney coin -> - NotEnoughMoney . fromIntegral . Core.getCoin $ coin - TxError.NotEnoughAllowedMoney coin -> - NotEnoughMoney . fromIntegral . Core.getCoin $ coin - TxError.FailedToStabilize -> - TxFailedToStabilize - TxError.OutputIsRedeem addr -> - OutputIsRedeem (V1 addr) - TxError.RedemptionDepleted -> - TxRedemptionDepleted - TxError.SafeSignerNotFound addr -> - TxSafeSignerNotFound (V1 addr) - TxError.GeneralTxError txt -> - UnknownError txt - --- --- Instances for `WalletError` - --- deriveWalletErrorJSON ''WalletError -deriveGeneric ''WalletError - -instance ToJSON WalletError where - toJSON = gtoJsend ErrorStatus - -instance FromJSON WalletError where - parseJSON = gparseJsend - -instance Exception WalletError where +import Cardano.Wallet.API.V1.Headers (applicationJson) +import Data.Aeson (ToJSON, encode) +import Formatting (build, sformat) +import Servant (ServantErr (..)) --- TODO: generate `Arbitrary` instance with TH too? -instance Arbitrary WalletError where - arbitrary = oneof (map pure sample) - - --- --- Helpers --- - -type ErrorName = Text -type ErrorCode = Int -type ErrorExample = Value - - -sampleSyncProgress :: SyncProgress -sampleSyncProgress = SyncProgress { - spEstimatedCompletionTime = mkEstimatedCompletionTime 3000 - , spThroughput = mkSyncThroughput (Core.BlockCount 400) - , spPercentage = mkSyncPercentage 80 -} - -sampleAddress :: V1 Core.Address -sampleAddress = V1 $ Core.Address - { Core.addrRoot = - Crypto.unsafeAbstractHash ("asdfasdf" :: String) - , Core.addrAttributes = - Core.mkAttributes $ Core.AddrAttributes Nothing Core.BootstrapEraDistr - , Core.addrType = - Core.ATPubKey - } - --- | Sample of errors we use for documentation -sample :: [WalletError] -sample = - [ NotEnoughMoney 1400 - , OutputIsRedeem sampleAddress - , MigrationFailed "Migration failed" - , JSONValidationFailed "Expected String, found Null." - , UnknownError "Unknown error" - , InvalidAddressFormat "Invalid base58 representation." - , WalletNotFound - , WalletAlreadyExists exampleWalletId - , AddressNotFound - , MissingRequiredParams (("wallet_id", "walletId") :| []) - , WalletIsNotReadyToProcessPayments sampleSyncProgress - , NodeIsStillSyncing (mkSyncPercentage 42) - ] - - --- | Give a short description of an error -describe :: WalletError -> String -describe = \case - NotEnoughMoney _ -> - "Not enough available coins to proceed." - OutputIsRedeem _ -> - "One of the TX outputs is a redemption address." - MigrationFailed _ -> - "Error while migrating a legacy type into the current version." - JSONValidationFailed _ -> - "Couldn't decode a JSON input." - UnknownError _ -> - "Unexpected internal error." - InvalidAddressFormat _ -> - "Provided address format is not valid." - WalletNotFound -> - "Reference to an unexisting wallet was given." - WalletAlreadyExists _ -> - "Can't create or restore a wallet. The wallet already exists." - AddressNotFound -> - "Reference to an unexisting address was given." - MissingRequiredParams _ -> - "Missing required parameters in the request payload." - WalletIsNotReadyToProcessPayments _ -> - "This wallet is restoring, and it cannot send new transactions until restoration completes." - NodeIsStillSyncing _ -> - "The node is still syncing with the blockchain, and cannot process the request yet." - TxRedemptionDepleted -> - "The redemption address was already used." - TxSafeSignerNotFound _ -> - "The safe signer at the specified address was not found." - TxFailedToStabilize -> - "We were unable to find a set of inputs to satisfy this transaction." - - --- | Convert wallet errors to Servant errors -toServantError :: WalletError -> ServantErr -toServantError err = - mkServantErr $ case err of - NotEnoughMoney{} -> - err403 - OutputIsRedeem{} -> - err403 - MigrationFailed{} -> - err422 - JSONValidationFailed{} -> - err400 - UnknownError{} -> - err500 - WalletNotFound{} -> - err404 - WalletAlreadyExists{} -> - err403 - InvalidAddressFormat{} -> - err401 - AddressNotFound{} -> - err404 - MissingRequiredParams{} -> - err400 - WalletIsNotReadyToProcessPayments{} -> - err403 - NodeIsStillSyncing{} -> - err412 -- Precondition failed - TxFailedToStabilize{} -> - err500 - TxRedemptionDepleted{} -> - err400 - TxSafeSignerNotFound{} -> - err400 - where - mkServantErr serr@ServantErr{..} = serr - { errBody = encode err - , errHeaders = applicationJson : errHeaders - } +import qualified Network.HTTP.Types as HTTP -toHttpStatus :: WalletError -> HTTP.Status -toHttpStatus err = HTTP.Status (errHTTPCode $ toServantError err) - (encodeUtf8 $ describe err) --- | Generates the @Content-Type: application/json@ 'HTTP.Header'. -applicationJson :: HTTP.Header -applicationJson = - let [hdr] = getHeaders (addHeader "application/json" mempty :: (Headers '[Header "Content-Type" String] String)) - in hdr +class (ToJSON e) => ToServantError e where + declareServantError :: e -> ServantErr + toServantError :: e -> ServantErr + toServantError err = + mkServantErr (declareServantError err) + where + mkServantErr serr@ServantErr{..} = serr + { errBody = encode err + , errHeaders = applicationJson : errHeaders + } + +class (ToServantError e, Buildable e) => ToHttpErrorStatus e where + toHttpErrorStatus :: e -> HTTP.Status + toHttpErrorStatus err = + HTTP.Status (errHTTPCode $ toServantError err) (encodeUtf8 $ sformat build err) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs b/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs index a75549e7ac9..743d7d7f111 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Generic.hs @@ -14,8 +14,7 @@ import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V import Generics.SOP -import Generics.SOP.JSON (JsonInfo (..), JsonOptions (..), Tag (..), defaultJsonOptions, - jsonInfo) +import Generics.SOP.JSON (JsonInfo (..), JsonOptions (..), Tag (..), defaultJsonOptions) import Cardano.Wallet.API.Response.JSend (ResponseStatus (..)) import Cardano.Wallet.Util (mkJsonKey) @@ -42,24 +41,46 @@ allpf = Proxy -- JSON encoding/decoding -- --- | Returns `JsonInfo` for type (from `json-sop` package) --- for representing a type in a JSend format. -jsendInfo - :: forall a. (HasDatatypeInfo a, SListI (Code a)) - => Proxy a -> NP JsonInfo (Code a) -jsendInfo pa = jsonInfo pa $ defaultJsonOptions - { jsonFieldName = const mkJsonKey - } - -- | Generic method which makes JSON `Value` from a Haskell value in -- JSend format. gtoJsend :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a)) => ResponseStatus -> a -> Value -gtoJsend rs a = hcollapse $ - hcliftA2 allpt (gtoJsend' rs) - (jsendInfo (Proxy :: Proxy a)) - (unSOP $ from a) +gtoJsend rs a = + hcollapse $ + hcliftA2 allpt (gtoJsend' rs) + (jsendInfo (Proxy :: Proxy a) jsendOptions) + (unSOP $ from a) + +-- | Our custom naming options +jsendOptions :: JsonOptions +jsendOptions = defaultJsonOptions + { jsonFieldName = const mkJsonKey + } + +-- | Slightly modified version compared to Generics.SOP.JSON, we also tag +-- single-constructor (ADT with one constructor and newtype) because we +-- rely on that information to wrap the corresponding json in a jsend payload. +jsendInfo :: forall a. (HasDatatypeInfo a, SListI (Code a)) + => Proxy a -> JsonOptions -> NP JsonInfo (Code a) +jsendInfo pa opts = + case datatypeInfo pa of + Newtype _ t _ -> JsonOne (Tag $ jsonTagName opts t) :* Nil + ADT _ n cs -> hliftA (jsonInfoFor opts n (Tag . jsonTagName opts)) cs + +-- Extracted from Generics.SOP.JSON +jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs +jsonInfoFor _ _ tag (Infix n _ _) = JsonMultiple (tag n) +jsonInfoFor _ _ tag (Constructor n) = + case shape :: Shape xs of + ShapeNil -> JsonZero n + ShapeCons ShapeNil -> JsonOne (tag n) + _ -> JsonMultiple (tag n) +jsonInfoFor opts d tag (Record n fields) = + JsonRecord (tag n) (hliftA jfieldName fields) + where + jfieldName :: FieldInfo a -> K String a + jfieldName (FieldInfo name) = K (jsonFieldName opts d name) gtoJsend' :: All ToJSON xs @@ -79,7 +100,7 @@ gtoJsend' rs (JsonRecord tag fields) cs = gparseJsend :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a)) => Value -> Parser a -gparseJsend v = to <$> gparseJsend' v (jsendInfo (Proxy :: Proxy a)) +gparseJsend v = to <$> gparseJsend' v (jsendInfo (Proxy :: Proxy a) jsendOptions) gparseJsend' :: forall (xss :: [[*]]). All2 FromJSON xss diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Headers.hs b/wallet-new/src/Cardano/Wallet/API/V1/Headers.hs new file mode 100644 index 00000000000..eba778586f5 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/API/V1/Headers.hs @@ -0,0 +1,11 @@ +module Cardano.Wallet.API.V1.Headers + ( applicationJson + ) where + +import Network.HTTP.Types (Header, hContentType) + + +-- | Generates the @Content-Type: application/json@ 'HTTP.Header'. +applicationJson :: Header +applicationJson = + (hContentType, "application/json") diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Addresses.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Addresses.hs index e9a4cb89be9..d992e1283ed 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Addresses.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Addresses.hs @@ -32,7 +32,6 @@ import Cardano.Wallet.API.Indices (IxSet') import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response import qualified Cardano.Wallet.API.V1.Addresses as Addresses -import Cardano.Wallet.API.V1.Errors import Cardano.Wallet.API.V1.Migration import Cardano.Wallet.API.V1.Types diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs index d3fa87618ea..7140a8935d6 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs @@ -23,11 +23,29 @@ import qualified Pos.Wallet.Web.Util as V0 import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response -import Cardano.Wallet.API.V1.Errors import Cardano.Wallet.API.V1.Migration (HasConfigurations, MonadV1, migrate) import qualified Cardano.Wallet.API.V1.Transactions as Transactions import Cardano.Wallet.API.V1.Types + +convertTxError :: V0.TxError -> WalletError +convertTxError err = case err of + V0.NotEnoughMoney coin -> + NotEnoughMoney . fromIntegral . Core.getCoin $ coin + V0.NotEnoughAllowedMoney coin -> + NotEnoughMoney . fromIntegral . Core.getCoin $ coin + V0.FailedToStabilize -> + TxFailedToStabilize + V0.OutputIsRedeem addr -> + OutputIsRedeem (V1 addr) + V0.RedemptionDepleted -> + TxRedemptionDepleted + V0.SafeSignerNotFound addr -> + TxSafeSignerNotFound (V1 addr) + V0.GeneralTxError txt -> + UnknownError txt + + handlers :: HasConfigurations => ProtocolMagic @@ -38,6 +56,7 @@ handlers pm submitTx = :<|> allTransactions :<|> estimateFees pm + newTransaction :: forall ctx m . (V0.MonadWalletTxFull ctx m) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index f9b8c53da2b..0696be50789 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -16,7 +16,6 @@ import qualified Pos.Wallet.Web.State.Storage as V0 import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response -import Cardano.Wallet.API.V1.Errors import Cardano.Wallet.API.V1.Migration import Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.API.V1.Wallets as Wallets @@ -151,7 +150,7 @@ addWalletInfo => V0.WalletSnapshot -> V0.CWallet -> m Wallet -addWalletInfo snapshot wallet = do +addWalletInfo snapshot wallet = case V0.getWalletInfo (V0.cwId wallet) snapshot of Nothing -> throwM WalletNotFound diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs index faad3a50721..62b20061703 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Migration/Types.hs @@ -3,36 +3,45 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeSynonymInstances #-} -module Cardano.Wallet.API.V1.Migration.Types ( - Migrate(..) +module Cardano.Wallet.API.V1.Migration.Types + ( Migrate(..) + , MigrationError(..) , migrate ) where import Universum hiding (elems) -import qualified Control.Lens as Lens -import qualified Control.Monad.Catch as Catch +import Cardano.Wallet.API.Response.JSend (ResponseStatus (..)) +import Cardano.Wallet.API.V1.Errors (ToServantError (..)) +import Cardano.Wallet.API.V1.Generic (gparseJsend, gtoJsend) +import Cardano.Wallet.API.V1.Types (V1 (..)) +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Map (elems) import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Units (fromMicroseconds, toMicroseconds) import Data.Typeable (typeRep) -import Formatting (sformat) +import Formatting (bprint, build, sformat) +import Generics.SOP.TH (deriveGeneric) +import Pos.Core (addressF) +import Pos.Crypto (decodeHash) +import Pos.Wallet.Web.ClientTypes.Instances () +import Pos.Wallet.Web.Tracking.Sync (calculateEstimatedRemainingTime) +import Servant (err422) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (oneof) -import Cardano.Wallet.API.V1.Errors as Errors -import Cardano.Wallet.API.V1.Types (V1 (..)) import qualified Cardano.Wallet.API.V1.Types as V1 +import qualified Control.Lens as Lens +import qualified Control.Monad.Catch as Catch +import qualified Data.Text.Buildable import qualified Pos.Client.Txp.Util as V0 -import Pos.Core (addressF) import qualified Pos.Core.Common as Core import qualified Pos.Core.Slotting as Core import qualified Pos.Core.Txp as Core -import Pos.Crypto (decodeHash) import qualified Pos.Txp.Toil.Types as V0 import qualified Pos.Util.Servant as V0 -import qualified Pos.Wallet.Web.ClientTypes.Instances () import qualified Pos.Wallet.Web.ClientTypes.Types as V0 import qualified Pos.Wallet.Web.State.Storage as OldStorage -import Pos.Wallet.Web.Tracking.Sync (calculateEstimatedRemainingTime) -- | 'Migrate' encapsulates migration between types, when possible. -- NOTE: This has @nothing@ to do with database migrations (see `safecopy`), @@ -40,7 +49,7 @@ import Pos.Wallet.Web.Tracking.Sync (calculateEstimatedRemainingTime) -- will be completed and the V0 API removed, we will be able to remove this -- typeclass altogether. class Migrate from to where - eitherMigrate :: from -> Either Errors.WalletError to + eitherMigrate :: from -> Either MigrationError to -- | "Run" the migration. migrate :: ( Migrate from to, Catch.MonadThrow m ) => from -> m to @@ -92,14 +101,14 @@ instance Migrate (OldStorage.SyncStatistics, Maybe Core.ChainDifficulty) V1.Sync Just nd | wspCurrentBlockchainDepth >= nd -> 100 Just nd -> (fromIntegral wspCurrentBlockchainDepth / max 1.0 (fromIntegral nd)) * 100.0 toMs (Core.Timestamp microsecs) = - V1.mkEstimatedCompletionTime (round @Double $ (realToFrac (toMicroseconds microsecs) / 1000.0)) + V1.mkEstimatedCompletionTime (round @Double (realToFrac (toMicroseconds microsecs) / 1000.0)) tput (OldStorage.SyncThroughput blocks) = V1.mkSyncThroughput blocks remainingBlocks = fmap (\total -> total - wspCurrentBlockchainDepth) currentBlockchainHeight in V1.SyncProgress <$> pure (toMs (maybe unknownCompletionTime (calculateEstimatedRemainingTime wspThroughput) remainingBlocks)) <*> pure (tput wspThroughput) - <*> pure (V1.mkSyncPercentage (floor @Double $ percentage)) + <*> pure (V1.mkSyncPercentage (floor @Double percentage)) -- NOTE: Migrate V1.Wallet V0.CWallet unable to do - not idempotent @@ -115,7 +124,7 @@ instance Migrate V1.AssuranceLevel V0.CWalletAssurance where -- instance Migrate V0.CCoin (V1 Core.Coin) where eitherMigrate c = - let err = Left . Errors.MigrationFailed . mappend "error migrating V0.CCoin -> Core.Coin, mkCoin failed: " + let err = Left . MigrationFailed . mappend "error migrating V0.CCoin -> Core.Coin, mkCoin failed: " in either err (pure . V1) (V0.decodeCType c) instance Migrate (V1 Core.Coin) V0.CCoin where @@ -154,7 +163,7 @@ instance Migrate V0.CAddress V1.WalletAddress where instance Migrate V0.SyncProgress V1.SyncPercentage where eitherMigrate V0.SyncProgress{..} = let percentage = case _spNetworkCD of - Nothing -> (0 :: Word8) + Nothing -> 0 :: Word8 Just nd | _spLocalCD >= nd -> 100 Just nd -> floor @Double $ (fromIntegral _spLocalCD / max 1.0 (fromIntegral nd)) * 100.0 in pure $ V1.mkSyncPercentage (fromIntegral percentage) @@ -178,7 +187,7 @@ instance Migrate V0.CAccount V1.Account where -- in old API 'V0.AccountId' supposed to carry both wallet id and derivation index instance Migrate (V1.WalletId, V1.AccountIndex) V0.AccountId where eitherMigrate (walId, accIdx) = - V0.AccountId <$> eitherMigrate walId <*> pure accIdx + V0.AccountId <$> eitherMigrate walId <*> pure (V1.getAccIndex accIdx) instance Migrate V1.PaymentSource V0.AccountId where eitherMigrate V1.PaymentSource{..} = eitherMigrate (psWalletId, psAccountIndex) @@ -192,10 +201,14 @@ instance Migrate V1.PaymentSource V0.CAccountId where instance Migrate V0.AccountId (V1.WalletId, V1.AccountIndex) where eitherMigrate accId = - (,) <$> eitherMigrate (V0.aiWId accId) <*> pure (V0.aiIndex accId) + (,) + <$> eitherMigrate (V0.aiWId accId) + <*> first + (MigrationFailed . sformat build) + (V1.mkAccountIndex $ V0.aiIndex accId) instance Migrate V0.CAccountId V0.AccountId where - eitherMigrate = first Errors.MigrationFailed . V0.decodeCType + eitherMigrate = first MigrationFailed . V0.decodeCType instance Migrate V0.CAccountId V1.AccountIndex where eitherMigrate cAccId = do @@ -211,24 +224,24 @@ instance Migrate V0.CAccountId V1.WalletId where instance Migrate V0.CAddress (V1 Core.Address) where eitherMigrate V0.CAddress {..} = - let err = Left . Errors.MigrationFailed . mappend "Error migrating V0.CAddress -> Core.Address failed: " + let err = Left . MigrationFailed . mappend "Error migrating V0.CAddress -> Core.Address failed: " in either err (pure . V1) (V0.decodeCType cadId) instance Migrate (V0.CId V0.Addr) (V1 Core.Address) where eitherMigrate (V0.CId (V0.CHash h)) = - let err = Left . Errors.MigrationFailed . mappend "Error migrating (V0.CId V0.Addr) -> Core.Address failed." + let err = Left . MigrationFailed . mappend "Error migrating (V0.CId V0.Addr) -> Core.Address failed." in either err (pure . V1) (Core.decodeTextAddress h) instance Migrate (V1 Core.Address) (V0.CId V0.Addr) where eitherMigrate (V1 address) = let h = sformat addressF address in - pure $ (V0.CId (V0.CHash h)) + pure (V0.CId (V0.CHash h)) instance Migrate (V0.CId V0.Addr, V0.CCoin) V1.PaymentDistribution where eitherMigrate (cIdAddr, cCoin) = do pdAddress <- eitherMigrate cIdAddr pdAmount <- eitherMigrate cCoin - pure $ V1.PaymentDistribution {..} + pure V1.PaymentDistribution {..} instance Migrate V1.PaymentDistribution (V0.CId V0.Addr, Core.Coin) where eitherMigrate V1.PaymentDistribution {..} = @@ -243,7 +256,7 @@ instance Migrate (V0.CId V0.Addr, Core.Coin) V1.PaymentDistribution where instance Migrate V0.CTxId (V1 Core.TxId) where eitherMigrate (V0.CTxId (V0.CHash h)) = - let err = Left . Errors.MigrationFailed . mappend "Error migrating a TxId: " + let err = Left . MigrationFailed . mappend "Error migrating a TxId: " in either err (pure . V1) (decodeHash h) instance Migrate POSIXTime (V1 Core.Timestamp) where @@ -304,7 +317,7 @@ instance Migrate V1.EstimatedFees V0.TxFee where instance Migrate V1.WalletUpdate V0.CWalletMeta where eitherMigrate V1.WalletUpdate{..} = do migratedAssurance <- eitherMigrate uwalAssuranceLevel - pure $ V0.CWalletMeta + pure V0.CWalletMeta { cwName = uwalName , cwAssurance = migratedAssurance , cwUnit = 0 @@ -313,7 +326,40 @@ instance Migrate V1.WalletUpdate V0.CWalletMeta where instance Migrate V0.CWalletMeta V1.WalletUpdate where eitherMigrate V0.CWalletMeta{..} = do migratedAssurance <- eitherMigrate cwAssurance - pure $ V1.WalletUpdate + pure V1.WalletUpdate { uwalName = cwName , uwalAssuranceLevel = migratedAssurance } + +-- +-- Migration Errors +-- + +newtype MigrationError + = MigrationFailed Text + deriving (Eq, Show) + +deriveGeneric ''MigrationError + +instance ToJSON MigrationError where + toJSON = gtoJsend ErrorStatus + +instance FromJSON MigrationError where + parseJSON = gparseJsend + +instance Exception MigrationError + +instance Arbitrary MigrationError where + arbitrary = oneof + [ pure $ MigrationFailed "Migration failed." + ] + +instance Buildable MigrationError where + build = \case + MigrationFailed _ -> + bprint "Error while migrating a legacy type into the current version." + +instance ToServantError MigrationError where + declareServantError = \case + MigrationFailed _ -> + err422 diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs index fa2f135d5f4..b5ce7e17bb6 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs @@ -17,32 +17,26 @@ import Cardano.Wallet.API.Request.Pagination import Cardano.Wallet.API.Request.Sort import Cardano.Wallet.API.Response import Cardano.Wallet.API.Types -import qualified Cardano.Wallet.API.V1.Errors as Errors import Cardano.Wallet.API.V1.Generic (gconsName) +import Cardano.Wallet.API.V1.Migration.Types (MigrationError (..)) import Cardano.Wallet.API.V1.Parameters import Cardano.Wallet.API.V1.Swagger.Example import Cardano.Wallet.API.V1.Types import Cardano.Wallet.TypeLits (KnownSymbols (..)) -import qualified Pos.Core as Core -import Pos.Core.Update (SoftwareVersion) -import Pos.Util.CompileInfo (CompileTimeInfo, ctiGitRevision) -import Pos.Util.Mnemonic (Mnemonic) -import Pos.Util.Servant (LoggingApi) -import Pos.Wallet.Web.Swagger.Instances.Schema () - import Control.Lens ((?~)) import Data.Aeson (ToJSON (..), encode) import Data.Aeson.Encode.Pretty -import qualified Data.ByteString.Lazy as BL import Data.Map (Map) -import qualified Data.Map.Strict as M -import qualified Data.Set as Set import Data.Swagger hiding (Example, Header, example) import Data.Swagger.Declare -import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Typeable +import Formatting (build, sformat) import NeatInterpolation +import Pos.Core.Update (SoftwareVersion) +import Pos.Util.CompileInfo (CompileTimeInfo, ctiGitRevision) +import Pos.Util.Mnemonic (Mnemonic) +import Pos.Util.Servant (LoggingApi) +import Pos.Wallet.Web.Swagger.Instances.Schema () import Servant (Handler, ServantErr (..), Server) import Servant.API.Sub import Servant.Swagger @@ -52,13 +46,23 @@ import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as M +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Pos.Core as Core +import qualified Pos.Crypto.Hashing as Crypto +import qualified Pos.Data.Attributes as Core + + -- -- Helper functions -- -- | Generates an example for type `a` with a static seed. genExample :: Example a => a -genExample = (unGen (resize 3 example)) (mkQCGen 42) 42 +genExample = unGen (resize 3 example) (mkQCGen 42) 42 -- | Generates a `NamedSchema` exploiting the `ToJSON` instance in scope, -- by calling `sketchSchema` under the hood. @@ -155,7 +159,7 @@ instance in swgr & over (operationsOf swgr . parameters) addSortOperation where addSortOperation :: [Referenced Param] -> [Referenced Param] - addSortOperation xs = (Inline newParam) : xs + addSortOperation xs = Inline newParam : xs newParam :: Param newParam = @@ -196,7 +200,6 @@ instance ToParamSchema Core.Address where instance ToParamSchema (V1 Core.Address) where toParamSchema _ = toParamSchema (Proxy @Core.Address) - -- -- Descriptions -- @@ -229,14 +232,45 @@ Error Name / Description | HTTP Error code | Example $errors |] where errors = T.intercalate "\n" rows - rows = map (mkRow errToDescription) Errors.sample + rows = + [ mkRow errToDescription $ NotEnoughMoney 1400 + , mkRow errToDescription $ OutputIsRedeem sampleAddress + , mkRow errToDescription $ MigrationFailed "Migration failed." + , mkRow errToDescription $ JSONValidationFailed "Expected String, found Null." + , mkRow errToDescription $ UnknownError "Unknown error." + , mkRow errToDescription $ InvalidAddressFormat "Invalid Base58 representation." + , mkRow errToDescription WalletNotFound + , mkRow errToDescription $ WalletAlreadyExists sampleWalletId + , mkRow errToDescription AddressNotFound + , mkRow errToDescription $ MissingRequiredParams (("wallet_id", "walletId") :| []) + , mkRow errToDescription $ WalletIsNotReadyToProcessPayments sampleSyncProgress + , mkRow errToDescription $ NodeIsStillSyncing (mkSyncPercentage 42) + ] mkRow fmt err = T.intercalate "|" (fmt err) errToDescription err = - [ surroundedBy "`" (gconsName err) <> "
" <> toText (Errors.describe err) - , show $ errHTTPCode $ Errors.toServantError err + [ surroundedBy "`" (gconsName err) <> "
" <> toText (sformat build err) + , show $ errHTTPCode $ toServantError err , inlineCodeBlock (T.decodeUtf8 $ BL.toStrict $ encodePretty err) ] + sampleWalletId = + WalletId "J7rQqaLLHBFPrgJXwpktaMB1B1kQBXAyc2uRSfRPzNVGiv6TdxBzkPNBUWysZZZdhFG9gRy3sQFfX5wfpLbi4XTFGFxTg" + + sampleAddress = V1 Core.Address + { Core.addrRoot = + Crypto.unsafeAbstractHash ("asdfasdf" :: String) + , Core.addrAttributes = + Core.mkAttributes $ Core.AddrAttributes Nothing Core.BootstrapEraDistr + , Core.addrType = + Core.ATPubKey + } + + sampleSyncProgress = SyncProgress + { spEstimatedCompletionTime = mkEstimatedCompletionTime 3000 + , spThroughput = mkSyncThroughput (Core.BlockCount 400) + , spPercentage = mkSyncPercentage 80 + } + -- | Shorter version of the doc below, only for Dev & V0 documentations highLevelShortDescription :: DescriptionEnvironment -> T.Text @@ -843,12 +877,12 @@ api (compileInfo, curSoftwareVersion) walletAPI mkDescription = toSwagger wallet & info.title .~ "Cardano Wallet API" & info.version .~ fromString (show curSoftwareVersion) & host ?~ "127.0.0.1:8090" - & info.description ?~ (mkDescription $ DescriptionEnvironment - { deErrorExample = decodeUtf8 $ encodePretty Errors.WalletNotFound + & info.description ?~ mkDescription DescriptionEnvironment + { deErrorExample = decodeUtf8 $ encodePretty WalletNotFound , deMnemonicExample = decodeUtf8 $ encode (genExample @(Mnemonic 12)) , deDefaultPerPage = fromString (show defaultPerPageEntries) , deWalletErrorTable = errorsDescription , deGitRevision = ctiGitRevision compileInfo , deSoftwareVersion = fromString $ show curSoftwareVersion - }) + } & info.license ?~ ("MIT" & url ?~ URL "https://raw.githubusercontent.com/input-output-hk/cardano-sl/develop/lib/LICENSE") diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs index 5e1aa9b4a58..7efc51e9e3c 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs @@ -2,8 +2,6 @@ module Cardano.Wallet.API.V1.Swagger.Example where import Universum -import Test.QuickCheck (Arbitrary (..), Gen, listOf1, oneof) - import Cardano.Wallet.API.Response import Cardano.Wallet.API.V1.Types import Cardano.Wallet.Orphans.Arbitrary () @@ -14,6 +12,7 @@ import Pos.Client.Txp.Util (InputSelectionPolicy (..)) import Pos.Util.Mnemonic (Mnemonic) import Pos.Wallet.Web.ClientTypes (CUpdateInfo) import Pos.Wallet.Web.Methods.Misc (WalletStateSnapshot (..)) +import Test.QuickCheck (Arbitrary (..), Gen, listOf1, oneof) import qualified Data.Map.Strict as Map import qualified Pos.Core.Common as Core @@ -139,7 +138,6 @@ instance Example Payment where instance Example WalletStateSnapshot - -- IMPORTANT: if executing `grep "[]\|null" wallet-new/spec/swagger.json` returns any element - then we have to add Example instances for those objects because we don't want to see [] or null examples in our docs. -- -- TODO: We should probably add this as a part of our swagger CI script and fail swagger if we find some of them - with instruction to the developer above what is said above. diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index 60e200493f3..d42712fbe36 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -40,6 +40,9 @@ module Cardano.Wallet.API.V1.Types ( , Account (..) , accountsHaveSameId , AccountIndex + , getAccIndex + , mkAccountIndex + , AccountIndexError(..) -- * Addresses , WalletAddress (..) , NewAddress (..) @@ -78,6 +81,10 @@ module Cardano.Wallet.API.V1.Types ( , CaptureAccountId -- * Core re-exports , Core.Address + -- * Wallet Errors + , WalletError(..) + , toServantError + , toHttpErrorStatus ) where import Universum @@ -86,53 +93,55 @@ import Control.Lens (At, Index, IxValue, at, ix, makePrisms, to, (?~)) import Data.Aeson import Data.Aeson.TH as A import Data.Aeson.Types (toJSONKeyText, typeMismatch) -import qualified Data.Char as C +import Data.Bifunctor (first) import Data.Swagger as S import Data.Swagger.Declare (Declare, look) import Data.Swagger.Internal.Schema (GToSchema) import Data.Swagger.Internal.TypeShape (GenericHasSimpleShape, GenericShape) import Data.Text (Text, dropEnd, toLower) -import qualified Data.Text as T -import qualified Data.Text.Buildable import Data.Version (Version) import Formatting (bprint, build, fconst, int, sformat, (%)) +import Generics.SOP.TH (deriveGeneric) import GHC.Generics (Generic, Rep) import Network.Transport (EndPointAddress (..)) import Node (NodeId (..)) -import qualified Prelude -import qualified Serokell.Aeson.Options as Serokell import Serokell.Util (listJson) -import qualified Serokell.Util.Base16 as Base16 import Servant +import Test.Pos.Core.Arbitrary () import Test.QuickCheck import Test.QuickCheck.Gen (Gen (..)) import Test.QuickCheck.Random (mkQCGen) +import Cardano.Wallet.API.Response.JSend (ResponseStatus (ErrorStatus)) import Cardano.Wallet.API.Types.UnitOfMeasure (MeasuredIn (..), UnitOfMeasure (..)) +import Cardano.Wallet.API.V1.Errors (ToHttpErrorStatus (..), ToServantError (..)) +import Cardano.Wallet.API.V1.Generic (gparseJsend, gtoJsend) import Cardano.Wallet.Orphans.Aeson () - --- V0 logic +import Cardano.Wallet.Util (showApiUtcTime) +import Pos.Aeson.Core () +import Pos.Core (addressF) +import Pos.Crypto (decodeHash, hashHexF) +import Pos.Infra.Diffusion.Subscription.Status (SubscriptionStatus (..)) +import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), buildSafe, + buildSafeList, buildSafeMaybe, deriveSafeBuildable, + plainOrSecureF) import Pos.Util.Mnemonic (Mnemonic) - --- importing for orphan instances for Coin import Pos.Wallet.Web.ClientTypes.Instances () -import Cardano.Wallet.Util (showApiUtcTime) import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS +import qualified Data.Char as C import qualified Data.Map.Strict as Map -import Pos.Aeson.Core () +import qualified Data.Text as T +import qualified Data.Text.Buildable import qualified Pos.Client.Txp.Util as Core -import Pos.Core (addressF) import qualified Pos.Core as Core -import Pos.Crypto (decodeHash, hashHexF) import qualified Pos.Crypto.Signing as Core -import Pos.Infra.Diffusion.Subscription.Status (SubscriptionStatus (..)) -import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), buildSafe, buildSafeList, - buildSafeMaybe, deriveSafeBuildable, plainOrSecureF) import qualified Pos.Wallet.Web.State.Storage as OldStorage +import qualified Prelude +import qualified Serokell.Aeson.Options as Serokell +import qualified Serokell.Util.Base16 as Base16 -import Test.Pos.Core.Arbitrary () -- | Declare generic schema, while documenting properties -- For instance: @@ -180,7 +189,7 @@ genericSchemaDroppingPrefix prfx extraDoc proxy = do & schema . example ?~ toJSON (genExample :: a) where genExample = - (unGen (resize 3 arbitrary)) (mkQCGen 42) 42 + unGen (resize 3 arbitrary) (mkQCGen 42) 42 addFieldDescription defs field desc = over (at field) (addDescription defs field desc) @@ -243,13 +252,14 @@ instance Buildable (SecureLog a) => Buildable (SecureLog (V1 a)) where instance (Buildable a, Buildable b) => Buildable (a, b) where build (a, b) = bprint ("("%build%", "%build%")") a b + -- -- Benign instances -- instance ByteArray.ByteArrayAccess a => ByteArray.ByteArrayAccess (V1 a) where length (V1 a) = ByteArray.length a - withByteArray (V1 a) callback = ByteArray.withByteArray a callback + withByteArray (V1 a) = ByteArray.withByteArray a instance Arbitrary (V1 (Mnemonic 12)) where arbitrary = @@ -295,7 +305,7 @@ instance Arbitrary (V1 Core.PassPhrase) where arbitrary = fmap V1 arbitrary instance ToSchema (V1 Core.PassPhrase) where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "V1PassPhrase") $ mempty & type_ .~ SwaggerString & format ?~ "hex|base16" @@ -408,7 +418,7 @@ deriveJSON Serokell.defaultOptions { A.constructorTagModifier = toString . toLow } ''AssuranceLevel instance ToSchema AssuranceLevel where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "AssuranceLevel") $ mempty & type_ .~ SwaggerString & enum_ ?~ ["normal", "strict"] @@ -460,7 +470,7 @@ deriveJSON Serokell.defaultOptions { A.constructorTagModifier = reverse . drop } ''WalletOperation instance ToSchema WalletOperation where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "WalletOperation") $ mempty & type_ .~ SwaggerString & enum_ ?~ ["create", "restore"] @@ -568,7 +578,7 @@ instance FromJSON SyncPercentage where parseJSON = withObject "SyncPercentage" $ \sl -> mkSyncPercentage <$> sl .: "quantity" instance ToSchema SyncPercentage where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "SyncPercentage") $ mempty & type_ .~ SwaggerObject & required .~ ["quantity", "unit"] @@ -603,6 +613,14 @@ instance Ord EstimatedCompletionTime where instance Arbitrary EstimatedCompletionTime where arbitrary = EstimatedCompletionTime . MeasuredIn <$> arbitrary +deriveSafeBuildable ''EstimatedCompletionTime +instance BuildableSafeGen EstimatedCompletionTime where + buildSafeGen _ (EstimatedCompletionTime (MeasuredIn w)) = bprint ("{" + %" quantity="%build + %" unit=milliseconds" + %" }") + w + instance ToJSON EstimatedCompletionTime where toJSON (EstimatedCompletionTime (MeasuredIn w)) = object [ "quantity" .= toJSON w @@ -613,7 +631,7 @@ instance FromJSON EstimatedCompletionTime where parseJSON = withObject "EstimatedCompletionTime" $ \sl -> mkEstimatedCompletionTime <$> sl .: "quantity" instance ToSchema EstimatedCompletionTime where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "EstimatedCompletionTime") $ mempty & type_ .~ SwaggerObject & required .~ ["quantity", "unit"] @@ -643,6 +661,14 @@ instance Ord SyncThroughput where instance Arbitrary SyncThroughput where arbitrary = SyncThroughput . MeasuredIn . OldStorage.SyncThroughput <$> arbitrary +deriveSafeBuildable ''SyncThroughput +instance BuildableSafeGen SyncThroughput where + buildSafeGen _ (SyncThroughput (MeasuredIn (OldStorage.SyncThroughput (Core.BlockCount blocks)))) = bprint ("{" + %" quantity="%build + %" unit=blocksPerSecond" + %" }") + blocks + instance ToJSON SyncThroughput where toJSON (SyncThroughput (MeasuredIn (OldStorage.SyncThroughput (Core.BlockCount blocks)))) = object [ "quantity" .= toJSON blocks @@ -653,7 +679,7 @@ instance FromJSON SyncThroughput where parseJSON = withObject "SyncThroughput" $ \sl -> mkSyncThroughput . Core.BlockCount <$> sl .: "quantity" instance ToSchema SyncThroughput where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "SyncThroughput") $ mempty & type_ .~ SwaggerObject & required .~ ["quantity", "unit"] @@ -689,7 +715,14 @@ instance ToSchema SyncProgress where deriveSafeBuildable ''SyncProgress -- Nothing secret to redact for a SyncProgress. instance BuildableSafeGen SyncProgress where - buildSafeGen _ sp = bprint build sp + buildSafeGen sl SyncProgress {..} = bprint ("{" + %" estimatedCompletionTime="%buildSafe sl + %" throughput="%buildSafe sl + %" percentage="%buildSafe sl + %" }") + spEstimatedCompletionTime + spThroughput + spPercentage instance Arbitrary SyncProgress where arbitrary = SyncProgress <$> arbitrary @@ -814,7 +847,7 @@ newtype AddressValidity = AddressValidity { isValid :: Bool } deriveJSON Serokell.defaultOptions ''AddressValidity instance ToSchema AddressValidity where - declareNamedSchema = genericSchemaDroppingPrefix "is" (\_ -> identity) + declareNamedSchema = genericSchemaDroppingPrefix "is" (const identity) instance Arbitrary AddressValidity where arbitrary = AddressValidity <$> arbitrary @@ -850,7 +883,67 @@ instance Arbitrary WalletAddress where <*> arbitrary <*> arbitrary -type AccountIndex = Word32 +newtype AccountIndex = AccountIndex { getAccIndex :: Word32 } + deriving (Show, Eq, Ord, Generic) + +newtype AccountIndexError = AccountIndexError Word32 + deriving (Eq, Show) + +instance Buildable AccountIndexError where + build (AccountIndexError i) = + bprint + ("Account index should be in range ["%int%".."%int%"], but "%int%" was provided.") + (getAccIndex minBound) + (getAccIndex maxBound) + i + +mkAccountIndex :: Word32 -> Either AccountIndexError AccountIndex +mkAccountIndex index + | index >= getAccIndex minBound = Right $ AccountIndex index + | otherwise = Left $ AccountIndexError index + +instance Bounded AccountIndex where + -- NOTE: minimum for hardened key. See https://iohk.myjetbrains.com/youtrack/issue/CO-309 + minBound = AccountIndex 2147483648 + maxBound = AccountIndex maxBound + +instance ToJSON AccountIndex where + toJSON = toJSON . getAccIndex + +instance FromJSON AccountIndex where + parseJSON = + either fmtFail pure . mkAccountIndex <=< parseJSON + where + fmtFail = fail . toString . sformat build + +instance Arbitrary AccountIndex where + arbitrary = + AccountIndex <$> choose (getAccIndex minBound, getAccIndex maxBound) + +deriveSafeBuildable ''AccountIndex +-- Nothing secret to redact for a AccountIndex. +instance BuildableSafeGen AccountIndex where + buildSafeGen _ = + bprint build . getAccIndex + +instance ToParamSchema AccountIndex where + toParamSchema _ = mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just (fromIntegral $ getAccIndex minBound) + & maximum_ .~ Just (fromIntegral $ getAccIndex maxBound) + +instance ToSchema AccountIndex where + declareNamedSchema = + pure . paramSchemaToNamedSchema defaultSchemaOptions + +instance FromHttpApiData AccountIndex where + parseQueryParam = + first (sformat build) . mkAccountIndex <=< parseQueryParam + +instance ToHttpApiData AccountIndex where + toQueryParam = + fromString . show . getAccIndex + -- | A wallet 'Account'. data Account = Account @@ -1185,7 +1278,7 @@ instance ToJSON (V1 Core.TxId) where toJSON (V1 t) = String (sformat hashHexF t) instance FromJSON (V1 Core.TxId) where - parseJSON = withText "TxId" $ \t -> do + parseJSON = withText "TxId" $ \t -> case decodeHash t of Left err -> fail $ "Failed to parse transaction ID: " <> toString err Right a -> pure (V1 a) @@ -1580,7 +1673,7 @@ instance FromJSON LocalTimeDifference where parseJSON = withObject "LocalTimeDifference" $ \sl -> mkLocalTimeDifference <$> sl .: "quantity" instance ToSchema LocalTimeDifference where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "LocalTimeDifference") $ mempty & type_ .~ SwaggerObject & required .~ ["quantity"] @@ -1621,7 +1714,7 @@ instance FromJSON BlockchainHeight where mkBlockchainHeight . Core.BlockCount <$> sl .: "quantity" instance ToSchema BlockchainHeight where - declareNamedSchema _ = do + declareNamedSchema _ = pure $ NamedSchema (Just "BlockchainHeight") $ mempty & type_ .~ SwaggerObject & required .~ ["quantity"] @@ -1761,6 +1854,154 @@ instance BuildableSafeGen NodeInfo where (Map.toList nfoSubscriptionStatus) +-- +-- Wallet Errors +-- + +-- +-- Error handling +-- + +-- | Type representing any error which might be thrown by wallet. +-- +-- Errors are represented in JSON in the JSend format (): +-- ``` +-- { +-- "status": "error" +-- "message" : , +-- "diagnostic" : +-- } +-- ``` +-- where `` is a string containing name of error's constructor (e. g. `NotEnoughMoney`), +-- and `` is an object containing additional error data. +-- Additional data contains constructor fields, field names are record field names without +-- a `we` prefix, e. g. for `OutputIsRedeem` error "diagnostic" field will be the following: +-- ``` +-- { +-- "address" :
+-- } +-- ``` +-- +-- Additional data in constructor should be represented as record fields. +-- Otherwise TemplateHaskell will raise an error. +-- +-- If constructor does not have additional data (like in case of `WalletNotFound` error), +-- then "diagnostic" field will be empty object. +-- +-- TODO: change fields' types to actual Cardano core types, like `Coin` and `Address` +data WalletError = + NotEnoughMoney { weNeedMore :: !Int } + | OutputIsRedeem { weAddress :: !(V1 Core.Address) } + | UnknownError { weMsg :: !Text } + | InvalidAddressFormat { weMsg :: !Text } + | WalletNotFound + -- FIXME(akegalj): https://iohk.myjetbrains.com/youtrack/issue/CSL-2496 + | WalletAlreadyExists { weWalletId :: WalletId } + | AddressNotFound + | TxFailedToStabilize + | TxRedemptionDepleted + | TxSafeSignerNotFound { weAddress :: V1 Core.Address } + | MissingRequiredParams { requiredParams :: NonEmpty (Text, Text) } + | WalletIsNotReadyToProcessPayments { weStillRestoring :: SyncProgress } + -- ^ The @Wallet@ where a @Payment@ is being originated is not fully + -- synced (its 'WalletSyncState' indicates it's either syncing or + -- restoring) and thus cannot accept new @Payment@ requests. + | NodeIsStillSyncing { wenssStillSyncing :: SyncPercentage } + -- ^ The backend couldn't process the incoming request as the underlying + -- node is still syncing with the blockchain. + deriving (Show, Eq) + +-- deriveWalletErrorJSON ''WalletError +deriveGeneric ''WalletError + +instance ToJSON WalletError where + toJSON = gtoJsend ErrorStatus + +instance FromJSON WalletError where + parseJSON = gparseJsend + +instance Exception WalletError + +instance Arbitrary WalletError where + arbitrary = oneof + [ NotEnoughMoney <$> arbitrary + , OutputIsRedeem <$> arbitrary + , pure (UnknownError "Unknown error.") + , pure (InvalidAddressFormat "Invalid Base58 representation.") + , pure WalletNotFound + , WalletAlreadyExists <$> arbitrary + , pure AddressNotFound + , pure TxFailedToStabilize + , pure TxRedemptionDepleted + , TxSafeSignerNotFound <$> arbitrary + , pure (MissingRequiredParams (("wallet_id", "walletId") :| [])) + , WalletIsNotReadyToProcessPayments <$> arbitrary + , NodeIsStillSyncing <$> arbitrary + ] + +-- | Give a short description of an error +instance Buildable WalletError where + build = \case + NotEnoughMoney _ -> + bprint "Not enough available coins to proceed." + OutputIsRedeem _ -> + bprint "One of the TX outputs is a redemption address." + UnknownError _ -> + bprint "Unexpected internal error." + InvalidAddressFormat _ -> + bprint "Provided address format is not valid." + WalletNotFound -> + bprint "Reference to an unexisting wallet was given." + WalletAlreadyExists _ -> + bprint "Can't create or restore a wallet. The wallet already exists." + AddressNotFound -> + bprint "Reference to an unexisting address was given." + MissingRequiredParams _ -> + bprint "Missing required parameters in the request payload." + WalletIsNotReadyToProcessPayments _ -> + bprint "This wallet is restoring, and it cannot send new transactions until restoration completes." + NodeIsStillSyncing _ -> + bprint "The node is still syncing with the blockchain, and cannot process the request yet." + TxRedemptionDepleted -> + bprint "The redemption address was already used." + TxSafeSignerNotFound _ -> + bprint "The safe signer at the specified address was not found." + TxFailedToStabilize -> + bprint "We were unable to find a set of inputs to satisfy this transaction." + +-- | Convert wallet errors to Servant errors +instance ToServantError WalletError where + declareServantError = \case + NotEnoughMoney{} -> + err403 + OutputIsRedeem{} -> + err403 + UnknownError{} -> + err500 + WalletNotFound{} -> + err404 + WalletAlreadyExists{} -> + err403 + InvalidAddressFormat{} -> + err401 + AddressNotFound{} -> + err404 + MissingRequiredParams{} -> + err400 + WalletIsNotReadyToProcessPayments{} -> + err403 + NodeIsStillSyncing{} -> + err412 -- Precondition failed + TxFailedToStabilize{} -> + err500 + TxRedemptionDepleted{} -> + err400 + TxSafeSignerNotFound{} -> + err400 + +instance ToHttpErrorStatus WalletError + + -- -- POST/PUT requests isomorphisms -- diff --git a/wallet-new/src/Cardano/Wallet/Client.hs b/wallet-new/src/Cardano/Wallet/Client.hs index 915efcf270d..4ab3b140306 100644 --- a/wallet-new/src/Cardano/Wallet/Client.hs +++ b/wallet-new/src/Cardano/Wallet/Client.hs @@ -16,7 +16,7 @@ module Cardano.Wallet.Client , liftClient -- * The type of errors that the client might return , ClientError(..) - , V1Errors.WalletError(..) + , WalletError(..) , ServantError(..) , Response , GenResponse(..) @@ -34,13 +34,12 @@ module Cardano.Wallet.Client import Universum import Control.Exception (Exception (..)) -import Servant.Client (Response, GenResponse (..), ServantError (..)) +import Servant.Client (GenResponse (..), Response, ServantError (..)) import Cardano.Wallet.API.Request.Filter import Cardano.Wallet.API.Request.Pagination import Cardano.Wallet.API.Request.Sort import Cardano.Wallet.API.Response -import qualified Cardano.Wallet.API.V1.Errors as V1Errors import Cardano.Wallet.API.V1.Parameters import Cardano.Wallet.API.V1.Types import qualified Pos.Core as Core @@ -137,7 +136,7 @@ paginateAll request = fmap fixMetadata <$> paginatePage 1 where fixMetadata WalletResponse{..} = WalletResponse - { wrMeta = Metadata $ + { wrMeta = Metadata PaginationMetadata { metaTotalPages = 1 , metaPage = Page 1 @@ -238,7 +237,7 @@ type Resp m a = m (Either ClientError (WalletResponse a)) -- | The type of errors that the wallet might return. data ClientError - = ClientWalletError V1Errors.WalletError + = ClientWalletError WalletError -- ^ The 'WalletError' type represents known failures that the API -- might return. | ClientHttpError ServantError diff --git a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs index 7ce3f00f9d6..8555b88e2e3 100644 --- a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs @@ -2,7 +2,6 @@ A @Plugin@ is essentially a set of actions which will be run in a particular monad, at some point in time. -} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module Cardano.Wallet.Server.Plugins ( @@ -20,7 +19,8 @@ module Cardano.Wallet.Server.Plugins ( import Universum import Cardano.Wallet.API as API -import qualified Cardano.Wallet.API.V1.Errors as V1 +import Cardano.Wallet.API.V1.Headers (applicationJson) +import qualified Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.Kernel.Diffusion as Kernel import qualified Cardano.Wallet.Kernel.Mode as Kernel import qualified Cardano.Wallet.LegacyServer as LegacyServer @@ -171,7 +171,7 @@ legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> handleV1Errors :: SomeException -> Maybe Response handleV1Errors se = let reify (we :: V1.WalletError) = - responseLBS (V1.toHttpStatus we) [V1.applicationJson] . encode $ we + responseLBS (V1.toHttpErrorStatus we) [applicationJson] . encode $ we in fmap reify (fromException se) -- Handles domain-specific errors coming from the V0 API, but rewraps it @@ -187,13 +187,18 @@ legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> V0.RequestError _ -> err V0.InternalError _ -> V0.RequestError "InternalError" V0.DecodeError _ -> V0.RequestError "DecodeError" - reify (re :: V0.WalletError) = V1.UnknownError (sformat build . maskSensitive $ re) - in fmap (responseLBS badRequest400 [V1.applicationJson] . encode . reify) (fromException se) + reify :: V0.WalletError -> V1.WalletError + reify = V1.UnknownError . sformat build . maskSensitive + in fmap (responseLBS badRequest400 [applicationJson] . encode . reify) (fromException se) -- Handles any generic error, trying to prevent internal exceptions from leak outside. handleGenericError :: SomeException -> Response handleGenericError _ = - responseLBS badRequest400 [V1.applicationJson] . encode $ V1.UnknownError "Something went wrong." + let + unknownV1Error = V1.UnknownError "Something went wrong." + in + responseLBS badRequest400 [applicationJson] $ encode unknownV1Error + -- | A 'Plugin' to start the wallet REST server -- diff --git a/wallet-new/test/MarshallingSpec.hs b/wallet-new/test/MarshallingSpec.hs index 967cd9adc9b..15c2ee4ce9c 100644 --- a/wallet-new/test/MarshallingSpec.hs +++ b/wallet-new/test/MarshallingSpec.hs @@ -11,6 +11,7 @@ import Pos.Client.Txp.Util (InputSelectionPolicy) import qualified Pos.Crypto as Crypto import qualified Pos.Txp.Toil.Types as V0 import qualified Pos.Wallet.Web.ClientTypes.Types as V0 +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -22,8 +23,9 @@ import Pos.Util.Mnemonic (Mnemonic) import qualified Pos.Core as Core import Cardano.Wallet.API.Indices -import Cardano.Wallet.API.V1.Errors (WalletError) -import Cardano.Wallet.API.V1.Migration.Types (Migrate (..)) +import Cardano.Wallet.API.Request.Pagination (Page, PerPage) +import Cardano.Wallet.API.Response (JSONValidationError) +import Cardano.Wallet.API.V1.Migration.Types (Migrate (..), MigrationError) import Cardano.Wallet.API.V1.Types import Cardano.Wallet.Orphans () import qualified Cardano.Wallet.Util as Util @@ -32,7 +34,6 @@ import qualified Cardano.Wallet.Util as Util spec :: Spec spec = parallel $ describe "Marshalling & Unmarshalling" $ do parallel $ describe "Roundtrips" $ do - -- Aeson roundrips aesonRoundtripProp @(V1 (Mnemonic 12)) Proxy aesonRoundtripProp @Account Proxy aesonRoundtripProp @AssuranceLevel Proxy @@ -52,6 +53,8 @@ spec = parallel $ describe "Marshalling & Unmarshalling" $ do aesonRoundtripProp @TransactionType Proxy aesonRoundtripProp @TransactionStatus Proxy aesonRoundtripProp @WalletError Proxy + aesonRoundtripProp @JSONValidationError Proxy + aesonRoundtripProp @MigrationError Proxy aesonRoundtripProp @WalletId Proxy aesonRoundtripProp @Wallet Proxy aesonRoundtripProp @SlotDuration Proxy @@ -63,8 +66,19 @@ spec = parallel $ describe "Marshalling & Unmarshalling" $ do aesonRoundtripProp @EstimatedCompletionTime Proxy aesonRoundtripProp @SyncProgress Proxy aesonRoundtripProp @SyncThroughput Proxy - - -- Migrate roundrips + aesonRoundtripProp @AccountIndex Proxy + + -- HttpApiData roundtrips + httpApiDataRoundtripProp @AccountIndex Proxy + httpApiDataRoundtripProp @(V1 Core.TxId) Proxy + httpApiDataRoundtripProp @WalletId Proxy + httpApiDataRoundtripProp @(V1 Core.Timestamp) Proxy + httpApiDataRoundtripProp @(V1 Core.Address) Proxy + httpApiDataRoundtripProp @PerPage Proxy + httpApiDataRoundtripProp @Page Proxy + httpApiDataRoundtripProp @Core.Coin Proxy + + -- Migrate roundtrips migrateRoundtripProp @(V1 Core.Address) @(V0.CId V0.Addr) Proxy Proxy migrateRoundtripProp @(V1 Core.Coin) @V0.CCoin Proxy Proxy migrateRoundtripProp @AssuranceLevel @V0.CWalletAssurance Proxy Proxy @@ -133,7 +147,7 @@ migrateRoundtrip :: (Arbitrary from, Migrate from to, Migrate to from, Eq from, migrateRoundtrip (_ :: proxy from) (_ :: proxy to) = forAll arbitrary $ \(arbitraryFrom :: from) -> do (eitherMigrate =<< migrateTo arbitraryFrom) === Right arbitraryFrom where - migrateTo x = eitherMigrate x :: Either WalletError to + migrateTo x = eitherMigrate x :: Either MigrationError to migrateRoundtripProp :: (Arbitrary from, Migrate from to, Migrate to from, Eq from, Show from, Typeable from, Typeable to) @@ -151,6 +165,16 @@ aesonRoundtripProp aesonRoundtripProp proxy = prop ("Aeson " <> show (typeRep proxy) <> " roundtrips") (aesonRoundtrip proxy) +httpApiDataRoundtrip :: (Arbitrary a, FromHttpApiData a, ToHttpApiData a, Eq a, Show a) => proxy a -> Property +httpApiDataRoundtrip (_ :: proxy a) = forAll arbitrary $ \(s :: a) -> do + parseQueryParam (toQueryParam s) === Right s + +httpApiDataRoundtripProp + :: (Arbitrary a, ToHttpApiData a, FromHttpApiData a, Eq a, Show a, Typeable a) + => proxy a -> Spec +httpApiDataRoundtripProp proxy = + prop ("HttpApiData " <> show (typeRep proxy) <> " roundtrips") (httpApiDataRoundtrip proxy) + generalRoundtrip :: (Arbitrary from, Eq from, Show from, Show e) => (from -> to) -> (to -> Either e from) -> Property