From 7d52ebf7ce9f1eba72d858b4cc1e21c89fadfd11 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Thu, 13 Oct 2022 18:19:07 +0200 Subject: [PATCH] Extract cardano-wallet-api-http library --- cabal.project | 7 +- .../src/Network/Wai/Middleware/Logging.hs | 5 +- .../src/Network/Wai/Middleware/ServerError.hs | 20 +- lib/wai-middleware-logging/test/Main.hs | 13 + .../Network/Wai/Middleware/LoggingSpec.hs | 93 +++- .../wai-middleware-logging.cabal | 76 +++ lib/wallet/{src => api/http}/Cardano/CLI.hs | 2 +- .../{src => api/http}/Cardano/Wallet/Api.hs | 67 +-- .../http}/Cardano/Wallet/Api/Aeson.hs | 0 .../http}/Cardano/Wallet/Api/Aeson/Variant.hs | 0 .../http}/Cardano/Wallet/Api/Client.hs | 51 +- .../http}/Cardano/Wallet/Api/Hex.hs | 0 .../http/Cardano/Wallet/Api/Http}/Logging.hs | 4 +- .../http/Cardano/Wallet/Api/Http}/Server.hs | 30 +- .../Cardano/Wallet/Api/Http}/Server/Error.hs | 39 +- .../Api/Http}/Server/Handlers/Certificates.hs | 6 +- .../Api/Http}/Server/Handlers/TxCBOR.hs | 4 +- .../Cardano/Wallet/Api/Http}/Server/Tls.hs | 2 +- .../Wallet/Api/Http/Shelley}/Server.hs | 63 ++- .../Cardano/Wallet/Api/Lib/ApiAsArray.hs | 0 .../http}/Cardano/Wallet/Api/Lib/ApiT.hs | 0 .../Cardano/Wallet/Api/Lib/ExtendedObject.hs | 0 .../http}/Cardano/Wallet/Api/Lib/Options.hs | 0 .../http}/Cardano/Wallet/Api/Link.hs | 70 +-- .../http}/Cardano/Wallet/Api/Types.hs | 514 +++++++++--------- .../Cardano/Wallet/Api/Types/BlockHeader.hs | 0 .../Cardano/Wallet/Api/Types/Certificate.hs | 4 +- .../http}/Cardano/Wallet/Api/Types/Key.hs | 0 .../Cardano/Wallet/Api/Types/Primitive.hs | 14 +- .../Wallet/Api/Types/SchemaMetadata.hs | 0 .../Cardano/Wallet/Api/Types/Transaction.hs | 4 +- .../http/Cardano/Wallet}/Launch.hs | 14 +- .../http/Cardano/Wallet}/Launch/Blockfrost.hs | 2 +- .../http/Cardano/Wallet}/Launch/Cluster.hs | 8 +- .../http}/Cardano/Wallet/Shelley.hs | 60 +- .../http/Cardano/Wallet}/Tracers.hs | 8 +- lib/wallet/bench/latency-bench.hs | 28 +- lib/wallet/bench/restore-bench.hs | 16 +- lib/wallet/cardano-wallet.cabal | 214 ++++++-- lib/wallet/exe/cardano-wallet.hs | 18 +- lib/wallet/exe/local-cluster.hs | 30 +- .../src/Test/Integration/Framework/DSL.hs | 33 +- .../Test/Integration/Scenario/API/Network.hs | 6 +- .../Scenario/API/Shelley/Network.hs | 6 +- .../Scenario/API/Shelley/Settings.hs | 10 +- .../Scenario/API/Shelley/StakePools.hs | 198 +++---- .../Scenario/API/Shelley/TransactionsNew.hs | 67 ++- .../Test/Integration/Scenario/CLI/Network.hs | 3 +- .../Wallet/TokenMetadata/MockServer.hs | 0 lib/wallet/src/Cardano/Pool/Metadata.hs | 72 ++- .../src/Cardano/Wallet/Api/Types/Address.hs | 58 -- lib/wallet/src/Cardano/Wallet/Gen.hs | 14 - .../src/Cardano/Wallet/Primitive/Types.hs | 3 +- .../Cardano/Wallet/Shelley/Compatibility.hs | 92 ++-- .../Wallet/Shelley/Network/Blockfrost.hs | 65 ++- .../Shelley/Network/Blockfrost/Conversion.hs | 26 +- .../Wallet/Shelley/Network/Discriminant.hs | 92 +++- .../src/Cardano/Wallet/Shelley/Pools.hs | 219 ++++---- lib/wallet/src/Cardano/Wallet/Unsafe.hs | 12 - lib/wallet/src/Network/Ntp.hs | 74 ++- .../Cardano/Wallet/Api/ApiTStakePool.json | 51 ++ .../Wallet/Api/ApiTStakePoolMetrics.json | 20 + .../integration/shelley-integration-test.hs | 42 +- .../test/unit/Cardano/Wallet/Api/Malformed.hs | 6 +- .../unit/Cardano/Wallet/Api/Server/TlsSpec.hs | 4 +- .../unit/Cardano/Wallet/Api/ServerSpec.hs | 2 +- .../test/unit/Cardano/Wallet/Api/TypesSpec.hs | 259 +++++---- .../test/unit/Cardano/Wallet/ApiSpec.hs | 79 ++- .../Wallet/Shelley/Launch/BlockfrostSpec.hs | 4 +- .../unit/Cardano/Wallet/Shelley/LaunchSpec.hs | 2 +- .../Cardano/Wallet/Shelley/NetworkSpec.hs | 16 +- nix/project-package-list.nix | 2 +- 72 files changed, 1704 insertions(+), 1319 deletions(-) rename lib/{wallet => wai-middleware-logging}/src/Network/Wai/Middleware/Logging.hs (99%) rename lib/{wallet => wai-middleware-logging}/src/Network/Wai/Middleware/ServerError.hs (89%) create mode 100644 lib/wai-middleware-logging/test/Main.hs rename lib/{wallet/test/unit => wai-middleware-logging/test}/Network/Wai/Middleware/LoggingSpec.hs (78%) create mode 100644 lib/wai-middleware-logging/wai-middleware-logging.cabal rename lib/wallet/{src => api/http}/Cardano/CLI.hs (99%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api.hs (97%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Aeson.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Aeson/Variant.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Client.hs (94%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Hex.hs (100%) rename lib/wallet/{src/Cardano/Wallet/Shelley => api/http/Cardano/Wallet/Api/Http}/Logging.hs (97%) rename lib/wallet/{src/Cardano/Wallet/Shelley/Api => api/http/Cardano/Wallet/Api/Http}/Server.hs (97%) rename lib/wallet/{src/Cardano/Wallet/Api => api/http/Cardano/Wallet/Api/Http}/Server/Error.hs (99%) rename lib/wallet/{src/Cardano/Wallet/Api => api/http/Cardano/Wallet/Api/Http}/Server/Handlers/Certificates.hs (89%) rename lib/wallet/{src/Cardano/Wallet/Api => api/http/Cardano/Wallet/Api/Http}/Server/Handlers/TxCBOR.hs (95%) rename lib/wallet/{src/Cardano/Wallet/Api => api/http/Cardano/Wallet/Api/Http}/Server/Tls.hs (98%) rename lib/wallet/{src/Cardano/Wallet/Api => api/http/Cardano/Wallet/Api/Http/Shelley}/Server.hs (99%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Lib/ApiAsArray.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Lib/ApiT.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Lib/ExtendedObject.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Lib/Options.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Link.hs (95%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types.hs (96%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/BlockHeader.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/Certificate.hs (99%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/Key.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/Primitive.hs (99%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/SchemaMetadata.hs (100%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Api/Types/Transaction.hs (99%) rename lib/wallet/{src/Cardano/Wallet/Shelley => api/http/Cardano/Wallet}/Launch.hs (97%) rename lib/wallet/{src/Cardano/Wallet/Shelley => api/http/Cardano/Wallet}/Launch/Blockfrost.hs (97%) rename lib/wallet/{src/Cardano/Wallet/Shelley => api/http/Cardano/Wallet}/Launch/Cluster.hs (99%) rename lib/wallet/{src => api/http}/Cardano/Wallet/Shelley.hs (94%) rename lib/wallet/{src/Cardano/Wallet/Shelley => api/http/Cardano/Wallet}/Tracers.hs (98%) rename lib/wallet/{ => mock-token-metadata}/src/Cardano/Wallet/TokenMetadata/MockServer.hs (100%) delete mode 100644 lib/wallet/src/Cardano/Wallet/Api/Types/Address.hs create mode 100644 lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePool.json create mode 100644 lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePoolMetrics.json diff --git a/cabal.project b/cabal.project index 11241d75efd..853a6b89446 100644 --- a/cabal.project +++ b/cabal.project @@ -49,6 +49,7 @@ packages: , lib/text-class/ , lib/test-utils/ , lib/strict-non-empty-containers/ + , lib/wai-middleware-logging/ -- Using RDRAND instead of /dev/urandom as an entropy source for key -- generation is dubious. Set the flag so we use /dev/urandom by default. @@ -381,7 +382,7 @@ package cardano-wallet tests: True ghc-options: -fwrite-ide-info -package cardano-wallet +package cardano-wallet-api-http tests: True ghc-options: -fwrite-ide-info @@ -413,6 +414,10 @@ package strict-non-empty-containers tests: True ghc-options: -fwrite-ide-info +package wai-middleware-logging + tests: True + ghc-options: -fwrite-ide-info + -- Now disable all other tests with a global flag. -- This is what they do in cardano-node/cabal.project. diff --git a/lib/wallet/src/Network/Wai/Middleware/Logging.hs b/lib/wai-middleware-logging/src/Network/Wai/Middleware/Logging.hs similarity index 99% rename from lib/wallet/src/Network/Wai/Middleware/Logging.hs rename to lib/wai-middleware-logging/src/Network/Wai/Middleware/Logging.hs index de7320a48fa..5b28f2bc73e 100644 --- a/lib/wallet/src/Network/Wai/Middleware/Logging.hs +++ b/lib/wai-middleware-logging/src/Network/Wai/Middleware/Logging.hs @@ -78,10 +78,7 @@ import qualified Data.Text.Encoding as T -- -- The logger logs requests' and responses' bodies along with a few other -- useful piece of information. -withApiLogger - :: Tracer IO ApiLog - -> ApiLoggerSettings - -> Middleware +withApiLogger :: Tracer IO ApiLog -> ApiLoggerSettings -> Middleware withApiLogger t0 settings app req0 sendResponse = do rid <- nextRequestId settings let t = contramap (ApiLog rid) t0 diff --git a/lib/wallet/src/Network/Wai/Middleware/ServerError.hs b/lib/wai-middleware-logging/src/Network/Wai/Middleware/ServerError.hs similarity index 89% rename from lib/wallet/src/Network/Wai/Middleware/ServerError.hs rename to lib/wai-middleware-logging/src/Network/Wai/Middleware/ServerError.hs index 182b37b40bc..5a7783c2745 100644 --- a/lib/wallet/src/Network/Wai/Middleware/ServerError.hs +++ b/lib/wai-middleware-logging/src/Network/Wai/Middleware/ServerError.hs @@ -55,9 +55,7 @@ handleRawError adjust app req send = -- | Analyze whether a given error is a raw error thrown by Servant before -- reaching our application layer, or one from our application layer. -eitherRawError - :: Response - -> Either ServerError Response +eitherRawError :: Response -> Either ServerError Response eitherRawError res = let status = responseStatus res @@ -74,15 +72,9 @@ eitherRawError res = -- | Extract raw body of a response, only if it suitables for transformation. -- Servant doesn't return files or streams by default, so if one of the two is -- met, it means it comes from our application layer anyway. -responseBody - :: Response - -> Maybe ByteString +responseBody :: Response -> Maybe ByteString responseBody = \case - ResponseBuilder _ _ b -> - Just (Binary.toLazyByteString b) - ResponseRaw _ r -> - responseBody r - ResponseFile{} -> - Nothing - ResponseStream{} -> - Nothing + ResponseBuilder _ _ b -> Just (Binary.toLazyByteString b) + ResponseRaw _ r -> responseBody r + ResponseFile{} -> Nothing + ResponseStream{} -> Nothing diff --git a/lib/wai-middleware-logging/test/Main.hs b/lib/wai-middleware-logging/test/Main.hs new file mode 100644 index 00000000000..21bc27cea85 --- /dev/null +++ b/lib/wai-middleware-logging/test/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Main.Utf8 + ( withUtf8 ) +import Test.Hspec.Extra + ( hspecMain ) + +import qualified Network.Wai.Middleware.LoggingSpec as LoggingSpec + +main :: IO () +main = withUtf8 $ hspecMain LoggingSpec.spec diff --git a/lib/wallet/test/unit/Network/Wai/Middleware/LoggingSpec.hs b/lib/wai-middleware-logging/test/Network/Wai/Middleware/LoggingSpec.hs similarity index 78% rename from lib/wallet/test/unit/Network/Wai/Middleware/LoggingSpec.hs rename to lib/wai-middleware-logging/test/Network/Wai/Middleware/LoggingSpec.hs index 0cd5b93af7c..90ff0085e44 100644 --- a/lib/wallet/test/unit/Network/Wai/Middleware/LoggingSpec.hs +++ b/lib/wai-middleware-logging/test/Network/Wai/Middleware/LoggingSpec.hs @@ -3,12 +3,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Network.Wai.Middleware.LoggingSpec - ( spec - ) where +module Network.Wai.Middleware.LoggingSpec (spec) where import Prelude @@ -18,8 +17,6 @@ import Cardano.BM.Data.Tracer ( HasSeverityAnnotation (..) ) import Cardano.BM.Trace ( traceInTVarIO ) -import Cardano.Wallet.Api.Server - ( Listen (..), withListeningSocket ) import Control.Monad ( forM_, void, when ) import Control.Monad.IO.Class @@ -34,8 +31,12 @@ import Data.Function ( (&) ) import Data.Functor ( ($>), (<&>) ) +import Data.List + ( isInfixOf ) import Data.Proxy ( Proxy (..) ) +import Data.Streaming.Network + ( HostPreference, bindPortTCP, bindRandomPortTCP ) import Data.Text ( Text ) import Data.Text.Class @@ -57,7 +58,7 @@ import Network.HTTP.Client import Network.HTTP.Types.Header ( hContentType ) import Network.Socket - ( Socket ) + ( Socket, close ) import Network.Wai.Handler.Warp ( Port, runSettingsSocket, setBeforeMainLoop ) import Network.Wai.Middleware.Logging @@ -88,10 +89,19 @@ import Servant ) import Servant.Server ( Handler ) +import System.IO.Error + ( ioeGetErrorType + , isAlreadyInUseError + , isDoesNotExistError + , isPermissionError + , isUserError + ) import Test.Hspec ( Spec, after, before, describe, it, shouldBe, shouldContain ) import Test.QuickCheck ( Arbitrary (..), choose ) +import UnliftIO + ( IOException, bracket, tryJust ) import UnliftIO.Async ( Async, async, cancel ) import UnliftIO.Concurrent @@ -413,3 +423,74 @@ type Api = :<|> "error400" :> Get '[JSON] () :<|> "error500" :> Get '[JSON] () :<|> "error503" :> Get '[JSON] () + +-- | How the server should listen for incoming requests. +data Listen + = ListenOnPort Port + -- ^ Listen on given TCP port + | ListenOnRandomPort + -- ^ Listen on an unused TCP port, selected at random + deriving (Show, Eq) + +withListeningSocket + :: HostPreference + -- ^ Which host to bind. + -> Listen + -- ^ Whether to listen on a given port, or random port. + -> (Either ListenError (Port, Socket) -> IO a) + -- ^ Action to run with listening socket. + -> IO a +withListeningSocket hostPreference portOpt = bracket acquire release + where + acquire = tryJust handleErr bindAndListen + -- Note: These Data.Streaming.Network functions also listen on the socket, + -- even though their name just says "bind". + bindAndListen = case portOpt of + ListenOnPort p -> (p,) <$> bindPortTCP p hostPreference + ListenOnRandomPort -> bindRandomPortTCP hostPreference + release (Right (_, socket)) = liftIO $ close socket + release (Left _) = pure () + handleErr = ioToListenError hostPreference portOpt + +data ListenError + = ListenErrorAddressAlreadyInUse (Maybe Port) + | ListenErrorOperationNotPermitted + | ListenErrorHostDoesNotExist HostPreference + | ListenErrorInvalidAddress HostPreference + deriving (Show, Eq) + +ioToListenError :: HostPreference -> Listen -> IOException -> Maybe ListenError +ioToListenError hostPreference portOpt e + -- A socket is already listening on that address and port + | isAlreadyInUseError e = + Just (ListenErrorAddressAlreadyInUse (listenPort portOpt)) + -- Usually caused by trying to listen on a privileged port + | isPermissionError e = + Just ListenErrorOperationNotPermitted + -- Bad hostname -- Linux and Darwin + | isDoesNotExistError e = + Just (ListenErrorHostDoesNotExist hostPreference) + -- Bad hostname -- Windows + -- WSAHOST_NOT_FOUND, WSATRY_AGAIN, or bind: WSAEOPNOTSUPP + | isUserError e && any hasDescription ["11001", "11002", "10045"] = + Just (ListenErrorHostDoesNotExist hostPreference) + -- Address is valid, but can't be used for listening -- Linux + | show (ioeGetErrorType e) == "invalid argument" = + Just (ListenErrorInvalidAddress hostPreference) + -- Address is valid, but can't be used for listening -- Darwin + | show (ioeGetErrorType e) == "unsupported operation" = + Just (ListenErrorInvalidAddress hostPreference) + -- Address is valid, but can't be used for listening -- Windows + | isOtherError e && any hasDescription ["WSAEINVAL", "WSAEADDRNOTAVAIL"] = + Just (ListenErrorInvalidAddress hostPreference) + -- Listening on an unavailable or privileged port -- Windows + | isOtherError e && hasDescription "WSAEACCESS" = + Just (ListenErrorAddressAlreadyInUse (listenPort portOpt)) + | otherwise = + Nothing + where + listenPort (ListenOnPort p) = Just p + listenPort ListenOnRandomPort = Nothing + + isOtherError ex = show (ioeGetErrorType ex) == "failed" + hasDescription text = text `isInfixOf` show e diff --git a/lib/wai-middleware-logging/wai-middleware-logging.cabal b/lib/wai-middleware-logging/wai-middleware-logging.cabal new file mode 100644 index 00000000000..af1f139cb8d --- /dev/null +++ b/lib/wai-middleware-logging/wai-middleware-logging.cabal @@ -0,0 +1,76 @@ +cabal-version: 2.2 +name: wai-middleware-logging +version: 1.0 +synopsis: WAI Middleware for Logging +homepage: https://github.com/input-output-hk/cardano-wallet +author: IOHK Engineering Team +maintainer: operations@iohk.io +copyright: 2018-2022 IOHK +license: Apache-2.0 +category: Web +build-type: Simple + +flag release + description: Enable optimization and `-Werror` + default: False + manual: True + +common language + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +common opts-lib + ghc-options: -Wall -Wcompat -fwarn-redundant-constraints + + if flag(release) + ghc-options: -O2 -Werror + +common opts-exe + ghc-options: -threaded -rtsopts -Wall + + if flag(release) + ghc-options: -O2 -Werror + +common deps + build-depends: + , aeson + , base + , binary + , bytestring + , cardano-wallet-test-utils + , contra-tracer + , hspec + , http-client + , http-types + , iohk-monitoring + , network + , QuickCheck + , servant-server + , streaming-commons + , text + , text-class + , time + , unliftio + , unordered-containers + , wai + , warp + , with-utf8 + +library + import: language, opts-lib, deps + hs-source-dirs: src + exposed-modules: + Network.Wai.Middleware.Logging + Network.Wai.Middleware.ServerError + +test-suite unit + import: language, opts-exe, deps + ghc-options: -with-rtsopts=-M2G -with-rtsopts=-N4 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: wai-middleware-logging + build-tool-depends: hspec-discover:hspec-discover + other-modules: Network.Wai.Middleware.LoggingSpec diff --git a/lib/wallet/src/Cardano/CLI.hs b/lib/wallet/api/http/Cardano/CLI.hs similarity index 99% rename from lib/wallet/src/Cardano/CLI.hs rename to lib/wallet/api/http/Cardano/CLI.hs index bb2017df381..6eceff82dbd 100644 --- a/lib/wallet/src/Cardano/CLI.hs +++ b/lib/wallet/api/http/Cardano/CLI.hs @@ -137,7 +137,7 @@ import Cardano.Wallet.Api.Client , TransactionClient (..) , WalletClient (..) ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( HostPreference, Listen (..), TlsConfiguration (..) ) import Cardano.Wallet.Api.Types ( AccountPostData (..) diff --git a/lib/wallet/src/Cardano/Wallet/Api.hs b/lib/wallet/api/http/Cardano/Wallet/Api.hs similarity index 97% rename from lib/wallet/src/Cardano/Wallet/Api.hs rename to lib/wallet/api/http/Cardano/Wallet/Api.hs index 17fffd2ae37..485cc2628c1 100644 --- a/lib/wallet/src/Cardano/Wallet/Api.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api.hs @@ -72,6 +72,7 @@ module Cardano.Wallet.Api , QuitStakePool , DelegationFee , ListStakeKeys + , PoolMaintenance , PostPoolMaintenance , GetPoolMaintenance @@ -196,7 +197,7 @@ import Cardano.Wallet.Api.Types , ApiNetworkParameters , ApiPolicyId , ApiPolicyKey - , ApiPoolId + , ApiPoolSpecifier , ApiPostAccountKeyData , ApiPostAccountKeyDataWithPurpose , ApiPostPolicyIdData @@ -307,11 +308,13 @@ import Servant.API.Verbs ) import qualified Cardano.Wallet.Primitive.Types as W +import Cardano.Wallet.Shelley.Pools + ( StakePool ) -type ApiV2 n apiPool = "v2" :> Api n apiPool +type ApiV2 n = "v2" :> Api n -- | The full cardano-wallet API. -type Api n apiPool = +type Api n = Wallets :<|> WalletKeys :<|> Assets @@ -319,7 +322,7 @@ type Api n apiPool = :<|> CoinSelections n :<|> ShelleyTransactions n :<|> ShelleyMigrations n - :<|> StakePools n apiPool + :<|> StakePools n :<|> ByronWallets :<|> ByronAssets :<|> ByronAddresses n @@ -669,56 +672,54 @@ type CreateShelleyWalletMigrationPlan n = "wallets" See also: https://input-output-hk.github.io/cardano-wallet/api/edge/#tag/Stake-Pools -------------------------------------------------------------------------------} -type StakePools n apiPool = - ListStakePools apiPool +-- Factoring out common prefixes into nested APIs +-- doesn't work well with the functionality provided +-- by the Servant.Links module. + +type StakePools n + = ListStakePools :<|> JoinStakePool n :<|> QuitStakePool n + :<|> PoolMaintenance :<|> DelegationFee :<|> ListStakeKeys n - :<|> PostPoolMaintenance - :<|> GetPoolMaintenance --- | https://input-output-hk.github.io/cardano-wallet/api/edge/#operation/listStakePools -type ListStakePools apiPool = "stake-pools" - :> QueryParam "stake" (ApiT Coin) - :> Get '[JSON] [apiPool] +type ListStakePools = + "stake-pools" + :> QueryParam "stake" (ApiT Coin) :> Get '[JSON] [ApiT StakePool] --- | https://input-output-hk.github.io/cardano-wallet/api/#operation/joinStakePool -type JoinStakePool n = "stake-pools" - :> Capture "stakePoolId" ApiPoolId - :> "wallets" - :> Capture "walletId" (ApiT WalletId) +type JoinStakePool n = + "stake-pools" :> Capture "stakePoolId" ApiPoolSpecifier + :> "wallets" :> Capture "walletId" (ApiT WalletId) :> ReqBody '[JSON] ApiWalletPassphrase :> PutAccepted '[JSON] (ApiTransactionT n) --- | https://input-output-hk.github.io/cardano-wallet/api/#operation/quitStakePool -type QuitStakePool n = "stake-pools" - :> "*" - :> "wallets" - :> Capture "walletId" (ApiT WalletId) +type QuitStakePool n = + "stake-pools" :> "*" + :> "wallets" :> Capture "walletId" (ApiT WalletId) :> ReqBody '[JSON] ApiWalletPassphrase :> DeleteAccepted '[JSON] (ApiTransactionT n) +type DelegationFee = "wallets" + :> Capture "walletId" (ApiT WalletId) + :> "delegation-fees" + :> Get '[JSON] ApiFee + type ListStakeKeys n = "wallets" :> Capture "walletId" (ApiT WalletId) :> "stake-keys" :> Get '[JSON] (ApiStakeKeysT n) --- | https://input-output-hk.github.io/cardano-wallet/api/#operation/getDelegationFee -type DelegationFee = "wallets" - :> Capture "walletId" (ApiT WalletId) - :> "delegation-fees" - :> Get '[JSON] ApiFee +type PoolMaintenance + = PostPoolMaintenance :<|> GetPoolMaintenance --- | https://input-output-hk.github.io/cardano-wallet/api/#operation/postPoolMaintenance -type PostPoolMaintenance = "stake-pools" - :> "maintenance-actions" +type PostPoolMaintenance = + "stake-pools" :> "maintenance-actions" :> ReqBody '[JSON] ApiMaintenanceActionPostData :> PostNoContent --- | https://input-output-hk.github.io/cardano-wallet/api/#operation/getPoolMaintenance -type GetPoolMaintenance = "stake-pools" - :> "maintenance-actions" +type GetPoolMaintenance = + "stake-pools" :> "maintenance-actions" :> Get '[JSON] ApiMaintenanceAction {------------------------------------------------------------------------------- diff --git a/lib/wallet/src/Cardano/Wallet/Api/Aeson.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Aeson.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Aeson.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Aeson.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Aeson/Variant.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Aeson/Variant.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Aeson/Variant.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Aeson/Variant.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Client.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs similarity index 94% rename from lib/wallet/src/Cardano/Wallet/Api/Client.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Client.hs index 7762e3a5bd8..b8ea61eeda0 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Client.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -72,14 +73,13 @@ import Cardano.Wallet.Api.Types , ApiNetworkClock , ApiNetworkInformation (..) , ApiNetworkParameters - , ApiPoolId + , ApiPoolSpecifier , ApiPostRandomAddressData , ApiPutAddressesDataT , ApiSelectCoinsDataT , ApiSerialisedTransaction (..) , ApiSignTransactionPostData , ApiStakeKeysT - , ApiStakePool , ApiT (..) , ApiTransactionT , ApiTxId (..) @@ -122,6 +122,8 @@ import Servant.Client import UnliftIO.Exception ( throwString ) +import Cardano.Wallet.Shelley.Pools + ( StakePool ) import qualified Data.Aeson as Aeson {------------------------------------------------------------------------------- @@ -235,9 +237,9 @@ data AddressClient = AddressClient data StakePoolClient = StakePoolClient { listPools - :: Maybe (ApiT Coin) -> ClientM [ApiStakePool] + :: Maybe (ApiT Coin) -> ClientM [ApiT StakePool] , joinStakePool - :: ApiPoolId + :: ApiPoolSpecifier -> ApiT WalletId -> ApiWalletPassphrase -> ClientM (ApiTransactionT Aeson.Value) @@ -309,8 +311,7 @@ byronWalletClient = } -- | Produces a 'TransactionClient t' working against the /wallets API. -transactionClient - :: TransactionClient +transactionClient :: TransactionClient transactionClient = let _constructTransaction @@ -348,8 +349,7 @@ fromSerialisedTx :: ApiBytesT base SerialisedTx -> ApiT SealedTx fromSerialisedTx = ApiT . unsafeSealedTxFromBytes . view (#getApiBytesT . #payload) -- | Produces a 'TransactionClient n' working against the /byron-wallets API. -byronTransactionClient - :: TransactionClient +byronTransactionClient :: TransactionClient byronTransactionClient = let _listTransactions @@ -378,8 +378,7 @@ byronTransactionClient = } -- | Produces an 'AddressClient n' working against the /wallets API -addressClient - :: AddressClient +addressClient :: AddressClient addressClient = let _listAddresses @@ -399,8 +398,7 @@ addressClient = } -- | Produces an 'AddressClient n' working against the /wallets API -byronAddressClient - :: AddressClient +byronAddressClient :: AddressClient byronAddressClient = let _ :<|> _inspectAddress @@ -427,30 +425,25 @@ byronAddressClient = -- | Produces an 'StakePoolsClient n' working against the /stake-pools API stakePoolClient :: StakePoolClient stakePoolClient = - let - _listPools - :<|> _joinStakePool - :<|> _quitStakePool - :<|> _delegationFee - :<|> _listStakeKeys - :<|> _postPoolMaintenance - :<|> _getPoolMaintenance - = client (Proxy @("v2" :> StakePools Aeson.Value ApiStakePool)) + let listPools + :<|> joinStakePool + :<|> quitStakePool + :<|> _ + :<|> _ + :<|> _ + = client (Proxy @("v2" :> StakePools Aeson.Value)) in StakePoolClient - { listPools = _listPools - , joinStakePool = _joinStakePool - , quitStakePool = _quitStakePool + { listPools + , joinStakePool + , quitStakePool } -- | Produces a 'NetworkClient' -networkClient - :: NetworkClient +networkClient :: NetworkClient networkClient = let - _networkInformation - :<|> _networkParameters - :<|> _networkClock + _networkInformation :<|> _networkParameters :<|> _networkClock = client (Proxy @("v2" :> Network)) in NetworkClient diff --git a/lib/wallet/src/Cardano/Wallet/Api/Hex.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Hex.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Hex.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Hex.hs diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Logging.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Logging.hs similarity index 97% rename from lib/wallet/src/Cardano/Wallet/Shelley/Logging.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Logging.hs index 9856e2c74c1..da5cd87b0cd 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Logging.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Logging.hs @@ -10,7 +10,7 @@ -- -- Logging functionality for the Shelley wallet -- -module Cardano.Wallet.Shelley.Logging +module Cardano.Wallet.Api.Http.Logging ( ApplicationLog(..) ) where @@ -22,7 +22,7 @@ import Cardano.BM.Tracing ( HasPrivacyAnnotation, HasSeverityAnnotation, Severity (..) ) import Cardano.Launcher.Node ( CardanoNodeConn ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( ListenError (..) ) import Data.Text ( Text ) diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs similarity index 97% rename from lib/wallet/src/Cardano/Wallet/Shelley/Api/Server.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs index 6b52e7266bc..da1f6ea14b6 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs @@ -13,7 +13,7 @@ -- API handlers and server using the underlying wallet layer to provide -- endpoints reachable through HTTP. -module Cardano.Wallet.Shelley.Api.Server +module Cardano.Wallet.Api.Http.Server ( server ) where @@ -23,8 +23,15 @@ import Cardano.Address ( unAddress ) import Cardano.Address.Script ( prettyErrValidateScript, validateScript ) +import Cardano.Api + ( NetworkId ) import Cardano.Pool.Metadata - ( defaultManagerSettings, healthCheck, newManager, toHealthCheckSMASH ) + ( HealthCheckSMASH (NoSmashConfigured) + , defaultManagerSettings + , healthCheck + , newManager + , toHealthCheckSMASH + ) import Cardano.Wallet ( ErrCreateRandomAddress (..) , ErrNotASequentialWallet (..) @@ -59,7 +66,7 @@ import Cardano.Wallet.Api , WalletKeys , Wallets ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( apiError , balanceTransaction , constructSharedTransaction @@ -148,13 +155,11 @@ import Cardano.Wallet.Api.Types , ApiPostAccountKeyDataWithPurpose (..) , ApiSelectCoinsAction (..) , ApiSelectCoinsData (..) - , ApiStakePool , ApiT (..) , ApiVerificationKeyShared (..) , ApiVerificationKeyShelley (..) , ApiWalletMode (..) , ApiWithdrawalPostData (..) - , HealthCheckSMASH (..) , MaintenanceAction (..) , SettingsPutData (..) , SomeByronWalletPostData (..) @@ -186,7 +191,9 @@ import Cardano.Wallet.Primitive.Types import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Compatibility - ( HasNetworkId (..), NetworkId, inspectAddress, rewardAccountFromAddress ) + ( inspectAddress, rewardAccountFromAddress ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( HasNetworkId (networkIdVal) ) import Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) ) import Control.Applicative @@ -244,7 +251,7 @@ server -> StakePoolLayer -> NtpClient -> BlockchainSource - -> Server (Api n ApiStakePool) + -> Server (Api n) server byron icarus shelley multisig spl ntp blockchainSource = wallets :<|> walletKeys @@ -354,20 +361,19 @@ server byron icarus shelley multisig spl ntp blockchainSource = createMigrationPlan @_ @_ shelley (Just SelfWithdrawal) :<|> migrateWallet shelley (Just SelfWithdrawal) - stakePools :: Server (StakePools n ApiStakePool) + stakePools :: Server (StakePools n) stakePools = - listStakePools_ + listStakePools_ :<|> joinStakePool shelley (knownPools spl) (getPoolLifeCycleStatus spl) :<|> quitStakePool shelley + :<|> (postPoolMaintenance :<|> getPoolMaintenance) :<|> delegationFee shelley :<|> listStakeKeys rewardAccountFromAddress shelley - :<|> postPoolMaintenance - :<|> getPoolMaintenance where listStakePools_ = \case Just (ApiT stake) -> do currentEpoch <- getCurrentEpoch shelley - liftIO $ listStakePools spl currentEpoch stake + liftIO $ fmap ApiT <$> listStakePools spl currentEpoch stake Nothing -> Handler $ throwE $ apiError err400 QueryParamMissing $ mconcat [ "The stake intended to delegate must be provided as a query " diff --git a/lib/wallet/src/Cardano/Wallet/Api/Server/Error.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Api/Server/Error.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs index fdc8539c0f0..c8590558955 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Server/Error.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs @@ -10,7 +10,7 @@ -- -- 'IsServerError' definition along with most instances -- -module Cardano.Wallet.Api.Server.Error +module Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..) , liftHandler , liftE @@ -22,25 +22,6 @@ module Cardano.Wallet.Api.Server.Error import Prelude -import Cardano.Wallet.Api.Types - ( ApiErrorCode (..), Iso8601Time (..) ) -import Control.Monad.Except - ( ExceptT, withExceptT ) -import Control.Monad.Trans.Except - ( throwE ) -import Data.Aeson - ( (.=) ) -import Data.Text - ( Text ) -import Fmt - ( blockListF', build, fmt, listF, pretty ) -import Network.HTTP.Media - ( renderHeader ) -import Network.HTTP.Types - ( hContentType ) -import Servant - ( Accept (contentType), JSON, Proxy (Proxy) ) - import Cardano.Address.Script ( Cosigner (..) ) import Cardano.Ledger.Alonzo.TxInfo @@ -91,6 +72,8 @@ import Cardano.Wallet , ErrWritePolicyPublicKey (..) , ErrWrongPassphrase (..) ) +import Cardano.Wallet.Api.Types + ( ApiErrorCode (..), Iso8601Time (..) ) import Cardano.Wallet.CoinSelection ( SelectionBalanceError (..) , SelectionCollateralError @@ -113,16 +96,32 @@ import Cardano.Wallet.Primitive.Types.TokenBundle ( Flat (..) ) import Cardano.Wallet.Transaction ( ErrAssignRedeemers (..), ErrSignTx (..) ) +import Control.Monad.Except + ( ExceptT, withExceptT ) +import Control.Monad.Trans.Except + ( throwE ) +import Data.Aeson + ( (.=) ) import Data.Generics.Internal.VL ( view, (^.) ) import Data.List ( isInfixOf, isPrefixOf, isSubsequenceOf ) import Data.Maybe ( isJust ) +import Data.Text + ( Text ) import Data.Text.Class ( ToText (..) ) +import Fmt + ( blockListF', build, fmt, listF, pretty ) +import Network.HTTP.Media + ( renderHeader ) +import Network.HTTP.Types + ( hContentType ) import Network.Wai ( Request (pathInfo) ) +import Servant + ( Accept (contentType), JSON, Proxy (Proxy) ) import Servant.Server ( Handler (Handler) , ServerError (..) diff --git a/lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/Certificates.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs similarity index 89% rename from lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/Certificates.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs index 41c71f83407..167cc251c17 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/Certificates.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs @@ -9,16 +9,16 @@ -- License: Apache-2.0 -- -module Cardano.Wallet.Api.Server.Handlers.Certificates +module Cardano.Wallet.Api.Http.Server.Handlers.Certificates ( getApiAnyCertificates ) where import Cardano.Wallet.Api ( ApiLayer ) -import Cardano.Wallet.Api.Server.Error +import Cardano.Wallet.Api.Http.Server.Error ( liftHandler ) -import Cardano.Wallet.Api.Server.Handlers.TxCBOR +import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR ( ParsedTxCBOR (..) ) import Cardano.Wallet.Api.Types.Certificate ( ApiAnyCertificate, mkApiAnyCertificate ) diff --git a/lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/TxCBOR.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/TxCBOR.hs similarity index 95% rename from lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/TxCBOR.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/TxCBOR.hs index a472bd8ba8f..94755e8b391 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Server/Handlers/TxCBOR.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/TxCBOR.hs @@ -6,7 +6,7 @@ -- License: Apache-2.0 -- -module Cardano.Wallet.Api.Server.Handlers.TxCBOR +module Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR ( parseTxCBOR , ParsedTxCBOR (..) ) @@ -15,7 +15,7 @@ module Cardano.Wallet.Api.Server.Handlers.TxCBOR import Prelude hiding ( (.) ) -import Cardano.Wallet.Api.Server.Error +import Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..), apiError, liftE, showT ) import Cardano.Wallet.Api.Types ( ApiErrorCode (UnexpectedError) ) diff --git a/lib/wallet/src/Cardano/Wallet/Api/Server/Tls.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Tls.hs similarity index 98% rename from lib/wallet/src/Cardano/Wallet/Api/Server/Tls.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Tls.hs index 9ea80eb1e75..1859264adb8 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Server/Tls.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Tls.hs @@ -7,7 +7,7 @@ -- Optional TLS support for mutual client-server authentication on top of a Wai -- application. -module Cardano.Wallet.Api.Server.Tls +module Cardano.Wallet.Api.Http.Server.Tls ( TlsConfiguration (..) , requireClientAuth ) where diff --git a/lib/wallet/src/Cardano/Wallet/Api/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Api/Server.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs index 140d860ef18..a5f4f4d7280 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs @@ -23,7 +23,7 @@ -- API handlers and server using the underlying wallet layer to provide -- endpoints reachable through HTTP. -module Cardano.Wallet.Api.Server +module Cardano.Wallet.Api.Http.Shelley.Server ( -- * Server Configuration Listen (..) @@ -182,13 +182,13 @@ import Cardano.Wallet.Api , walletLocks , workerRegistry ) -import Cardano.Wallet.Api.Server.Error +import Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..), apiError, liftE, liftHandler ) -import Cardano.Wallet.Api.Server.Handlers.Certificates +import Cardano.Wallet.Api.Http.Server.Handlers.Certificates ( getApiAnyCertificates ) -import Cardano.Wallet.Api.Server.Handlers.TxCBOR +import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR ( parseTxCBOR ) -import Cardano.Wallet.Api.Server.Tls +import Cardano.Wallet.Api.Http.Server.Tls ( TlsConfiguration (..), requireClientAuth ) import Cardano.Wallet.Api.Types ( AccountPostData (..) @@ -217,7 +217,6 @@ import Cardano.Wallet.Api.Types , ApiConstructTransaction (..) , ApiConstructTransactionData (..) , ApiDecodedTransaction (..) - , ApiEpochInfo (ApiEpochInfo) , ApiErrorCode (..) , ApiExternalInput (..) , ApiFee (..) @@ -236,7 +235,7 @@ import Cardano.Wallet.Api.Types , ApiPendingSharedWallet (..) , ApiPolicyId (..) , ApiPolicyKey (..) - , ApiPoolId (..) + , ApiPoolSpecifier (..) , ApiPostAccountKeyDataWithPurpose (..) , ApiPostPolicyIdData , ApiPostPolicyKeyData (..) @@ -310,7 +309,6 @@ import Cardano.Wallet.Api.Types , XPubOrSelf (..) , getApiMnemonicT , toApiAsset - , toApiEpochInfo , toApiEra , toApiNetworkParameters , toApiUtxoStatistics @@ -488,6 +486,8 @@ import Cardano.Wallet.Registry , defaultWorkerAfter , workerResource ) +import Cardano.Wallet.Shelley.Pools + ( EpochInfo (..), toEpochInfo ) import Cardano.Wallet.TokenMetadata ( TokenMetadataClient, fillMetadata ) import Cardano.Wallet.Transaction @@ -622,9 +622,14 @@ import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Primitive.Types.Coin as Coin import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap -import qualified Cardano.Wallet.Primitive.Types.Tx as W +import qualified Cardano.Wallet.Primitive.Types.Tx.SealedTx as W + ( SealedTx, sealedTxFromCardano ) +import qualified Cardano.Wallet.Primitive.Types.Tx.Tx as W + ( TxMetadata, TxScriptValidity ) +import qualified Cardano.Wallet.Primitive.Types.Tx.TxMeta as W + ( Direction (Incoming, Outgoing), TxMeta ) import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO -import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex +import qualified Cardano.Wallet.Primitive.Types.UTxOIndex.Internal as UTxOIndex import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection import qualified Cardano.Wallet.Registry as Registry import qualified Control.Concurrent.Concierge as Concierge @@ -634,6 +639,7 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Network.Ntp as Ntp import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as Warp @@ -904,12 +910,10 @@ mkShelleyWallet ctx wid cp meta pending progress = do } toApiWalletDelegation - :: W.WalletDelegation - -> TimeInterpreter IO - -> IO ApiWalletDelegation + :: W.WalletDelegation -> TimeInterpreter IO -> IO ApiWalletDelegation toApiWalletDelegation W.WalletDelegation{active,next} ti = do apiNext <- forM next $ \W.WalletDelegationNext{status,changesAt} -> do - info <- interpretQuery ti $ toApiEpochInfo changesAt + info <- interpretQuery ti $ toEpochInfo changesAt return $ toApiWalletDelegationNext (Just info) status return $ ApiWalletDelegation @@ -3141,23 +3145,22 @@ joinStakePool -- ^ Known pools -- We could maybe replace this with a @IO (PoolId -> Bool)@ -> (PoolId -> IO PoolLifeCycleStatus) - -> ApiPoolId + -> ApiPoolSpecifier -> ApiT WalletId -> ApiWalletPassphrase -> Handler (ApiTransaction n) -joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do +joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do let pwd = coerce $ getApiT $ body ^. #passphrase + poolId <- case apiPool of + AllPools -> liftE ErrUnexpectedPoolIdPlaceholder + SpecificPool pool -> pure pool - pid <- case apiPoolId of - ApiPoolIdPlaceholder -> liftE ErrUnexpectedPoolIdPlaceholder - ApiPoolId pid -> pure pid - - poolStatus <- liftIO (getPoolStatus pid) + poolStatus <- liftIO (getPoolStatus poolId) pools <- liftIO knownPools curEpoch <- getCurrentEpoch ctx withWorkerCtx ctx wid liftE liftE $ \wrk -> do (action, _) <- liftHandler - $ W.joinStakePool @_ @s @k wrk curEpoch pools pid poolStatus wid + $ W.joinStakePool @_ @s @k wrk curEpoch pools poolId poolStatus wid -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read -- @currentNodeEra@ which is not guaranteed with the era read here. This @@ -3682,15 +3685,13 @@ getNetworkInformation nid -- (network tip, next epoch) -- May be unavailable if the node is still syncing. - networkTipInfo :: RelativeTime -> MaybeT IO (ApiSlotReference, ApiEpochInfo) + networkTipInfo :: RelativeTime -> MaybeT IO (ApiSlotReference, EpochInfo) networkTipInfo now = do networkTipSlot <- interpretQuery ti $ ongoingSlotAt now tip <- makeApiSlotReference ti networkTipSlot let curEpoch = tip ^. #slotId . #epochNumber . #getApiT (_, nextEpochStart) <- interpretQuery ti $ timeOfEpoch curEpoch - let nextEpoch = ApiEpochInfo - (ApiT $ succ curEpoch) - nextEpochStart + let nextEpoch = EpochInfo (succ curEpoch) nextEpochStart return (tip, nextEpoch) getNetworkParameters @@ -3701,7 +3702,7 @@ getNetworkParameters (_block0, genesisNp) nl = do pp <- liftIO $ NW.currentProtocolParameters nl sp <- liftIO $ NW.currentSlottingParameters nl let np = genesisNp { protocolParameters = pp, slottingParameters = sp } - liftIO $ toApiNetworkParameters np (interpretQuery ti . toApiEpochInfo) + liftIO $ toApiNetworkParameters np (interpretQuery ti . toEpochInfo) where ti :: TimeInterpreter IO ti = neverFails @@ -3711,7 +3712,13 @@ getNetworkParameters (_block0, genesisNp) nl = do (timeInterpreter nl) getNetworkClock :: NtpClient -> Bool -> Handler ApiNetworkClock -getNetworkClock client = liftIO . getNtpStatus client +getNetworkClock client force = + liftIO $ ApiNetworkClock <$> getNtpStatus client forceCheck + where + forceCheck = + if force + then Ntp.ForceBlockingRequest + else Ntp.CanUseCachedResults getBlocksLatestHeader :: NetworkLayer IO Block -> Handler ApiBlockHeader getBlocksLatestHeader nl = liftIO $ mkApiBlockHeader <$> NW.currentNodeTip nl diff --git a/lib/wallet/src/Cardano/Wallet/Api/Lib/ApiAsArray.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Lib/ApiAsArray.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Lib/ApiAsArray.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Lib/ApiAsArray.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Lib/ApiT.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Lib/ApiT.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Lib/ApiT.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Lib/ApiT.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Lib/ExtendedObject.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Lib/ExtendedObject.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Lib/ExtendedObject.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Lib/ExtendedObject.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Lib/Options.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Lib/Options.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Lib/Options.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Lib/Options.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Link.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs similarity index 95% rename from lib/wallet/src/Cardano/Wallet/Api/Link.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Link.hs index ffc0dc28a79..f3784ea73b8 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Link.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs @@ -125,7 +125,7 @@ import Prelude import Cardano.Wallet.Api.Types ( ApiAddressInspectData (..) - , ApiPoolId (..) + , ApiPoolSpecifier , ApiT (..) , ApiTxId (ApiTxId) , Iso8601Time @@ -140,7 +140,7 @@ import Cardano.Wallet.Primitive.AddressDerivation import Cardano.Wallet.Primitive.AddressDiscovery.Shared ( CredentialType (..) ) import Cardano.Wallet.Primitive.Types - ( PoolId, SmashServer, SortOrder, WalletId (..) ) + ( SmashServer, SortOrder, WalletId (..) ) import Cardano.Wallet.Primitive.Types.Address ( AddressState ) import Cardano.Wallet.Primitive.Types.Coin @@ -169,7 +169,7 @@ import Numeric.Natural ( Natural ) import Servant.API ( (:>) - , Capture + , Capture' , Header' , IsElem , NoContentVerb @@ -776,34 +776,21 @@ submitTransaction w = discriminate @style -- -- Stake Pools -- -postPoolMaintenance - :: (Method, Text) -postPoolMaintenance = - endpoint @Api.PostPoolMaintenance id +postPoolMaintenance :: (Method, Text) +postPoolMaintenance = endpoint @Api.PostPoolMaintenance id -getPoolMaintenance - :: (Method, Text) -getPoolMaintenance = - endpoint @Api.GetPoolMaintenance id +getPoolMaintenance :: (Method, Text) +getPoolMaintenance = endpoint @Api.GetPoolMaintenance id -listStakePools - :: Maybe Coin - -> (Method, Text) -listStakePools stake = - endpoint @(Api.ListStakePools ()) (\mk -> mk (ApiT <$> stake)) +listStakePools :: Maybe Coin -> (Method, Text) +listStakePools stake = endpoint @Api.ListStakePools ($ ApiT <$> stake) -listStakeKeys - :: forall w. (HasType (ApiT WalletId) w) - => w - -> (Method, Text) -listStakeKeys w = - endpoint @(Api.ListStakeKeys ()) (\mk -> mk wid) - where - wid = w ^. typed @(ApiT WalletId) +listStakeKeys :: forall w. (HasType (ApiT WalletId) w) => w -> (Method, Text) +listStakeKeys w = endpoint @(Api.ListStakeKeys ()) ($ w^.typed @(ApiT WalletId)) joinStakePool :: forall s w. - ( HasType (ApiT PoolId) s + ( HasType ApiPoolSpecifier s , HasType (ApiT WalletId) w ) => s @@ -812,7 +799,7 @@ joinStakePool joinStakePool s w = endpoint @(Api.JoinStakePool Net) (\mk -> mk sid wid) where - sid = ApiPoolId $ getApiT $ s ^. typed @(ApiT PoolId) + sid = s ^. typed @ApiPoolSpecifier wid = w ^. typed @(ApiT WalletId) quitStakePool @@ -867,35 +854,26 @@ getNetworkClock' forceNtpCheck = -- Proxy -- -postExternalTransaction - :: (Method, Text) -postExternalTransaction = - endpoint @Api.PostExternalTransaction id +postExternalTransaction :: (Method, Text) +postExternalTransaction = endpoint @Api.PostExternalTransaction id -- -- Settings -- -putSettings - :: (Method, Text) -putSettings = - endpoint @Api.PutSettings id +putSettings :: (Method, Text) +putSettings = endpoint @Api.PutSettings id -getSettings - :: (Method, Text) -getSettings = - endpoint @Api.GetSettings id +getSettings :: (Method, Text) +getSettings = endpoint @Api.GetSettings id -- -- Utils -- -getCurrentSMASHHealth - :: (Method, Text) +getCurrentSMASHHealth :: (Method, Text) getCurrentSMASHHealth = getCurrentSMASHHealth' Nothing -getCurrentSMASHHealth' - :: Maybe SmashServer - -> (Method, Text) +getCurrentSMASHHealth' :: Maybe SmashServer -> (Method, Text) getCurrentSMASHHealth' smash = endpoint @Api.GetCurrentSMASHHealth (\mk -> mk (ApiT <$> smash)) @@ -903,9 +881,7 @@ getCurrentSMASHHealth' smash = -- Shared Wallets -- patchSharedWallet - :: forall w. - ( HasType (ApiT WalletId) w - ) + :: forall w. HasType (ApiT WalletId) w => w -> CredentialType -> (Method, Text) @@ -1009,7 +985,7 @@ instance (ReflectMethod m) => HasVerb (Verb m s ct a) where instance HasVerb sub => HasVerb ((path :: Symbol) :> sub) where method _ = method (Proxy @sub) -instance HasVerb sub => HasVerb (Capture param t :> sub) where +instance HasVerb sub => HasVerb (Capture' mods param t :> sub) where method _ = method (Proxy @sub) instance HasVerb sub => HasVerb (ReqBody a b :> sub) where diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs similarity index 96% rename from lib/wallet/src/Cardano/Wallet/Api/Types.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types.hs index 4715f04ffc1..e54eed4ac32 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Types.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs @@ -18,6 +18,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -49,142 +50,136 @@ module Cardano.Wallet.Api.Types , fmtAllowedWords -- * API Types - , ApiAsset (..) - , toApiAsset - , ApiAssetMetadata (..) - , toApiAssetMetadata + , AddressAmount (..) + , AddressAmountNoAssets (..) + , AnyAddress (..) + , AnyAddressType (..) + , ApiAccountKey (..) + , ApiAccountKeyShared (..) , ApiAddress (..) - , ApiCredential (..) , ApiAddressData (..) , ApiAddressDataPayload (..) - , AnyAddress (..) - , AnyAddressType (..) - , ApiCertificate (..) - , ApiDelegationAction (..) - , ApiEpochInfo (..) - , toApiEpochInfo - , ApiSelectCoinsData (..) - , ApiSelectCoinsPayments (..) - , ApiSelectCoinsAction (..) - , ApiMintBurnOperation (..) - , ApiMintData(..) + , ApiAddressInspect (..) + , ApiAddressInspectData (..) + , ApiAnyCertificate (..) + , ApiAsset (..) + , ApiAssetMetadata (..) + , ApiAssetMintBurn (..) + , ApiBalanceTransactionPostData (..) + , ApiBase64 + , ApiBlockInfo (..) + , ApiBlockReference (..) , ApiBurnData(..) + , ApiCertificate (..) , ApiCoinSelection (..) , ApiCoinSelectionChange (..) , ApiCoinSelectionCollateral (..) , ApiCoinSelectionOutput (..) , ApiCoinSelectionWithdrawal (..) - , ApiBase64 + , ApiConstructTransaction (..) + , ApiConstructTransactionData (..) + , ApiCredential (..) + , ApiDecodedTransaction (..) + , ApiDelegationAction (..) + , ApiDeregisterPool (..) + , ApiEra (..) + , ApiEraInfo (..) + , ApiErrorCode (..) + , ApiExternalCertificate (..) + , ApiExternalInput (..) + , ApiFee (..) + , ApiForeignStakeKey (..) + , ApiMaintenanceAction (..) + , ApiMaintenanceActionPostData (..) , ApiMintBurnData (..) - , ApiStakePool (..) - , ApiStakePoolMetrics (..) - , ApiStakePoolFlag (..) - , ApiWallet (..) - , ApiWalletBalance (..) - , ApiWalletAssetsBalance (..) - , ApiWalletMode (..) - , ApiWalletPassphrase (..) - , ApiWalletPassphraseInfo (..) - , ApiWalletUtxoSnapshot (..) - , ApiWalletUtxoSnapshotEntry (..) - , ApiUtxoStatistics (..) - , toApiUtxoStatistics - , WalletPostData (..) - , WalletPutData (..) - , SettingsPutData (..) - , WalletPutPassphraseData (..) - , WalletPutPassphraseOldPassphraseData (..) - , WalletPutPassphraseMnemonicData (..) - , ApiSignTransactionPostData (..) - , PostTransactionOldData (..) - , PostTransactionFeeOldData (..) + , ApiMintBurnOperation (..) + , ApiMintData(..) + , ApiMultiDelegationAction (..) + , ApiNetworkClock (..) + , ApiNetworkInfo (..) + , ApiNetworkInformation (..) + , ApiNetworkParameters (..) + , ApiNullStakeKey (..) + , ApiOurStakeKey (..) + , ApiPaymentDestination (..) + , ApiPoolSpecifier (..) + , ApiPolicyId (..) + , ApiPolicyKey (..) + , ApiPostAccountKeyData (..) + , ApiPostAccountKeyDataWithPurpose (..) + , ApiPostPolicyIdData (..) + , ApiPostPolicyKeyData (..) + , ApiRedeemer (..) + , ApiRegisterPool (..) + , ApiScriptTemplateEntry (..) + , ApiSealedTxEncoding (..) + , ApiSelectCoinsAction (..) + , ApiSelectCoinsData (..) + , ApiSelectCoinsPayments (..) + , ApiSelfWithdrawalPostData (..) , ApiSerialisedTransaction (..) + , ApiSignTransactionPostData (..) + , ApiSlotId (..) + , ApiSlotReference (..) + , ApiStakeKeyIndex (..) + , ApiStakeKeys (..) + , ApiTokenAmountFingerprint (..) + , ApiTokens (..) , ApiTransaction (..) - , ApiWithdrawalPostData (..) - , ApiSelfWithdrawalPostData (..) - , ApiMaintenanceAction (..) - , ApiMaintenanceActionPostData (..) - , MaintenanceAction (..) - , ApiFee (..) , ApiTxCollateral (..) , ApiTxId (..) , ApiTxInput (..) + , ApiTxInputGeneral (..) , ApiTxMetadata (..) - , AddressAmount (..) - , AddressAmountNoAssets (..) - , ApiAddressInspect (..) - , ApiAddressInspectData (..) - , ApiErrorCode (..) - , ApiNetworkInformation (..) - , ApiEra (..) - , toApiEra - , fromApiEra - , ApiNtpStatus (..) - , NtpSyncingStatus (..) - , ApiNetworkClock (..) - , ApiSlotReference (..) - , ApiSlotId (..) - , ApiBlockReference (..) - , ApiBlockInfo (..) - , ApiStakeKeys (..) - , ApiOurStakeKey (..) - , ApiForeignStakeKey (..) - , ApiNullStakeKey (..) - , Iso8601Time (..) - , MinWithdrawal (..) - , ApiNetworkParameters (..) - , ApiNetworkInfo (..) - , toApiNetworkParameters - , ApiEraInfo (..) + , ApiTxOutputGeneral (..) + , ApiUtxoStatistics (..) + , ApiValidityBound (..) + , ApiValidityInterval (..) + , ApiVerificationKeyShared (..) + , ApiVerificationKeyShelley (..) + , ApiWallet (..) + , ApiWalletAssetsBalance (..) + , ApiWalletBalance (..) , ApiWalletDelegation (..) - , ApiWalletDelegationStatus (..) , ApiWalletDelegationNext (..) - , ApiPoolId (..) - , ApiWalletMigrationPlanPostData (..) - , ApiWalletMigrationPostData (..) + , ApiWalletDelegationStatus (..) + , ApiWalletInput (..) , ApiWalletMigrationBalance (..) , ApiWalletMigrationPlan (..) - , ApiWithdrawal (..) + , ApiWalletMigrationPlanPostData (..) + , ApiWalletMigrationPostData (..) + , ApiWalletMode (..) + , ApiWalletOutput (..) + , ApiWalletPassphrase (..) + , ApiWalletPassphraseInfo (..) , ApiWalletSignData (..) - , ApiVerificationKeyShelley (..) - , ApiPolicyKey (..) - , ApiPolicyId (..) - , ApiPostPolicyIdData (..) - , ApiPostPolicyKeyData (..) - , ApiVerificationKeyShared (..) - , ApiScriptTemplateEntry (..) - , XPubOrSelf (..) - , VerificationKeyHashing (..) - , ApiAccountKey (..) - , ApiAccountKeyShared (..) + , ApiWalletUtxoSnapshot (..) + , ApiWalletUtxoSnapshotEntry (..) + , ApiWithdrawal (..) + , ApiWithdrawalGeneral (..) + , ApiWithdrawalPostData (..) + , fromApiEra + , Iso8601Time (..) , KeyFormat (..) - , ApiPostAccountKeyData (..) - , ApiPostAccountKeyDataWithPurpose (..) - , ApiConstructTransaction (..) - , ApiSealedTxEncoding (..) - , ApiConstructTransactionData (..) - , ApiMultiDelegationAction (..) - , ApiStakeKeyIndex (..) - , ApiPaymentDestination (..) - , ApiValidityInterval (..) - , ApiValidityBound (..) - , ApiBalanceTransactionPostData (..) - , ApiExternalInput (..) - , ApiRedeemer (..) - , ApiDecodedTransaction (..) - , ApiWalletInput (..) - , ApiTxInputGeneral (..) + , MaintenanceAction (..) + , MinWithdrawal (..) + , NtpSyncingStatus (..) + , PostTransactionFeeOldData (..) + , PostTransactionOldData (..) , ResourceContext (..) - , ApiWithdrawalGeneral (..) - , ApiWalletOutput (..) - , ApiTxOutputGeneral (..) - , ApiAnyCertificate (..) - , ApiExternalCertificate (..) - , ApiRegisterPool (..) - , ApiDeregisterPool (..) - , ApiAssetMintBurn (..) - , ApiTokenAmountFingerprint (..) - , ApiTokens (..) + , SettingsPutData (..) + , toApiAsset + , toApiAssetMetadata + , toApiEra + , toApiNetworkParameters + , toApiUtxoStatistics + , VerificationKeyHashing (..) + , WalletPostData (..) + , WalletPutData (..) + , WalletPutPassphraseData (..) + , WalletPutPassphraseMnemonicData (..) + , WalletPutPassphraseOldPassphraseData (..) + , XPubOrSelf (..) -- * API Types (Byron) , ApiByronWallet (..) @@ -224,27 +219,26 @@ module Cardano.Wallet.Api.Types , ApiBytesT (..) -- * Type families - , ApiAddressT - , ApiStakeKeysT - , ApiPutAddressesDataT , ApiAddressIdT + , ApiAddressT + , ApiBalanceTransactionPostDataT , ApiCoinSelectionT + , ApiConstructTransactionDataT + , ApiConstructTransactionT + , ApiDecodedTransactionT + , ApiPutAddressesDataT , ApiSelectCoinsDataT + , ApiStakeKeysT , ApiTransactionT - , ApiConstructTransactionT - , ApiConstructTransactionDataT - , PostTransactionOldDataT - , PostTransactionFeeOldDataT , ApiWalletMigrationPlanPostDataT , ApiWalletMigrationPostDataT - , ApiBalanceTransactionPostDataT - , ApiDecodedTransactionT + , PostTransactionFeeOldDataT + , PostTransactionOldDataT -- * Others , defaultRecordTypeOptions , strictRecordTypeOptions , HealthStatusSMASH (..) - , HealthCheckSMASH (..) , ApiHealthCheck (..) , ApiAsArray (..) @@ -279,6 +273,8 @@ import Cardano.Mnemonic , mnemonicToText , natVals ) +import Cardano.Pool.Metadata + ( HealthCheckSMASH, HealthStatusSMASH (..), SMASHPoolId (..) ) import Cardano.Wallet.Api.Aeson ( eitherToParser ) import Cardano.Wallet.Api.Aeson.Variant @@ -286,6 +282,7 @@ import Cardano.Wallet.Api.Aeson.Variant import Cardano.Wallet.Api.Hex ( fromHexText, hexText ) import Cardano.Wallet.Api.Lib.ApiAsArray + ( ApiAsArray (..) ) import Cardano.Wallet.Api.Lib.ApiT ( ApiT (..), fromTextApiT, toTextApiT ) import Cardano.Wallet.Api.Lib.Options @@ -296,12 +293,6 @@ import Cardano.Wallet.Api.Lib.Options , strictRecordTypeOptions , taggedSumTypeOptions ) -import Cardano.Wallet.Api.Types.Address - ( DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - ) import Cardano.Wallet.Api.Types.Certificate ( ApiAnyCertificate (..) , ApiCertificate (..) @@ -349,8 +340,6 @@ import Cardano.Wallet.Primitive.Passphrase.Types , PassphraseMaxLength (..) , PassphraseMinLength (..) ) -import Cardano.Wallet.Primitive.Slotting - ( Qry, timeOfEpoch ) import Cardano.Wallet.Primitive.SyncProgress ( SyncProgress (..) ) import Cardano.Wallet.Primitive.Types @@ -367,18 +356,21 @@ import Cardano.Wallet.Primitive.Types , SlotNo (..) , SlottingParameters (..) , SmashServer (..) - , StakePoolMetadata + , StakePoolMetadata (..) , StartTime (..) , WalletId (..) , WalletName (..) , decodePoolIdBech32 , encodePoolIdBech32 , getDecentralizationLevel + , unsafeEpochNo ) import Cardano.Wallet.Primitive.Types.Address ( Address (..), AddressState (..) ) import Cardano.Wallet.Primitive.Types.Hash ( Hash (..) ) +import Cardano.Wallet.Primitive.Types.TokenMap + ( AssetId (..), TokenMap ) import Cardano.Wallet.Primitive.Types.Tx ( Direction (..) , SealedTx (..) @@ -391,6 +383,14 @@ import Cardano.Wallet.Primitive.Types.Tx ) import Cardano.Wallet.Primitive.Types.UTxO ( BoundType, HistogramBar (..), UTxOStatistics (..) ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..) + , DecodeStakeAddress (..) + , EncodeAddress (..) + , EncodeStakeAddress (..) + ) +import Cardano.Wallet.Shelley.Pools + ( EpochInfo, StakePool (..), StakePoolFlag, StakePoolMetrics ) import Cardano.Wallet.TokenMetadata ( TokenMetadataError (..) ) import Cardano.Wallet.Util @@ -484,12 +484,16 @@ import Data.Typeable ( Typeable, typeRep ) import Data.Word ( Word16, Word32, Word64 ) +import Data.Word.Odd + ( Word31 ) import Fmt ( pretty ) import GHC.Generics ( Generic ) import GHC.TypeLits ( Nat, Symbol ) +import Network.Ntp + ( NtpStatusWithOffset, NtpSyncingStatus (..) ) import Numeric.Natural ( Natural ) import Quiet @@ -503,8 +507,6 @@ import qualified Cardano.Crypto.Wallet as CC import qualified Cardano.Wallet.Primitive.AddressDerivation as AD import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W -import qualified Cardano.Wallet.Primitive.Types.TokenBundle as W -import qualified Cardano.Wallet.Primitive.Types.TokenMap as W import qualified Cardano.Wallet.Primitive.Types.TokenPolicy as W import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.Binary.Bech32.TH as Bech32 @@ -610,7 +612,7 @@ newtype ApiMaintenanceAction = ApiMaintenanceAction deriving Show via (Quiet ApiMaintenanceAction) newtype ApiPolicyId = ApiPolicyId - { policyId :: ApiT W.TokenPolicyId + { policyId :: ApiT W.TokenPolicyId } deriving (Eq, Generic, Show) newtype ApiPostPolicyIdData = ApiPostPolicyIdData @@ -642,9 +644,9 @@ data ApiAssetMetadata = ApiAssetMetadata toApiAsset :: Either TokenMetadataError (Maybe W.AssetMetadata) - -> W.AssetId + -> AssetId -> ApiAsset -toApiAsset metadata_ (W.AssetId policyId_ assetName_) = ApiAsset +toApiAsset metadata_ (AssetId policyId_ assetName_) = ApiAsset { policyId = ApiT policyId_ , assetName = ApiT assetName_ , fingerprint = ApiT $ W.mkTokenFingerprint policyId_ assetName_ @@ -699,15 +701,6 @@ data AnyAddress = AnyAddress , network :: Int } deriving (Eq, Generic, Show) -data ApiEpochInfo = ApiEpochInfo - { epochNumber :: !(ApiT EpochNo) - , epochStartTime :: !UTCTime - } deriving (Eq, Generic, Show) - deriving anyclass NFData - -toApiEpochInfo :: EpochNo -> Qry ApiEpochInfo -toApiEpochInfo ep = ApiEpochInfo (ApiT ep) . fst <$> timeOfEpoch ep - data ApiSelectCoinsData (n :: NetworkDiscriminant) = ApiSelectForPayment (ApiSelectCoinsPayments n) | ApiSelectForDelegation ApiSelectCoinsAction @@ -745,7 +738,7 @@ data ApiCoinSelection (n :: NetworkDiscriminant) = ApiCoinSelection data ApiCoinSelectionChange (n :: NetworkDiscriminant) = ApiCoinSelectionChange { address :: !(ApiT Address, Proxy n) , amount :: !(Quantity "lovelace" Natural) - , assets :: !(ApiT W.TokenMap) + , assets :: !(ApiT TokenMap) , derivationPath :: NonEmpty (ApiT DerivationIndex) } deriving (Eq, Generic, Show, Typeable) deriving anyclass NFData @@ -753,7 +746,7 @@ data ApiCoinSelectionChange (n :: NetworkDiscriminant) = ApiCoinSelectionChange data ApiCoinSelectionOutput (n :: NetworkDiscriminant) = ApiCoinSelectionOutput { address :: !(ApiT Address, Proxy n) , amount :: !(Quantity "lovelace" Natural) - , assets :: !(ApiT W.TokenMap) + , assets :: !(ApiT TokenMap) } deriving (Eq, Ord, Generic, Show, Typeable) deriving anyclass (NFData, Hashable) @@ -789,8 +782,8 @@ data ApiWalletBalance = ApiWalletBalance deriving anyclass NFData data ApiWalletAssetsBalance = ApiWalletAssetsBalance - { available :: !(ApiT W.TokenMap) - , total :: !(ApiT W.TokenMap) + { available :: !(ApiT TokenMap) + , total :: !(ApiT TokenMap) } deriving (Eq, Generic, Show) deriving anyclass NFData @@ -810,7 +803,7 @@ data ApiWalletDelegation = ApiWalletDelegation data ApiWalletDelegationNext = ApiWalletDelegationNext { status :: !ApiWalletDelegationStatus , target :: !(Maybe (ApiT PoolId)) - , changesAt :: !(Maybe ApiEpochInfo) + , changesAt :: !(Maybe EpochInfo) } deriving (Eq, Generic, Show) deriving anyclass NFData @@ -837,35 +830,11 @@ newtype ApiWalletUtxoSnapshot = ApiWalletUtxoSnapshot data ApiWalletUtxoSnapshotEntry = ApiWalletUtxoSnapshotEntry { ada :: !(Quantity "lovelace" Natural) , adaMinimum :: !(Quantity "lovelace" Natural) - , assets :: !(ApiT W.TokenMap) + , assets :: !(ApiT TokenMap) } deriving (Eq, Generic, Show) deriving anyclass NFData -data ApiStakePool = ApiStakePool - { id :: !(ApiT PoolId) - , metrics :: !ApiStakePoolMetrics - , metadata :: !(Maybe (ApiT StakePoolMetadata)) - , cost :: !(Quantity "lovelace" Natural) - , margin :: !(Quantity "percent" Percentage) - , pledge :: !(Quantity "lovelace" Natural) - , retirement :: !(Maybe ApiEpochInfo) - , flags :: ![ApiStakePoolFlag] - } deriving (Eq, Generic, Show) - -data ApiStakePoolFlag - = Delisted - deriving stock (Eq, Generic, Show) - deriving anyclass NFData - -data ApiStakePoolMetrics = ApiStakePoolMetrics - { nonMyopicMemberRewards :: !(Quantity "lovelace" Natural) - , relativeStake :: !(Quantity "percent" Percentage) - , saturation :: !Double - , producedBlocks :: !(Quantity "block" Natural) - } deriving (Eq, Generic, Show) - deriving anyclass NFData - data ApiUtxoStatistics = ApiUtxoStatistics { total :: !(Quantity "lovelace" Natural) , scale :: !(ApiT BoundType) @@ -1091,7 +1060,7 @@ data ApiExternalInput (n :: NetworkDiscriminant) = ApiExternalInput , index :: !Word32 , address :: !(ApiT Address, Proxy n) , amount :: !(Quantity "lovelace" Natural) - , assets :: !(ApiT W.TokenMap) + , assets :: !(ApiT TokenMap) , datum :: !(Maybe (ApiT (Hash "Datum"))) } deriving (Eq, Generic, Show, Typeable) deriving anyclass NFData @@ -1135,18 +1104,18 @@ data ApiNetworkParameters = ApiNetworkParameters } deriving (Eq, Generic, Show) data ApiEraInfo = ApiEraInfo - { byron :: !(Maybe ApiEpochInfo) - , shelley :: !(Maybe ApiEpochInfo) - , allegra :: !(Maybe ApiEpochInfo) - , mary :: !(Maybe ApiEpochInfo) - , alonzo :: !(Maybe ApiEpochInfo) - , babbage :: !(Maybe ApiEpochInfo) + { byron :: !(Maybe EpochInfo) + , shelley :: !(Maybe EpochInfo) + , allegra :: !(Maybe EpochInfo) + , mary :: !(Maybe EpochInfo) + , alonzo :: !(Maybe EpochInfo) + , babbage :: !(Maybe EpochInfo) } deriving (Eq, Generic, Show) toApiNetworkParameters :: Monad m => NetworkParameters - -> (EpochNo -> m ApiEpochInfo) + -> (EpochNo -> m EpochInfo) -> m ApiNetworkParameters toApiNetworkParameters (NetworkParameters gp sp pp) toEpochInfo = do byron <- traverse toEpochInfo (pp ^. #eras . #byron) @@ -1158,7 +1127,7 @@ toApiNetworkParameters (NetworkParameters gp sp pp) toEpochInfo = do let apiEras = ApiEraInfo { byron, shelley, allegra, mary, alonzo, babbage } - return $ ApiNetworkParameters + return ApiNetworkParameters { genesisBlockHash = ApiT $ getGenesisBlockHash gp , blockchainStartTime = ApiT $ getGenesisBlockDate gp , slotLength = Quantity $ unSlotLength $ getSlotLength sp @@ -1183,9 +1152,25 @@ toApiNetworkParameters (NetworkParameters gp sp pp) toEpochInfo = do , executionUnitPrices = view #executionUnitPrices pp } -newtype ApiTxId = ApiTxId - { id :: ApiT (Hash "Tx") - } +-- | This type is used in URLs where there is a '*' in place of a pool id, +-- which means "for all pool ids" +-- This is a hack to work around Servant's problem with capturing path params. +data ApiPoolSpecifier = AllPools | SpecificPool PoolId + +instance FromHttpApiData ApiPoolSpecifier where + parseUrlPiece t + | t == "*" = Right AllPools + | otherwise = + SpecificPool <$> case fromText t of + Left _ -> left (T.pack . show . ShowFmt) $ decodePoolIdBech32 t + Right r -> Right r + +instance ToHttpApiData ApiPoolSpecifier where + toUrlPiece = \case + AllPools -> "*" + SpecificPool poolId -> encodePoolIdBech32 poolId + +newtype ApiTxId = ApiTxId { id :: ApiT (Hash "Tx") } deriving (Eq, Generic) deriving anyclass NFData deriving Show via (Quiet ApiTxId) @@ -1351,33 +1336,19 @@ instance ToJSON ApiWalletMode where data ApiNetworkInformation = ApiNetworkInformation { syncProgress :: !(ApiT SyncProgress) - , nextEpoch :: !(Maybe ApiEpochInfo) + , nextEpoch :: !(Maybe EpochInfo) , nodeTip :: !ApiBlockReference , networkTip :: !(Maybe ApiSlotReference) , nodeEra :: !ApiEra , networkInfo :: !ApiNetworkInfo , walletMode :: !ApiWalletMode - } deriving (Eq, Generic, Show) - deriving anyclass NFData - -data NtpSyncingStatus = - NtpSyncingStatusUnavailable - | NtpSyncingStatusPending - | NtpSyncingStatusAvailable + } deriving (Eq, Generic, Show) deriving anyclass NFData -data ApiNtpStatus = ApiNtpStatus - { status :: !NtpSyncingStatus - , offset :: !(Maybe (Quantity "microsecond" Integer)) - } deriving (Eq, Generic, Show) - deriving anyclass NFData -newtype ApiNetworkClock = ApiNetworkClock - { ntpStatus :: ApiNtpStatus - } +newtype ApiNetworkClock = ApiNetworkClock { ntpStatus :: NtpStatusWithOffset } deriving (Eq, Generic) - deriving anyclass NFData deriving Show via (Quiet ApiNetworkClock) data ApiPostRandomAddressData = ApiPostRandomAddressData @@ -1410,7 +1381,7 @@ newtype ApiPutAddressesData (n :: NetworkDiscriminant) = ApiPutAddressesData data ApiWalletMigrationBalance = ApiWalletMigrationBalance { ada :: !(Quantity "lovelace" Natural) - , assets :: !(ApiT W.TokenMap) + , assets :: !(ApiT TokenMap) } deriving (Eq, Generic, Show) deriving anyclass NFData @@ -1690,11 +1661,6 @@ instance FromText (ApiT ValidationLevel) where , "I am expecting one of the words 'required' or" , "'recommended'."] -data ApiPoolId - = ApiPoolIdPlaceholder - | ApiPoolId PoolId - deriving (Eq, Generic, Show) - instance FromText ApiAccountPublicKey where fromText txt = case xpubFromText txt of Nothing -> @@ -1954,11 +1920,6 @@ instance FromJSON ApiPostAccountKeyDataWithPurpose where instance ToJSON ApiPostAccountKeyDataWithPurpose where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiEpochInfo where - parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiEpochInfo where - toJSON = genericToJSON defaultRecordTypeOptions - instance FromJSON ApiSelectCoinsAction where parseJSON = genericParseJSON defaultRecordTypeOptions instance ToJSON ApiSelectCoinsAction where @@ -2481,19 +2442,58 @@ instance FromJSON ApiWalletDelegationNext where instance ToJSON ApiWalletDelegationNext where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiStakePool where +instance FromJSON EpochNo where + parseJSON = fmap unsafeEpochNo . parseJSON +instance ToJSON EpochNo where + toJSON (EpochNo en) = toJSON $ fromIntegral @Word31 @Word32 en + +instance FromJSON EpochInfo where parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiStakePool where +instance ToJSON EpochInfo where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiStakePoolMetrics where - parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiStakePoolMetrics where +instance FromJSON (ApiT StakePool) where + parseJSON = fmap (ApiT <$>) . withObject "StakePool" $ \o -> do + poolId <- o .: "id" + metrics <- o .: "metrics" >>= parseJsonStakePoolMetrics + metadata <- o .: "metadata" + cost <- o .: "cost" + margin <- o .: "margin" + pledge <- o .: "pledge" + retirement <- o .: "retirement" + flags <- o .: "flags" + pure StakePool{ id=poolId, .. } + +instance ToJSON (ApiT StakePool) where + toJSON (ApiT pool) = Aeson.object + [ "id" .= view #id pool + , "metrics" .= toJsonStakePoolMetrics (view #metrics pool) + , "metadata" .= view #metadata pool + , "cost" .= view #cost pool + , "margin" .= view #margin pool + , "pledge" .= view #pledge pool + , "retirement" .= view #retirement pool + , "flags" .= view #flags pool + ] + +instance FromJSON (ApiT StakePoolMetrics) where + parseJSON = fmap ApiT . parseJsonStakePoolMetrics + +parseJsonStakePoolMetrics :: Aeson.Value -> Aeson.Parser StakePoolMetrics +parseJsonStakePoolMetrics = genericParseJSON defaultRecordTypeOptions + +instance ToJSON (ApiT StakePoolMetrics) where + toJSON = toJsonStakePoolMetrics . getApiT + +toJsonStakePoolMetrics :: StakePoolMetrics -> Aeson.Value +toJsonStakePoolMetrics = genericToJSON defaultRecordTypeOptions + +instance ToJSON StakePoolMetadata where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiStakePoolFlag where +instance FromJSON StakePoolFlag where parseJSON = genericParseJSON defaultSumTypeOptions -instance ToJSON ApiStakePoolFlag where +instance ToJSON StakePoolFlag where toJSON = genericToJSON defaultSumTypeOptions instance FromJSON (ApiT WalletName) where @@ -2821,20 +2821,17 @@ instance ToJSON ApiNetworkInformation where toJSON = genericToJSON defaultRecordTypeOptions instance FromJSON NtpSyncingStatus where - parseJSON = - parseJSON >=> eitherToParser . first ShowFmt . fromText + parseJSON = parseJSON >=> eitherToParser . first ShowFmt . fromText instance ToJSON NtpSyncingStatus where toJSON = toJSON . toText -instance FromJSON ApiNtpStatus where +instance FromJSON NtpStatusWithOffset where parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiNtpStatus where +instance ToJSON NtpStatusWithOffset where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiNetworkClock where - parseJSON = parseJSON >=> pure . ApiNetworkClock -instance ToJSON ApiNetworkClock where - toJSON (ApiNetworkClock st) = toJSON st +deriving newtype instance FromJSON ApiNetworkClock +deriving newtype instance ToJSON ApiNetworkClock instance FromJSON (ApiT StakePoolMetadata) where parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions @@ -3158,23 +3155,20 @@ instance FromText (ApiT Cosigner) where instance MimeUnrender OctetStream (ApiBytesT base ByteString) where mimeUnrender _ = pure . ApiBytesT . BL.toStrict - instance MimeRender OctetStream (ApiBytesT base ByteString) where mimeRender _ = BL.fromStrict . getApiBytesT instance MimeUnrender OctetStream (ApiBytesT base SerialisedTx) where mimeUnrender _ = pure . ApiBytesT . SerialisedTx . BL.toStrict - instance MimeRender OctetStream (ApiBytesT base SerialisedTx) where mimeRender _ = BL.fromStrict . view #payload . getApiBytesT instance MimeUnrender OctetStream (ApiT SealedTx) where mimeUnrender _ = bimap show ApiT . sealedTxFromBytes . BL.toStrict - instance MimeRender OctetStream (ApiT SealedTx) where mimeRender _ = BL.fromStrict . view #serialisedTx . getApiT -instance FromText a => FromHttpApiData (ApiT a) where +instance {-# OVERLAPPABLE #-} FromText a => FromHttpApiData (ApiT a) where parseUrlPiece = bimap pretty ApiT . fromText instance ToText a => ToHttpApiData (ApiT a) where toUrlPiece = toText . getApiT @@ -3186,29 +3180,18 @@ instance FromHttpApiData ApiTxId where parseUrlPiece txt = case fromText txt of Left (TextDecodingError err) -> Left $ T.pack err Right tid -> Right $ ApiTxId $ ApiT tid - instance ToHttpApiData ApiTxId where toUrlPiece (ApiTxId (ApiT tid)) = toText tid -instance FromHttpApiData ApiPoolId where - parseUrlPiece t - | t == "*" = - Right ApiPoolIdPlaceholder - | otherwise = - ApiPoolId <$> case fromText t of - Left _ -> - left (T.pack . show . ShowFmt) $ decodePoolIdBech32 t - Right r -> - Right r - -instance ToHttpApiData ApiPoolId where - toUrlPiece = \case - ApiPoolIdPlaceholder -> "*" - ApiPoolId pid -> encodePoolIdBech32 pid +instance {-# OVERLAPPING #-} FromHttpApiData (ApiT PoolId) where + parseUrlPiece t = ApiT <$> case fromText t of + Left _ -> left (T.pack . show . ShowFmt) $ decodePoolIdBech32 t + Right r -> Right r +instance {-# OVERLAPPING #-} ToHttpApiData (ApiT PoolId) where + toUrlPiece = encodePoolIdBech32 . getApiT instance FromHttpApiData ApiAddressInspectData where parseUrlPiece = pure . ApiAddressInspectData - instance ToHttpApiData ApiAddressInspectData where toUrlPiece = unApiAddressInspectData @@ -3272,8 +3255,8 @@ type instance PostTransactionFeeOldDataT (n :: NetworkDiscriminant) = type instance ApiWalletMigrationPlanPostDataT (n :: NetworkDiscriminant) = ApiWalletMigrationPlanPostData n -type instance ApiWalletMigrationPostDataT (n :: NetworkDiscriminant) (s :: Symbol) = - ApiWalletMigrationPostData n s +type instance ApiWalletMigrationPostDataT + (n :: NetworkDiscriminant) (s :: Symbol) = ApiWalletMigrationPostData n s type instance ApiBalanceTransactionPostDataT (n :: NetworkDiscriminant) = ApiBalanceTransactionPostData n @@ -3282,30 +3265,17 @@ type instance ApiDecodedTransactionT (n :: NetworkDiscriminant) = ApiDecodedTransaction n {------------------------------------------------------------------------------- - SMASH interfacing types + SMASH types -------------------------------------------------------------------------------} --- | Parses the SMASH HealthCheck type from the SMASH API. -data HealthStatusSMASH = HealthStatusSMASH - { status :: Text - , version :: Text - } deriving (Generic, Show, Eq, Ord) +instance ToJSON SMASHPoolId where + toJSON = genericToJSON defaultRecordTypeOptions + { fieldLabelModifier = Prelude.id } -instance FromJSON HealthStatusSMASH where - parseJSON = genericParseJSON defaultRecordTypeOptions instance ToJSON HealthStatusSMASH where toJSON = genericToJSON defaultRecordTypeOptions --- | Dscribes the health status of the SMASH server. -data HealthCheckSMASH = - Available -- server available - | Unavailable -- server reachable, but unavailable - | Unreachable -- could not get a response from the SMASH server - | NoSmashConfigured -- no SMASH server has been configured - deriving (Generic, Show, Eq, Ord) - -newtype ApiHealthCheck = ApiHealthCheck - { health :: HealthCheckSMASH } +newtype ApiHealthCheck = ApiHealthCheck { health :: HealthCheckSMASH } deriving (Generic, Eq, Ord) deriving Show via (Quiet ApiHealthCheck) diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/BlockHeader.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/BlockHeader.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Types/BlockHeader.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/BlockHeader.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/Certificate.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Certificate.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Api/Types/Certificate.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/Certificate.hs index ff871004d2e..6ae70a7a09b 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Types/Certificate.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Certificate.hs @@ -30,14 +30,14 @@ import Cardano.Wallet.Api.Lib.ApiT ( ApiT (..) ) import Cardano.Wallet.Api.Lib.ExtendedObject ( extendAesonObject, parseExtendedAesonObject ) -import Cardano.Wallet.Api.Types.Address - ( DecodeStakeAddress, EncodeStakeAddress ) import Cardano.Wallet.Api.Types.Primitive () import Cardano.Wallet.Primitive.AddressDerivation ( DerivationIndex (..), NetworkDiscriminant ) import Cardano.Wallet.Primitive.Types ( NonWalletCertificate, PoolId (..) ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeStakeAddress, EncodeStakeAddress ) import Control.DeepSeq ( NFData ) import Data.Aeson.Types diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/Key.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Key.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Types/Key.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/Key.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/Primitive.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Primitive.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Api/Types/Primitive.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/Primitive.hs index fd7df457bc7..1e65d88de4d 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Types/Primitive.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Primitive.hs @@ -26,12 +26,6 @@ import Cardano.Wallet.Api.Hex ( fromHexText, hexText ) import Cardano.Wallet.Api.Lib.ApiT ( ApiT (..), fromTextApiT, toTextApiT ) -import Cardano.Wallet.Api.Types.Address - ( DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - ) import Cardano.Wallet.Primitive.AddressDerivation ( DerivationIndex, RewardAccount ) import Cardano.Wallet.Primitive.Types @@ -54,6 +48,12 @@ import Cardano.Wallet.Primitive.Types.Tx.Constraints ( coinIsValidForTxOut, txOutMaxCoin ) import Cardano.Wallet.Primitive.Types.Tx.Tx ( TxIn (..), TxMetadata (..), TxScriptValidity ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..) + , DecodeStakeAddress (..) + , EncodeAddress (..) + , EncodeStakeAddress (..) + ) import Cardano.Wallet.Transaction ( AnyScript (..) ) import Cardano.Wallet.Util @@ -78,7 +78,6 @@ import Data.Aeson ) import Data.Aeson.Types ( prependFailure ) -import qualified Data.Aeson.Types as Aeson import Data.Bifunctor ( Bifunctor (..) ) import Data.Proxy @@ -96,6 +95,7 @@ import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Primitive.Types.TokenBundle as W import qualified Cardano.Wallet.Primitive.Types.TokenMap as W import qualified Cardano.Wallet.Primitive.Types.TokenPolicy as W +import qualified Data.Aeson.Types as Aeson instance ToJSON (ApiT DerivationIndex) where toJSON = toTextApiT diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/SchemaMetadata.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/SchemaMetadata.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/Api/Types/SchemaMetadata.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/SchemaMetadata.hs diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/Transaction.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Transaction.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Api/Types/Transaction.hs rename to lib/wallet/api/http/Cardano/Wallet/Api/Types/Transaction.hs index 4bf3ea8de39..d77423dbb50 100644 --- a/lib/wallet/src/Cardano/Wallet/Api/Types/Transaction.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Types/Transaction.hs @@ -38,8 +38,6 @@ import Cardano.Wallet.Api.Lib.ApiT ( ApiT (ApiT) ) import Cardano.Wallet.Api.Lib.Options ( defaultRecordTypeOptions ) -import Cardano.Wallet.Api.Types.Address - ( DecodeAddress, DecodeStakeAddress, EncodeAddress, EncodeStakeAddress ) import Cardano.Wallet.Api.Types.Certificate ( ApiAnyCertificate ) import Cardano.Wallet.Api.Types.Key @@ -60,6 +58,8 @@ import Cardano.Wallet.Primitive.Types.Tx.Constraints ( coinIsValidForTxOut, txOutMaxCoin ) import Cardano.Wallet.Primitive.Types.Tx.Tx ( TxIn (..), TxMetadata (..), TxScriptValidity, txMetadataIsNull ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress, DecodeStakeAddress, EncodeAddress, EncodeStakeAddress ) import Cardano.Wallet.Transaction ( AnyScript, ValidityIntervalExplicit (..) ) import Control.DeepSeq diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Launch.hs b/lib/wallet/api/http/Cardano/Wallet/Launch.hs similarity index 97% rename from lib/wallet/src/Cardano/Wallet/Shelley/Launch.hs rename to lib/wallet/api/http/Cardano/Wallet/Launch.hs index 39aa56d8ead..4d3f2433303 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Launch.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Launch.hs @@ -16,7 +16,7 @@ -- Command-line option passing for cardano-wallet shelley. -- -module Cardano.Wallet.Shelley.Launch +module Cardano.Wallet.Launch ( -- * Network NetworkConfiguration (..) , CardanoNodeConn @@ -63,7 +63,9 @@ import Cardano.Wallet.Primitive.Types ( Block (..), NetworkParameters (..) ) import Cardano.Wallet.Primitive.Types.ProtocolMagic ( ProtocolMagic (..) ) -import Cardano.Wallet.Shelley +import Cardano.Wallet.Shelley.Compatibility + () +import Cardano.Wallet.Shelley.Network.Discriminant ( SomeNetworkDiscriminant (..) ) import Control.Monad.IO.Unlift ( MonadUnliftIO, liftIO ) @@ -100,8 +102,8 @@ import UnliftIO.Temporary ( withTempDirectory ) import qualified Cardano.Wallet.Byron.Compatibility as Byron +import qualified Cardano.Wallet.Launch.Blockfrost as Blockfrost import qualified Cardano.Wallet.Primitive.Types.ProtocolMagic as W -import qualified Cardano.Wallet.Shelley.Launch.Blockfrost as Blockfrost import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -179,7 +181,11 @@ someCustomDiscriminant mkSomeNetwork pm@(ProtocolMagic n) = parseGenesisData :: NetworkConfiguration -> ExceptT String IO - (SomeNetworkDiscriminant, NetworkParameters, NodeToClientVersionData, Block) + ( SomeNetworkDiscriminant + , NetworkParameters + , NodeToClientVersionData + , Block + ) parseGenesisData = \case MainnetConfig -> do let nm = NetworkMagic $ fromIntegral $ W.getProtocolMagic W.mainnetMagic diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Launch/Blockfrost.hs b/lib/wallet/api/http/Cardano/Wallet/Launch/Blockfrost.hs similarity index 97% rename from lib/wallet/src/Cardano/Wallet/Shelley/Launch/Blockfrost.hs rename to lib/wallet/api/http/Cardano/Wallet/Launch/Blockfrost.hs index 366ac66c86c..a7080686698 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Launch/Blockfrost.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Launch/Blockfrost.hs @@ -4,7 +4,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Wallet.Shelley.Launch.Blockfrost +module Cardano.Wallet.Launch.Blockfrost ( TokenFile (..) , readToken , tokenFileOption diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Launch/Cluster.hs b/lib/wallet/api/http/Cardano/Wallet/Launch/Cluster.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Shelley/Launch/Cluster.hs rename to lib/wallet/api/http/Cardano/Wallet/Launch/Cluster.hs index 42a376fd529..1556a208f9d 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Launch/Cluster.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Launch/Cluster.hs @@ -22,7 +22,7 @@ -- -- Provides functions to launch cardano-nodes in a cluster for /testing/. -module Cardano.Wallet.Shelley.Launch.Cluster +module Cardano.Wallet.Launch.Cluster ( -- * Local test cluster launcher withCluster , LocalClusterConfig (..) @@ -122,7 +122,7 @@ import Cardano.Pool.Metadata ( SMASHPoolId (..) ) import Cardano.Startup ( restrictFileMode ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( Listen (..) ) import Cardano.Wallet.Api.Types ( ApiEra (..) @@ -130,6 +130,8 @@ import Cardano.Wallet.Api.Types , EncodeAddress (..) , HealthStatusSMASH (..) ) +import Cardano.Wallet.Launch + ( TempDirLog (..), envFromText, lookupEnvNonEmpty ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network.Ports @@ -156,8 +158,6 @@ import Cardano.Wallet.Primitive.Types.TokenQuantity ( TokenQuantity (..) ) import Cardano.Wallet.Shelley.Compatibility ( StandardShelley, fromGenesisData ) -import Cardano.Wallet.Shelley.Launch - ( TempDirLog (..), envFromText, lookupEnvNonEmpty ) import Cardano.Wallet.Unsafe ( unsafeBech32Decode, unsafeFromHex ) import Cardano.Wallet.Util diff --git a/lib/wallet/src/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs similarity index 94% rename from lib/wallet/src/Cardano/Wallet/Shelley.hs rename to lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 2a917c18f26..963ca34296f 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -22,23 +22,21 @@ module Cardano.Wallet.Shelley ( SomeNetworkDiscriminant (..) , serveWallet - , module Logging , module Tracers ) where import Prelude +import Cardano.Api + ( NetworkId ) import Cardano.Wallet.Api ( ApiLayer, ApiV2 ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Logging + ( ApplicationLog (..) ) +import Cardano.Wallet.Api.Http.Server + ( server ) +import Cardano.Wallet.Api.Http.Shelley.Server ( HostPreference, Listen (..), ListenError (..), TlsConfiguration ) -import Cardano.Wallet.Api.Types - ( ApiStakePool - , DecodeAddress - , DecodeStakeAddress - , EncodeAddress - , EncodeStakeAddress - ) import Cardano.Wallet.DB.Sqlite.Migration ( DefaultFieldValues (..) ) import Cardano.Wallet.DB.Store.Checkpoints @@ -89,34 +87,37 @@ import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.RewardAccount ( RewardAccount ) -import Cardano.Wallet.Primitive.Types.Tx +import Cardano.Wallet.Primitive.Types.Tx.SealedTx ( SealedTx ) import Cardano.Wallet.Registry ( HasWorkerCtx (..) ) -import Cardano.Wallet.Shelley.Api.Server - ( server ) import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Compatibility - ( CardanoBlock - , HasNetworkId (..) - , NetworkId - , StandardCrypto - , fromCardanoBlock - ) -import Cardano.Wallet.Shelley.Logging as Logging - ( ApplicationLog (..) ) + ( CardanoBlock, StandardCrypto, fromCardanoBlock ) import Cardano.Wallet.Shelley.Network ( withNetworkLayer ) import Cardano.Wallet.Shelley.Network.Discriminant - ( SomeNetworkDiscriminant (..), networkDiscriminantToId ) + ( DecodeAddress + , DecodeStakeAddress + , EncodeAddress + , EncodeStakeAddress + , HasNetworkId + , SomeNetworkDiscriminant (..) + , discriminantNetwork + , networkDiscriminantToId + ) import Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) , withBlockfrostStakePoolLayer , withNodeStakePoolLayer , withStakePoolDbLayer ) -import Cardano.Wallet.Shelley.Tracers as Tracers +import Cardano.Wallet.Shelley.Transaction + ( newTransactionLayer ) +import Cardano.Wallet.TokenMetadata + ( newMetadataClient ) +import Cardano.Wallet.Tracers as Tracers ( TracerSeverities , Tracers , Tracers' (..) @@ -126,10 +127,6 @@ import Cardano.Wallet.Shelley.Tracers as Tracers , tracerLabels , tracerSeverities ) -import Cardano.Wallet.Shelley.Transaction - ( newTransactionLayer ) -import Cardano.Wallet.TokenMetadata - ( newMetadataClient ) import Cardano.Wallet.Transaction ( TransactionLayer ) import Control.Monad.Trans.Class @@ -164,7 +161,7 @@ import Type.Reflection ( Typeable ) import qualified Cardano.Pool.DB.Sqlite as Pool -import qualified Cardano.Wallet.Api.Server as Server +import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Cardano.Wallet.DB.Layer as Sqlite import qualified Network.Wai.Handler.Warp as Warp @@ -248,8 +245,11 @@ serveWallet netParams shelleyGenesisPools netLayer - BlockfrostSource bfProject -> do - withBlockfrostStakePoolLayer poolsEngineTracer bfProject network + BlockfrostSource bfProject -> + withBlockfrostStakePoolLayer + poolsEngineTracer + bfProject + (discriminantNetwork network) randomApi <- withRandomApi netLayer icarusApi <- withIcarusApi netLayer shelleyApi <- withShelleyApi netLayer @@ -319,7 +319,7 @@ serveWallet serverUrl <- getServerUrl tlsConfig socket let serverSettings = Warp.defaultSettings & setBeforeMainLoop (beforeMainLoop serverUrl) - let application = Server.serve (Proxy @(ApiV2 n ApiStakePool)) $ + let application = Server.serve (Proxy @(ApiV2 n)) $ server byron icarus shelley multisig spl ntp blockchainSource Server.start serverSettings apiServerTracer tlsConfig socket application diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Tracers.hs b/lib/wallet/api/http/Cardano/Wallet/Tracers.hs similarity index 98% rename from lib/wallet/src/Cardano/Wallet/Shelley/Tracers.hs rename to lib/wallet/api/http/Cardano/Wallet/Tracers.hs index 5dc729a807c..0a828a9fb94 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Tracers.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Tracers.hs @@ -8,7 +8,7 @@ -- -- Tracing functionality for the Shelley wallet -- -module Cardano.Wallet.Shelley.Tracers +module Cardano.Wallet.Tracers ( Tracers' (..) , Tracers , TracerSeverities @@ -27,14 +27,14 @@ import Cardano.BM.Tracing ( Severity (..), Trace, Tracer, appendName, nullTracer ) import Cardano.Pool.DB.Log ( PoolDbLog ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Logging + ( ApplicationLog ) +import Cardano.Wallet.Api.Http.Shelley.Server ( WalletEngineLog ) import Cardano.Wallet.DB.Layer ( DBFactoryLog ) import Cardano.Wallet.Logging ( trMessageText ) -import Cardano.Wallet.Shelley.Logging - ( ApplicationLog ) import Cardano.Wallet.Shelley.Network ( NetworkLayerLog ) import Cardano.Wallet.Shelley.Pools diff --git a/lib/wallet/bench/latency-bench.hs b/lib/wallet/bench/latency-bench.hs index 7cc2830016a..fc932bf2199 100644 --- a/lib/wallet/bench/latency-bench.hs +++ b/lib/wallet/bench/latency-bench.hs @@ -33,7 +33,7 @@ import Cardano.Wallet.Api.Types , ApiEra , ApiFee , ApiNetworkInformation - , ApiStakePool + , ApiT , ApiTransaction , ApiTxId (..) , ApiUtxoStatistics @@ -43,6 +43,17 @@ import Cardano.Wallet.Api.Types ) import Cardano.Wallet.LatencyBenchShared ( LogCaptureFunc, fmtResult, fmtTitle, measureApiLogs, withLatencyLogging ) +import Cardano.Wallet.Launch + ( withSystemTempDir ) +import Cardano.Wallet.Launch.Cluster + ( FaucetFunds (..) + , LocalClusterConfig (..) + , LogFileConfig (..) + , RunningNode (..) + , defaultPoolConfigs + , walletListenFromEnv + , withCluster + ) import Cardano.Wallet.Logging ( trMessage ) import Cardano.Wallet.Network.Ports @@ -64,17 +75,8 @@ import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Faucet ( initFaucet ) -import Cardano.Wallet.Shelley.Launch - ( withSystemTempDir ) -import Cardano.Wallet.Shelley.Launch.Cluster - ( FaucetFunds (..) - , LocalClusterConfig (..) - , LogFileConfig (..) - , RunningNode (..) - , defaultPoolConfigs - , walletListenFromEnv - , withCluster - ) +import Cardano.Wallet.Shelley.Pools + ( StakePool ) import Cardano.Wallet.Unsafe ( unsafeFromText ) import Control.Monad @@ -374,7 +376,7 @@ walletApiBench capture ctx = do (Link.createTransactionOld @'Shelley walMA) Default payloadMA fmtResult "postTransactionMA " t7b - t8 <- measureApiLogs capture $ request @[ApiStakePool] ctx + t8 <- measureApiLogs capture $ request @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Default Empty fmtResult "listStakePools " t8 diff --git a/lib/wallet/bench/restore-bench.hs b/lib/wallet/bench/restore-bench.hs index 56a4d2dd4ea..0dc20baa83f 100644 --- a/lib/wallet/bench/restore-bench.hs +++ b/lib/wallet/bench/restore-bench.hs @@ -37,15 +37,6 @@ -- -- since it relies on lots of configuration most most easily retrieved with nix. -- --- You can also connect to an already-running node using: --- @ --- stack bench cardano-wallet:bench:restore --- --ba 'mainnet -c $CONFIGURATION_DIR --- --running-node $CARDANO_NODE_SOCKET_PATH --- @ --- --- This makes iteration easy, but requires you to have the configuration --- directory layout setup correctly, and to know how to start a node. module Main where @@ -80,6 +71,8 @@ import Cardano.Wallet.DB ( DBLayer ) import Cardano.Wallet.DB.Layer ( PersistAddressBook, withDBLayer ) +import Cardano.Wallet.Launch + ( CardanoNodeConn, NetworkConfiguration (..), parseGenesisData ) import Cardano.Wallet.Logging ( trMessageText ) import Cardano.Wallet.Network @@ -152,15 +145,12 @@ import Cardano.Wallet.Shelley ( SomeNetworkDiscriminant (..) ) import Cardano.Wallet.Shelley.Compatibility ( CardanoBlock - , HasNetworkId (..) , NodeToClientVersionData , StandardCrypto , emptyGenesis , fromCardanoBlock , numberOfTransactionsInBlock ) -import Cardano.Wallet.Shelley.Launch - ( CardanoNodeConn, NetworkConfiguration (..), parseGenesisData ) import Cardano.Wallet.Shelley.Network.Node ( withNetworkLayer ) import Cardano.Wallet.Shelley.Transaction @@ -254,6 +244,8 @@ import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection +import Cardano.Wallet.Shelley.Network.Discriminant + ( HasNetworkId (networkIdVal) ) import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index 603adee236c..094a9048c1b 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -22,6 +22,7 @@ common language common opts-lib ghc-options: -Wall -Wcompat -fwarn-redundant-constraints + if flag(release) ghc-options: -O2 -Werror @@ -118,7 +119,6 @@ library , http-api-data , http-client , http-client-tls - , http-media , http-types , int-cast , io-classes @@ -164,10 +164,8 @@ library , scientific , semialign , serialise - , servant , servant-client , servant-client-core - , servant-server , split , splitmix , statistics @@ -193,20 +191,13 @@ library , unliftio-core , unordered-containers , vector - , wai - , warp - , warp-tls , Win32-network - , x509 - , x509-store - , x509-validation , yaml exposed-modules: Cardano.Api.Extra Cardano.Api.Gen Cardano.Byron.Codec.Cbor - Cardano.CLI Cardano.DB.Sqlite Cardano.DB.Sqlite.Delete Cardano.Ledger.Credential.Safe @@ -223,29 +214,6 @@ library Cardano.Wallet.Address.Book Cardano.Wallet.Address.HasDelegation Cardano.Wallet.Address.Pool - Cardano.Wallet.Api - Cardano.Wallet.Api.Aeson - Cardano.Wallet.Api.Aeson.Variant - Cardano.Wallet.Api.Client - Cardano.Wallet.Api.Hex - Cardano.Wallet.Api.Lib.ApiAsArray - Cardano.Wallet.Api.Lib.ApiT - Cardano.Wallet.Api.Lib.ExtendedObject - Cardano.Wallet.Api.Lib.Options - Cardano.Wallet.Api.Link - Cardano.Wallet.Api.Server - Cardano.Wallet.Api.Server.Error - Cardano.Wallet.Api.Server.Handlers.Certificates - Cardano.Wallet.Api.Server.Handlers.TxCBOR - Cardano.Wallet.Api.Server.Tls - Cardano.Wallet.Api.Types - Cardano.Wallet.Api.Types.Address - Cardano.Wallet.Api.Types.BlockHeader - Cardano.Wallet.Api.Types.Certificate - Cardano.Wallet.Api.Types.Key - Cardano.Wallet.Api.Types.Primitive - Cardano.Wallet.Api.Types.SchemaMetadata - Cardano.Wallet.Api.Types.Transaction Cardano.Wallet.Byron.Compatibility Cardano.Wallet.Checkpoints Cardano.Wallet.Checkpoints.Policy @@ -369,15 +337,9 @@ library Cardano.Wallet.Read.Tx.Eras Cardano.Wallet.Read.Tx.Hash Cardano.Wallet.Registry - Cardano.Wallet.Shelley - Cardano.Wallet.Shelley.Api.Server Cardano.Wallet.Shelley.BlockchainSource Cardano.Wallet.Shelley.Compatibility Cardano.Wallet.Shelley.Compatibility.Ledger - Cardano.Wallet.Shelley.Launch - Cardano.Wallet.Shelley.Launch.Blockfrost - Cardano.Wallet.Shelley.Launch.Cluster - Cardano.Wallet.Shelley.Logging Cardano.Wallet.Shelley.MinimumUTxO Cardano.Wallet.Shelley.MinimumUTxO.Internal Cardano.Wallet.Shelley.Network @@ -390,10 +352,8 @@ library Cardano.Wallet.Shelley.Network.Discriminant Cardano.Wallet.Shelley.Network.Node Cardano.Wallet.Shelley.Pools - Cardano.Wallet.Shelley.Tracers Cardano.Wallet.Shelley.Transaction Cardano.Wallet.TokenMetadata - Cardano.Wallet.TokenMetadata.MockServer Cardano.Wallet.Transaction Cardano.Wallet.Unsafe Cardano.Wallet.Util @@ -411,13 +371,127 @@ library Data.Time.Utils Data.Vector.Shuffle Network.Ntp - Network.Wai.Middleware.Logging - Network.Wai.Middleware.ServerError Ouroboros.Network.Client.Wallet UnliftIO.Compat other-modules: Paths_cardano_wallet +library cardano-wallet-api-http + import: language, opts-lib + hs-source-dirs: api/http + build-depends: + , aeson + , aeson-pretty + , aeson-qq + , ansi-terminal + , base + , base58-bytestring + , bech32 + , bech32-th + , binary + , blockfrost-api + , blockfrost-client + , bytestring + , cardano-addresses + , cardano-addresses-cli + , cardano-api + , cardano-binary + , cardano-cli + , cardano-crypto + , cardano-ledger-alonzo + , cardano-ledger-byron + , cardano-ledger-core + , cardano-ledger-shelley + , cardano-wallet + , cardano-wallet-launcher + , cardano-wallet-test-utils + , cborg + , containers + , contra-tracer + , data-default + , deepseq + , directory + , either + , errors + , extra + , filepath + , fmt + , generic-lens + , hashable + , http-api-data + , http-client + , http-client-tls + , http-media + , http-types + , int-cast + , iohk-monitoring + , memory + , mtl + , network + , network-uri + , ntp-client + , OddWord + , optparse-applicative + , ouroboros-network + , quiet + , random + , retry + , servant + , servant-client + , servant-client-core + , servant-server + , streaming-commons + , temporary + , text + , text-class + , time + , tls + , transformers + , typed-process + , unliftio + , unliftio-core + , wai + , wai-middleware-logging + , warp + , warp-tls + , Win32-network + , x509 + , x509-store + , x509-validation + , yaml + + exposed-modules: + Cardano.CLI + Cardano.Wallet.Api + Cardano.Wallet.Api.Aeson + Cardano.Wallet.Api.Aeson.Variant + Cardano.Wallet.Api.Client + Cardano.Wallet.Api.Hex + Cardano.Wallet.Api.Http.Logging + Cardano.Wallet.Api.Http.Server + Cardano.Wallet.Api.Http.Server.Error + Cardano.Wallet.Api.Http.Server.Handlers.Certificates + Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR + Cardano.Wallet.Api.Http.Server.Tls + Cardano.Wallet.Api.Http.Shelley.Server + Cardano.Wallet.Api.Lib.ApiAsArray + Cardano.Wallet.Api.Lib.ApiT + Cardano.Wallet.Api.Lib.ExtendedObject + Cardano.Wallet.Api.Lib.Options + Cardano.Wallet.Api.Link + Cardano.Wallet.Api.Types + Cardano.Wallet.Api.Types.BlockHeader + Cardano.Wallet.Api.Types.Certificate + Cardano.Wallet.Api.Types.Key + Cardano.Wallet.Api.Types.Primitive + Cardano.Wallet.Api.Types.SchemaMetadata + Cardano.Wallet.Api.Types.Transaction + Cardano.Wallet.Launch + Cardano.Wallet.Launch.Blockfrost + Cardano.Wallet.Launch.Cluster + Cardano.Wallet.Shelley + Cardano.Wallet.Tracers + library cardano-wallet-integration import: language, opts-lib hs-source-dirs: integration/src @@ -437,6 +511,7 @@ library cardano-wallet-integration , cardano-ledger-alonzo , cardano-ledger-core , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-launcher , cardano-wallet-test-utils , cborg @@ -478,6 +553,7 @@ library cardano-wallet-integration , unliftio , unliftio-core , unordered-containers + , wai-middleware-logging exposed-modules: Cardano.Wallet.BenchShared @@ -520,6 +596,31 @@ library cardano-wallet-integration Test.Integration.Scenario.CLI.Shelley.Transactions Test.Integration.Scenario.CLI.Shelley.Wallets +library mock-token-metadata + import: language, opts-lib + hs-source-dirs: mock-token-metadata/src + build-depends: + , aeson + , ansi-wl-pprint + , base + , bytestring + , cardano-wallet + , generic-lens + , memory + , network-uri + , optparse-applicative + , servant + , servant-server + , text + , unliftio + , unordered-containers + , wai + , wai-extra + , wai-middleware-logging + , warp + + exposed-modules: Cardano.Wallet.TokenMetadata.MockServer + executable cardano-wallet import: language, opts-exe hs-source-dirs: exe @@ -527,6 +628,7 @@ executable cardano-wallet build-depends: , base , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-launcher , contra-tracer , iohk-monitoring @@ -545,6 +647,7 @@ executable local-cluster build-depends: , base , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-integration , cardano-wallet-launcher , contra-tracer @@ -555,18 +658,18 @@ executable local-cluster , text , text-class +-- Triggers this https://github.com/haskell/cabal/issues/6470 +-- if moved to an external library executable mock-token-metadata-server - import: language, opts-exe + import: language, opts-exe + main-is: exe/mock-token-metadata-server.hs build-depends: - , ansi-wl-pprint , base , cardano-wallet + , mock-token-metadata , optparse-applicative , wai-extra - hs-source-dirs: exe - main-is: mock-token-metadata-server.hs - test-suite unit import: language, opts-exe ghc-options: -with-rtsopts=-M2G -with-rtsopts=-N4 @@ -602,6 +705,7 @@ test-suite unit , cardano-sl-x509 , cardano-slotting , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-launcher , cardano-wallet-test-utils , cborg @@ -641,6 +745,7 @@ test-suite unit , lens , list-transformer , memory + , mock-token-metadata , MonadRandom , mtl , network @@ -687,6 +792,7 @@ test-suite unit , unordered-containers , wai , wai-extra + , wai-middleware-logging , warp , x509 , x509-store @@ -696,7 +802,7 @@ test-suite unit cpp-options: -DHAVE_SCRYPT build-depends: scrypt - build-tool-depends: hspec-discover:hspec-discover -any + build-tool-depends: hspec-discover:hspec-discover other-modules: Cardano.Api.GenSpec Cardano.Byron.Codec.CborSpec @@ -776,6 +882,7 @@ test-suite unit Cardano.Wallet.Primitive.Types.UTxOSelectionSpec.TypeErrorSpec Cardano.Wallet.Primitive.Types.UTxOSpec Cardano.Wallet.Primitive.TypesSpec + Cardano.Wallet.Read.Tx.CBORSpec Cardano.Wallet.RegistrySpec Cardano.Wallet.Shelley.Compatibility.LedgerSpec Cardano.Wallet.Shelley.CompatibilitySpec @@ -786,7 +893,6 @@ test-suite unit Cardano.Wallet.Shelley.NetworkSpec Cardano.Wallet.Shelley.TransactionSpec Cardano.Wallet.TokenMetadataSpec - Cardano.Wallet.Read.Tx.CBORSpec Cardano.WalletSpec Control.Concurrent.ConciergeSpec Control.Monad.Random.ExtraSpec @@ -796,7 +902,6 @@ test-suite unit Data.Time.TextSpec Data.Time.UtilsSpec Data.Vector.ShuffleSpec - Network.Wai.Middleware.LoggingSpec Spec test-suite integration @@ -807,6 +912,7 @@ test-suite integration build-depends: , base , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-integration , cardano-wallet-launcher , cardano-wallet-test-utils @@ -819,12 +925,13 @@ test-suite integration , http-client , iohk-monitoring , lobemo-backend-ekg + , mock-token-metadata , network-uri , text , text-class , unliftio - build-tool-depends: cardano-wallet:cardano-wallet -any + build-tool-depends: cardano-wallet:cardano-wallet other-modules: Cardano.Wallet.Shelley.Faucet benchmark restore @@ -838,6 +945,7 @@ benchmark restore , bytestring , cardano-addresses , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-integration , contra-tracer , deepseq @@ -861,6 +969,7 @@ benchmark latency , aeson , base , cardano-wallet + , cardano-wallet-api-http , cardano-wallet-integration , cardano-wallet-launcher , directory @@ -872,6 +981,7 @@ benchmark latency , iohk-monitoring , text , unliftio + , wai-middleware-logging other-modules: Cardano.Wallet.Shelley.Faucet diff --git a/lib/wallet/exe/cardano-wallet.hs b/lib/wallet/exe/cardano-wallet.hs index da3fdfb4c8a..e21559d3ea9 100644 --- a/lib/wallet/exe/cardano-wallet.hs +++ b/lib/wallet/exe/cardano-wallet.hs @@ -75,8 +75,15 @@ import Cardano.Wallet.Api.Client , transactionClient , walletClient ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( HostPreference, Listen (..), TlsConfiguration ) +import Cardano.Wallet.Launch + ( Mode (Light, Normal) + , NetworkConfiguration (..) + , modeOption + , networkConfigurationOption + , parseGenesisData + ) import Cardano.Wallet.Logging ( trMessage, transformTextTrace ) import Cardano.Wallet.Primitive.Types @@ -92,13 +99,6 @@ import Cardano.Wallet.Shelley ) import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) -import Cardano.Wallet.Shelley.Launch - ( Mode (Light, Normal) - , NetworkConfiguration (..) - , modeOption - , networkConfigurationOption - , parseGenesisData - ) import Cardano.Wallet.Version ( GitRevision, Version, showFullVersion ) import Control.Applicative @@ -144,7 +144,7 @@ import UnliftIO.Exception ( catch, withException ) import qualified Cardano.BM.Backend.EKGView as EKG -import qualified Cardano.Wallet.Shelley.Launch.Blockfrost as Blockfrost +import qualified Cardano.Wallet.Launch.Blockfrost as Blockfrost import qualified Cardano.Wallet.Version as V import qualified Data.Text as T import qualified System.Info as I diff --git a/lib/wallet/exe/local-cluster.hs b/lib/wallet/exe/local-cluster.hs index 316a67656f8..09255fc0bcb 100644 --- a/lib/wallet/exe/local-cluster.hs +++ b/lib/wallet/exe/local-cluster.hs @@ -29,6 +29,21 @@ import Cardano.Startup ( installSignalHandlers, setDefaultFilePermissions, withUtf8Encoding ) import Cardano.Wallet.Api.Types ( decodeAddress ) +import Cardano.Wallet.Launch + ( withSystemTempDir ) +import Cardano.Wallet.Launch.Cluster + ( ClusterLog (..) + , Credential (..) + , FaucetFunds (..) + , RunningNode (..) + , localClusterConfigFromEnv + , oneMillionAda + , testMinSeverityFromEnv + , tokenMetadataServerFromEnv + , walletListenFromEnv + , walletMinSeverityFromEnv + , withCluster + ) import Cardano.Wallet.Logging ( stdoutTextTracer, trMessageText ) import Cardano.Wallet.Primitive.AddressDerivation @@ -45,21 +60,6 @@ import Cardano.Wallet.Shelley ) import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) -import Cardano.Wallet.Shelley.Launch - ( withSystemTempDir ) -import Cardano.Wallet.Shelley.Launch.Cluster - ( ClusterLog (..) - , Credential (..) - , FaucetFunds (..) - , RunningNode (..) - , localClusterConfigFromEnv - , oneMillionAda - , testMinSeverityFromEnv - , tokenMetadataServerFromEnv - , walletListenFromEnv - , walletMinSeverityFromEnv - , withCluster - ) import Control.Arrow ( first ) import Control.Monad diff --git a/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs b/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs index 056cf1c2967..915b3d14697 100644 --- a/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs +++ b/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs @@ -218,6 +218,8 @@ module Test.Integration.Framework.DSL , ResourceT ) where +import Prelude + import Cardano.Address.Derivation ( XPub, xpubFromBytes ) import Cardano.CLI @@ -241,15 +243,14 @@ import Cardano.Wallet.Api.Types , ApiBlockReference (..) , ApiByronWallet , ApiCoinSelection - , ApiEpochInfo , ApiEra (..) , ApiFee , ApiMaintenanceAction (..) , ApiNetworkInformation , ApiNetworkParameters (..) + , ApiPoolSpecifier , ApiSerialisedTransaction , ApiSharedWallet (..) - , ApiStakePool , ApiT (..) , ApiTransaction , ApiTxId (ApiTxId) @@ -334,6 +335,8 @@ import Cardano.Wallet.Primitive.Types.UTxO , computeUtxoStatistics , log10 ) +import Cardano.Wallet.Shelley.Pools + ( EpochInfo, StakePool ) import Control.Arrow ( second ) import Control.Monad @@ -404,7 +407,6 @@ import Network.HTTP.Types.Method ( Method ) import Numeric.Natural ( Natural ) -import Prelude import System.Command ( CmdOption (..), CmdResult, Exit (..), Stderr, Stdout (..), command ) import System.Directory @@ -2082,13 +2084,11 @@ joinStakePool , MonadUnliftIO m ) => Context - -> ApiT PoolId + -> ApiPoolSpecifier -> (w, Text) -> m (HTTP.Status, Either RequestException (ApiTransaction n)) joinStakePool ctx p (w, pass) = do - let payload = Json [aesonQQ| { - "passphrase": #{pass} - } |] + let payload = Json [aesonQQ| { "passphrase": #{pass} } |] request @(ApiTransaction n) ctx (Link.joinStakePool (Identity p) w) Default payload @@ -2121,11 +2121,8 @@ quitStakePool -> (w, Text) -> m (HTTP.Status, Either RequestException (ApiTransaction n)) quitStakePool ctx (w, pass) = do - let payload = Json [aesonQQ| { - "passphrase": #{pass} - } |] - request @(ApiTransaction n) ctx - (Link.quitStakePool w) Default payload + let payload = Json [aesonQQ|{ "passphrase": #{pass} }|] + request @(ApiTransaction n) ctx (Link.quitStakePool w) Default payload quitStakePoolUnsigned :: forall n style w m. @@ -2139,9 +2136,7 @@ quitStakePoolUnsigned -> w -> m (HTTP.Status, Either RequestException (ApiCoinSelection n)) quitStakePoolUnsigned ctx w = liftIO $ do - let payload = Json [aesonQQ| { - "delegation_action": { "action": "quit" } - } |] + let payload = Json [aesonQQ|{ "delegation_action": { "action": "quit" } }|] request @(ApiCoinSelection n) ctx (Link.selectCoins @style w) Default payload @@ -3014,7 +3009,7 @@ getTTLSlots ctx dt = liftIO $ do -- | Wallet not delegating and not about to join any stake pool. notDelegating - :: [(Maybe (ApiT PoolId), ApiEpochInfo)] + :: [(Maybe (ApiT PoolId), EpochInfo)] -- ^ Pools to be joined & epoch at which the new delegation will become active -> ApiWalletDelegation notDelegating nexts = ApiWalletDelegation @@ -3029,7 +3024,7 @@ notDelegating nexts = ApiWalletDelegation delegating :: ApiT PoolId -- ^ Pool joined - -> [(Maybe (ApiT PoolId), ApiEpochInfo)] + -> [(Maybe (ApiT PoolId), EpochInfo)] -- ^ Pools to be joined & epoch at which the new delegation will become active -> ApiWalletDelegation delegating pidActive nexts = (notDelegating nexts) @@ -3037,8 +3032,8 @@ delegating pidActive nexts = (notDelegating nexts) } -getRetirementEpoch :: ApiStakePool -> Maybe EpochNo -getRetirementEpoch = fmap (view (#epochNumber . #getApiT)) . view #retirement +getRetirementEpoch :: StakePool -> Maybe EpochNo +getRetirementEpoch = fmap (view #epochNumber) . view #retirement unsafeResponse :: (HTTP.Status, Either RequestException a) -> a unsafeResponse = either (error . show) id . snd diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs index 6d7979774aa..cf7b1edcad1 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs @@ -11,13 +11,11 @@ import Prelude import Cardano.Wallet.Api.Types ( ApiByronWallet - , ApiEpochInfo (..) , ApiNetworkClock , ApiNetworkInformation , ApiWalletMode (..) , NtpSyncingStatus (..) , WalletStyle (..) - , epochStartTime , nextEpoch ) import Cardano.Wallet.Primitive.SyncProgress @@ -57,6 +55,8 @@ import Test.Utils.Paths ( inNixBuild ) import qualified Cardano.Wallet.Api.Link as Link +import Cardano.Wallet.Shelley.Pools + ( EpochInfo (..) ) import qualified Network.HTTP.Types.Status as HTTP spec :: SpecWith Context @@ -82,7 +82,7 @@ spec = describe "COMMON_NETWORK" $ do let Just currentEpochNum = view (#slotId . #epochNumber . #getApiT) <$> (i ^. #networkTip) let Just nextEpochNum = - view (#epochNumber . #getApiT) <$> getFromResponse #nextEpoch r + view #epochNumber <$> getFromResponse #nextEpoch r nextEpochNum `shouldBe` currentEpochNum + 1 it "NETWORK_BYRON - Byron wallet has the same tip as network/information" $ diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs index aeda9aac215..236c8a4c1fb 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs @@ -11,9 +11,11 @@ module Test.Integration.Scenario.API.Shelley.Network import Prelude import Cardano.Wallet.Api.Types - ( ApiEpochInfo, ApiEra (..), ApiNetworkParameters (..) ) + ( ApiEra (..), ApiNetworkParameters (..) ) import Cardano.Wallet.Primitive.Types ( ExecutionUnitPrices (..) ) +import Cardano.Wallet.Shelley.Pools + ( EpochInfo (..) ) import Data.List ( (\\) ) import Data.Quantity @@ -59,7 +61,7 @@ spec = describe "SHELLEY_NETWORK" $ do let nOpt = 3 let expectEraField - :: (Maybe ApiEpochInfo -> Expectation) + :: (Maybe EpochInfo -> Expectation) -> ApiEra -> (HTTP.Status, Either RequestException ApiNetworkParameters) -> IO () diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs index bdc970f7cce..a3b501fa9ce 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs @@ -13,12 +13,14 @@ module Test.Integration.Scenario.API.Shelley.Settings import Prelude -import Cardano.Wallet.Api.Types - ( ApiStakePool, ApiT (..) ) +import Cardano.Wallet.Api.Lib.ApiT + ( ApiT (..) ) import Cardano.Wallet.Primitive.Types ( PoolMetadataSource (..), Settings ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) +import Cardano.Wallet.Shelley.Pools + ( StakePool ) import Data.Either ( fromRight ) import Data.Generics.Internal.VL.Lens @@ -66,8 +68,8 @@ spec = describe "SHELLEY_SETTINGS" $ do it "SETTINGS_02 - Changing pool_metadata_source re-syncs metadata" $ \ctx -> do let toNone = "none" toDirect = "direct" - getMetadata = fmap (view #metadata) . snd <$> unsafeRequest - @[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty + getMetadata = fmap (view #metadata . getApiT) . snd <$> unsafeRequest + @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty delay = 500 * 1000 timeout = 120 diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs index 461a16dc40d..06d0d7df037 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -14,15 +14,17 @@ module Test.Integration.Scenario.API.Shelley.StakePools ( spec ) where -import Prelude +import Prelude hiding + ( id ) +import Cardano.Pool.Metadata + ( HealthCheckSMASH (..) ) import Cardano.Wallet.Api.Types ( ApiCertificate (JoinPool, QuitPool, RegisterRewardAccount) , ApiEra (..) , ApiHealthCheck + , ApiPoolSpecifier (..) , ApiStakeKeys - , ApiStakePool (flags) - , ApiStakePoolFlag (..) , ApiT (..) , ApiTransaction , ApiTxId (..) @@ -30,10 +32,6 @@ import Cardano.Wallet.Api.Types , ApiWallet , ApiWalletDelegationStatus (..) , ApiWithdrawal (..) - , DecodeAddress - , DecodeStakeAddress - , EncodeAddress - , HealthCheckSMASH (..) , WalletStyle (..) ) import Cardano.Wallet.Primitive.Types @@ -48,8 +46,12 @@ import Cardano.Wallet.Primitive.Types ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) -import Cardano.Wallet.Primitive.Types.Tx +import Cardano.Wallet.Primitive.Types.Tx.TxMeta ( Direction (..), TxStatus (..) ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..), DecodeStakeAddress (..), EncodeAddress (..) ) +import Cardano.Wallet.Shelley.Pools + ( StakePool (..), StakePoolFlag (Delisted) ) import Cardano.Wallet.Unsafe ( unsafeFromHex, unsafeMkPercentage ) import Control.Monad @@ -154,6 +156,7 @@ import qualified Data.ByteString as BS import qualified Data.Set as Set import qualified Data.Text as T import qualified Network.HTTP.Types.Status as HTTP +import qualified Prelude spec :: forall n. ( DecodeAddress n @@ -161,8 +164,9 @@ spec :: forall n. , EncodeAddress n ) => SpecWith Context spec = describe "SHELLEY_STAKE_POOLS" $ do - let listPools ctx stake = request @[ApiStakePool] ctx - (Link.listStakePools stake) Default Empty + let listPools ctx stake = + request @[ApiT StakePool] ctx (Link.listStakePools stake) Default Empty + & (fmap . fmap . fmap . fmap) getApiT it "STAKE_POOLS_MAINTENANCE_01 - \ \trigger GC action when metadata source = direct" $ \ctx -> runResourceT $ bracketSettings ctx $ do @@ -190,24 +194,24 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do _ <- request @ApiWallet ctx (Link.deleteWallet @'Shelley w) Default Empty let poolIdAbsent = PoolId $ BS.pack $ replicate 32 1 - r <- joinStakePool @n ctx (ApiT poolIdAbsent) (w, fixturePassphrase) + r <- joinStakePool @n ctx (SpecificPool poolIdAbsent) (w, fixturePassphrase) expectResponseCode HTTP.status404 r expectErrorMessage (errMsg404NoWallet wid) r it "STAKE_POOLS_JOIN_01 - Cannot join non-existent stakepool" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx let poolIdAbsent = PoolId $ BS.pack $ replicate 32 1 - r <- joinStakePool @n ctx (ApiT poolIdAbsent) (w, fixturePassphrase) + r <- joinStakePool @n ctx (SpecificPool poolIdAbsent) (w, fixturePassphrase) expectResponseCode HTTP.status404 r expectErrorMessage (errMsg404NoSuchPool (toText poolIdAbsent)) r it "STAKE_POOLS_JOIN_01 - \ \Cannot join existent stakepool with wrong password" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool:_ <- map (view #id) . snd <$> unsafeRequest - @[ApiStakePool] + pool : _ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, "Wrong Passphrase") >>= flip verify [ expectResponseCode HTTP.status403 , expectErrorMessage errMsg403WrongPass ] @@ -219,10 +223,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do dest <- emptyWallet ctx -- Join Pool - pool:_ <- map (view #id) . snd <$> - unsafeRequest @[ApiStakePool] ctx - (Link.listStakePools arbitraryStake) Empty - rJoin <- joinStakePool @n ctx pool (src, fixturePassphrase) + pool:_ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty + rJoin <- joinStakePool @n ctx (SpecificPool pool) (src, fixturePassphrase) verify rJoin [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) @@ -321,7 +324,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do acc ^. (#_delegation . #active . #status) `shouldBe` Delegating acc ^. (#_delegation . #active . #target) - `shouldBe` (Just pool) + `shouldBe` (Just (ApiT pool)) _ -> expectationFailure "wrong number of accounts in \"ours\"" ) , expectField (#_none . #_stake) (.> Quantity 0) @@ -444,10 +447,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do it "STAKE_POOLS_JOIN_02 - \ \Cannot join already joined stake pool" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -462,10 +465,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do , expectListField 0 (#status . #getApiT) (`shouldBe` InLedger) ] - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status403 , expectErrorMessage - (errMsg403PoolAlreadyJoined $ toText $ getApiT pool) + (errMsg403PoolAlreadyJoined $ toText pool) ] it "STAKE_POOLS_JOIN_03 - Cannot join a pool that has retired" $ \ctx -> runResourceT $ do @@ -473,7 +476,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do response <- listPools ctx arbitraryStake verify response [ expectListSize 3 ] getFromResponse Prelude.id response - & fmap (view (#id . #getApiT)) + & fmap (view #id) & Set.fromList & pure let reportError = error $ unlines @@ -488,16 +491,16 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do let retiredPoolId = fromMaybe reportError $ listToMaybe $ Set.toList retiredPoolIds w <- fixtureWallet ctx - r <- joinStakePool @n ctx (ApiT retiredPoolId) (w, fixturePassphrase) + r <- joinStakePool @n ctx (SpecificPool retiredPoolId) (w, fixturePassphrase) expectResponseCode HTTP.status404 r expectErrorMessage (errMsg404NoSuchPool (toText retiredPoolId)) r it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -531,10 +534,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do $ \ctx -> runResourceT $ do (w, _) <- rewardWallet ctx - pool:_:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField #depositTaken (`shouldBe` (Quantity 0)) , expectField #depositReturned (`shouldBe` (Quantity 0)) @@ -549,15 +552,15 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do it "STAKE_POOLS_JOIN_01 - Can rejoin another stakepool" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool1:pool2:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool1:pool2:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty -- make sure we are at the beginning of new epoch waitForNextEpoch ctx (currentEpoch, _) <- getSlotParams ctx - joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool1) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -578,12 +581,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do [ expectField (#delegation . #next) (\case [dlg] -> do - (dlg ^. #status) `shouldBe` - Delegating - (dlg ^. #target) `shouldBe` - Just pool1 + (dlg ^. #status) `shouldBe` Delegating + (dlg ^. #target) `shouldBe` Just (ApiT pool1) (view #epochNumber <$> dlg ^. #changesAt) `shouldBe` - Just (ApiT $ currentEpoch + 2) + Just (currentEpoch + 2) _ -> fail "next delegation should contain exactly one element" ) @@ -592,11 +593,11 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do eventually "Wallet is delegating to p1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool1 []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool1) []) ] -- join another stake pool - joinStakePool @n ctx pool2 (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool2) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -615,16 +616,16 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do eventually "Wallet is delegating to p2" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool2 []) - ] + [ expectField #delegation (`shouldBe` delegating (ApiT pool2) []) + ] it "STAKE_POOLS_JOIN_04 - Rewards accumulate" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty -- Join a pool - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -671,12 +672,12 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do } |] w <- unsafeResponse <$> postWallet ctx payload - pool:_ <- map (view #id) . snd <$> - unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty eventually "wallet join a pool" $ do - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -700,8 +701,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do ] let nonRetiringPoolId = (view #id) . fromMaybe reportError - . find (isNothing . getRetirementEpoch) - $ nonRetiredPools + $ find (isNothing . getRetirementEpoch) nonRetiredPools let isValidCerts (Just (RegisterRewardAccount{}:|[JoinPool{}])) = True @@ -711,7 +711,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do -- Join Pool w <- fixtureWallet ctx liftIO $ joinStakePoolUnsigned - @n @'Shelley ctx w nonRetiringPoolId >>= \o -> do + @n @'Shelley ctx w (ApiT nonRetiringPoolId) >>= \o -> do verify o [ expectResponseCode HTTP.status200 , expectField #inputs @@ -745,18 +745,19 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do $ nonRetiredPools -- Join Pool w <- fixtureWallet ctx - liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w retiringPoolId >>= \o -> do - verify o - [ expectResponseCode HTTP.status200 - , expectField #inputs - (`shouldSatisfy` (not . null)) - , expectField #outputs - (`shouldSatisfy` null) - , expectField #change - (`shouldSatisfy` (not . null)) - , expectField #certificates - (`shouldSatisfy` (not . null)) - ] + liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w (ApiT retiringPoolId) + >>= \o -> do + verify o + [ expectResponseCode HTTP.status200 + , expectField #inputs + (`shouldSatisfy` (not . null)) + , expectField #outputs + (`shouldSatisfy` null) + , expectField #change + (`shouldSatisfy` (not . null)) + , expectField #certificates + (`shouldSatisfy` (not . null)) + ] describe "STAKE_POOLS_JOIN_UNSIGNED_03" $ it "Cannot join a pool that's retired" $ \ctx -> runResourceT $ do @@ -765,7 +766,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do response <- listPools ctx arbitraryStake verify response [ expectListSize 3 ] getFromResponse Prelude.id response - & fmap (view (#id . #getApiT)) + & fmap (view #id) & Set.fromList & pure let reportError = error $ unlines @@ -800,11 +801,12 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do $ it "Join/quit when already joined a pool" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx - pool1:pool2:_ <- map (view #id) . snd <$> - unsafeRequest @[ApiStakePool] + pool1:pool2:_ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - liftIO $ joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify + liftIO $ joinStakePool @n ctx (SpecificPool pool1) (w, fixturePassphrase) + >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -813,21 +815,20 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do eventually "Wallet is delegating to p1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool1 []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool1) []) ] -- Cannot join the same pool - let pid = toText $ pool1 ^. #getApiT - liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w pool1 >>= \o -> do + liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w (ApiT pool1) >>= \o -> verify o [ expectResponseCode HTTP.status403 - , expectErrorMessage (errMsg403PoolAlreadyJoined pid) + , expectErrorMessage (errMsg403PoolAlreadyJoined (toText pool1)) ] -- Can join another pool let isValidCertsJoin (Just (JoinPool{}:|[])) = True isValidCertsJoin _ = False - liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w pool2 >>= \o -> do + liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w (ApiT pool2) >>= \o -> verify o [ expectResponseCode HTTP.status200 , expectField #inputs @@ -839,7 +840,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do -- Can quit pool let isValidCertsQuit (Just (QuitPool{}:|[])) = True isValidCertsQuit _ = False - liftIO $ quitStakePoolUnsigned @n @'Shelley ctx w >>= \o -> do + liftIO $ quitStakePoolUnsigned @n @'Shelley ctx w >>= \o -> verify o [ expectResponseCode HTTP.status200 , expectField #inputs @@ -870,10 +871,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do it "STAKE_POOLS_JOIN_01x - \ \I can join if I have just the right amount" $ \ctx -> runResourceT $ do w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx] - pool:_ <- map (view #id) . snd <$> - unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase)>>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase)>>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -882,10 +883,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do it "STAKE_POOLS_JOIN_01x - \ \I cannot join if I have not enough fee to cover" $ \ctx -> runResourceT $ do w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx - 1] - pool:_ <- map (view #id) . snd <$> - unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd <$> + unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status403 , expectErrorMessage errMsg403Fee ] @@ -904,11 +905,11 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do ] w <- fixtureWalletWith @n ctx initBalance - pool:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -917,7 +918,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do eventually "Wallet is delegating to p1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool) []) ] rQuit <- quitStakePool @n ctx (w, fixturePassphrase) @@ -957,11 +958,11 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do let initBalance = [costOfJoining ctx + depositAmt ctx] w <- fixtureWalletWith @n ctx initBalance - pool:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty - joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + joinStakePool @n ctx (SpecificPool pool) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 , expectField (#status . #getApiT) (`shouldBe` Pending) , expectField (#direction . #getApiT) (`shouldBe` Outgoing) @@ -970,7 +971,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do eventually "Wallet is delegating to p1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool) []) ] quitStakePool @n ctx (w, fixturePassphrase) >>= flip verify @@ -1078,7 +1079,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do [ expectListSize 3 , expectField Prelude.id $ \pools' -> do let metadataActual = Set.fromList $ - mapMaybe (fmap getApiT . view #metadata) pools' + mapMaybe (view #metadata) pools' metadataActual `shouldSatisfy` (`Set.isSubsetOf` metadataPossible) metadataActual @@ -1110,7 +1111,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do rewardsStakeBig .> rewardsStakeSmall it "STAKE_POOLS_LIST_05 - Fails without query parameter" $ \ctx -> runResourceT $ do - r <- request @[ApiStakePool] ctx + r <- request @[ApiT StakePool] ctx (Link.listStakePools Nothing) Default Empty expectResponseCode HTTP.status400 r @@ -1118,9 +1119,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do \NonMyopicMemberRewards are 0 when stake is 0" $ \ctx -> runResourceT $ do liftIO $ pendingWith "This assumption seems false, for some reasons..." let stake = Just $ Coin 0 - r <- request @[ApiStakePool] - ctx (Link.listStakePools stake) - Default Empty + r <- request @[ApiT StakePool] ctx (Link.listStakePools stake) Default Empty + & (fmap . fmap . fmap . fmap) getApiT expectResponseCode HTTP.status200 r verify r [ expectListSize 3 @@ -1213,14 +1213,14 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do [ expectListSize 3 , expectField Prelude.id $ \pools' -> do let metadataActual = Set.fromList $ - mapMaybe (fmap getApiT . view #metadata) pools' + mapMaybe (view #metadata) pools' delistedPools = filter (\pool -> Delisted `elem` flags pool) pools' metadataActual `shouldSatisfy` (`Set.isSubsetOf` metadataPossible) metadataActual `shouldSatisfy` (not . Set.null) - (fmap (getApiT . view #id) delistedPools) + (fmap (view #id) delistedPools) `shouldBe` [PoolId . unsafeFromHex $ "b45768c1a2da4bd13ebcaa1ea51408eda31dcc21765ccbd407cda9f2"] ] @@ -1232,14 +1232,14 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do [ expectListSize 3 , expectField Prelude.id $ \pools' -> do let metadataActual = Set.fromList $ - mapMaybe (fmap getApiT . view #metadata) pools' + mapMaybe (view #metadata) pools' delistedPools = filter (\pool -> Delisted `elem` flags pool) pools' metadataActual `shouldSatisfy` (`Set.isSubsetOf` metadataPossible) metadataActual `shouldSatisfy` (not . Set.null) - (fmap (getApiT . view #id) delistedPools) + (fmap (view #id) delistedPools) `shouldBe` [] ] diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs index 6b9d93aaab6..6cc0fea581b 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs @@ -52,7 +52,6 @@ import Cardano.Wallet.Api.Types , ApiPolicyKey (..) , ApiRegisterPool (..) , ApiSerialisedTransaction (..) - , ApiStakePool , ApiT (..) , ApiTokenAmountFingerprint (..) , ApiTokens (..) @@ -115,6 +114,8 @@ import Cardano.Wallet.Primitive.Types.Tx , getSealedTxBody , sealedTxFromCardanoBody ) +import Cardano.Wallet.Shelley.Pools + ( StakePool ) import Cardano.Wallet.Transaction ( AnyScript (..), ValidityIntervalExplicit (..) ) import Cardano.Wallet.Unsafe @@ -133,6 +134,8 @@ import Data.Function ( (&) ) import Data.Generics.Internal.VL.Lens ( view, (^.) ) +import Data.Generics.Wrapped + ( _Unwrapped ) import Data.Maybe ( fromJust, isJust ) import Data.Proxy @@ -2268,14 +2271,13 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do dest <- emptyWallet ctx let depositAmt = Quantity 1000000 - pool1:pool2:_ <- map (view #id) . snd <$> unsafeRequest - @[ApiStakePool] + pool1:pool2:_ <- map (view $ _Unwrapped . #id) . snd <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty let delegationJoin = Json [json|{ "delegations": [{ "join": { - "pool": #{pool1}, + "pool": #{ApiT pool1}, "stake_key_index": "0H" } }] @@ -2288,7 +2290,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) ] - let (ApiSerialisedTransaction apiTx1 _)= getFromResponse #transaction rTx1 + let (ApiSerialisedTransaction apiTx1 _) = getFromResponse #transaction rTx1 signedTx1 <- signTx ctx src apiTx1 [ expectResponseCode HTTP.status202 ] -- as we are joining for the first time we expect two certificates @@ -2302,7 +2304,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do let registerStakeKeyCert = WalletDelegationCertificate $ RegisterRewardAccount stakeKeyDerPath let delegatingCert = - WalletDelegationCertificate $ JoinPool stakeKeyDerPath pool1 + WalletDelegationCertificate $ JoinPool stakeKeyDerPath (ApiT pool1) let decodePayload1 = Json (toJSON signedTx1) rDecodedTx1 <- request @(ApiDecodedTransaction n) ctx @@ -2360,14 +2362,14 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do eventually "Wallet is delegating to pool1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool1 []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool1) []) ] -- join another stake pool let delegationRejoin = Json [json|{ "delegations": [{ "join": { - "pool": #{pool2}, + "pool": #{ApiT pool2}, "stake_key_index": "0H" } }] @@ -2382,7 +2384,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do let (ApiSerialisedTransaction apiTx2 _)= getFromResponse #transaction rTx2 signedTx2 <- signTx ctx src apiTx2 [ expectResponseCode HTTP.status202 ] let delegatingCert2 = - WalletDelegationCertificate $ JoinPool stakeKeyDerPath pool2 + WalletDelegationCertificate $ JoinPool stakeKeyDerPath (ApiT pool2) let decodePayload2 = Json (toJSON signedTx2) rDecodedTx2 <- request @(ApiDecodedTransaction n) ctx @@ -2421,7 +2423,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do eventually "Wallet is delegating to pool2" $ do request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool2 []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool2) []) ] -- there's currently no withdrawals in the wallet @@ -2628,14 +2630,14 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do it "TRANS_NEW_JOIN_01e - Can re-join and withdraw at once" $ \ctx -> runResourceT $ do (src, _) <- rewardWallet ctx - pool1:_ <- map (view #id) . snd <$> unsafeRequest - @[ApiStakePool] + pool1:_ <- map (view #id . getApiT) . snd <$> unsafeRequest + @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty let delegationJoin = Json [json|{ "delegations": [{ "join": { - "pool": #{pool1}, + "pool": #{ApiT pool1}, "stake_key_index": "0H" } }] @@ -2688,7 +2690,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do eventually "Wallet is delegating to pool1" $ do request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating pool1 []) + [ expectField #delegation (`shouldBe` delegating (ApiT pool1) []) ] it "TRANS_NEW_JOIN_02 - Can join stakepool in case I have many UTxOs on 1 address" @@ -2746,14 +2748,14 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do ] -- Delegate from src wallet - pool1:_ <- map (view #id) . snd <$> unsafeRequest - @[ApiStakePool] + pool1:_ <- map (view #id . getApiT) . snd <$> unsafeRequest + @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty let delegationJoin = Json [json|{ "delegations": [{ "join": { - "pool": #{pool1}, + "pool": #{ApiT pool1}, "stake_key_index": "0H" } }] @@ -2819,14 +2821,14 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do $ \ctx -> runResourceT $ do (w, _) <- rewardWallet ctx - pool1:_:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool1:_:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty let payload = Json [json|{ "delegations": [{ "join": { - "pool": #{pool1}, + "pool": #{ApiT pool1}, "stake_key_index": "0H" } }] @@ -2860,14 +2862,14 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do $ \ctx -> runResourceT $ do (w, _) <- rewardWallet ctx - pool1:_:_ <- map (view #id) . snd - <$> unsafeRequest @[ApiStakePool] + pool1:_:_ <- map (view #id . getApiT) . snd + <$> unsafeRequest @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty let payload = Json [json|{ "delegations": [{ "join": { - "pool": #{pool1}, + "pool": #{ApiT pool1}, "stake_key_index": "0H" } }] @@ -2891,11 +2893,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do waitForTxImmutability ctx let payload2 = Json [json|{ - "delegations": [{ - "quit": { - "stake_key_index": "0H" - } - }], + "delegations": [{ "quit": { "stake_key_index": "0H" } }], "withdrawal": "self" }|] rUnsignedTx2 <- request @(ApiConstructTransaction n) ctx @@ -2926,8 +2924,8 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do let destination1 = (addrs !! 1) ^. #id let destination2 = (addrs !! 2) ^. #id let deposit = fromIntegral oneAda - pool':_ <- map (view #id) . snd <$> unsafeRequest - @[ApiStakePool] + pool':_ <- map (view #id . getApiT) . snd <$> unsafeRequest + @[ApiT StakePool] ctx (Link.listStakePools arbitraryStake) Empty rSlot <- request @ApiNetworkInformation ctx @@ -2953,7 +2951,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do }], "delegations": [{ "join": { - "pool": #{pool'}, + "pool": #{ApiT pool'}, "stake_key_index": "0H" } }], @@ -3007,7 +3005,8 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do (`shouldBe` InLedger) , expectField (#metadata . traverse . #txMetadataWithSchema_metadata) - (`shouldBe` Cardano.TxMetadata (Map.fromList [(1, Cardano.TxMetaText "hello")])) + (`shouldBe` Cardano.TxMetadata + (Map.fromList [(1, Cardano.TxMetaText "hello")])) ] eventually "Delegation certificates are inserted" $ do @@ -3015,9 +3014,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do (Link.getWallet @'Shelley wa) Default Empty verify rWa [ expectSuccess - , expectField - #delegation - (`shouldBe` delegating pool' []) + , expectField #delegation (`shouldBe` delegating (ApiT pool') []) ] eventually "Destination wallet balance is as expected" $ do diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/CLI/Network.hs b/lib/wallet/integration/src/Test/Integration/Scenario/CLI/Network.hs index c73faf65afa..6c51f685a41 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/CLI/Network.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/CLI/Network.hs @@ -56,8 +56,7 @@ spec :: SpecWith Context spec = describe "COMMON_CLI_NETWORK" $ do it "CLI_NETWORK - cardano-wallet network information" $ \ctx -> do info <- getNetworkInfoViaCLI ctx - let nextEpochNum = - (fromJust (info ^. #nextEpoch)) ^. #epochNumber . #getApiT + let nextEpochNum = fromJust (info ^. #nextEpoch) ^. #epochNumber nextEpochNum `shouldBe` (currentEpochNo info) + 1 it "NETWORK_PARAMS - network parameters" $ \ctx -> do diff --git a/lib/wallet/src/Cardano/Wallet/TokenMetadata/MockServer.hs b/lib/wallet/mock-token-metadata/src/Cardano/Wallet/TokenMetadata/MockServer.hs similarity index 100% rename from lib/wallet/src/Cardano/Wallet/TokenMetadata/MockServer.hs rename to lib/wallet/mock-token-metadata/src/Cardano/Wallet/TokenMetadata/MockServer.hs diff --git a/lib/wallet/src/Cardano/Pool/Metadata.hs b/lib/wallet/src/Cardano/Pool/Metadata.hs index 5eb54670cb0..a4e680f7905 100644 --- a/lib/wallet/src/Cardano/Pool/Metadata.hs +++ b/lib/wallet/src/Cardano/Pool/Metadata.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE Rank2Types #-} @@ -15,11 +16,11 @@ module Cardano.Pool.Metadata ( - -- * Fetch fetchFromRemote , StakePoolMetadataFetchLog (..) , fetchDelistedPools + , HealthCheckSMASH(..) , healthCheck , isHealthyStatus , toHealthCheckSMASH @@ -45,8 +46,6 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) -import Cardano.Wallet.Api.Types - ( HealthCheckSMASH (..), HealthStatusSMASH (..), defaultRecordTypeOptions ) import Cardano.Wallet.Primitive.AddressDerivation ( hex ) import Cardano.Wallet.Primitive.Types @@ -68,13 +67,11 @@ import Crypto.Hash.Utils ( blake2b256 ) import Data.Aeson ( FromJSON - , ToJSON + , Options (..) + , camelTo2 , eitherDecodeStrict - , fieldLabelModifier , genericParseJSON - , genericToJSON , parseJSON - , toJSON ) import Data.Bifunctor ( first ) @@ -86,6 +83,8 @@ import Data.Coerce ( coerce ) import Data.List ( intercalate ) +import Data.Text + ( Text ) import Data.Text.Class ( TextDecodingError (..), ToText (..), fromText ) import Fmt @@ -112,6 +111,7 @@ import Network.URI import UnliftIO.Exception ( IOException, handle ) +import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL @@ -135,20 +135,6 @@ healthCheckEP = T.unpack $ T.intercalate "/" ["api", "v1", "status"] delistedEP :: String delistedEP = T.unpack $ T.intercalate "/" ["api", "v1", "delisted"] --- | TODO: import SMASH types -newtype SMASHPoolId = SMASHPoolId - { poolId :: T.Text - } deriving stock (Eq, Show, Ord) - deriving (Generic) - -instance FromJSON SMASHPoolId where - parseJSON = genericParseJSON defaultRecordTypeOptions - { fieldLabelModifier = id } - -instance ToJSON SMASHPoolId where - toJSON = genericToJSON defaultRecordTypeOptions - { fieldLabelModifier = id } - toPoolId :: SMASHPoolId -> Either TextDecodingError PoolId toPoolId (SMASHPoolId pid) = either (\_ -> decodePoolIdBech32 pid) Right (fromText @PoolId pid) @@ -228,8 +214,12 @@ healthCheck -> Manager -> IO (Maybe HealthStatusSMASH) healthCheck tr uri manager = runExceptTLog $ do - pl <- smashRequest tr - (uri { uriPath = "/" <> healthCheckEP , uriQuery = "", uriFragment = "" }) + pl <- smashRequest tr ( + uri { uriPath = "/" <> healthCheckEP + , uriQuery = "" + , uriFragment = "" + } + ) manager except . eitherDecodeStrict @HealthStatusSMASH $ pl where @@ -363,6 +353,42 @@ fetchFromRemote tr builders manager pid url hash = runExceptTLog $ do fromIOException :: Monad m => IOException -> m (Either String a) fromIOException = return . Left . ("IO exception: " <>) . show +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +newtype SMASHPoolId = SMASHPoolId { poolId :: T.Text } + deriving newtype (Eq, Show, Ord) + deriving stock (Generic) + +instance FromJSON SMASHPoolId where + parseJSON = genericParseJSON smashRecordTypeOptions{fieldLabelModifier=id} + +-- | Parses the SMASH HealthCheck type from the SMASH API. +data HealthStatusSMASH = HealthStatusSMASH { status :: Text, version :: Text } + deriving stock (Generic, Show, Eq, Ord) + +instance FromJSON HealthStatusSMASH where + parseJSON = genericParseJSON smashRecordTypeOptions + +smashRecordTypeOptions :: Aeson.Options +smashRecordTypeOptions = Aeson.defaultOptions + { fieldLabelModifier = camelTo2 '_' . dropWhile (== '_') + , omitNothingFields = True + } + +-- | Dscribes the health status of the SMASH server. +data HealthCheckSMASH + = Available -- server available + | Unavailable -- server reachable, but unavailable + | Unreachable -- could not get a response from the SMASH server + | NoSmashConfigured -- no SMASH server has been configured + deriving stock (Generic, Show, Eq, Ord) + +-------------------------------------------------------------------------------- +-- Logging +-------------------------------------------------------------------------------- + data StakePoolMetadataFetchLog = MsgFetchPoolMetadata StakePoolMetadataHash URI | MsgFetchPoolMetadataSuccess StakePoolMetadataHash StakePoolMetadata diff --git a/lib/wallet/src/Cardano/Wallet/Api/Types/Address.hs b/lib/wallet/src/Cardano/Wallet/Api/Types/Address.hs deleted file mode 100644 index 23d81399423..00000000000 --- a/lib/wallet/src/Cardano/Wallet/Api/Types/Address.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Copyright: © 2018-2022 IOHK --- License: Apache-2.0 - -module Cardano.Wallet.Api.Types.Address - ( DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - ) - where - -import Prelude - -import Cardano.Wallet.Primitive.AddressDerivation - ( NetworkDiscriminant (..) ) -import Cardano.Wallet.Primitive.Types.Address - ( Address (..) ) -import Data.Text - ( Text ) -import Data.Text.Class - ( TextDecodingError (..) ) - -import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W - --- | An abstract class to allow encoding of addresses depending on the target --- backend used. -class EncodeAddress (n :: NetworkDiscriminant) where - encodeAddress :: Address -> Text - -instance EncodeAddress 'Mainnet => EncodeAddress ('Staging pm) where - encodeAddress = encodeAddress @'Mainnet - --- | An abstract class to allow decoding of addresses depending on the target --- backend used. -class DecodeAddress (n :: NetworkDiscriminant) where - decodeAddress :: Text -> Either TextDecodingError Address - -instance DecodeAddress 'Mainnet => DecodeAddress ('Staging pm) where - decodeAddress = decodeAddress @'Mainnet - -class EncodeStakeAddress (n :: NetworkDiscriminant) where - encodeStakeAddress :: W.RewardAccount -> Text - -instance EncodeStakeAddress 'Mainnet => EncodeStakeAddress ('Staging pm) where - encodeStakeAddress = encodeStakeAddress @'Mainnet - -class DecodeStakeAddress (n :: NetworkDiscriminant) where - decodeStakeAddress :: Text -> Either TextDecodingError W.RewardAccount - -instance DecodeStakeAddress 'Mainnet => DecodeStakeAddress ('Staging pm) where - decodeStakeAddress = decodeStakeAddress @'Mainnet diff --git a/lib/wallet/src/Cardano/Wallet/Gen.hs b/lib/wallet/src/Cardano/Wallet/Gen.hs index 14ac9965409..a25a3aa4216 100644 --- a/lib/wallet/src/Cardano/Wallet/Gen.hs +++ b/lib/wallet/src/Cardano/Wallet/Gen.hs @@ -26,7 +26,6 @@ module Cardano.Wallet.Gen , genScript , genScriptCosigners , genScriptTemplate - , genScriptTemplateEntry , genMockXPub , genNatural ) where @@ -45,8 +44,6 @@ import Cardano.Api ) import Cardano.Mnemonic ( ConsistentEntropy, EntropySize, Mnemonic, entropyToMnemonic ) -import Cardano.Wallet.Api.Types - ( ApiScriptTemplateEntry (..), XPubOrSelf (..) ) import Cardano.Wallet.Primitive.AddressDiscovery.Shared ( retrieveAllCosigners ) import Cardano.Wallet.Primitive.Types @@ -346,20 +343,9 @@ genScriptTemplate = do xpubs <- vectorOf (length cosignersSubset) genMockXPub pure $ ScriptTemplate (Map.fromList $ zip cosignersSubset xpubs) script -genScriptTemplateEntry :: Gen ApiScriptTemplateEntry -genScriptTemplateEntry = do - script <- genScriptCosigners `suchThat` (not . null . retrieveAllCosigners) - let scriptCosigners = retrieveAllCosigners script - cosignersSubset <- sublistOf scriptCosigners `suchThat` (not . null) - xpubsOrSelf <- vectorOf (length cosignersSubset) genXPubOrSelf - pure $ ApiScriptTemplateEntry (Map.fromList $ zip cosignersSubset xpubsOrSelf) script - genMockXPub :: Gen XPub genMockXPub = fromMaybe impossible . xpubFromBytes . BS.pack <$> genBytes where genBytes = vectorOf 64 arbitrary impossible = error "incorrect length in genMockXPub" -genXPubOrSelf :: Gen XPubOrSelf -genXPubOrSelf = - oneof [SomeAccountKey <$> genMockXPub, pure Self] diff --git a/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs b/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs index edb0701dd49..456f04ba2ad 100644 --- a/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs @@ -695,7 +695,8 @@ decodePoolIdBech32 t = Right _ -> Left textDecodingError where textDecodingError = TextDecodingError $ unwords - [ "Invalid stake pool id: expecting a Bech32 encoded value with human readable part of 'pool'." + [ "Invalid stake pool id: expecting a Bech32 encoded value" + , "with human readable part of 'pool'." ] -- | A stake pool owner, which is a public key encoded in bech32 with prefix diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs index 55212b1d2fb..0baeacb5ac7 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -97,6 +97,12 @@ module Cardano.Wallet.Shelley.Compatibility , toCardanoPolicyId , toCardanoSimpleScript + -- * Address encoding + , shelleyEncodeAddress + , shelleyEncodeStakeAddress + , shelleyDecodeAddress + , shelleyDecodeStakeAddress + -- * Unsafe conversions , unsafeLovelaceToWalletCoin , unsafeValueToLovelace @@ -111,7 +117,6 @@ module Cardano.Wallet.Shelley.Compatibility , fromNonMyopicMemberRewards , optimumNumberOfPools , getProducer - , HasNetworkId(..) , fromBlockNo , fromCardanoBlock , toCardanoEra @@ -202,12 +207,6 @@ import Cardano.Slotting.Slot ( EpochNo (..), EpochSize (..) ) import Cardano.Slotting.Time ( SystemStart (..) ) -import Cardano.Wallet.Api.Types - ( DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - ) import Cardano.Wallet.Byron.Compatibility ( fromByronBlock, fromTxAux, maryTokenBundleMaxSize, toByronBlockHeader ) import Cardano.Wallet.Primitive.AddressDerivation @@ -240,6 +239,12 @@ import Cardano.Wallet.Read.Primitive.Tx.Shelley ) import Cardano.Wallet.Read.Tx.Hash ( fromShelleyTxId ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..) + , DecodeStakeAddress (..) + , EncodeAddress (..) + , EncodeStakeAddress (..) + ) import Cardano.Wallet.Unsafe ( unsafeIntToWord, unsafeMkPercentage ) import Cardano.Wallet.Util @@ -282,8 +287,6 @@ import Data.Map.Strict ( Map ) import Data.Maybe ( fromMaybe, isJust, mapMaybe ) -import Data.Proxy - ( Proxy (..) ) import Data.Quantity ( Percentage, Quantity (..), mkPercentage ) import Data.Text @@ -300,8 +303,6 @@ import GHC.Records ( HasField (..) ) import GHC.Stack ( HasCallStack ) -import GHC.TypeLits - ( KnownNat, natVal ) import Numeric.Natural ( Natural ) import Ouroboros.Consensus.Byron.Ledger @@ -1674,14 +1675,14 @@ computeTokenBundleSerializedLengthBytes = W.TxSize . safeCast -------------------------------------------------------------------------------} instance EncodeStakeAddress 'Mainnet where - encodeStakeAddress = _encodeStakeAddress SL.Mainnet + encodeStakeAddress = shelleyEncodeStakeAddress SL.Mainnet instance EncodeStakeAddress ('Testnet pm) where - encodeStakeAddress = _encodeStakeAddress SL.Testnet + encodeStakeAddress = shelleyEncodeStakeAddress SL.Testnet instance DecodeStakeAddress 'Mainnet where - decodeStakeAddress = _decodeStakeAddress SL.Mainnet + decodeStakeAddress = shelleyDecodeStakeAddress SL.Mainnet instance DecodeStakeAddress ('Testnet pm) where - decodeStakeAddress = _decodeStakeAddress SL.Testnet + decodeStakeAddress = shelleyDecodeStakeAddress SL.Testnet stakeAddressPrefix :: Word8 stakeAddressPrefix = 0xE0 @@ -1694,11 +1695,8 @@ toNetworkId = \case SL.Testnet -> 0 SL.Mainnet -> 1 -_encodeStakeAddress - :: SL.Network - -> W.RewardAccount - -> Text -_encodeStakeAddress network (W.RewardAccount acct) = +shelleyEncodeStakeAddress :: SL.Network -> W.RewardAccount -> Text +shelleyEncodeStakeAddress network (W.RewardAccount acct) = Bech32.encodeLenient hrp (dataPartFromBytes bytes) where hrp = case network of @@ -1708,11 +1706,9 @@ _encodeStakeAddress network (W.RewardAccount acct) = putWord8 $ (networkIdMask .&. toNetworkId network) .|. stakeAddressPrefix putByteString acct -_decodeStakeAddress - :: SL.Network - -> Text - -> Either TextDecodingError W.RewardAccount -_decodeStakeAddress serverNetwork txt = do +shelleyDecodeStakeAddress :: + SL.Network -> Text -> Either TextDecodingError W.RewardAccount +shelleyDecodeStakeAddress serverNetwork txt = do (_, dp) <- left (const errBech32) $ Bech32.decodeLenient txt bytes <- maybe (Left errBech32) Right $ dataPartToBytes dp rewardAcnt <- runGetOrFail' (SL.getRewardAcnt @StandardCrypto) bytes @@ -1739,26 +1735,29 @@ _decodeStakeAddress serverNetwork txt = do "Unable to decode stake-address: must be a valid bech32 string." instance EncodeAddress 'Mainnet where - encodeAddress = _encodeAddress [Bech32.humanReadablePart|addr|] + encodeAddress = shelleyEncodeAddress SL.Mainnet instance EncodeAddress ('Testnet pm) where -- https://github.com/cardano-foundation/CIPs/tree/master/CIP5 - encodeAddress = _encodeAddress [Bech32.humanReadablePart|addr_test|] + encodeAddress = shelleyEncodeAddress SL.Testnet -_encodeAddress :: Bech32.HumanReadablePart -> W.Address -> Text -_encodeAddress hrp (W.Address bytes) = +shelleyEncodeAddress :: SL.Network -> W.Address -> Text +shelleyEncodeAddress network (W.Address bytes) = if isJust (CBOR.deserialiseCbor CBOR.decodeAddressPayload bytes) then base58 else bech32 where base58 = T.decodeUtf8 $ encodeBase58 bitcoinAlphabet bytes bech32 = Bech32.encodeLenient hrp (dataPartFromBytes bytes) + hrp = case network of + SL.Testnet -> [Bech32.humanReadablePart|addr_test|] + SL.Mainnet -> [Bech32.humanReadablePart|addr|] instance DecodeAddress 'Mainnet where - decodeAddress = _decodeAddress SL.Mainnet + decodeAddress = shelleyDecodeAddress SL.Mainnet instance DecodeAddress ('Testnet pm) where - decodeAddress = _decodeAddress SL.Testnet + decodeAddress = shelleyDecodeAddress SL.Testnet decodeBytes :: Text -> Either TextDecodingError ByteString decodeBytes t = @@ -1801,14 +1800,12 @@ errMalformedAddress = TextDecodingError -- practice, there is one discrimination for 'Shelley' addresses, and one for -- 'Byron' addresses. Yet, on Mainnet, 'Byron' addresses have no explicit -- discrimination. -_decodeAddress - :: SL.Network - -> Text - -> Either TextDecodingError W.Address -_decodeAddress serverNetwork = +shelleyDecodeAddress :: SL.Network -> Text -> Either TextDecodingError W.Address +shelleyDecodeAddress serverNetwork = decodeBytes >=> decodeShelleyAddress @StandardCrypto where - decodeShelleyAddress :: forall c. (SL.Crypto c) => ByteString -> Either TextDecodingError W.Address + decodeShelleyAddress :: forall c. + (SL.Crypto c) => ByteString -> Either TextDecodingError W.Address decodeShelleyAddress bytes = do case SL.deserialiseAddr @c bytes of Just (SL.Addr addrNetwork _ _) -> do @@ -1816,7 +1813,9 @@ _decodeAddress serverNetwork = pure (W.Address bytes) Just (SL.AddrBootstrap (SL.BootstrapAddress addr)) -> do - guardNetwork (fromByronNetworkMagic (Byron.addrNetworkMagic addr)) serverNetwork + guardNetwork + (fromByronNetworkMagic (Byron.addrNetworkMagic addr)) + serverNetwork pure (W.Address bytes) Nothing -> Left errMalformedAddress @@ -1868,23 +1867,6 @@ guardNetwork addrNetwork serverNetwork = <> show addrNetwork <> "." --- | Class to extract a @NetworkId@ from @NetworkDiscriminant@. -class HasNetworkId (n :: NetworkDiscriminant) where - networkIdVal :: Proxy n -> NetworkId - -instance HasNetworkId 'Mainnet where - networkIdVal _ = Cardano.Mainnet - -instance KnownNat protocolMagic => HasNetworkId ('Testnet protocolMagic) where - networkIdVal _ = Cardano.Testnet networkMagic - where - networkMagic = Cardano.NetworkMagic - . fromIntegral - $ natVal (Proxy @protocolMagic) - -instance HasNetworkId ('Staging protocolMagic) where - networkIdVal _ = Cardano.Mainnet - {------------------------------------------------------------------------------- Logging -------------------------------------------------------------------------------} diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs index b8af31ce23c..e04690c6692 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs @@ -60,8 +60,6 @@ import Cardano.Pool.Rank.Likelihood ( BlockProduction (..), PerformanceEstimate (..), estimatePoolPerformance ) import Cardano.Slotting.Slot ( unEpochSize ) -import Cardano.Wallet.Api.Types - ( Base (Base16), decodeStakeAddress, encodeAddress, encodeStakeAddress ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network @@ -145,6 +143,11 @@ import Cardano.Wallet.Primitive.Types.Tx ) import Cardano.Wallet.Primitive.Types.Tx.Constraints ( TxSize (..) ) +import Cardano.Wallet.Shelley.Compatibility + ( shelleyDecodeStakeAddress + , shelleyEncodeAddress + , shelleyEncodeStakeAddress + ) import Cardano.Wallet.Shelley.Network.Blockfrost.Conversion ( bfBlockHeader , fromBfAddress @@ -166,7 +169,10 @@ import Cardano.Wallet.Shelley.Network.Blockfrost.Layer , withRecovery ) import Cardano.Wallet.Shelley.Network.Discriminant - ( SomeNetworkDiscriminant (..), networkDiscriminantToId ) + ( SomeNetworkDiscriminant (..) + , discriminantNetwork + , networkDiscriminantToId + ) import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async.Lifted @@ -187,6 +193,8 @@ import Data.Bifunctor ( first ) import Data.Bitraversable ( bitraverse ) +import Data.ByteArray.Encoding + ( Base (..), convertFromBase ) import Data.Default ( Default (..) ) import Data.Function @@ -259,8 +267,6 @@ import qualified Cardano.Wallet.Primitive.Types.Coin as Coin import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Fixture as Fixture import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Layer as Layer -import Data.ByteArray.Encoding - ( convertFromBase ) import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq @@ -384,17 +390,19 @@ withNetworkLayer tr network np project k = do -> BlockfrostLayer IO -> Set RewardAccount -> IO (Map RewardAccount Coin) - fetchNetworkRewardAccountBalances - (SomeNetworkDiscriminant (Proxy :: Proxy nd)) bfLayer accounts = do - traceWith tr MsgFetchNetworkRewardAccountBalances - Map.fromList . catMaybes <$> - for (Set.toList accounts) \rewardAccount -> do - let addr = BF.mkAddress $ encodeStakeAddress @nd rewardAccount - bfGetAccount bfLayer addr - >>= traverse \BF.AccountInfo{..} -> throwBlockfrostError $ - (rewardAccount,) . Coin <$> - fromIntegral @_ @Integer _accountInfoWithdrawableAmount - "AccountInfoRewardsSum" + fetchNetworkRewardAccountBalances nd bfLayer accounts = do + traceWith tr MsgFetchNetworkRewardAccountBalances + Map.fromList . catMaybes <$> + for (Set.toList accounts) \rewardAccount -> do + let addr = BF.mkAddress $ + shelleyEncodeStakeAddress + (discriminantNetwork nd) + rewardAccount + bfGetAccount bfLayer addr + >>= traverse \BF.AccountInfo{..} -> throwBlockfrostError $ + (rewardAccount,) . Coin <$> + fromIntegral @_ @Integer _accountInfoWithdrawableAmount + "AccountInfoRewardsSum" getCachedRewardAccountBalance :: BlockfrostLayer IO -> RewardAccount -> IO Coin getCachedRewardAccountBalance bfLayer account = @@ -572,7 +580,8 @@ blockfrostLightSyncSource Left address -> do txs <- bfGetAddressTransactions - (BF.Address (encodeAddress @nd address)) + (BF.Address (shelleyEncodeAddress + (discriminantNetwork network) address)) (Just $ headerToIndex bhFrom) (Just $ headerToIndex bhTo) for txs \BF.AddressTransaction{..} -> do @@ -590,7 +599,9 @@ blockfrostLightSyncSource (unsafeMkSublist [((txIndex, 0), tx)]) (unsafeMkSublist []) Right account -> do - let address = BF.Address $ encodeStakeAddress @nd account + let address = BF.Address $ + shelleyEncodeStakeAddress + (discriminantNetwork network) account regTxHashes <- fmap BF._accountRegistrationTxHash <$> bfGetAccountRegistrations address @@ -692,8 +703,7 @@ fetchDelegation -> BlockfrostLayer IO -> BF.TxHash -> IO [DelegationCertificate] -fetchDelegation - tr (SomeNetworkDiscriminant (Proxy :: Proxy nd)) bfLayer hash = do +fetchDelegation tr network bfLayer hash = do liftIO $ traceWith tr $ MsgFetchDelegation hash delegations <- concurrently @@ -712,7 +722,8 @@ fetchDelegation parseTxDelegation BF.TransactionDelegation{..} = do let addr = BF.unAddress _transactionDelegationAddress rewardAccount <- - first (InvalidAddress addr) $ decodeStakeAddress @nd addr + first (InvalidAddress addr) $ + shelleyDecodeStakeAddress (discriminantNetwork network) addr poolId <- fromBfPoolId _transactionDelegationPoolId pure ( _transactionDelegationCertIndex @@ -721,7 +732,8 @@ fetchDelegation parseTxStake BF.TransactionStake{..} = do let addr = BF.unAddress _transactionStakeAddress rewardAccount <- - first (InvalidAddress addr) $ decodeStakeAddress @nd addr + first (InvalidAddress addr) $ + shelleyDecodeStakeAddress (discriminantNetwork network) addr let action = if _transactionStakeRegistration then CertRegisterKey @@ -751,7 +763,7 @@ assembleTransaction -> [BF.TransactionMetaCBOR] -> IO Tx assembleTransaction - network@(SomeNetworkDiscriminant (Proxy :: Proxy nd)) + network BF.Transaction{..} BF.TransactionUtxos{..} txWithdrawals @@ -763,7 +775,7 @@ assembleTransaction let sortedTransactionUtxosOutputs = sortOn BF._utxoOutputOutputIndex _transactionUtxosOutputs outputs <- for sortedTransactionUtxosOutputs \out@BF.UtxoOutput{..} -> do - address <- fromBfAddress network _utxoOutputAddress + address <- fromBfAddress (discriminantNetwork network) _utxoOutputAddress tokens <- do coin <- case [ lovelaces | BF.AdaAmount lovelaces <- _utxoOutputAmount @@ -792,7 +804,9 @@ assembleTransaction <$> for txWithdrawals \BF.TransactionWithdrawal{..} -> do let addr = BF.unAddress _transactionWithdrawalAddress rewardAccount <- - first (InvalidAddress addr) $ decodeStakeAddress @nd addr + first (InvalidAddress addr) $ + shelleyDecodeStakeAddress + (discriminantNetwork network) addr coin <- fromBfLovelaces _transactionWithdrawalAmount pure (rewardAccount, coin) metadata <- @@ -1218,3 +1232,4 @@ instance HasSeverityAnnotation Log where MsgNextBlockHeader{} -> Notice MsgGotNextBlocks {} -> Notice MsgBlockfrostLayer l -> getSeverityAnnotation l + diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs index 69800cd3c11..ab370bffb07 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs @@ -9,8 +9,6 @@ module Cardano.Wallet.Shelley.Network.Blockfrost.Conversion where import Prelude -import Cardano.Wallet.Api.Types - ( decodeAddress, decodeStakeAddress ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) , EpochNo @@ -27,10 +25,10 @@ import Cardano.Wallet.Primitive.Types.Hash ( Hash ) import Cardano.Wallet.Primitive.Types.RewardAccount ( RewardAccount ) +import Cardano.Wallet.Shelley.Compatibility + ( shelleyDecodeAddress, shelleyDecodeStakeAddress ) import Cardano.Wallet.Shelley.Network.Blockfrost.Error ( BlockfrostError (..), () ) -import Cardano.Wallet.Shelley.Network.Discriminant - ( SomeNetworkDiscriminant (..) ) import Control.Monad.Error.Class ( MonadError (throwError) ) import Data.Bifunctor @@ -39,8 +37,6 @@ import Data.IntCast ( intCast ) import Data.Maybe ( fromMaybe ) -import Data.Proxy - ( Proxy (..) ) import Data.Quantity ( Percentage, Quantity (Quantity), mkPercentage ) import Data.Text @@ -51,27 +47,23 @@ import Data.Traversable ( for ) import qualified Blockfrost.Client as BF +import qualified Cardano.Ledger.BaseTypes as Ledger fromBfLovelaces :: MonadError BlockfrostError m => BF.Lovelaces -> m Coin fromBfLovelaces lovs = Coin <$> (intCast @_ @Integer lovs "Lovelaces") fromBfAddress - :: MonadError BlockfrostError m - => SomeNetworkDiscriminant - -> BF.Address - -> m Address -fromBfAddress (SomeNetworkDiscriminant (Proxy :: Proxy nd)) (BF.Address addr) = - case decodeAddress @nd addr of + :: MonadError BlockfrostError m => Ledger.Network -> BF.Address -> m Address +fromBfAddress network (BF.Address addr) = + case shelleyDecodeAddress network addr of Left e -> throwError (InvalidAddress addr e) Right a -> pure a fromBfStakeAddress :: MonadError BlockfrostError m - => SomeNetworkDiscriminant - -> BF.Address - -> m RewardAccount -fromBfStakeAddress (SomeNetworkDiscriminant (Proxy :: Proxy nd)) (BF.Address addr) = - case decodeStakeAddress @nd addr of + => Ledger.Network -> BF.Address -> m RewardAccount +fromBfStakeAddress network (BF.Address addr) = + case shelleyDecodeStakeAddress network addr of Left e -> throwError (InvalidStakeAddress addr e) Right a -> pure a diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Discriminant.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Discriminant.hs index c81cfbe4277..9f087ce2cd9 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Discriminant.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Discriminant.hs @@ -1,23 +1,34 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Wallet.Shelley.Network.Discriminant ( SomeNetworkDiscriminant (..) , networkDiscriminantToId + , discriminantNetwork + , EncodeAddress (..) + , EncodeStakeAddress (..) + , DecodeAddress (..) + , DecodeStakeAddress (..) + , HasNetworkId (..) ) where import Prelude -import Cardano.Wallet.Api.Types - ( DecodeAddress, DecodeStakeAddress, EncodeAddress, EncodeStakeAddress ) +import Cardano.Api.Shelley + ( NetworkId ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress , Depth (..) - , NetworkDiscriminant + , NetworkDiscriminant (..) , NetworkDiscriminantVal , PaymentAddress ) @@ -27,12 +38,24 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus ( IcarusKey ) import Cardano.Wallet.Primitive.AddressDerivation.Shelley ( ShelleyKey ) -import Cardano.Wallet.Shelley.Compatibility - ( HasNetworkId (..), NetworkId ) +import Cardano.Wallet.Primitive.Types.Address + ( Address (..) ) +import Control.Arrow + ( (>>>) ) import Data.Proxy - ( Proxy ) + ( Proxy (..) ) +import Data.Text + ( Text ) +import Data.Text.Class + ( TextDecodingError ) import Data.Typeable ( Typeable ) +import GHC.TypeLits + ( KnownNat, natVal ) + +import qualified Cardano.Api as Cardano +import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W -- | Encapsulate a network discriminant and the necessary constraints it should -- satisfy. @@ -43,12 +66,12 @@ data SomeNetworkDiscriminant where , PaymentAddress n IcarusKey 'CredFromKeyK , PaymentAddress n ByronKey 'CredFromKeyK , PaymentAddress n ShelleyKey 'CredFromKeyK - , DelegationAddress n ShelleyKey 'CredFromKeyK - , HasNetworkId n - , DecodeAddress n , EncodeAddress n - , DecodeStakeAddress n + , DecodeAddress n , EncodeStakeAddress n + , DecodeStakeAddress n + , DelegationAddress n ShelleyKey 'CredFromKeyK + , HasNetworkId n , Typeable n ) => Proxy n @@ -56,5 +79,54 @@ data SomeNetworkDiscriminant where deriving instance Show SomeNetworkDiscriminant +-- | An abstract class to allow encoding of addresses depending on the target +-- backend used. +class EncodeAddress (n :: NetworkDiscriminant) where + encodeAddress :: Address -> Text + +instance EncodeAddress 'Mainnet => EncodeAddress ('Staging pm) where + encodeAddress = encodeAddress @'Mainnet + +-- | An abstract class to allow decoding of addresses depending on the target +-- backend used. +class DecodeAddress (n :: NetworkDiscriminant) where + decodeAddress :: Text -> Either TextDecodingError Address + +instance DecodeAddress 'Mainnet => DecodeAddress ('Staging pm) where + decodeAddress = decodeAddress @'Mainnet + +class EncodeStakeAddress (n :: NetworkDiscriminant) where + encodeStakeAddress :: W.RewardAccount -> Text + +instance EncodeStakeAddress 'Mainnet => EncodeStakeAddress ('Staging pm) where + encodeStakeAddress = encodeStakeAddress @'Mainnet + +class DecodeStakeAddress (n :: NetworkDiscriminant) where + decodeStakeAddress :: Text -> Either TextDecodingError W.RewardAccount + +instance DecodeStakeAddress 'Mainnet => DecodeStakeAddress ('Staging pm) where + decodeStakeAddress = decodeStakeAddress @'Mainnet + networkDiscriminantToId :: SomeNetworkDiscriminant -> NetworkId networkDiscriminantToId (SomeNetworkDiscriminant proxy) = networkIdVal proxy + +discriminantNetwork :: SomeNetworkDiscriminant -> Ledger.Network +discriminantNetwork = networkDiscriminantToId >>> \case + Cardano.Mainnet -> Ledger.Mainnet + Cardano.Testnet _magic -> Ledger.Testnet + +-- | Class to extract a @NetworkId@ from @NetworkDiscriminant@. +class HasNetworkId (n :: NetworkDiscriminant) where + networkIdVal :: Proxy n -> NetworkId + +instance HasNetworkId 'Mainnet where + networkIdVal _ = Cardano.Mainnet + +instance KnownNat protocolMagic => HasNetworkId ('Testnet protocolMagic) where + networkIdVal _ = Cardano.Testnet networkMagic + where + networkMagic = + Cardano.NetworkMagic . fromIntegral . natVal $ Proxy @protocolMagic + +instance HasNetworkId ('Staging protocolMagic) where + networkIdVal _ = Cardano.Mainnet diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs index f70c6ba1f69..559a91d2e44 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -22,6 +24,11 @@ -- as provided through @StakePoolLayer@. module Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) + , StakePool (..) + , StakePoolMetrics (..) + , StakePoolFlag (..) + , EpochInfo (..) + , toEpochInfo , withBlockfrostStakePoolLayer , withNodeStakePoolLayer , withStakePoolDbLayer @@ -51,30 +58,28 @@ import Cardano.Pool.DB import Cardano.Pool.DB.Log ( PoolDbLog ) import Cardano.Pool.Metadata - ( Manager + ( HealthCheckSMASH (..) , StakePoolMetadataFetchLog , UrlBuilder - , defaultManagerSettings , fetchDelistedPools , fetchFromRemote , healthCheck , identityUrlBuilder - , newManager , registryUrlBuilder , toHealthCheckSMASH ) -import Cardano.Wallet.Api.Types - ( ApiT (..), HealthCheckSMASH (..), toApiEpochInfo ) import Cardano.Wallet.Byron.Compatibility ( toByronBlockHeader ) import Cardano.Wallet.Network ( ChainFollowLog (..), ChainFollower (..), NetworkLayer (..) ) import Cardano.Wallet.Primitive.Slotting ( PastHorizonException (..) + , Qry , TimeInterpreter , epochOf , interpretQuery , neverFails + , timeOfEpoch , unsafeExtendSafeZone ) import Cardano.Wallet.Primitive.Types @@ -134,10 +139,10 @@ import Cardano.Wallet.Shelley.Network.Blockfrost.Error ( BlockfrostError (..) ) import Cardano.Wallet.Shelley.Network.Blockfrost.Monad ( BFM ) -import Cardano.Wallet.Shelley.Network.Discriminant - ( SomeNetworkDiscriminant (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) +import Control.DeepSeq + ( NFData ) import Control.Monad ( forM, forM_, forever, join, void, when, (>=>) ) import Control.Monad.Cont @@ -180,14 +185,14 @@ import Data.Maybe ( fromMaybe, mapMaybe ) import Data.Ord ( Down (..) ) -import Data.Proxy - ( Proxy (..) ) import Data.Quantity ( Percentage (..), Quantity (..) ) import Data.Set ( Set ) import Data.Text.Class ( ToText (..) ) +import Data.Time + ( UTCTime ) import Data.Time.Clock.POSIX ( getPOSIXTime, posixDayLength ) import Data.Traversable @@ -202,6 +207,10 @@ import Fmt ( fixedF, pretty ) import GHC.Generics ( Generic ) +import Network.HTTP.Client + ( Manager, defaultManagerSettings, newManager ) +import Numeric.Natural + ( Natural ) import Ouroboros.Consensus.Cardano.Block ( CardanoBlock, HardForkBlock (..) ) import System.Exit @@ -228,9 +237,9 @@ import UnliftIO.STM ) import qualified Blockfrost.Client as BF +import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Pool.DB as PoolDb import qualified Cardano.Pool.DB.Sqlite as Pool -import qualified Cardano.Wallet.Api.Types as Api import qualified Cardano.Wallet.Checkpoints.Policy as CP import qualified Cardano.Wallet.Primitive.Types.Coin as Coin import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Monad as BFM @@ -256,7 +265,7 @@ data StakePoolLayer = StakePoolLayer , listStakePools :: EpochNo -- Exclude all pools that retired in or before this epoch. -> Coin - -> IO [Api.ApiStakePool] + -> IO [StakePool] , forceMetadataGC :: IO () @@ -308,7 +317,7 @@ withStakePoolDbLayer poolDbTracer databaseDir poolDbDecorator netLayer = withBlockfrostStakePoolLayer :: Tracer IO StakePoolLog -> BF.Project - -> SomeNetworkDiscriminant + -> Ledger.Network -> ContT r IO StakePoolLayer withBlockfrostStakePoolLayer _tr project network = do bfConfig <- lift (BFM.newClientConfig project) @@ -322,31 +331,25 @@ withBlockfrostStakePoolLayer _tr project network = do , getGCMetadataStatus = pure NotApplicable } -_getPoolLifeCycleStatus - :: BF.ClientConfig - -> SomeNetworkDiscriminant - -> PoolId - -> IO PoolLifeCycleStatus -_getPoolLifeCycleStatus - cfg network@(SomeNetworkDiscriminant (Proxy :: Proxy nd)) poolId = - BFM.run cfg do - let bfPoolId = BF.PoolId (toText poolId) - poolUpdates <- BF.allPages \paged -> - BF.getPoolUpdates' bfPoolId paged BF.Descending - case poolUpdates of - [] -> pure PoolNotRegistered - lastUpdate : otherUpdates -> - case BF._poolUpdateAction lastUpdate of - BF.PoolRegistered -> - PoolRegistered <$> poolRegCert lastUpdate - BF.PoolDeregistered -> - case findRegCert otherUpdates of - Just regCertUpdate -> - PoolRegisteredAndRetired - <$> poolRegCert regCertUpdate - <*> poolDeregCert lastUpdate - Nothing -> throwError $ - PoolRegistrationIsMissing poolId +_getPoolLifeCycleStatus :: + BF.ClientConfig -> Ledger.Network -> PoolId -> IO PoolLifeCycleStatus +_getPoolLifeCycleStatus cfg network poolId = BFM.run cfg do + let bfPoolId = BF.PoolId (toText poolId) + poolUpdates <- BF.allPages \paged -> + BF.getPoolUpdates' bfPoolId paged BF.Descending + case poolUpdates of + [] -> pure PoolNotRegistered + lastUpdate : otherUpdates -> + case BF._poolUpdateAction lastUpdate of + BF.PoolRegistered -> PoolRegistered <$> poolRegCert lastUpdate + BF.PoolDeregistered -> + case findRegCert otherUpdates of + Just regCertUpdate -> + PoolRegisteredAndRetired + <$> poolRegCert regCertUpdate + <*> poolDeregCert lastUpdate + Nothing -> throwError $ + PoolRegistrationIsMissing poolId where findRegCert :: [BF.PoolUpdate] -> Maybe BF.PoolUpdate @@ -360,7 +363,8 @@ _getPoolLifeCycleStatus case find byIdx poolUpdates of Just BF.TransactionPoolUpdate{..} -> do poolOwners <- for _transactionPoolUpdateOwners do - (PoolOwner . unRewardAccount <$>) . fromBfStakeAddress network + (PoolOwner . unRewardAccount <$>) + . fromBfStakeAddress network poolMargin <- percentageFromDouble _transactionPoolUpdateMarginCost poolCost <- @@ -450,7 +454,7 @@ newStakePoolLayer gcStatus nl db@DBLayer{..} restartSyncThread = :: EpochNo -- Exclude all pools that retired in or before this epoch. -> Coin - -> IO [Api.ApiStakePool] + -> IO [StakePool] _listPools currentEpoch userStake = do rawLsqData <- stakeDistribution nl userStake dbData <- readPoolDbData db currentEpoch @@ -472,8 +476,8 @@ newStakePoolLayer gcStatus nl db@DBLayer{..} restartSyncThread = sortByReward :: RandomGen g => g - -> [Api.ApiStakePool] - -> [Api.ApiStakePool] + -> [StakePool] + -> [StakePool] sortByReward g0 = map stakePool . L.sortOn (Down . rewards) @@ -521,7 +525,7 @@ data PoolDbData = PoolDbData { registrationCert :: PoolRegistrationCertificate , retirementCert :: Maybe PoolRetirementCertificate , nProducedBlocks :: Quantity "block" Word64 - , metadata :: Maybe StakePoolMetadata + , poolDbMetadata :: Maybe StakePoolMetadata , delisted :: Bool } @@ -531,7 +535,7 @@ combineDbAndLsqData -> Int -- ^ nOpt; desired number of pools -> Map PoolId PoolLsqData -> Map PoolId PoolDbData - -> IO (Map PoolId Api.ApiStakePool) + -> IO (Map PoolId StakePool) combineDbAndLsqData ti nOpt lsqData = Map.mergeA lsqButNoDb dbButNoLsq bothPresent lsqData where @@ -545,14 +549,11 @@ combineDbAndLsqData ti nOpt lsqData = -- for all stake pool metric values so that the pool can still be -- included in the list of all known stake pools: -- - dbButNoLsq = traverseMissing $ \k db -> - mkApiPool k lsqDefault db - where - lsqDefault = PoolLsqData - { nonMyopicMemberRewards = freshmanMemberRewards - , relativeStake = minBound - , saturation = 0 - } + dbButNoLsq = traverseMissing $ \k -> mkApiPool k PoolLsqData + { nonMyopicMemberRewards = freshmanMemberRewards + , relativeStake = minBound + , saturation = 0 + } -- To give a chance to freshly registered pools that haven't been part of -- any leader schedule, we assign them the average reward of the top @k@ @@ -562,7 +563,7 @@ combineDbAndLsqData ti nOpt lsqData = $ average $ L.take nOpt $ L.sort - $ map (Down . unCoin . nonMyopicMemberRewards) + $ map (Down . unCoin . view #nonMyopicMemberRewards) $ Map.elems lsqData where average [] = 0 @@ -571,37 +572,26 @@ combineDbAndLsqData ti nOpt lsqData = double :: Integral a => a -> Double double = fromIntegral - mkApiPool - :: PoolId - -> PoolLsqData - -> PoolDbData - -> IO Api.ApiStakePool + mkApiPool :: PoolId -> PoolLsqData -> PoolDbData -> IO StakePool mkApiPool pid (PoolLsqData prew pstk psat) dbData = do let mRetirementEpoch = retirementEpoch <$> retirementCert dbData retirementEpochInfo <- traverse - (interpretQuery (unsafeExtendSafeZone ti) . toApiEpochInfo) + (interpretQuery (unsafeExtendSafeZone ti) . toEpochInfo) mRetirementEpoch - pure $ Api.ApiStakePool - { Api.id = ApiT pid - , Api.metrics = Api.ApiStakePoolMetrics - { Api.nonMyopicMemberRewards = Coin.toQuantity prew - , Api.relativeStake = Quantity pstk - , Api.saturation = psat - , Api.producedBlocks = - (fmap fromIntegral . nProducedBlocks) dbData + pure StakePool + { id = pid + , metrics = StakePoolMetrics + { nonMyopicMemberRewards = Coin.toQuantity prew + , relativeStake = Quantity pstk + , saturation = psat + , producedBlocks = (fmap fromIntegral . nProducedBlocks) dbData } - , Api.metadata = - ApiT <$> metadata dbData - , Api.cost = - Coin.toQuantity $ poolCost $ registrationCert dbData - , Api.pledge = - Coin.toQuantity $ poolPledge $ registrationCert dbData - , Api.margin = - Quantity $ poolMargin $ registrationCert dbData - , Api.retirement = - retirementEpochInfo - , Api.flags = - [ Api.Delisted | delisted dbData ] + , metadata = poolDbMetadata dbData + , cost = Coin.toQuantity $ poolCost $ registrationCert dbData + , pledge = Coin.toQuantity $ poolPledge $ registrationCert dbData + , margin = Quantity $ poolMargin $ registrationCert dbData + , retirement = retirementEpochInfo + , flags = [ Delisted | delisted dbData ] } -- | Combines all the LSQ data into a single map. @@ -611,9 +601,7 @@ combineDbAndLsqData ti nOpt lsqData = -- -- Calculating e.g. the nonMyopicMemberRewards ourselves through chain-following -- would be completely impractical. -combineLsqData - :: StakePoolsSummary - -> Map PoolId PoolLsqData +combineLsqData :: StakePoolsSummary -> Map PoolId PoolLsqData combineLsqData StakePoolsSummary{nOpt, rewards, stake} = Map.merge stakeButNoRewards rewardsButNoStake bothPresent stake rewards where @@ -918,8 +906,8 @@ monitorMetadata gcStatus tr sp db@DBLayer{..} = do maxRetries = 8 retryCheck RetryStatus{rsIterNumber} b - | rsIterNumber < maxRetries = pure - (b == Unavailable || b == Unreachable) + | rsIterNumber < maxRetries = + pure (b == Unavailable || b == Unreachable) | otherwise = pure False ms = (* 1_000_000) @@ -1032,6 +1020,60 @@ gcDelistedPools gcStatus tr DBLayer{..} fetchDelisted = forever $ do threadDelay sleepTime pure () +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +data StakePool = StakePool + { id :: !(PoolId) + , metrics :: !StakePoolMetrics + , metadata :: !(Maybe StakePoolMetadata) + , cost :: !(Quantity "lovelace" Natural) + , margin :: !(Quantity "percent" Percentage) + , pledge :: !(Quantity "lovelace" Natural) + , retirement :: !(Maybe EpochInfo) + , flags :: ![StakePoolFlag] + } + deriving (Eq, Generic, Show) + +data EpochInfo = EpochInfo + { epochNumber :: !EpochNo + , epochStartTime :: !UTCTime + } + deriving (Eq, Generic, Show) + deriving anyclass NFData + +toEpochInfo :: EpochNo -> Qry EpochInfo +toEpochInfo ep = EpochInfo ep . fst <$> timeOfEpoch ep + +data StakePoolFlag = Delisted + deriving stock (Eq, Generic, Show) + deriving anyclass NFData + +data StakePoolMetrics = StakePoolMetrics + { nonMyopicMemberRewards :: !(Quantity "lovelace" Natural) + , relativeStake :: !(Quantity "percent" Percentage) + , saturation :: !Double + , producedBlocks :: !(Quantity "block" Natural) + } + deriving (Eq, Generic, Show) + deriving anyclass NFData + +data PoolGarbageCollectionInfo = PoolGarbageCollectionInfo + { currentEpoch :: EpochNo + -- ^ The current epoch at the point in time the garbage collector + -- was invoked. + , latestRetirementEpoch :: EpochNo + -- ^ The latest retirement epoch for which garbage collection will be + -- performed. The garbage collector will remove all pools that have an + -- active retirement epoch equal to or earlier than this epoch. + } + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Logging +-------------------------------------------------------------------------------- + data StakePoolLog = MsgExitMonitoring AfterThreadLog | MsgChainMonitoring ChainFollowLog @@ -1046,17 +1088,6 @@ data StakePoolLog | MsgSMASHUnreachable deriving (Show, Eq) -data PoolGarbageCollectionInfo = PoolGarbageCollectionInfo - { currentEpoch :: EpochNo - -- ^ The current epoch at the point in time the garbage collector - -- was invoked. - , latestRetirementEpoch :: EpochNo - -- ^ The latest retirement epoch for which garbage collection will be - -- performed. The garbage collector will remove all pools that have an - -- active retirement epoch equal to or earlier than this epoch. - } - deriving (Eq, Show) - instance HasPrivacyAnnotation StakePoolLog instance HasSeverityAnnotation StakePoolLog where getSeverityAnnotation = \case diff --git a/lib/wallet/src/Cardano/Wallet/Unsafe.hs b/lib/wallet/src/Cardano/Wallet/Unsafe.hs index 786924258fe..448738e3b85 100644 --- a/lib/wallet/src/Cardano/Wallet/Unsafe.hs +++ b/lib/wallet/src/Cardano/Wallet/Unsafe.hs @@ -23,7 +23,6 @@ module Cardano.Wallet.Unsafe , unsafeFromHexText , unsafeFromBase64 , unsafeFromHexFile - , unsafeDecodeAddress , unsafeDecodeHex , unsafeFromText , unsafeRunExceptT @@ -59,10 +58,6 @@ import Cardano.Mnemonic , mkEntropy , mkMnemonic ) -import Cardano.Wallet.Api.Types - ( DecodeAddress (..) ) -import Cardano.Wallet.Primitive.Types.Address - ( Address ) import Cardano.Wallet.Util ( internalError ) import Control.Monad @@ -131,13 +126,6 @@ unsafeFromBase64 = unsafeRight . convertFromBase @ByteString @ByteString Base64 unsafeFromHexFile :: HasCallStack => FilePath -> IO ByteString unsafeFromHexFile = fmap (unsafeFromHex . B8.filter isHexDigit) . B8.readFile --- | Decode a bech32-encoded 'Text' into an 'Address', or fail. -unsafeDecodeAddress - :: forall n. (HasCallStack, DecodeAddress n) - => Text - -> Address -unsafeDecodeAddress = unsafeRight . decodeAddress @n - -- | Run a decoder on a hex-encoded 'ByteString', or fail. unsafeDecodeHex :: HasCallStack => Get a -> ByteString -> a unsafeDecodeHex get = runGet get . BL.fromStrict . unsafeFromHex diff --git a/lib/wallet/src/Network/Ntp.hs b/lib/wallet/src/Network/Ntp.hs index fe7f23679b0..35e2f99efcd 100644 --- a/lib/wallet/src/Network/Ntp.hs +++ b/lib/wallet/src/Network/Ntp.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TypeApplications #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -13,6 +18,9 @@ module Network.Ntp ( withWalletNtpClient , getNtpStatus + , NtpSyncingStatus (..) + , NtpStatusWithOffset (..) + , ForceCheck (..) -- * re-exports from ntp-client , NtpTrace (..) @@ -25,8 +33,8 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) -import Cardano.Wallet.Api.Types - ( ApiNetworkClock (..), ApiNtpStatus (..), NtpSyncingStatus (..) ) +import Control.DeepSeq + ( NFData ) import Control.Tracer ( Tracer ) import Data.Quantity @@ -35,6 +43,8 @@ import Data.Text ( Text ) import Data.Text.Class ( ToText (..) ) +import GHC.Generics + ( Generic ) import Network.NTP.Client ( IPVersion (..) , NtpClient (..) @@ -74,6 +84,28 @@ ntpSettings = NtpSettings , ntpPollDelay = 300_000_000 } +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +data NtpSyncingStatus + = NtpSyncingStatusUnavailable + | NtpSyncingStatusPending + | NtpSyncingStatusAvailable + deriving (Eq, Generic, Show) + deriving anyclass NFData + +data NtpStatusWithOffset = NtpStatusWithOffset + { status :: !NtpSyncingStatus + , offset :: !(Maybe (Quantity "microsecond" Integer)) + } + deriving (Eq, Generic, Show) + deriving anyclass NFData + +-------------------------------------------------------------------------------- +-- Printing and Logging +-------------------------------------------------------------------------------- + -- TODO: Move this upstream. prettyNtpStatus :: NtpStatus -> Text prettyNtpStatus = \case @@ -160,30 +192,26 @@ instance HasSeverityAnnotation NtpTrace where where ms = 1000 -getNtpStatus - :: NtpClient - -> Bool - -- ^ When 'True', will block and force a NTP check instead of using cached results - -> IO ApiNetworkClock -getNtpStatus client forceCheck = (ApiNetworkClock . toStatus) <$> - if forceCheck - -- Forces an NTP check / query on the central servers, use with care - then do - ntpQueryBlocking client +data ForceCheck = ForceBlockingRequest | CanUseCachedResults - else atomically $ do - -- Reads a cached NTP status from an STM.TVar so we don't get - -- blacklisted by the central NTP "authorities" for sending too many NTP - -- requests. - s <- ntpGetStatus client - checkSTM (s /= NtpSyncPending) - pure s +getNtpStatus :: NtpClient -> ForceCheck -> IO NtpStatusWithOffset +getNtpStatus client forceCheck = toStatus <$> case forceCheck of + ForceBlockingRequest -> + -- Forces an NTP check / query on the central servers, use with care + ntpQueryBlocking client + CanUseCachedResults -> atomically $ do + -- Reads a cached NTP status from an STM.TVar so we don't get + -- blacklisted by the central NTP "authorities" for sending + -- too many NTP requests. + s <- ntpGetStatus client + checkSTM (s /= NtpSyncPending) + pure s where toStatus = \case NtpSyncPending -> - ApiNtpStatus NtpSyncingStatusPending Nothing + NtpStatusWithOffset NtpSyncingStatusPending Nothing NtpSyncUnavailable -> - ApiNtpStatus NtpSyncingStatusUnavailable Nothing + NtpStatusWithOffset NtpSyncingStatusUnavailable Nothing NtpDrift ms -> - ApiNtpStatus NtpSyncingStatusAvailable - (Just $ Quantity (fromIntegral ms :: Integer)) + NtpStatusWithOffset NtpSyncingStatusAvailable + (Just $ Quantity (fromIntegral ms :: Integer)) diff --git a/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePool.json b/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePool.json new file mode 100644 index 00000000000..08ed66f507a --- /dev/null +++ b/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePool.json @@ -0,0 +1,51 @@ +{ + "samples": [ + { + "cost": { + "quantity": 139, + "unit": "lovelace" + }, + "flags": [ + "delisted", + "delisted", + "delisted", + "delisted" + ], + "id": "89ca57a9d227c823a9159683994c74a21629dde0a314a0f17b057a31", + "margin": { + "quantity": 82.38, + "unit": "percent" + }, + "metadata": { + "description": "􍄑1󾽦{sJ󷦏㷖ZnW&\u0005𩛓\u0007𨉁i\u0008h􇠍 #,􍟽;␄[4𧹁.4VLe𥓲D:oel.o𢷂밦Q𠷁󾟕YrḸ󲫟7&\u000e􋥦U′Q(0串\u000b\u0006􉮌𗍬D ZM\u0010)󳁊Vv=愳󽘉􇇬P𦷭\u001fmF𰨶􄪲F󾻟p`@\u00133:\u001b\u00080P_<\u001frX", + "homepage": "a𗹿\u0000i𨹜􏦄S\"𤳔􄄳鋩N&KM𠌘􃎄~ꮥ&\u000c> Z󷇛]\nL\u001e}\u0006\u0002'6M:a&W\u000e̞>$􂲇521wye@𫰷oq4J=\u0017鼆\nᖬ䄗􈻛\u0015{S.􊮋𨴛邞7\\!4𬁷𭇿𢬑罭5\u0010", + "name": "\u0004𮄅\u00084?T\n􎘜A\u001dU\ng&잔g􋋈", + "ticker": "􊏵<'}" + }, + "metrics": { + "non_myopic_member_rewards": { + "quantity": 146422802079, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 20290559, + "unit": "block" + }, + "relative_stake": { + "quantity": 25.25, + "unit": "percent" + }, + "saturation": 2.6742633858636 + }, + "pledge": { + "quantity": 223, + "unit": "lovelace" + }, + "retirement": { + "epoch_number": 5819, + "epoch_start_time": "1859-09-19T11:34:44Z" + } + } + ], + "seed": 124597234 +} \ No newline at end of file diff --git a/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePoolMetrics.json b/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePoolMetrics.json new file mode 100644 index 00000000000..60bf2df8ace --- /dev/null +++ b/lib/wallet/test/data/Cardano/Wallet/Api/ApiTStakePoolMetrics.json @@ -0,0 +1,20 @@ +{ + "samples": [ + { + "non_myopic_member_rewards": { + "quantity": 7469081169, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 22411142, + "unit": "block" + }, + "relative_stake": { + "quantity": 82.34, + "unit": "percent" + }, + "saturation": 3.409471194653939 + } + ], + "seed": 2104969769 +} \ No newline at end of file diff --git a/lib/wallet/test/integration/shelley-integration-test.hs b/lib/wallet/test/integration/shelley-integration-test.hs index 2c74254ca2c..edf03590ffa 100644 --- a/lib/wallet/test/integration/shelley-integration-test.hs +++ b/lib/wallet/test/integration/shelley-integration-test.hs @@ -41,6 +41,27 @@ import Cardano.Startup ) import Cardano.Wallet.Api.Types ( DecodeAddress (..), EncodeAddress (..) ) +import Cardano.Wallet.Launch + ( withSystemTempDir ) +import Cardano.Wallet.Launch.Cluster + ( ClusterLog + , Credential (..) + , FaucetFunds (..) + , RunningNode (..) + , clusterEraFromEnv + , clusterEraToString + , clusterToApiEra + , localClusterConfigFromEnv + , moveInstantaneousRewardsTo + , oneMillionAda + , sendFaucetAssetsTo + , testLogDirFromEnv + , testMinSeverityFromEnv + , walletListenFromEnv + , walletMinSeverityFromEnv + , withCluster + , withSMASH + ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer, stdoutTextTracer, trMessageText ) import Cardano.Wallet.Network.Ports @@ -62,27 +83,6 @@ import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Faucet ( initFaucet ) -import Cardano.Wallet.Shelley.Launch - ( withSystemTempDir ) -import Cardano.Wallet.Shelley.Launch.Cluster - ( ClusterLog - , Credential (..) - , FaucetFunds (..) - , RunningNode (..) - , clusterEraFromEnv - , clusterEraToString - , clusterToApiEra - , localClusterConfigFromEnv - , moveInstantaneousRewardsTo - , oneMillionAda - , sendFaucetAssetsTo - , testLogDirFromEnv - , testMinSeverityFromEnv - , walletListenFromEnv - , walletMinSeverityFromEnv - , withCluster - , withSMASH - ) import Cardano.Wallet.TokenMetadata.MockServer ( queryServerStatic, withMetadataServer ) import Control.Arrow diff --git a/lib/wallet/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/wallet/test/unit/Cardano/Wallet/Api/Malformed.hs index 9ef9f9294fb..5ae2cdd9599 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Api/Malformed.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Api/Malformed.hs @@ -56,7 +56,7 @@ import Cardano.Wallet.Api.Types , ApiBytesT (..) , ApiConstructTransactionData , ApiMaintenanceActionPostData - , ApiPoolId + , ApiPoolSpecifier , ApiPostAccountKeyData , ApiPostAccountKeyDataWithPurpose , ApiPostPolicyIdData @@ -172,13 +172,13 @@ instance Malformed (PathParam ApiTxId) where where msg = "Invalid tx hash: expecting a hex-encoded value that is 32 bytes in length." -instance Wellformed (PathParam ApiPoolId) where +instance Wellformed (PathParam ApiPoolSpecifier) where wellformed = PathParam <$> [ T.replicate 64 "0" , "pool1wqaz0q0zhtxlgn0ewssevn2mrtm30fgh2g7hr7z9rj5856457mm" ] -instance Malformed (PathParam ApiPoolId) where +instance Malformed (PathParam ApiPoolSpecifier) where malformed = first PathParam <$> [ (T.replicate 64 "ś", msg) , (T.replicate 63 "1", msg) diff --git a/lib/wallet/test/unit/Cardano/Wallet/Api/Server/TlsSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Api/Server/TlsSpec.hs index 8ba29bce4a0..86a840a5f5e 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Api/Server/TlsSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Api/Server/TlsSpec.hs @@ -8,7 +8,7 @@ module Cardano.Wallet.Api.Server.TlsSpec import Prelude -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( Listen (..), TlsConfiguration (..), withListeningSocket ) import Cardano.X509.Configuration ( CertDescription (..) @@ -85,7 +85,7 @@ import UnliftIO.Async import UnliftIO.Exception ( fromException ) -import qualified Cardano.Wallet.Api.Server as Server +import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Data.ByteString as BS import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai as Wai diff --git a/lib/wallet/test/unit/Cardano/Wallet/Api/ServerSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Api/ServerSpec.hs index 142a171a800..65c89f59cd4 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Api/ServerSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Api/ServerSpec.hs @@ -15,7 +15,7 @@ import Cardano.BM.Trace ( nullTracer ) import Cardano.Slotting.Slot ( EpochNo (..) ) -import Cardano.Wallet.Api.Server +import Cardano.Wallet.Api.Http.Shelley.Server ( IsServerError (..) , Listen (..) , ListenError (..) diff --git a/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 117f82a01a2..172cf7af1c3 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +14,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -56,6 +58,8 @@ import Cardano.Mnemonic , entropyToMnemonic , mkEntropy ) +import Cardano.Pool.Metadata + ( HealthCheckSMASH ) import Cardano.Wallet.Api ( Api ) import Cardano.Wallet.Api.Types @@ -95,7 +99,6 @@ import Cardano.Wallet.Api.Types , ApiDecodedTransaction (..) , ApiDelegationAction (..) , ApiDeregisterPool (..) - , ApiEpochInfo (..) , ApiEra (..) , ApiEraInfo (..) , ApiErrorCode (..) @@ -115,7 +118,6 @@ import Cardano.Wallet.Api.Types , ApiNetworkInfo (..) , ApiNetworkInformation (..) , ApiNetworkParameters (..) - , ApiNtpStatus (..) , ApiNullStakeKey , ApiOurStakeKey , ApiPaymentDestination (..) @@ -147,9 +149,6 @@ import Cardano.Wallet.Api.Types , ApiSlotReference (..) , ApiStakeKeyIndex (..) , ApiStakeKeys - , ApiStakePool (..) - , ApiStakePoolFlag (..) - , ApiStakePoolMetrics (..) , ApiT (..) , ApiTokenAmountFingerprint (..) , ApiTokens (..) @@ -189,11 +188,6 @@ import Cardano.Wallet.Api.Types , ByronWalletFromXPrvPostData (..) , ByronWalletPostData (..) , ByronWalletPutPassphraseData (..) - , DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - , HealthCheckSMASH (..) , Iso8601Time (..) , KeyFormat (..) , NtpSyncingStatus (..) @@ -209,6 +203,7 @@ import Cardano.Wallet.Api.Types , WalletPutPassphraseData (..) , WalletPutPassphraseMnemonicData (..) , WalletPutPassphraseOldPassphraseData (..) + , XPubOrSelf (..) , toApiAsset ) import Cardano.Wallet.Api.Types.BlockHeader @@ -217,13 +212,12 @@ import Cardano.Wallet.Api.Types.SchemaMetadata ( TxMetadataSchema (..), TxMetadataWithSchema (..) ) import Cardano.Wallet.Gen ( genMnemonic - , genNatural + , genMockXPub , genNestedTxMetadata , genPercentage , genScript , genScriptCosigners , genScriptTemplate - , genScriptTemplateEntry , shrinkPercentage , shrinkTxMetadata ) @@ -246,6 +240,8 @@ import Cardano.Wallet.Primitive.AddressDerivationSpec () import Cardano.Wallet.Primitive.AddressDiscovery.Sequential ( AddressPoolGap, getAddressPoolGap, purposeCIP1852 ) +import Cardano.Wallet.Primitive.AddressDiscovery.Shared + ( retrieveAllCosigners ) import Cardano.Wallet.Primitive.Passphrase.Types ( Passphrase (..) , PassphraseHash (PassphraseHash) @@ -332,6 +328,18 @@ import Cardano.Wallet.Primitive.Types.UTxO , computeUtxoStatistics , log10 ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..) + , DecodeStakeAddress (..) + , EncodeAddress (..) + , EncodeStakeAddress (..) + ) +import Cardano.Wallet.Shelley.Pools + ( EpochInfo (..) + , StakePool (StakePool) + , StakePoolFlag + , StakePoolMetrics (StakePoolMetrics) + ) import Cardano.Wallet.TokenMetadata ( TokenMetadataError (..) ) import Cardano.Wallet.Transaction @@ -359,12 +367,14 @@ import Data.Aeson , (.:?) , (.=) ) +import Data.Aeson.KeyMap + ( keys ) import Data.Aeson.QQ ( aesonQQ ) +import Data.Bifunctor + ( Bifunctor (..) ) import Data.ByteString ( ByteString ) -import Data.Char - ( toLower ) import Data.Data ( dataTypeConstrs, dataTypeOf, showConstr ) import Data.Either @@ -374,7 +384,7 @@ import Data.FileEmbed import Data.Function ( (&) ) import Data.List - ( foldl' ) + ( foldl', intercalate ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe @@ -393,8 +403,6 @@ import Data.Text.Class ( FromText (..), TextDecodingError (..) ) import Data.Time.Clock ( NominalDiffTime ) -import Data.Time.Clock.POSIX - ( utcTimeToPOSIXSeconds ) import Data.Typeable ( Typeable ) import Data.Word @@ -403,6 +411,8 @@ import Data.Word.Odd ( Word31 ) import GHC.TypeLits ( KnownSymbol, natVal, symbolVal ) +import Network.Ntp + ( NtpStatusWithOffset (..) ) import Network.URI ( URI, parseURI ) import Numeric.Natural @@ -463,6 +473,8 @@ import Test.QuickCheck.Arbitrary.Generic ( genericArbitrary, genericShrink ) import Test.QuickCheck.Extra ( reasonablySized ) +import Test.QuickCheck.Gen + ( sublistOf ) import Test.QuickCheck.Modifiers ( NonNegative (..) ) import Test.Text.Roundtrip @@ -487,6 +499,7 @@ import qualified Data.Aeson.Types as Aeson import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 +import qualified Data.Char as Char import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text as T @@ -566,7 +579,6 @@ spec = parallel $ do jsonTest @ApiByronWalletBalance jsonTest @ApiCredential jsonTest @ApiDelegationAction - jsonTest @ApiEpochInfo jsonTest @ApiEra jsonTest @ApiEraInfo jsonTest @ApiFee @@ -594,9 +606,8 @@ spec = parallel $ do jsonTest @ApiSharedWalletPostDataFromMnemonics jsonTest @ApiSignTransactionPostData jsonTest @ApiSlotReference - jsonTest @ApiStakePool - jsonTest @ApiStakePoolMetrics - jsonTest @ApiStakePoolMetrics + jsonTest @(ApiT StakePool) + jsonTest @(ApiT StakePoolMetrics) jsonTest @ApiTokenAmountFingerprint jsonTest @ApiTokens jsonTest @ApiTxId @@ -635,7 +646,8 @@ spec = parallel $ do describe "SealedTx JSON decoding" $ do -- NOTE(AB): I tried to factor more of the properties as their structure only -- differs by the encoding but this required exporting 'HasBase' from Types to - let parseJSONSealedTx jsonTx = (serialisedTx . getApiT <$> Aeson.eitherDecode @(ApiT SealedTx) jsonTx) + let parseJSONSealedTx jsonTx = + (serialisedTx . getApiT <$> Aeson.eitherDecode @(ApiT SealedTx) jsonTx) it "can decode from base-16 encoded string" $ forAll selectFromPreparedBinaries $ \ bs -> @@ -659,32 +671,49 @@ spec = parallel $ do === Left (TextDecodingError err) describe "HttpApiData roundtrip" $ do - httpApiDataRoundtrip $ Proxy @(ApiT WalletId) - httpApiDataRoundtrip $ Proxy @(ApiT AddressState) - httpApiDataRoundtrip $ Proxy @Iso8601Time - httpApiDataRoundtrip $ Proxy @(ApiT SortOrder) + httpApiDataRoundtrip $ Proxy @(ApiT PoolId) + httpApiDataRoundtrip $ Proxy @(ApiT WalletId) + httpApiDataRoundtrip $ Proxy @(ApiT AddressState) + httpApiDataRoundtrip $ Proxy @Iso8601Time + httpApiDataRoundtrip $ Proxy @(ApiT SortOrder) describe "verify that every type used with JSON content type in a servant API \ - \has compatible ToJSON and ToSchema instances using validateToJSON." $ do + \has compatible ToJSON and ToSchema instances using a matcher" $ do let match regex sourc = matchTest (makeRegexOpts compBlank execBlank $ T.unpack regex) (T.unpack sourc) - validateEveryToJSONWithPatternChecker - match - (Proxy :: Proxy (Api ('Testnet 0) ApiStakePool)) - -- NOTE See (ToSchema WalletOrAccountPostData) - validateEveryToJSON - (Proxy :: Proxy ( + validateEveryToJSONWithPatternChecker match (Proxy @(Api ('Testnet 0))) + + describe + "Verify that every type used with JSON content type in a servant API \ + \has compatible ToJSON and ToSchema instances using validateEveryToJSON" $ + validateEveryToJSON $ + Proxy @( ReqBody '[JSON] AccountPostData :> PostNoContent :<|> ReqBody '[JSON] WalletPostData :> PostNoContent - )) + ) describe "verify that every path specified by the servant server matches an \ \existing path in the specification" $ - validateEveryPath (Proxy :: Proxy (Api ('Testnet 0) ApiStakePool)) + forM_ (everyApiEndpoint (Proxy @(Api ('Testnet 0)))) $ \endpoint -> + it (show endpoint <> " exists in specification") $ do + let path = T.pack (apiEndpointPath endpoint) + verb = apiEndpointVerb endpoint + case foldl' unsafeLookupKey specification ["paths", path] of + Aeson.Object obj -> do + let key = Aeson.fromString (Char.toLower <$> verb) + case Aeson.lookup key obj of + Just{} -> pure @IO () + Nothing -> + fail $ "Path " <> show path + <> " doesn't allow method " <> show verb + _ -> fail $ + "couldn't find path " <> show path <> " in specification: " + <> show (unsafeLookupKey specification "paths" & + \(Aeson.Object m) -> keys m) describe "verify JSON parsing failures too" $ do @@ -940,19 +969,17 @@ instance FromJSON SchemaApiErrorCode where Address Encoding -------------------------------------------------------------------------------} --- Dummy instances -instance EncodeAddress ('Testnet 0) where +instance {-# OVERLAPPING #-} EncodeAddress ('Testnet 0) where encodeAddress = const "" -instance DecodeAddress ('Testnet 0) where +instance {-# OVERLAPPING #-} DecodeAddress ('Testnet 0) where decodeAddress "" = Right $ Address "" decodeAddress _ = Left $ TextDecodingError "invalid address" --- Dummy instances -instance EncodeStakeAddress ('Testnet 0) where +instance {-# OVERLAPPING #-} EncodeStakeAddress ('Testnet 0) where encodeStakeAddress = const "" -instance DecodeStakeAddress ('Testnet 0) where +instance {-# OVERLAPPING #-} DecodeStakeAddress ('Testnet 0) where decodeStakeAddress "" = Right $ RewardAccount "" decodeStakeAddress _ = Left $ TextDecodingError "invalid stake address" @@ -960,10 +987,6 @@ instance DecodeStakeAddress ('Testnet 0) where Arbitrary Instances -------------------------------------------------------------------------------} -instance Arbitrary (Proxy (n :: NetworkDiscriminant)) where - shrink _ = [] - arbitrary = pure (Proxy @n) - instance Arbitrary (ApiAddress n) where shrink _ = [] arbitrary = ApiAddress @@ -971,8 +994,8 @@ instance Arbitrary (ApiAddress n) where <*> arbitrary <*> arbitrary -instance Arbitrary ApiEpochInfo where - arbitrary = ApiEpochInfo <$> arbitrary <*> genUniformTime +instance Arbitrary EpochInfo where + arbitrary = EpochInfo <$> arbitrary <*> genUniformTime shrink _ = [] instance Arbitrary (Script KeyHash) where @@ -1053,7 +1076,17 @@ instance Arbitrary ApiSharedWallet where , ApiSharedWallet . Left <$> arbitrary ] instance Arbitrary ApiScriptTemplateEntry where - arbitrary = genScriptTemplateEntry + arbitrary = do + script <- + genScriptCosigners `suchThat` (not . null . retrieveAllCosigners) + let scriptCosigners = retrieveAllCosigners script + cosignersSubset <- sublistOf scriptCosigners `suchThat` (not . null) + xpubsOrSelf <- vectorOf (length cosignersSubset) genXPubOrSelf + pure $ ApiScriptTemplateEntry + (Map.fromList $ zip cosignersSubset xpubsOrSelf) script + where + genXPubOrSelf :: Gen XPubOrSelf + genXPubOrSelf = oneof [SomeAccountKey <$> genMockXPub, pure Self] instance Arbitrary ApiSharedWalletPostDataFromMnemonics where arbitrary = genericArbitrary @@ -1220,9 +1253,6 @@ instance Arbitrary ApiTxId where instance Arbitrary AddressPoolGap where arbitrary = arbitraryBoundedEnum -instance Arbitrary NominalDiffTime where - arbitrary = fmap utcTimeToPOSIXSeconds genUniformTime - instance Arbitrary Iso8601Time where arbitrary = Iso8601Time <$> genUniformTime @@ -1372,8 +1402,8 @@ instance Arbitrary PoolId where InfiniteList bytes _ <- arbitrary return $ PoolId $ BS.pack $ take 28 bytes -instance Arbitrary ApiStakePool where - arbitrary = ApiStakePool +instance Arbitrary StakePool where + arbitrary = StakePool <$> arbitrary <*> arbitrary <*> arbitrary @@ -1383,17 +1413,17 @@ instance Arbitrary ApiStakePool where <*> arbitrary <*> arbitrary -instance Arbitrary ApiStakePoolMetrics where - arbitrary = ApiStakePoolMetrics +instance Arbitrary StakePoolFlag where + shrink = genericShrink + arbitrary = genericArbitrary + +instance Arbitrary StakePoolMetrics where + arbitrary = StakePoolMetrics <$> (Quantity . fromIntegral <$> choose (1::Integer, 1_000_000_000_000)) <*> arbitrary <*> (choose (0.0, 5.0)) <*> (Quantity . fromIntegral <$> choose (1::Integer, 22_600_000)) -instance Arbitrary ApiStakePoolFlag where - shrink = genericShrink - arbitrary = genericArbitrary - instance Arbitrary StakePoolMetadata where arbitrary = StakePoolMetadata <$> arbitrary @@ -1453,10 +1483,6 @@ instance Arbitrary a => Arbitrary (ApiT a) where arbitrary = ApiT <$> arbitrary shrink = fmap ApiT . shrink . getApiT -instance Arbitrary a => Arbitrary (NonEmpty a) where - arbitrary = genericArbitrary - shrink = genericShrink - -- | The initial seed has to be vector or length multiple of 4 bytes and shorter -- than 64 bytes. Note that this is good for testing or examples, but probably -- not for generating truly random Mnemonic words. @@ -1546,13 +1572,13 @@ instance Arbitrary ApiNetworkInformation where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary ApiNtpStatus where +instance Arbitrary NtpStatusWithOffset where arbitrary = do - o <- Quantity <$> (arbitrary @Integer) + o <- Quantity <$> arbitrary @Integer elements - [ ApiNtpStatus NtpSyncingStatusUnavailable Nothing - , ApiNtpStatus NtpSyncingStatusPending Nothing - , ApiNtpStatus NtpSyncingStatusAvailable (Just o) + [ NtpStatusWithOffset NtpSyncingStatusUnavailable Nothing + , NtpStatusWithOffset NtpSyncingStatusPending Nothing + , NtpStatusWithOffset NtpSyncingStatusAvailable (Just o) ] instance Arbitrary ApiNetworkClock where @@ -2317,10 +2343,6 @@ instance Arbitrary ApiAccountKeyShared where oneof [ pure $ ApiAccountKeyShared pubKey NonExtended purposeCIP1854 , pure $ ApiAccountKeyShared xpubKey Extended purposeCIP1854 ] -instance Arbitrary Natural where - shrink = shrinkIntegral - arbitrary = genNatural - instance Arbitrary (Proxy n) => Arbitrary (ApiStakeKeys n) where arbitrary = Test.QuickCheck.scale (`div` 4) genericArbitrary shrink = genericShrink @@ -2369,7 +2391,7 @@ instance Arbitrary ApiBlockHeader where 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 + we've also built another check 'extractEndpoints' 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: @@ -2453,11 +2475,11 @@ instance ToSchema ApiWalletUtxoSnapshot where declareNamedSchema _ = declareSchemaForDefinition "ApiWalletUtxoSnapshot" -instance ToSchema ApiStakePool where +instance ToSchema (ApiT StakePool) where declareNamedSchema _ = declareSchemaForDefinition "ApiStakePool" -instance ToSchema ApiStakePoolMetrics where - declareNamedSchema _ = declareSchemaForDefinition "ApiStakePoolMetrics" +instance ToSchema (ApiT StakePoolMetrics) where + declareNamedSchema _ = declareSchemaForDefinition "StakePoolMetrics" instance ToSchema ApiFee where declareNamedSchema _ = declareSchemaForDefinition "ApiFee" @@ -2757,60 +2779,75 @@ unsafeLookupKey json k = case json of bombMissing = error $ "no value found in map for key: " <> T.unpack k +data ApiEndpoint = ApiEndpoint + { apiEndpointVerb :: String + , apiEndpointPath :: String + } + +instance Show ApiEndpoint where + show (ApiEndpoint verb path) = verb <> " " <> path + +everyApiEndpoint :: ExtractEndpoints api => Proxy api -> [ApiEndpoint] +everyApiEndpoint p = extractEndpoints p [] + -- | 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 - let verbStr = toLower <$> show verb - it (verbStr <> " " <> path <> " exists in specification") $ do - case foldl' unsafeLookupKey specification ["paths", T.pack path] of - Aeson.Object m -> - case Aeson.lookup (Aeson.fromString verbStr) m of - Just{} -> return @IO () - Nothing -> fail "couldn't find path in specification" - _ -> fail "couldn't find path in specification" - -instance (ValidateEveryPath a, ValidateEveryPath b) => ValidateEveryPath (a :<|> b) where - validateEveryPath _ = do - validateEveryPath (Proxy @a) - validateEveryPath (Proxy @b) +class ExtractEndpoints api where + extractEndpoints :: Proxy api -> [String] -> [ApiEndpoint] + +instance {-# OVERLAPPING #-} (ExtractEndpoints sub, KnownSymbol path) => + ExtractEndpoints (path :> sub) where + extractEndpoints _ prefixes = do + let prefixes' = symbolVal (Proxy @path) : prefixes + extractEndpoints (Proxy @sub) prefixes' + +instance {-# OVERLAPPING #-} (ExtractEndpoints left, ExtractEndpoints right) => + ExtractEndpoints (left :<|> right) where + extractEndpoints _ paths = + extractEndpoints (Proxy @left) paths + <> extractEndpoints (Proxy @right) paths + +instance {-# OVERLAPPABLE #-} GetPath a => ExtractEndpoints a where + extractEndpoints proxy prefixes = do + let (verb, subPath) = first show (getPath proxy) + path = "/" <> intercalate "/" (reverse prefixes) <> subPath + [ApiEndpoint verb path] -- | Extract the path of a given endpoint, in a format that is swagger-friendly -class HasPath api where +class GetPath api where getPath :: Proxy api -> (StdMethod, String) -instance (Method m) => HasPath (Verb m s ct a) where +instance (Method m) => GetPath (Verb m s ct a) where getPath _ = (method (Proxy @m), "") -instance (Method m) => HasPath (NoContentVerb m) where +instance (Method m) => GetPath (NoContentVerb m) where getPath _ = (method (Proxy @m), "") -instance (KnownSymbol path, HasPath sub) => HasPath (path :> sub) where +instance (KnownSymbol path, GetPath sub) => GetPath (path :> sub) where getPath _ = - let (verb, sub) = getPath (Proxy @sub) - in (verb, "/" <> symbolVal (Proxy :: Proxy path) <> sub) + getPath (Proxy @sub) & \(verb, sub) -> + (verb, "/" <> symbolVal (Proxy @path) <> sub) -instance (KnownSymbol param, HasPath sub) => HasPath (Capture param t :> sub) +instance (KnownSymbol param, GetPath sub) => GetPath (Capture param t :> sub) where getPath _ = - let (verb, sub) = getPath (Proxy @sub) - in case symbolVal (Proxy :: Proxy param) of - sym | sym == "*" -> (verb, "/" <> sym <> sub) - sym -> (verb, "/{" <> sym <> "}" <> sub) - -instance HasPath sub => HasPath (ReqBody a b :> sub) where + case symbolVal (Proxy :: Proxy param) of + sym | sym == "*" -> + getPath (Proxy @sub) & \(verb, sub) -> + (verb, "/" <> sym <> sub) + sym -> + getPath (Proxy @sub) & \(verb, sub) -> + (verb, "/{" <> sym <> "}" <> sub) + +instance GetPath sub => GetPath (ReqBody a b :> sub) where getPath _ = getPath (Proxy @sub) -instance HasPath sub => HasPath (QueryParam a b :> sub) where +instance GetPath sub => GetPath (QueryParam a b :> sub) where getPath _ = getPath (Proxy @sub) -instance HasPath sub => HasPath (QueryFlag sym :> sub) where +instance GetPath sub => GetPath (QueryFlag sym :> sub) where getPath _ = getPath (Proxy @sub) -instance HasPath sub => HasPath (Header' opts name ty :> sub) where +instance GetPath sub => GetPath (Header' opts name ty :> sub) where getPath _ = getPath (Proxy @sub) -- A way to demote 'StdMethod' back to the world of values. Servant provides a diff --git a/lib/wallet/test/unit/Cardano/Wallet/ApiSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/ApiSpec.hs index 8f60b583aa8..bbefd9daf8d 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/ApiSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/ApiSpec.hs @@ -27,8 +27,7 @@ -- mount an existing request body in a request. {-# OPTIONS_GHC -fno-warn-deprecations #-} --- See comment in Cardano.Wallet.Shelley.Compatibility -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Wallet.ApiSpec ( spec @@ -38,6 +37,8 @@ import Prelude import Cardano.Wallet.Api ( Api ) +import Cardano.Wallet.Api.Http.Shelley.Server + ( IsServerError (..) ) import Cardano.Wallet.Api.Malformed ( BodyParam (..) , ExpectedError (..) @@ -48,21 +49,18 @@ import Cardano.Wallet.Api.Malformed , malformed , wellformed ) -import Cardano.Wallet.Api.Server - ( IsServerError (..) ) -import Cardano.Wallet.Api.Types - ( ApiStakePool - , DecodeAddress (..) - , DecodeStakeAddress (..) - , EncodeAddress (..) - , EncodeStakeAddress (..) - ) import Cardano.Wallet.Primitive.AddressDerivation ( NetworkDiscriminant (..) ) import Cardano.Wallet.Primitive.Types.Address ( Address (..) ) import Cardano.Wallet.Primitive.Types.RewardAccount ( RewardAccount (..) ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( DecodeAddress (..) + , DecodeStakeAddress (..) + , EncodeAddress (..) + , EncodeStakeAddress (..) + ) import Control.Monad ( forM_ ) import Data.Aeson.QQ @@ -74,7 +72,7 @@ import Data.Function import Data.IORef ( atomicModifyIORef, newIORef ) import Data.List - ( (\\) ) + ( delete, (\\) ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -98,7 +96,7 @@ import Network.HTTP.Media.RenderHeader import Network.HTTP.Types.Header ( hAccept, hContentType ) import Network.HTTP.Types.Method - ( Method ) + ( Method, methodHead, renderStdMethod ) import Network.Wai ( Request , RequestBodyLength (..) @@ -141,6 +139,18 @@ import qualified Data.Text as T import qualified Servant +instance {-# OVERLAPPING #-} EncodeAddress ('Testnet 0) where + encodeAddress = T.pack . show + +instance {-# OVERLAPPING #-} DecodeAddress ('Testnet 0) where + decodeAddress _ = pure (Address "") + +instance {-# OVERLAPPING #-} EncodeStakeAddress ('Testnet 0) where + encodeStakeAddress = T.pack . show + +instance {-# OVERLAPPING #-} DecodeStakeAddress ('Testnet 0) where + decodeStakeAddress _ = pure (RewardAccount "") + spec :: Spec spec = parallel $ do gSpec (everyPathParam api) $ \(SomeTest proxy tests) -> @@ -183,10 +193,8 @@ assertErrorResponse assertErrorResponse status code (ExpectedError msg) response = do response & assertStatus status response & assertHeader "Content-Type" "application/json;charset=utf-8" - response & assertBody (Aeson.encode [aesonQQ| - { "code": #{code} - , "message": #{msg} - }|]) + response & assertBody + (Aeson.encode [aesonQQ|{ "code": #{code}, "message": #{msg} }|]) spec_MalformedParam :: Request -> ExpectedError -> Session () spec_MalformedParam malformedRequest expectedError = do @@ -322,8 +330,8 @@ instance GenericApiSpec (Map [Text] [Method]) gSpec allowedMethods toSpec = do toSpec $ SomeTest (Proxy @Void) $ mconcat $ for (Map.toList allowedMethods) $ \(pathInfo, methods) -> - forMaybe (allMethods \\ methods) $ \requestMethod -> - if isWhiteListed pathInfo requestMethod + forMaybe (allMethodsButHead \\ methods) $ \requestMethod -> + if shouldSkipRequest requestMethod pathInfo then Nothing else Just (defaultRequest { pathInfo, requestMethod }, msg) where @@ -335,15 +343,14 @@ instance GenericApiSpec (Map [Text] [Method]) \the method: one of them is likely to be incorrect (for example: \ \POST instead of PUT, or GET instead of POST...)." - allMethods :: [Method] - allMethods = - ["GET","PUT","POST","PATCH","DELETE","CONNECT","TRACE","OPTIONS"] + allMethodsButHead :: [Method] + allMethodsButHead = + delete methodHead (renderStdMethod <$> [minBound .. maxBound]) - isWhiteListed :: [Text] -> Method -> Bool - isWhiteListed - [ "stake-pools", "*", "wallets", _ ] "PUT" = True - isWhiteListed - _ _ = False + shouldSkipRequest :: Method -> [Text] -> Bool + shouldSkipRequest method = \case + [ "stake-pools", "*", "wallets", _ ] -> method /= "DELETE" + _ -> False -- @@ -354,30 +361,16 @@ application :: Application application = serve api server & handleRawError (curry toServerError) -api :: Proxy (Api ('Testnet 0) ApiStakePool) +api :: Proxy (Api ('Testnet 0)) api = Proxy -server :: Server (Api ('Testnet 0) ApiStakePool) +server :: Server (Api ('Testnet 0)) server = error "No test from this module should actually reach handlers of the server. \ \Tests are indeed all testing the internal machinery of Servant + Wai and \ \the way they interact with the outside world. Only valid requests are \ \delegated to our handlers." --- Dummy instances -instance EncodeAddress ('Testnet 0) where - encodeAddress = T.pack . show - -instance DecodeAddress ('Testnet 0) where - decodeAddress _ = pure (Address "") - --- Dummy instances -instance EncodeStakeAddress ('Testnet 0) where - encodeStakeAddress = T.pack . show - -instance DecodeStakeAddress ('Testnet 0) where - decodeStakeAddress _ = pure (RewardAccount "") - everyPathParam :: GEveryEndpoints api => Proxy api -> MkPathRequest api everyPathParam proxy = gEveryPathParam proxy defaultRequest diff --git a/lib/wallet/test/unit/Cardano/Wallet/Shelley/Launch/BlockfrostSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Shelley/Launch/BlockfrostSpec.hs index be532fe1011..4ba4f9ca1aa 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Shelley/Launch/BlockfrostSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Shelley/Launch/BlockfrostSpec.hs @@ -10,9 +10,9 @@ import qualified Data.Text as T import Blockfrost.Env ( Env (Testnet) ) -import Cardano.Wallet.Shelley.Launch +import Cardano.Wallet.Launch ( Mode (Light, Normal), modeOption ) -import Cardano.Wallet.Shelley.Launch.Blockfrost +import Cardano.Wallet.Launch.Blockfrost ( TokenException (..), TokenFile (TokenFile), readToken ) -- See ADP-1910 import "optparse-applicative" Options.Applicative diff --git a/lib/wallet/test/unit/Cardano/Wallet/Shelley/LaunchSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Shelley/LaunchSpec.hs index 490cdb003d2..c7a347c06ac 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Shelley/LaunchSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Shelley/LaunchSpec.hs @@ -8,7 +8,7 @@ module Cardano.Wallet.Shelley.LaunchSpec (spec) where import Prelude -import Cardano.Wallet.Shelley.Launch +import Cardano.Wallet.Launch ( nodeSocketOption ) -- See ADP-1910 import "optparse-applicative" Options.Applicative diff --git a/lib/wallet/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs index aaa67b73c4e..9690fda3052 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs @@ -12,15 +12,9 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Trace ( nullTracer, traceInTVarIO ) -import Cardano.Wallet.Network - ( NetworkLayer (..) ) -import Cardano.Wallet.Primitive.SyncProgress - ( SyncTolerance (..) ) -import Cardano.Wallet.Primitive.Types - ( NetworkParameters (..) ) -import Cardano.Wallet.Shelley.Launch +import Cardano.Wallet.Launch ( CardanoNodeConn, withSystemTempDir ) -import Cardano.Wallet.Shelley.Launch.Cluster +import Cardano.Wallet.Launch.Cluster ( ClusterEra (..) , ClusterLog (..) , LocalClusterConfig (..) @@ -29,6 +23,12 @@ import Cardano.Wallet.Shelley.Launch.Cluster , defaultPoolConfigs , withCluster ) +import Cardano.Wallet.Network + ( NetworkLayer (..) ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncTolerance (..) ) +import Cardano.Wallet.Primitive.Types + ( NetworkParameters (..) ) import Cardano.Wallet.Shelley.Network.Node ( Observer (..), ObserverLog (..), newObserver, withNetworkLayer ) import Control.Monad diff --git a/nix/project-package-list.nix b/nix/project-package-list.nix index 3a6d0b9f649..ae33d858858 100644 --- a/nix/project-package-list.nix +++ b/nix/project-package-list.nix @@ -1 +1 @@ -[ "cardano-numeric" "cardano-wallet" "cardano-wallet-launcher" "cardano-wallet-test-utils" "dbvar" "strict-non-empty-containers" "text-class" ] +[ "cardano-numeric" "cardano-wallet" "cardano-wallet-launcher" "cardano-wallet-test-utils" "dbvar" "strict-non-empty-containers" "text-class" "wai-middleware-logging" ]