From fd0c67880dadc64c2a819df9ba50c1e323f7cf2b Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 26 Feb 2025 14:10:38 +0000 Subject: [PATCH 1/4] Remove cardano-deposit-wallet exe code --- flake.nix | 9 - .../cardano-deposit-wallet.cabal | 2 +- lib/exe/app/deposit/cardano-deposit-wallet.hs | 370 ------------------ lib/exe/cardano-wallet-exe.cabal | 47 --- .../Cardano/Wallet/Deposit/Application.hs | 300 -------------- nix/haskell.nix | 1 - 6 files changed, 1 insertion(+), 728 deletions(-) delete mode 100644 lib/exe/app/deposit/cardano-deposit-wallet.hs delete mode 100644 lib/exe/deposit/Cardano/Wallet/Deposit/Application.hs diff --git a/flake.nix b/flake.nix index 8ddbafdef0c..53f30c3a186 100644 --- a/flake.nix +++ b/flake.nix @@ -210,10 +210,6 @@ exe = project.hsPkgs.cardano-wallet-exe.components.exes.cardano-wallet; backend = self.cardano-node; }; - cardano-deposit-wallet = import ./nix/release-build.nix { - inherit pkgs; - exe = project.hsPkgs.cardano-wallet-exe.components.exes.cardano-deposit-wallet; - }; # Local test cluster and mock metadata server inherit (project.hsPkgs.cardano-wallet.components.exes) mock-token-metadata-server; inherit (project.hsPkgs.cardano-wallet-benchmarks.components.exes) benchmark-history; @@ -295,7 +291,6 @@ linuxPackages = mkPackages project.projectCross.musl64; linuxReleaseExes = [ linuxPackages.cardano-wallet - linuxPackages.cardano-deposit-wallet linuxPackages.bech32 linuxPackages.cardano-address cardano-node-runtime.hydraJobs.x86_64-linux.musl.cardano-cli @@ -304,7 +299,6 @@ # Which exes should be put in the release archives. checkReleaseContents = jobs: map (exe: jobs.${exe}) [ "cardano-wallet" - "cardano-deposit-wallet" "bech32" "cardano-address" "cardano-cli" @@ -335,7 +329,6 @@ walletLib = lib; exes = [ windowsPackages.cardano-wallet - windowsPackages.cardano-deposit-wallet windowsPackages.bech32 windowsPackages.cardano-address windowsPackages.cardano-cli @@ -363,7 +356,6 @@ walletLib = lib; exes = let macOsPkgs = mkPackages project; in [ macOsPkgs.cardano-wallet - macOsPkgs.cardano-deposit-wallet macOsPkgs.bech32 macOsPkgs.cardano-address nodePackages.cardano-cli @@ -379,7 +371,6 @@ walletLib = lib; exes = let macOsPkgs = mkPackages project; in [ macOsPkgs.cardano-wallet - macOsPkgs.cardano-deposit-wallet macOsPkgs.bech32 macOsPkgs.cardano-address nodePackages.cardano-cli diff --git a/lib/deposit-wallet/cardano-deposit-wallet.cabal b/lib/deposit-wallet/cardano-deposit-wallet.cabal index 7ca8e69b2e7..8d4bea54d21 100644 --- a/lib/deposit-wallet/cardano-deposit-wallet.cabal +++ b/lib/deposit-wallet/cardano-deposit-wallet.cabal @@ -262,7 +262,7 @@ test-suite unit Paths_cardano_deposit_wallet Spec -executable cardano-deposit-wallet-run +executable cardano-deposit-wallet import: language, opts-exe hs-source-dirs: exe build-depends: base diff --git a/lib/exe/app/deposit/cardano-deposit-wallet.hs b/lib/exe/app/deposit/cardano-deposit-wallet.hs deleted file mode 100644 index b38f4b4f82e..00000000000 --- a/lib/exe/app/deposit/cardano-deposit-wallet.hs +++ /dev/null @@ -1,370 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PackageImports #-} - -module Main where - -import Prelude - -import Cardano.BM.Data.Severity - ( Severity (..) - ) -import Cardano.BM.Extra - ( trMessage - , transformTextTrace - ) -import Cardano.BM.Plugin - ( loadPlugin - ) -import Cardano.BM.Trace - ( Trace - , appendName - , logDebug - , logError - , logInfo - , logNotice - ) -import Cardano.Launcher.Node - ( CardanoNodeConn - ) -import Cardano.Startup - ( ShutdownHandlerLog - , installSignalHandlers - , withShutdownHandler - ) -import Cardano.Wallet.Application.CLI - ( LogOutput (..) - , LoggingOptions - , Mode (..) - , cli - , cmdVersion - , databaseOption - , depositByronGenesisFileOption - , ekgEnabled - , enableWindowsANSI - , helperTracing - , hostPreferenceOption - , listenDepositOption - , listenDepositUiOption - , loggingMinSeverity - , loggingOptions - , loggingSeverityOrOffReader - , loggingTracers - , modeOption - , runCli - , setupDirectory - , shutdownHandlerFlag - , tlsOption - , withLogging - ) -import Cardano.Wallet.Application.Server - ( HostPreference - , Listen - ) -import Cardano.Wallet.Application.Tls - ( TlsConfiguration - ) -import Cardano.Wallet.Application.Tracers as Tracers - ( TracerSeverities - , Tracers - , Tracers' (..) - , setupTracers - , tracerDescriptions - , tracerLabels - ) -import Cardano.Wallet.Application.Version - ( GitRevision - , Version - , showFullVersion - ) -import Cardano.Wallet.CLI - ( networkConfigurationOption - , nodeSocketOption - ) -import Cardano.Wallet.Deposit.Application - ( serveDepositWallet - ) -import Cardano.Wallet.Network.Config - ( NetworkConfiguration (..) - , parseGenesisData - ) -import Cardano.Wallet.Network.Implementation.Ouroboros - ( tunedForMainnetPipeliningStrategy - ) -import Cardano.Wallet.Shelley.BlockchainSource - ( BlockchainSource (..) - ) -import Cardano.Wallet.Shelley.Network - ( withNetworkLayer - ) -import Control.Applicative - ( Const (..) - , optional - ) -import Control.Exception.Base - ( AsyncException (..) - ) -import Control.Monad - ( void - , when - , (<=<) - ) -import Control.Monad.Trans.Cont - ( evalContT - ) -import Control.Monad.Trans.Except - ( runExceptT - ) -import Control.Tracer - ( contramap - ) -import Data.Bifunctor - ( second - ) -import Data.Foldable - ( forM_ - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Main.Utf8 - ( withUtf8 - ) -import Network.URI - ( URI - ) -import "optparse-applicative" Options.Applicative - ( CommandFields - , Mod - , Parser - , command - , helper - , info - , internal - , long - , metavar - , option - , progDesc - , value - ) -import System.Environment - ( getArgs - , getExecutablePath - ) -import System.Exit - ( ExitCode (..) - , exitWith - ) -import UnliftIO.Exception - ( withException - ) - -import qualified Cardano.BM.Backend.EKGView as EKG -import qualified Cardano.Wallet.Application.Version as V -import qualified Data.Text as T -import qualified System.Info as I - -{------------------------------------------------------------------------------- - Main entry point --------------------------------------------------------------------------------} - -main :: IO () -main = withUtf8 $ do - enableWindowsANSI - runCli - $ cli - $ mempty - <> cmdServe - <> cmdVersion - -beforeMainLoop :: Trace IO MainLog -> URI -> IO () -beforeMainLoop tr = logInfo tr . MsgListenAddress - -{------------------------------------------------------------------------------- - Command - 'serve' --------------------------------------------------------------------------------} - --- | Arguments for the 'serve' command -data ServeArgs = ServeArgs - { _hostPreference :: HostPreference - , _mode :: Mode CardanoNodeConn - , _listenDeposit :: Maybe Listen - , _listenDepositUi :: Maybe Listen - , _tlsConfig :: Maybe TlsConfiguration - , _networkConfiguration :: NetworkConfiguration - , _database :: Maybe FilePath - , _enableShutdownHandler :: Bool - , _logging :: LoggingOptions TracerSeverities - , _depositByronGenesisFile :: Maybe FilePath - } - deriving (Show) - -cmdServe :: Mod CommandFields (IO ()) -cmdServe = - command "serve" - $ info (helper <*> helper' <*> cmd) - $ progDesc "Serve API that listens for commands/actions." - where - helper' = helperTracing tracerDescriptions - - cmd = - fmap exec - $ ServeArgs - <$> hostPreferenceOption - <*> modeOption nodeSocketOption - <*> listenDepositOption - <*> listenDepositUiOption - <*> optional tlsOption - <*> networkConfigurationOption - <*> optional databaseOption - <*> shutdownHandlerFlag - <*> loggingOptions tracerSeveritiesOption - <*> optional depositByronGenesisFileOption - - exec :: ServeArgs -> IO () - exec - args@( ServeArgs - host - mode - listenDeposit - listenDepositUi - tlsConfig - networkConfig - databaseDir - enableShutdownHandler - logOpt - byronGenesisFileOpt - ) = withTracers logOpt $ \tr tracers -> do - withShutdownHandlerMaybe tr enableShutdownHandler $ do - logDebug tr $ MsgServeArgs args - - (discriminant, netParams, vData, _block0) <- - runExceptT (parseGenesisData networkConfig) >>= \case - Right x -> pure x - Left err -> do - logError tr (MsgFailedToParseGenesis $ T.pack err) - exitWith $ ExitFailure 33 - forM_ databaseDir - $ setupDirectory (logInfo tr . MsgSetupDatabases) - - blockchainSource <- case mode of - Normal conn syncTolerance -> - pure $ NodeSource conn vData syncTolerance - - exitWith - <=< evalContT - $ do - netLayer <- - withNetworkLayer - (networkTracer tracers) - tunedForMainnetPipeliningStrategy - blockchainSource - discriminant - netParams - serveDepositWallet - tracers - databaseDir - host - listenDeposit - listenDepositUi - tlsConfig - byronGenesisFileOpt - netLayer - - withShutdownHandlerMaybe :: Trace IO MainLog -> Bool -> IO () -> IO () - withShutdownHandlerMaybe _ False = void - withShutdownHandlerMaybe tr True = void . withShutdownHandler trShutdown - where - trShutdown = trMessage $ contramap (second (fmap MsgShutdownHandler)) tr - -{------------------------------------------------------------------------------- - Logging --------------------------------------------------------------------------------} - -data MainLog - = MsgCmdLine String [String] - | MsgVersion Version GitRevision String String - | MsgSetupStateDir Text - | MsgSetupDatabases Text - | MsgServeArgs ServeArgs - | MsgListenAddress URI - | MsgSigTerm - | MsgSigInt - | MsgShutdownHandler ShutdownHandlerLog - | MsgFailedToParseGenesis Text - deriving (Show) - -instance ToText MainLog where - toText = \case - MsgCmdLine exe args -> - T.pack $ unwords ("Command line:" : exe : args) - MsgVersion ver rev arch os -> - "Running as " - <> T.pack (showFullVersion ver rev) - <> " on " - <> T.pack arch - <> "-" - <> T.pack os - MsgSetupStateDir txt -> - "Wallet state: " <> txt - MsgSetupDatabases txt -> - "Wallet databases: " <> txt - MsgServeArgs args -> - T.pack $ show args - MsgListenAddress url -> - "Wallet backend server listening on " <> T.pack (show url) - MsgSigTerm -> - "Terminated by signal." - MsgSigInt -> - "Interrupted by user." - MsgShutdownHandler msg' -> - toText msg' - MsgFailedToParseGenesis hint -> - T.unwords - [ "Failed to parse Byron genesis configuration. You may want to check" - , "the filepath given via --genesis and make sure it points to a " - , "valid JSON Byron genesis file. The genesis file must be Byron, not" - , "Shelley as it used to feed the wallet with the initial blockchain" - , "parameters." - , "Here's (perhaps) some helpful hint:" - , hint - ] - -withTracers - :: LoggingOptions TracerSeverities - -> (Trace IO MainLog -> Tracers IO -> IO a) - -> IO a -withTracers logOpt action = - withLogging [LogToStdStreams (loggingMinSeverity logOpt)] $ \(sb, (cfg, tr)) -> do - ekgEnabled >>= flip when (EKG.plugin cfg tr sb >>= loadPlugin sb) - let trMain = appendName "main" (transformTextTrace tr) - let tracers = setupTracers (loggingTracers logOpt) tr - logInfo trMain $ MsgVersion V.version V.gitRevision I.arch I.os - logInfo trMain =<< MsgCmdLine <$> getExecutablePath <*> getArgs - installSignalHandlers (logNotice trMain MsgSigTerm) - let logInterrupt UserInterrupt = logNotice trMain MsgSigInt - logInterrupt _ = pure () - action trMain tracers `withException` logInterrupt - -tracerSeveritiesOption :: Parser TracerSeverities -tracerSeveritiesOption = - Tracers - <$> traceOpt applicationTracer (Just Info) - <*> traceOpt apiServerTracer (Just Info) - <*> traceOpt tokenMetadataTracer (Just Info) - <*> traceOpt walletEngineTracer (Just Info) - <*> traceOpt walletDbTracer (Just Info) - <*> traceOpt poolsEngineTracer (Just Info) - <*> traceOpt poolsDbTracer (Just Info) - <*> traceOpt ntpClientTracer (Just Info) - <*> traceOpt networkTracer (Just Info) - where - traceOpt field def = - fmap Const . option loggingSeverityOrOffReader - $ mempty - <> long ("trace-" <> T.unpack (getConst (field tracerLabels))) - <> value def - <> metavar "SEVERITY" - <> internal diff --git a/lib/exe/cardano-wallet-exe.cabal b/lib/exe/cardano-wallet-exe.cabal index b33598f3b67..567aa80d39a 100644 --- a/lib/exe/cardano-wallet-exe.cabal +++ b/lib/exe/cardano-wallet-exe.cabal @@ -152,50 +152,3 @@ library other-modules: Paths_cardano_wallet_exe -library deposit - import: language, opts-lib - hs-source-dirs: deposit - build-depends: - , base - , cardano-deposit-wallet - , cardano-deposit-wallet:http - , cardano-deposit-wallet:rest - , cardano-wallet-exe - , cardano-wallet-network-layer - , cardano-wallet-primitive - , cardano-wallet-ui:common - , cardano-wallet-ui:deposit - , contra-tracer - , network - , servant-server - , streaming-commons - , transformers - , unliftio - , warp - - exposed-modules: Cardano.Wallet.Deposit.Application - -executable cardano-deposit-wallet - import: language, opts-exe - main-is: cardano-deposit-wallet.hs - hs-source-dirs: app/deposit - build-depends: base ^>=4.18.2.0 - default-language: Haskell2010 - build-depends: - , base - , cardano-wallet - , cardano-wallet-exe - , cardano-wallet-exe:deposit - , cardano-wallet-launcher - , cardano-wallet-network-layer - , contra-tracer - , iohk-monitoring - , iohk-monitoring-extra - , lobemo-backend-ekg - , network-uri - , optparse-applicative - , text - , text-class - , transformers - , unliftio - , with-utf8 diff --git a/lib/exe/deposit/Cardano/Wallet/Deposit/Application.hs b/lib/exe/deposit/Cardano/Wallet/Deposit/Application.hs deleted file mode 100644 index bf4bca39142..00000000000 --- a/lib/exe/deposit/Cardano/Wallet/Deposit/Application.hs +++ /dev/null @@ -1,300 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Wallet.Deposit.Application - ( serveDepositWallet - ) where - -import Prelude - -import Cardano.Wallet.Application.Logging - ( ApplicationLog (..) - ) -import Cardano.Wallet.Application.Server - ( Listen - , ListenError (..) - , start - , withListeningSocket - ) -import Cardano.Wallet.Application.Tls - ( TlsConfiguration - ) -import Cardano.Wallet.Application.Tracers as Tracers - ( Tracers - , Tracers' (..) - ) -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv - ) -import Cardano.Wallet.Deposit.IO.Resource - ( withResource - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - ) -import Cardano.Wallet.Deposit.REST.Start - ( loadDepositWalletFromDisk - , newBootEnv - ) -import Cardano.Wallet.Network - ( NetworkLayer - ) -import Cardano.Wallet.Primitive.Ledger.Shelley - ( CardanoBlock - , StandardCrypto - ) -import Cardano.Wallet.UI.Common.Html.Pages.Template.Head - ( PageConfig (..) - ) -import Cardano.Wallet.UI.Common.Layer - ( Push (..) - , UILayer - , oobMessages - , sourceOfNewTip - , walletTipChanges - ) -import Control.Monad - ( void - ) -import Control.Monad.Trans.Class - ( lift - ) -import Control.Monad.Trans.Cont - ( ContT (..) - , callCC - ) -import Control.Tracer - ( nullTracer - , traceWith - ) -import Data.Functor.Contravariant - ( (>$<) - ) -import Data.Proxy - ( Proxy (..) - ) -import Data.Streaming.Network - ( HostPreference - ) -import Network.Socket - ( Socket - ) -import Servant - ( serve - ) -import System.Exit - ( ExitCode (..) - ) -import UnliftIO - ( MonadIO (..) - , withAsync - , withSystemTempDirectory - ) - -import qualified Cardano.Wallet.Deposit.HTTP.Server as Deposit -import qualified Cardano.Wallet.Deposit.HTTP.Types.API as Deposit -import qualified Cardano.Wallet.Deposit.IO.Resource.Event as REST -import qualified Cardano.Wallet.UI.Common.Layer as Ui -import qualified Cardano.Wallet.UI.Deposit.API as DepositUi -import qualified Cardano.Wallet.UI.Deposit.Server as DepositUi -import qualified Network.Wai.Handler.Warp as Warp - --- | The @cardano-deposit-wallet@ main function. It takes the configuration --- which was passed from the CLI and environment and starts all components of --- the wallet. -serveDepositWallet - :: Tracers IO - -- ^ Logging config. - -> Maybe FilePath - -- ^ Database folder filepath - -> HostPreference - -- ^ Which host to bind. - -> Maybe Listen - -- ^ Optional HTTP JSON data server port for the deposit wallet. - -> Maybe Listen - -- ^ Optional HTTP UI Server port for the deposit wallet. - -> Maybe TlsConfiguration - -- ^ An optional TLS configuration - -> Maybe FilePath - -- See also: 'Cardano.Wallet.Primitive.Ledger.Shelley#KnownNetwork'. - -> NetworkLayer IO (CardanoBlock StandardCrypto) - -> ContT r IO ExitCode -serveDepositWallet - Tracers{applicationTracer, apiServerTracer} - databaseDir - hostPref - mListenDeposit - mListenDepositUi - tlsConfig - depositByronGenesisFile - netLayer = do - eDepositUiSocket <- bindDepositUiSocket - eDepositSocket <- bindDepositSocket - bootEnv <- lift $ newBootEnv depositByronGenesisFile netLayer - callCC $ \exit -> do - mDepositDatabaseDirAndResource <- case eDepositUiSocket of - Left err -> do - lift $ trace $ MsgServerStartupError err - _ <- exit $ ExitFailure $ exitCodeApiServer err - pure Nothing - Right ms -> do - case ms of - Nothing -> pure Nothing - Just (_port, socket) -> do - databaseDir' <- case databaseDir of - Nothing -> - ContT - $ withSystemTempDirectory - "deposit-wallet" - Just databaseDir' -> pure databaseDir' - resource <- ContT withResource - ui <- Ui.withUILayer 1 resource - liftIO - $ loadDepositWalletFromDisk - (walletTipChanges >$< oobMessages ui) - ( DepositApplicationLog - >$< applicationTracer - ) - databaseDir' - bootEnv - resource - REST.onResourceChange - ( \_ -> do - traceWith (oobMessages ui) - $ Push "wallet" - ) - resource - sourceOfNewTip netLayer ui - let uiService = - startDepositUiServer - ui - bootEnv - databaseDir' - socket - ContT $ \k -> - withAsync uiService $ \_ -> k () - pure $ Just (databaseDir', resource) - case eDepositSocket of - Left err -> do - lift $ trace $ MsgServerStartupError err - void $ exit $ ExitFailure $ exitCodeApiServer err - Right ms -> do - case ms of - Nothing -> pure () - Just (_port, socket) -> do - (databaseDir', resource) <- - case mDepositDatabaseDirAndResource of - Nothing -> do - databaseDir' <- - ContT - $ withSystemTempDirectory - "deposit-wallet" - resource <- ContT withResource - liftIO - $ loadDepositWalletFromDisk - nullTracer - ( DepositApplicationLog - >$< applicationTracer - ) - databaseDir' - bootEnv - resource - pure (databaseDir', resource) - Just (databaseDir', w) -> - pure (databaseDir', w) - liftIO - $ startDepositServer - resource - bootEnv - databaseDir' - socket - - exit ExitSuccess - where - trace :: ApplicationLog -> IO () - trace = traceWith applicationTracer - - bindDepositUiSocket - :: ContT r IO (Either ListenError (Maybe (Warp.Port, Socket))) - bindDepositUiSocket = case mListenDepositUi of - Nothing -> pure $ Right Nothing - Just listenUi -> do - fmap (fmap Just) - $ ContT - $ withListeningSocket hostPref listenUi - - bindDepositSocket - :: ContT r IO (Either ListenError (Maybe (Warp.Port, Socket))) - bindDepositSocket = case mListenDeposit of - Nothing -> pure $ Right Nothing - Just listenDeposit -> - fmap (fmap Just) - $ ContT - $ withListeningSocket hostPref listenDeposit - startDepositServer - :: WalletResource - -> WalletBootEnv IO - -> FilePath - -> Socket - -> IO () - startDepositServer - resource - bootEnv - databaseDir' - socket = - do - let serverSettings = Warp.defaultSettings - api = Proxy @Deposit.API - application = - serve api - $ Deposit.server - nullTracer - (DepositApplicationLog >$< applicationTracer) - databaseDir' - bootEnv - resource - start - serverSettings - apiServerTracer - tlsConfig - socket - application - startDepositUiServer - :: UILayer WalletResource - -> WalletBootEnv IO - -> FilePath - -> Socket - -> IO () - startDepositUiServer - ui - bootEnv - databaseDir' - socket = - do - let serverSettings = Warp.defaultSettings - api = Proxy @DepositUi.UI - application = - serve api - $ DepositUi.serveUI - (walletTipChanges >$< oobMessages ui) - (DepositUIApplicationLog >$< applicationTracer) - ui - bootEnv - databaseDir' - (PageConfig "" "Deposit Cardano Wallet") - start - serverSettings - apiServerTracer - tlsConfig - socket - application - --- | Failure status codes for HTTP API server errors. -exitCodeApiServer :: ListenError -> Int -exitCodeApiServer = \case - ListenErrorHostDoesNotExist _ -> 10 - ListenErrorInvalidAddress _ -> 11 - ListenErrorAddressAlreadyInUse _ -> 12 - ListenErrorOperationNotPermitted -> 13 diff --git a/nix/haskell.nix b/nix/haskell.nix index 390c163c9a3..39ba5f0ebc8 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -293,7 +293,6 @@ CHaP: haskell-nix: nixpkgs-recent: nodePkgs: mithrilPkgs: haskell-nix.cabalProje # Apply fully static options to our Haskell executables packages.cardano-wallet-benchmarks.components.benchmarks.restore = fullyStaticOptions; packages.cardano-wallet-exe.components.exes.cardano-wallet = fullyStaticOptions; - packages.cardano-wallet-exe.components.exes.cardano-deposit-wallet = fullyStaticOptions; packages.cardano-wallet-integration.components.tests.integration = fullyStaticOptions; packages.cardano-wallet-unit.components.tests.unit = fullyStaticOptions; packages.cardano-wallet-benchmarks.components.benchmarks.db = fullyStaticOptions; From 0a2e06eefafa71b135df25ec819314672f6cadfc Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 26 Feb 2025 15:57:11 +0000 Subject: [PATCH 2/4] Remove deposit UI code --- lib/ui/cardano-wallet-ui.cabal | 118 ---- .../deposit/Cardano/Wallet/UI/Deposit/API.hs | 339 ----------- .../UI/Deposit/API/Addresses/Transactions.hs | 64 -- .../Cardano/Wallet/UI/Deposit/API/Common.hs | 91 --- .../UI/Deposit/API/Deposits/Deposits.hs | 130 ---- .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 320 ---------- .../Wallet/UI/Deposit/Handlers/Addresses.hs | 61 -- .../Handlers/Addresses/Transactions.hs | 155 ----- .../UI/Deposit/Handlers/Deposits/Customers.hs | 190 ------ .../UI/Deposit/Handlers/Deposits/Times.hs | 117 ---- .../UI/Deposit/Handlers/Deposits/TxIds.hs | 200 ------ .../Cardano/Wallet/UI/Deposit/Handlers/Lib.hs | 73 --- .../UI/Deposit/Handlers/Payments/Balance.hs | 36 -- .../Deposit/Handlers/Payments/Transaction.hs | 488 --------------- .../Wallet/UI/Deposit/Handlers/Wallet.hs | 154 ----- .../Cardano/Wallet/UI/Deposit/Html/Common.hs | 163 ----- .../Wallet/UI/Deposit/Html/Pages/About.hs | 16 - .../Wallet/UI/Deposit/Html/Pages/Addresses.hs | 151 ----- .../Html/Pages/Addresses/Transactions.hs | 309 ---------- .../Deposit/Html/Pages/Deposits/Customers.hs | 239 -------- .../UI/Deposit/Html/Pages/Deposits/Page.hs | 188 ------ .../UI/Deposit/Html/Pages/Deposits/Times.hs | 264 -------- .../UI/Deposit/Html/Pages/Deposits/TxIds.hs | 153 ----- .../Wallet/UI/Deposit/Html/Pages/Page.hs | 143 ----- .../UI/Deposit/Html/Pages/Payments/Page.hs | 570 ------------------ .../Wallet/UI/Deposit/Html/Pages/Wallet.hs | 258 -------- .../Cardano/Wallet/UI/Deposit/Server.hs | 230 ------- .../Wallet/UI/Deposit/Server/Addresses.hs | 95 --- .../UI/Deposit/Server/Deposits/Customers.hs | 163 ----- .../Wallet/UI/Deposit/Server/Deposits/Page.hs | 51 -- .../UI/Deposit/Server/Deposits/Times.hs | 116 ---- .../UI/Deposit/Server/Deposits/TxIds.hs | 168 ------ .../Cardano/Wallet/UI/Deposit/Server/Lib.hs | 43 -- .../Wallet/UI/Deposit/Server/Payments/Page.hs | 195 ------ .../Wallet/UI/Deposit/Server/Wallet.hs | 156 ----- .../Wallet/UI/Deposit/Types/Payments.hs | 62 -- .../Cardano/Wallet/UI/Deposit/Types/Wallet.hs | 23 - .../Cardano/Wallet/UI/Lib/Discretization.hs | 120 ---- .../Cardano/Wallet/UI/Lib/Pagination/Map.hs | 60 -- .../Wallet/UI/Lib/Pagination/TimedSeq.hs | 60 -- .../Cardano/Wallet/UI/Lib/Pagination/Type.hs | 43 -- .../Cardano/Wallet/UI/Lib/Time/Direction.hs | 47 -- 42 files changed, 6622 deletions(-) delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Addresses/Transactions.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Common.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Deposits/Deposits.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Payments.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Customers.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/TxIds.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Lib.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Wallet.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Common.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/About.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Customers.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Page.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Times.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/TxIds.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Wallet.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Addresses.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Customers.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Page.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Times.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/TxIds.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Lib.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Wallet.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Payments.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Wallet.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Discretization.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Map.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/TimedSeq.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Type.hs delete mode 100644 lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Time/Direction.hs diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal index bc72b6c6629..d0f52ac2423 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/lib/ui/cardano-wallet-ui.cabal @@ -141,121 +141,3 @@ library shelley hs-source-dirs: src/shelley default-language: Haskell2010 -test-suite unit - default-language: Haskell2010 - default-extensions: - NoImplicitPrelude - OverloadedStrings - - ghc-options: -threaded -rtsopts -Wall - - if flag(release) - ghc-options: -O2 -Werror - - build-depends: - , base - , base16-bytestring - , bytestring - , cardano-addresses - , cardano-crypto - , cardano-deposit-wallet - , cardano-deposit-wallet:rest - , cardano-wallet-read - , cardano-wallet-ui:common - , cardano-wallet-ui:deposit - , containers - , contra-tracer - , hspec - , hspec-golden-aeson - , mtl - , QuickCheck - , temporary - , text - , time - - build-tool-depends: hspec-discover:hspec-discover - type: exitcode-stdio-1.0 - hs-source-dirs: test/unit - main-is: unit-test.hs - other-modules: - Cardano.Wallet.UI.Deposit.Html.Pages.Payments.PageSpec - Cardano.Wallet.UI.Lib.DiscretizationSpec - Cardano.Wallet.UI.Lib.Pagination.MapSpec - -library deposit - import: language, opts-lib - visibility: public - exposed-modules: - Cardano.Wallet.UI.Deposit.API - Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - Cardano.Wallet.UI.Deposit.API.Common - Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - Cardano.Wallet.UI.Deposit.API.Payments - Cardano.Wallet.UI.Deposit.Handlers.Addresses - Cardano.Wallet.UI.Deposit.Handlers.Addresses.Transactions - Cardano.Wallet.UI.Deposit.Handlers.Deposits.Customers - Cardano.Wallet.UI.Deposit.Handlers.Deposits.Times - Cardano.Wallet.UI.Deposit.Handlers.Deposits.TxIds - Cardano.Wallet.UI.Deposit.Handlers.Lib - Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance - Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction - Cardano.Wallet.UI.Deposit.Handlers.Wallet - Cardano.Wallet.UI.Deposit.Html.Common - Cardano.Wallet.UI.Deposit.Html.Pages.About - Cardano.Wallet.UI.Deposit.Html.Pages.Addresses - Cardano.Wallet.UI.Deposit.Html.Pages.Addresses.Transactions - Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Customers - Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Page - Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Times - Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.TxIds - Cardano.Wallet.UI.Deposit.Html.Pages.Page - Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page - Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - Cardano.Wallet.UI.Deposit.Server - Cardano.Wallet.UI.Deposit.Server.Addresses - Cardano.Wallet.UI.Deposit.Server.Deposits.Customers - Cardano.Wallet.UI.Deposit.Server.Deposits.Page - Cardano.Wallet.UI.Deposit.Server.Deposits.Times - Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds - Cardano.Wallet.UI.Deposit.Server.Lib - Cardano.Wallet.UI.Deposit.Server.Payments.Page - Cardano.Wallet.UI.Deposit.Server.Wallet - Cardano.Wallet.UI.Deposit.Types.Payments - Cardano.Wallet.UI.Deposit.Types.Wallet - Cardano.Wallet.UI.Lib.Discretization - Cardano.Wallet.UI.Lib.Pagination.Map - Cardano.Wallet.UI.Lib.Pagination.TimedSeq - Cardano.Wallet.UI.Lib.Pagination.Type - Cardano.Wallet.UI.Lib.Time.Direction - - other-modules: Paths_cardano_wallet_ui - build-depends: - , aeson - , base - , base16-bytestring - , bytestring - , cardano-addresses - , cardano-binary - , cardano-deposit-wallet - , cardano-deposit-wallet:rest - , cardano-slotting - , cardano-wallet-read - , cardano-wallet-ui:common - , containers - , contra-tracer - , hashable - , http-api-data - , lens - , lucid - , monoidal-containers - , mtl - , servant - , servant-server - , stm - , text - , text-class - , time - , transformers - - hs-source-dirs: src/deposit - default-language: Haskell2010 diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API.hs deleted file mode 100644 index 977f0624f6d..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.API where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Read - ( Address - , TxId - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic - , PostWalletViaXPub - ) -import Cardano.Wallet.Read - ( WithOrigin (..) - ) -import Cardano.Wallet.UI.Common.API - ( Image - , SessionedHtml - , type (|>) - , type (|>>) - ) -import Cardano.Wallet.UI.Common.Handlers.SSE - ( SSE - ) -import Cardano.Wallet.UI.Cookies - ( CookieRequest - ) -import Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - ( TransactionHistoryParams - ) -import Cardano.Wallet.UI.Deposit.API.Common - ( Expand - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams - ) -import Cardano.Wallet.UI.Deposit.API.Payments - ( AddReceiverForm - , NewReceiverValidation - , SignatureForm - ) -import Control.Lens - ( makePrisms - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime - ) -import Servant - ( Delete - , FormUrlEncoded - , FromHttpApiData (..) - , Get - , Link - , Post - , Proxy (..) - , QueryParam - , ReqBody - , ToHttpApiData (..) - , allLinks - , (:<|>) (..) - , (:>) - ) -import Web.FormUrlEncoded - ( FromForm (..) - ) - -import qualified Cardano.Wallet.UI.Deposit.API.Payments as Payment -import qualified Data.ByteString.Lazy as BL - -instance FromForm PostWalletViaMnemonic - -instance FromForm PostWalletViaXPub - -data Page - = About - | Settings - | Wallet - | Addresses - | Deposits - | Payments - -makePrisms ''Page - -instance ToHttpApiData Page where - toUrlPiece About = "about" - toUrlPiece Settings = "settings" - toUrlPiece Wallet = "wallet" - toUrlPiece Addresses = "addresses" - toUrlPiece Deposits = "deposits" - toUrlPiece Payments = "payments" - -instance FromHttpApiData Page where - parseUrlPiece "about" = Right About - parseUrlPiece "settings" = Right Settings - parseUrlPiece "wallet" = Right Wallet - parseUrlPiece "addresses" = Right Addresses - parseUrlPiece "deposits" = Right Deposits - parseUrlPiece "payments" = Right Payments - parseUrlPiece _ = Left "Invalid page" - --- | Pages endpoints -type Pages = - "about" :> SessionedHtml Get - :<|> "settings" :> SessionedHtml Get - :<|> "wallet" :> SessionedHtml Get - :<|> "addresses" :> SessionedHtml Get - :<|> "deposits" :> SessionedHtml Get - :<|> "payments" :> SessionedHtml Get - --- | Data endpoints -type Data = - "settings" :> SessionedHtml Get - :<|> "settings" :> "sse" :> "toggle" :> SessionedHtml Post - :<|> "sse" :> (CookieRequest :> SSE) - :<|> "favicon.ico" :> Get '[Image] BL.ByteString - :<|> "wallet" - :> "mnemonic" - :> QueryParam "clean" Bool - :> SessionedHtml Get - :<|> "wallet" :> SessionedHtml Get - :<|> "wallet" - :> "mnemonic" - :> ReqBody '[FormUrlEncoded] PostWalletViaMnemonic - :> SessionedHtml Post - :<|> "wallet" - :> "xpub" - :> ReqBody '[FormUrlEncoded] PostWalletViaXPub - :> SessionedHtml Post - :<|> "wallet" :> SessionedHtml Delete - :<|> "wallet" :> "delete" :> "modal" :> SessionedHtml Get - :<|> "customer" - :> "address" - :> ReqBody '[FormUrlEncoded] Customer - :> SessionedHtml Post - :<|> "addresses" :> SessionedHtml Get - :<|> "navigation" :> QueryParam "page" Page :> SessionedHtml Get - :<|> "customer" - :> "transactions" - :> "history" - :> ReqBody '[FormUrlEncoded] TransactionHistoryParams - :> SessionedHtml Post - :<|> "deposits" :> SessionedHtml Get - :<|> "deposits" - :> "times" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> SessionedHtml Post - :<|> "deposits" - :> "times" - :> "page" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> QueryParam "index" (WithOrigin UTCTime) - :> SessionedHtml Post - :<|> "deposits" - :> "history" - :> "customers" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> QueryParam "time" (WithOrigin UTCTime) - :> QueryParam "expand" Expand - :> SessionedHtml Post - :<|> "deposits" - :> "history" - :> "customers" - :> "page" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> QueryParam "time" (WithOrigin UTCTime) - :> QueryParam "customer" Customer - :> SessionedHtml Post - :<|> "deposits" - :> "history" - :> "customers" - :> "tx-ids" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> QueryParam "time" (WithOrigin UTCTime) - :> QueryParam "customer" Customer - :> QueryParam "expand" Expand - :> SessionedHtml Post - :<|> "deposits" - :> "history" - :> "customers" - :> "tx-ids" - :> "page" - :> ReqBody '[FormUrlEncoded] DepositsParams - :> QueryParam "time" (WithOrigin UTCTime) - :> QueryParam "customer" Customer - :> QueryParam "tx-id" TxId - :> SessionedHtml Post - :<|> "payments" :> SessionedHtml Get - :<|> "payments" - :> "receiver" - :> ReqBody '[FormUrlEncoded] AddReceiverForm - :> SessionedHtml Post - :<|> "payments" - :> "receiver" - :> "delete" - :> ReqBody '[FormUrlEncoded] Payment.State - :> QueryParam "receiver-number" Address - :> SessionedHtml Post - :<|> "payments" - :> "balance" - :> "available" - :> SessionedHtml Get - :<|> "payments" - :> "receiver" - :> "address" - :> "validation" - :> ReqBody '[FormUrlEncoded] NewReceiverValidation - :> SessionedHtml Post - :<|> "payments" - :> "receiver" - :> "amount" - :> "validation" - :> ReqBody '[FormUrlEncoded] NewReceiverValidation - :> SessionedHtml Post - :<|> "modal" - :> "info" - :> QueryParam "title" Text - :> QueryParam "text" Text - :> SessionedHtml Get - :<|> "payments" - :> "sign" - :> ReqBody '[FormUrlEncoded] SignatureForm - :> SessionedHtml Post - :<|> "payments" - :> "submit" - :> ReqBody '[FormUrlEncoded] Payment.State - :> SessionedHtml Post - :<|> "payments" - :> "reset" - :> SessionedHtml Post - :<|> "wallet" - :> "status" - :> SessionedHtml Get - -type Home = SessionedHtml Get - --- | UI endpoints -type UI = - Home - :<|> "page" - |> Pages - |>> "data" - |> Data - -homePageLink :: Link -aboutPageLink :: Link -settingsPageLink :: Link -walletPageLink :: Link -addressesPageLink :: Link -depositPageLink :: Link -paymentsPageLink :: Link -settingsGetLink :: Link -settingsSseToggleLink :: Link -sseLink :: Link -faviconLink :: Link -walletMnemonicLink :: Maybe Bool -> Link -walletLink :: Link -walletPostMnemonicLink :: Link -walletPostXPubLink :: Link -walletDeleteLink :: Link -walletDeleteModalLink :: Link -customerAddressLink :: Link -addressesLink :: Link -navigationLink :: Maybe Page -> Link -customerHistoryLink :: Link -depositsLink :: Link -depositsTimesLink :: Link -depositsTimesPaginatingLink - :: Maybe (WithOrigin UTCTime) -> Link -depositsCustomersLink - :: Maybe (WithOrigin UTCTime) -> Maybe Expand -> Link -depositsCustomersPaginatingLink - :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Link -depositsTxIdsLink - :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe Expand -> Link -depositsTxIdsPaginatingLink - :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe TxId -> Link -paymentsLink :: Link -paymentsNewReceiverLink :: Link -paymentsDeleteReceiverLink :: Maybe Address -> Link -paymentsBalanceAvailableLink :: Link -paymentsReceiverAddressValidationLink :: Link -paymentsReceiverAmountValidationLink :: Link -modalLink :: Maybe Text -> Maybe Text -> Link -paymentsSignLink :: Link -paymentsSubmitLink :: Link -paymentsResetLink :: Link -walletStatusLink :: Link -homePageLink - :<|> aboutPageLink - :<|> settingsPageLink - :<|> walletPageLink - :<|> addressesPageLink - :<|> depositPageLink - :<|> paymentsPageLink - :<|> settingsGetLink - :<|> settingsSseToggleLink - :<|> sseLink - :<|> faviconLink - :<|> walletMnemonicLink - :<|> walletLink - :<|> walletPostMnemonicLink - :<|> walletPostXPubLink - :<|> walletDeleteLink - :<|> walletDeleteModalLink - :<|> customerAddressLink - :<|> addressesLink - :<|> navigationLink - :<|> customerHistoryLink - :<|> depositsLink - :<|> depositsTimesLink - :<|> depositsTimesPaginatingLink - :<|> depositsCustomersLink - :<|> depositsCustomersPaginatingLink - :<|> depositsTxIdsLink - :<|> depositsTxIdsPaginatingLink - :<|> paymentsLink - :<|> paymentsNewReceiverLink - :<|> paymentsDeleteReceiverLink - :<|> paymentsBalanceAvailableLink - :<|> paymentsReceiverAddressValidationLink - :<|> paymentsReceiverAmountValidationLink - :<|> modalLink - :<|> paymentsSignLink - :<|> paymentsSubmitLink - :<|> paymentsResetLink - :<|> walletStatusLink = - allLinks (Proxy @UI) diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Addresses/Transactions.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Addresses/Transactions.hs deleted file mode 100644 index 3b3fee49bc8..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Addresses/Transactions.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - ( TransactionHistoryParams (..) - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.UI.Lib.Time.Direction - ( Direction (..) - ) -import Data.Maybe - ( isJust - ) -import Servant - ( FromHttpApiData (..) - ) -import Web.FormUrlEncoded - ( FromForm (..) - , lookupMaybe - , parseUnique - ) - -instance FromHttpApiData Direction where - parseUrlPiece "asc" = Right Asc - parseUrlPiece "desc" = Right Desc - parseUrlPiece _ = Left "Invalid sorting direction" - -data TransactionHistoryParams = TransactionHistoryParams - { txHistoryCustomer :: Customer - , txHistoryUTC :: Bool - , txHistorySlot :: Bool - , txHistorySpent :: Bool - , txHistoryReceived :: Bool - , txHistorySorting :: Direction - , txHistoryStartYear :: Int - , txHistoryStartMonth :: Int - } - -instance FromForm TransactionHistoryParams where - fromForm form = do - utc <- isJust <$> lookupMaybe "utc" form - customer <- fromIntegral @Int <$> parseUnique "customer" form - slot <- isJust <$> lookupMaybe "slot" form - spent <- isJust <$> lookupMaybe "spent" form - received <- isJust <$> lookupMaybe "received" form - sorting <- parseUnique "sorting" form - year <- parseUnique "start-year" form - month <- parseUnique "start-month" form - pure - $ TransactionHistoryParams - customer - utc - slot - spent - received - sorting - year - month diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Common.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Common.hs deleted file mode 100644 index 45026fee178..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Common.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.API.Common where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Read - ( TxId - ) -import Cardano.Wallet.Read - ( SlotNo (..) - , WithOrigin (..) - , hashFromTxId - , txIdFromHash - ) -import Cardano.Wallet.Read.Hash - ( hashFromStringAsHex - , hashToStringAsHex - ) -import Data.Hashable - ( Hashable - ) -import Data.Text.Class - ( ToText (..) - ) -import Data.Time - ( UTCTime - ) -import Servant - ( FromHttpApiData (..) - , ToHttpApiData (..) - ) -import Web.FormUrlEncoded - ( FromForm (..) - , parseUnique - ) - -import qualified Data.Text as T - -instance FromForm Customer where - fromForm form = fromIntegral @Int <$> parseUnique "customer" form - -instance FromHttpApiData SlotNo where - parseUrlPiece = fmap SlotNo . parseUrlPiece - -instance FromHttpApiData t => FromHttpApiData (WithOrigin t) where - parseUrlPiece "Origin" = pure Origin - parseUrlPiece t = At <$> parseUrlPiece t - -instance ToHttpApiData SlotNo where - toUrlPiece (SlotNo t) = toUrlPiece t - -instance ToHttpApiData t => ToHttpApiData (WithOrigin t) where - toUrlPiece Origin = "Origin" - toUrlPiece (At t) = toUrlPiece t - -data Expand = Expand | Collapse - deriving (Eq, Show, Enum, Bounded) - -instance ToHttpApiData Expand where - toUrlPiece Expand = "expand" - toUrlPiece Collapse = "collapse" - -instance FromHttpApiData Expand where - parseUrlPiece "expand" = Right Expand - parseUrlPiece "collapse" = Right Collapse - parseUrlPiece _ = Left "Invalid expand/collapse" - -deriving instance Hashable (WithOrigin UTCTime) - -instance ToHttpApiData Customer where - toUrlPiece = toUrlPiece . toText - -instance FromHttpApiData Customer where - parseUrlPiece = fmap (fromIntegral @Int) . parseUrlPiece - -instance FromHttpApiData TxId where - parseUrlPiece x = - case fmap txIdFromHash . hashFromStringAsHex . T.unpack $ x of - Just txId -> Right txId - _ -> Left "Invalid TxId" - -instance ToHttpApiData TxId where - toUrlPiece = T.pack . hashToStringAsHex . hashFromTxId diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Deposits/Deposits.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Deposits/Deposits.hs deleted file mode 100644 index 7faf176df4c..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Deposits/Deposits.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.API.Deposits.Deposits where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Slot - , TxId - ) -import Cardano.Wallet.Read - ( WithOrigin (..) - ) -import Cardano.Wallet.UI.Deposit.API.Common - () -import Cardano.Wallet.UI.Lib.Discretization - ( Window (..) - ) -import Data.Maybe - ( isJust - ) -import Data.Ord - ( Down (..) - ) -import Data.Set - ( Set - ) -import Data.Time - ( DayOfWeek - , UTCTime - ) -import Servant - ( FromHttpApiData (..) - , ToHttpApiData (..) - ) -import Web.FormUrlEncoded - ( FromForm (..) - , lookupMaybe - , parseAll - , parseMaybe - , parseUnique - ) - -import qualified Data.Set as Set -import qualified Data.Text as T - -instance FromHttpApiData Window where - parseUrlPiece "5m" = Right Minute5 - parseUrlPiece "10m" = Right Minute10 - parseUrlPiece "15m" = Right Minute15 - parseUrlPiece "30m" = Right Minute30 - parseUrlPiece "1h" = Right Hour1 - parseUrlPiece "2h" = Right Hour2 - parseUrlPiece "4h" = Right Hour4 - parseUrlPiece "6h" = Right Hour6 - parseUrlPiece "12h" = Right Hour12 - parseUrlPiece "1d" = Right Day - parseUrlPiece "1w" = Right Week - parseUrlPiece "1M" = Right Month - parseUrlPiece "1y" = Right Year - parseUrlPiece _ = Left "Invalid time window" - -instance ToHttpApiData Window where - toUrlPiece Minute5 = "5m" - toUrlPiece Minute10 = "10m" - toUrlPiece Minute15 = "15m" - toUrlPiece Minute30 = "30m" - toUrlPiece Hour1 = "1h" - toUrlPiece Hour2 = "2h" - toUrlPiece Hour4 = "4h" - toUrlPiece Hour6 = "6h" - toUrlPiece Hour12 = "12h" - toUrlPiece Day = "1d" - toUrlPiece Week = "1w" - toUrlPiece Month = "1M" - toUrlPiece Year = "1y" - -data DepositsParams = DepositsParams - { depositsSlot :: Bool - , depositsWindow :: Window - , depositsFirstWeekDay :: DayOfWeek - , depositsViewStart :: Maybe (WithOrigin UTCTime) - , depositsWindowOpen :: Maybe (WithOrigin UTCTime) - , depositsSpent :: Bool - , depositsCustomers :: Set (WithOrigin UTCTime) - , depositsPages :: Set DownTime - , depositsCustomersPages :: Set Customer - , depositsCustomersTxIdsPages :: Set TxId - } - deriving (Eq, Show) - -instance FromHttpApiData (Customer, Slot) where - parseUrlPiece t = do - case T.splitOn "-" t of - [c, s] -> (,) <$> parseUrlPiece c <*> parseUrlPiece s - _ -> Left "Invalid customer/slot pair" - -instance FromForm DepositsParams where - fromForm form = do - slot <- isJust <$> lookupMaybe "slot" form - window <- parseUnique "window" form - firstWeekDay <- parseUnique "first-week-day" form - viewStart <- parseMaybe "view-start" form - windowOpen <- parseMaybe "window-open" form - spent <- isJust <$> lookupMaybe "spent" form - customers <- Set.fromList <$> parseAll "customers" form - pageTimes <- Set.fromList . fmap Down <$> - parseAll "times-paginating-presence" form - pageCustomers <- - Set.fromList <$> parseAll "customers-paginating-presence" form - pageTxIds <- Set.fromList <$> parseAll "tx-ids-paginating-presence" form - pure - $ DepositsParams - slot - window - firstWeekDay - viewStart - windowOpen - spent - customers - pageTimes - pageCustomers - pageTxIds diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Payments.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Payments.hs deleted file mode 100644 index 5ab83ba3e0d..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/API/Payments.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.API.Payments -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( BIP32Path (..) - , DerivationType (..) - , Word31 - ) -import Cardano.Wallet.Deposit.Pure.API.Address - ( encodeAddress - ) -import Cardano.Wallet.Deposit.Write - ( Address - ) -import Cardano.Wallet.UI.Deposit.Types.Payments - ( Receiver (..) - ) -import Data.Aeson - ( FromJSON (parseJSON) - , KeyValue ((.=)) - , ToJSON (toJSON) - , object - , withObject - , withText - , (.:) - , (.:?) - ) -import Data.Aeson.Types - ( Parser - , parseFail - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap - ) -import Data.Semigroup - ( Sum (..) - ) -import Data.Text - ( Text - ) -import GHC.Generics - ( Generic - ) -import Numeric.Natural - ( Natural - ) -import Servant - ( FromHttpApiData (..) - , ToHttpApiData - ) -import Servant.API - ( ToHttpApiData (..) - ) -import Web.FormUrlEncoded - ( FromForm (..) - , parseMaybe - , parseUnique - ) - -import qualified Data.Aeson as Aeson -import qualified Data.Map.Monoidal.Strict as MonoidalMap -import Data.Maybe - ( fromMaybe - ) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL - -newtype NewReceiver = NewReceiver Receiver - -data AddReceiverForm = AddReceiverForm - { newReceiver :: NewReceiver - , addReceiverState :: State - } - -instance FromForm AddReceiverForm where - fromForm form = do - newReceiver <- fromForm form - addReceiverState <- fromForm form - pure AddReceiverForm{newReceiver, addReceiverState} - -instance FromForm NewReceiver where - fromForm form = do - address <- parseUnique "new-receiver-address" form - amountDouble :: Double <- parseUnique "new-receiver-amount" form - let amount = round $ amountDouble * 1_000_000 - pure - $ NewReceiver - $ Receiver{address, amount} - -data NewReceiverValidation - = NewReceiverValidation - { addressValidation :: Maybe Text - , amountValidation :: Maybe Text - } - -instance FromForm NewReceiverValidation where - fromForm form = do - addressValidation <- parseMaybe "new-receiver-address" form - amountValidation <- parseMaybe "new-receiver-amount" form - pure $ NewReceiverValidation{addressValidation, amountValidation} - -data Transaction = Transaction - { dataType :: !Text - , description :: !Text - , cborHex :: !Text - , bip32Paths :: ![BIP32Path] - } - deriving (Eq, Show, Generic) - -instance ToJSON Transaction where - toJSON Transaction{dataType, description, cborHex, bip32Paths} = - object - [ "type" .= dataType - , "description" .= description - , "cborHex" .= cborHex - , "bip32Paths" .= bip32Paths - ] - -instance FromJSON Transaction where - parseJSON = withObject "Transaction" $ \o -> do - dataType <- o .: "type" - description <- o .: "description" - cborHex <- o .: "cborHex" - bip32Paths <- o .:? "bip32Paths" - pure - Transaction - { dataType - , description - , cborHex - , bip32Paths = fromMaybe [] bip32Paths - } - --- Orphan instances for BIP32Path --- TODO: move where they belong, in the module defining BIP32Path -instance ToJSON BIP32Path where - toJSON = toJSON . encodeBIP32 - where - encodeBIP32 = \case - (Segment Root Hardened n) -> T.pack (show n) <> "H" - (Segment Root Soft n) -> T.pack (show n) - (Segment p Hardened n) -> - encodeBIP32 p - <> "/" - <> T.pack (show n) - <> "H" - (Segment p Soft n) -> - encodeBIP32 p <> "/" <> T.pack (show n) - Root -> "" - -instance FromJSON BIP32Path where - parseJSON = withText "BIP32Path" parseBip32 - where - parseBip32 :: Text -> Parser BIP32Path - parseBip32 t = case T.splitOn "/" t of - [""] -> pure Root - xs -> foldSegments <$> traverse parseSegment xs - - foldSegments :: [(Word31, DerivationType)] -> BIP32Path - foldSegments = foldl (\p (i, t) -> Segment p t i) Root - - parseSegment :: Text -> Parser (Word31, DerivationType) - parseSegment t = case T.stripSuffix "H" t of - Nothing -> do - s <- parseIndex t - pure (s, Soft) - Just t' -> do - s <- parseIndex t' - pure (s, Hardened) - where - parseIndex :: Text -> Parser Word31 - parseIndex text = case reads $ T.unpack text of - [(i, "")] -> pure i - _ -> parseFail "Invalid index" - -newtype Password = Password Text - -data SignatureForm - = SignatureForm - { signatureFormState :: State - , signaturePassword :: Password - } - | ExternalSignatureForm - { signatureFormState :: State - , signatureSignedTransaction :: Transaction - } - -instance FromForm SignatureForm where - fromForm form = do - signatureFormState <- fromForm form - let - signature = do - signaturePassword <- Password <$> parseUnique "passphrase" form - pure SignatureForm{signatureFormState, signaturePassword} - externalSignature = do - signatureSignedTransaction <- parseUnique "signed-transaction" form - pure - ExternalSignatureForm{signatureFormState, signatureSignedTransaction} - case signature of - Left _ -> externalSignature - Right s -> pure s - -instance FromHttpApiData Transaction where - parseQueryParam :: Text -> Either Text Transaction - parseQueryParam t = case Aeson.decode $ TL.encodeUtf8 $ TL.fromStrict t of - Nothing -> Left "Invalid JSON for a Transaction" - Just tx -> pure tx - -data StateA t - = NoState - | Unsigned t - | Signed Transaction t - | Submitted Transaction t - deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -type State = StateA Transaction - -instance ToJSON State -instance FromJSON State - -instance FromHttpApiData State where - parseQueryParam :: Text -> Either Text State - parseQueryParam t = case Aeson.decode $ TL.encodeUtf8 $ TL.fromStrict t of - Nothing -> Left "Invalid JSON for a State" - Just tx -> pure tx - -instance FromForm State where - fromForm form = do - r <- parseMaybe "payment-state" form - case r of - Nothing -> pure NoState - Just tx -> pure tx - -data Signal - = AddReceiver Receiver - | DeleteReceiver Address - | Sign Password - | ExternallySign Transaction - | Unsign - | Submit - | Reset - -type Receivers = MonoidalMap Address (Sum Natural) - -data Payment m = Payment - { unsigned :: Receivers -> m Transaction - , sign :: Transaction -> Password -> m Transaction - , submit :: Transaction -> m () - , receivers :: Transaction -> m Receivers - } - -onReceivers - :: Monad m - => Payment m - -> Transaction - -> (Receivers -> Receivers) - -> m Receivers -onReceivers Payment{receivers} tx f = do - rs <- receivers tx - pure $ f rs - -deleteReceiver - :: Monad m => Payment m -> Transaction -> Address -> m State -deleteReceiver c tx a = do - rs' <- onReceivers c tx $ \r -> - MonoidalMap.filter (> 0) - $ MonoidalMap.delete a r - if null rs' - then pure NoState - else Unsigned <$> unsigned c rs' - -addReceiver - :: Monad m => Payment m -> Transaction -> Receiver -> m State -addReceiver c tx r = do - rs' <- onReceivers c tx $ \rs -> rs <> singleReceivers r - Unsigned <$> unsigned c rs' - -singleReceivers :: Receiver -> Receivers -singleReceivers Receiver{address, amount} = - MonoidalMap.singleton address (Sum amount) - -step :: Monad m => Payment m -> State -> Signal -> m (Maybe State) -step _ _ Reset = pure $ Just NoState -step c NoState (AddReceiver receiver) = do - tx <- unsigned c (singleReceivers receiver) - pure $ Just $ Unsigned tx -step c (Unsigned utx) (AddReceiver receiver) = do - Just <$> addReceiver c utx receiver -step c (Unsigned utx) (DeleteReceiver addr) = do - Just <$> deleteReceiver c utx addr -step c (Unsigned utx) (Sign pwd) = do - stx <- sign c utx pwd - pure $ Just $ Signed utx stx -step _ (Unsigned utx) (ExternallySign stx) = do - pure $ Just $ Signed utx stx -step c (Signed utx _) (AddReceiver receiver) = do - Just <$> addReceiver c utx receiver -step c (Signed utx _) (DeleteReceiver addr) = do - Just <$> deleteReceiver c utx addr -step c (Signed utx stx) Submit = do - submit c stx - pure $ Just $ Submitted utx stx -step _ _ _ = pure Nothing - -instance ToHttpApiData Address where - toUrlPiece = encodeAddress diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses.hs deleted file mode 100644 index a1914b60bfd..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Addresses -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , customerAddress - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - , walletPresence - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Data.Time - ( UTCTime - , getCurrentTime - ) -import Servant - ( Handler - ) - -import qualified Data.ByteString.Lazy.Char8 as BL - -getAddresses - :: SessionLayer WalletResource - -> (UTCTime -> WalletPresent -> html) -- success report - -> Handler html -getAddresses layer render = do - now <- liftIO getCurrentTime - render now <$> walletPresence layer - -getCustomerAddress - :: SessionLayer WalletResource - -> (Address -> html) - -> (BL.ByteString -> html) - -> Customer - -> Handler html -getCustomerAddress layer render alert customer = do - catchRunWalletResourceHtml layer alert render' - $ customerAddress customer - where - render' = \case - Just a -> render a - Nothing -> alert "Address not discovered" diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs deleted file mode 100644 index 292b6008672..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Addresses.Transactions -where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Map - ( F - , Map (..) - , W - , lookupMap - , unPatch - , value - ) -import Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) - ) -import Cardano.Wallet.Deposit.Pure - ( ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Address - , Slot - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , customerAddress - , getTxHistoryByCustomer - ) -import Cardano.Wallet.Read - ( TxId - , WithOrigin (..) - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer (..) - ) -import Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - ( TransactionHistoryParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - ) -import Cardano.Wallet.UI.Lib.Time.Direction - ( Match (..) - , filterByDirection - , sortByDirection - , utcTimeByDirection - ) -import Data.Bifunctor - ( first - ) -import Data.Monoid - ( First (..) - , Last (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) -import Servant - ( Handler - ) - -import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Map.Monoidal.Strict as MonoidalMap - -getCustomerHistory - :: SessionLayer WalletResource - -> ( TransactionHistoryParams - -> [(WithOrigin UTCTime, (Slot, TxId, ValueTransfer))] - -> html - ) - -> (BL.ByteString -> html) - -> TransactionHistoryParams - -> Handler html -getCustomerHistory - layer - render - alert - params@TransactionHistoryParams{..} = do - catchRunWalletResourceHtml layer alert id $ do - r <- customerAddress txHistoryCustomer - case r of - Nothing -> pure $ alert "Address not discovered" - Just _ -> do - h <- getTxHistoryByCustomer - pure - $ render params - $ filterByParams params - $ convert - $ snd <$> lookupMap txHistoryCustomer h - -convert - :: Maybe - (Map [F (First Address) DownTime, W (First Slot) TxId] ValueTransfer) - -> [(DownTime, (Slot, TxId, ValueTransfer))] -convert Nothing = [] -convert (Just mtxs) = concatMap f $ TimedSeq.toList $ value mtxs - where - f - :: Timed DownTime (Map '[W (First Slot) TxId] ValueTransfer) - -> [(DownTime, (Slot, TxId, ValueTransfer))] - f (Timed (Last (Just time)) txs) = do - (txId, Value (First (Just slot), v)) <- - MonoidalMap.assocs . value . unPatch $ txs - pure (time, (slot, txId, v)) - f _ = [] - -filterByParams - :: TransactionHistoryParams - -> [(DownTime, (Slot, TxId, ValueTransfer))] - -> [(WithOrigin UTCTime, (Slot, TxId, ValueTransfer))] -filterByParams TransactionHistoryParams{..} = - sortByDirection txHistorySorting fst - . filterByDirection - txHistorySorting - startTime - matchUTCTime - . fmap (first getDown) - . filterByTransfer - where - startTime = - utcTimeByDirection - txHistorySorting - txHistoryStartYear - txHistoryStartMonth - matchUTCTime (time, (_, _, _)) = - case time of - At t -> Match t - Origin -> DirectionMatch - filterByTransfer = case (txHistoryReceived, txHistorySpent) of - (True, False) -> - filter - ( \(_, (_, _, ValueTransferC{received})) -> - received /= mempty - ) - (False, True) -> - filter - ( \(_, (_, _, ValueTransferC{spent})) -> - spent /= mempty - ) - _ -> id diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Customers.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Customers.hs deleted file mode 100644 index 83d260a683e..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Customers.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use <$>" #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Deposits.Customers - ( depositCustomersPaginateM - , depositCustomersHandler - , AtTimeByCustomer - ) -where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Map - ( Map (..) - , W - , forgetPatch - , lookupFinger - , unPatch - , value - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByTime - , DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Address - , Slot - , WithOrigin (..) - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , getTxHistoryByTime - ) -import Cardano.Wallet.Read - ( TxId - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - ) -import Cardano.Wallet.UI.Lib.Discretization - ( nextDiscretizedTime - ) -import Cardano.Wallet.UI.Lib.Pagination.Map - ( Paginate (..) - , mkStrictMapPaginate - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( PaginateM - ) -import Control.Monad.Trans - ( lift - ) -import Control.Monad.Trans.Maybe - ( MaybeT (..) - , hoistMaybe - ) -import Data.Bifunctor - ( first - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap (..) - ) -import Data.Monoid - ( First (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime (..) - ) -import Servant - ( Handler - ) - -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map - -type AtTimeByCustomer = - Map - '[ W (First Slot) Customer - , W (First Address) TxId - ] - ValueTransfer - -depositCustomersPaginateM - :: forall m - . Monad m - => DepositsParams - -> m ByTime - -> DownTime - -> Int - -> PaginateM - m - Customer - (Map.Map Customer (Maybe Address, ValueTransfer)) -depositCustomersPaginateM - depositsParams - retrieveByTime - time - rows = - Paginate - { previousIndex = \customer -> runMaybeT $ do - Paginate{previousIndex} <- history - hoistMaybe $ previousIndex customer - , nextIndex = \customer -> runMaybeT $ do - Paginate{nextIndex} <- history - hoistMaybe $ nextIndex customer - , minIndex = runMaybeT $ do - Paginate{minIndex} <- history - hoistMaybe minIndex - , pageAtIndex = \k -> runMaybeT $ do - Paginate{pageAtIndex} <- history - hoistMaybe - $ fmap (fmap (first getFirst . fold . unPatch)) - <$> pageAtIndex k - } - where - history = - mkStrictMapPaginate rows - . getMonoidalMap - . value - . forgetPatch - <$> retrieveAtTimeByCustomer - retrieveByTime - depositsParams - time - -retrieveAtTimeByCustomer - :: Monad m - => m ByTime - -> DepositsParams - -> DownTime - -> MaybeT m AtTimeByCustomer -retrieveAtTimeByCustomer - retrieveByTime - DepositsParams{depositsFirstWeekDay, depositsWindow} - tStart = do - transfers' <- lift retrieveByTime - let tEnd = - fmap - (nextDiscretizedTime depositsFirstWeekDay depositsWindow) - <$> tStart - hoistMaybe - $ fmap snd - $ lookupFinger tEnd tStart transfers' - -depositCustomersHandler - :: SessionLayer WalletResource - -> (AtTimeByCustomer -> html) - -> (BL.ByteString -> html) - -> DepositsParams - -> WithOrigin UTCTime - -> Handler html -depositCustomersHandler - layer - render - alert - params - start = catchRunWalletResourceHtml layer alert id $ do - transfers <- - runMaybeT - $ retrieveAtTimeByCustomer - getTxHistoryByTime - params - (Down start) - pure $ case transfers of - Just customers -> render customers - Nothing -> - alert - "No deposits found for that time period" diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs deleted file mode 100644 index 5b1ec63bd76..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Deposits.Times - ( depositsPaginateM - ) -where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Map - ( unPatch - , value - ) -import Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) - ) -import Cardano.Wallet.Deposit.Pure - ( ValueTransfer - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByTime - , DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Slot - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Lib.Discretization - ( discretizeTime - ) -import Cardano.Wallet.UI.Lib.Pagination.Map - ( Paginate (..) - ) -import Cardano.Wallet.UI.Lib.Pagination.TimedSeq - ( mkTimedSeqPaginate - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( PaginateM - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Control.Monad.Trans - ( lift - ) -import Control.Monad.Trans.Maybe - ( MaybeT (..) - , hoistMaybe - ) -import Data.Bifunctor - ( Bifunctor (..) - , first - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Monoid - ( First (..) - , Last (..) - ) -import Data.Ord - ( Down (..) - ) - -import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq -import qualified Data.Map.Strict as Map - -depositsPaginateM - :: MonadIO m - => DepositsParams - -> m ByTime - -> Int - -> PaginateM - m - DownTime - (Map.Map DownTime (Maybe Slot, ValueTransfer)) -depositsPaginateM - DepositsParams{depositsFirstWeekDay, depositsWindow} - retrieveByTime - rows = - Paginate - { previousIndex = \t -> runMaybeT $ do - Paginate{previousIndex} <- lift history - hoistMaybe $ previousIndex t - , nextIndex = \t -> runMaybeT $ do - Paginate{nextIndex} <- lift history - hoistMaybe $ nextIndex t - , pageAtIndex = \t -> do - Paginate{pageAtIndex} <- history - pure - $ second - ( Map.fromList - . concatMap fromTimed - . TimedSeq.toList - ) - <$> pageAtIndex t - , minIndex = do - Paginate{minIndex} <- paginate <$> retrieveByTime - pure minIndex - } - where - discretize = discretizeTime depositsFirstWeekDay depositsWindow - paginate = mkTimedSeqPaginate bucket rows . id . value - history = paginate <$> retrieveByTime - bucket (Down t) = Down $ fmap discretize t - fromTimed (Timed (Last (Just t)) x) = - [(bucket t, first getFirst $ fold $ unPatch x)] - fromTimed _ = [] diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/TxIds.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/TxIds.hs deleted file mode 100644 index 3cb6f8bb731..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Deposits/TxIds.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use <$>" #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Deposits.TxIds - ( depositCustomersTxIdsPaginateM - , depositCustomersTxIdsHandler - , AtTimeAtCustomerByTxId - ) -where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Map - ( Map (..) - , W - , forgetPatch - , lookupFinger - , lookupMap - , value - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByTime - , DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Address - , WithOrigin (..) - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , getTxHistoryByTime - ) -import Cardano.Wallet.Read - ( TxId - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - ) -import Cardano.Wallet.UI.Lib.Discretization - ( nextDiscretizedTime - ) -import Cardano.Wallet.UI.Lib.Pagination.Map - ( Paginate (..) - , mkStrictMapPaginate - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( PaginateM - ) -import Control.Monad.Trans - ( lift - ) -import Control.Monad.Trans.Maybe - ( MaybeT (..) - , hoistMaybe - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap (..) - ) -import Data.Monoid - ( First (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime (..) - ) -import Servant - ( Handler - ) - -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map - -type AtTimeAtCustomerByTxId = - Map - '[ W (First Address) TxId - ] - ValueTransfer - -depositCustomersTxIdsPaginateM - :: forall m - . Monad m - => DepositsParams - -> m ByTime - -> DownTime - -> Customer - -> Int - -> PaginateM - m - TxId - (Map.Map TxId ValueTransfer) -depositCustomersTxIdsPaginateM - depositsParams - retrieveByTime - time - customer - rows = - Paginate - { previousIndex = \k -> runMaybeT $ do - Paginate{previousIndex} <- history - hoistMaybe $ previousIndex k - , nextIndex = \k -> runMaybeT $ do - Paginate{nextIndex} <- history - hoistMaybe $ nextIndex k - , minIndex = runMaybeT $ do - Paginate{minIndex} <- history - hoistMaybe minIndex - , pageAtIndex = \k -> runMaybeT $ do - Paginate{pageAtIndex} <- history - hoistMaybe $ do - (n, x) <- pageAtIndex k - pure (n, fmap fold x) - } - where - history = - mkStrictMapPaginate rows - . getMonoidalMap - . value - . forgetPatch - <$> retrieveAtTimeAtCustomerByTxId - retrieveByTime - depositsParams - time - customer - -retrieveAtTimeAtCustomerByTxId - :: Monad m - => m ByTime - -> DepositsParams - -> DownTime - -> Customer - -> MaybeT m AtTimeAtCustomerByTxId -retrieveAtTimeAtCustomerByTxId - retrieveByTime - DepositsParams{depositsFirstWeekDay, depositsWindow} - tStart - customerStart = - do - transfers' <- lift retrieveByTime - let tEnd = - fmap - (nextDiscretizedTime depositsFirstWeekDay depositsWindow) - <$> tStart - customers <- - hoistMaybe - $ fmap snd - $ lookupFinger tEnd tStart transfers' - hoistMaybe - $ fmap snd - $ lookupMap customerStart - $ forgetPatch customers - -depositCustomersTxIdsHandler - :: SessionLayer WalletResource - -> (AtTimeAtCustomerByTxId -> html) - -> (BL.ByteString -> html) - -> DepositsParams - -> WithOrigin UTCTime - -> Customer - -> Handler html -depositCustomersTxIdsHandler - layer - render - alert - params - start - customer = catchRunWalletResourceHtml layer alert id $ do - transfers <- - runMaybeT - $ retrieveAtTimeAtCustomerByTxId - getTxHistoryByTime - params - (Down start) - customer - pure $ case transfers of - Just txIds -> render txIds - Nothing -> - alert - "No deposits found for that time period and customer" diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Lib.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Lib.hs deleted file mode 100644 index 5f18df157c5..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Lib.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Handlers.Lib -where - -import Prelude - -import Cardano.Wallet.Deposit.IO.Resource - ( ResourceStatus (..) - , readStatus - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , runWalletResourceM - , walletPublicIdentity - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer (..) - , stateL - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent (..) - ) -import Control.Concurrent.STM - ( atomically - ) -import Control.Lens - ( view - ) -import Control.Monad.Reader - ( MonadReader (..) - ) -import Control.Monad.Trans - ( MonadIO (..) - ) -import Servant - ( Handler (..) - , err500 - ) - -import qualified Cardano.Wallet.Deposit.REST.Catch as REST -import qualified Data.ByteString.Lazy.Char8 as BL - -catchRunWalletResourceM - :: SessionLayer WalletResource - -> WalletResourceM a - -> Handler a -catchRunWalletResourceM layer f = do - r <- liftIO $ view stateL <$> state layer - REST.catchRunWalletResourceM r err500 f - -catchRunWalletResourceHtml - :: SessionLayer WalletResource - -> (BL.ByteString -> html) - -> (a -> html) - -> WalletResourceM a - -> Handler html -catchRunWalletResourceHtml layer alert render f = liftIO $ do - s <- view stateL <$> state layer - r <- runWalletResourceM f s - pure $ case r of - Left e -> alert $ BL.pack $ show e - Right a -> render a - -walletPresence :: SessionLayer WalletResource -> Handler WalletPresent -walletPresence session = catchRunWalletResourceM session $ do - s <- ask >>= liftIO . atomically . readStatus - case s of - Closed -> pure WalletAbsent - Open _ -> WalletPresent <$> walletPublicIdentity - Vanished e -> pure $ WalletVanished e - FailedToOpen e -> pure $ WalletFailedToInitialize e - Opening -> pure WalletInitializing - Closing -> pure WalletClosing diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs deleted file mode 100644 index 0dfc06d9b8b..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance - ( getAvailableBalance - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.REST - ( WalletResource - , availableBalance - ) -import Cardano.Wallet.Read - ( Coin (..) - , Value (..) - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - ) -import Servant - ( Handler - ) - -import qualified Data.ByteString.Lazy.Char8 as BL8 - -getAvailableBalance - :: SessionLayer WalletResource - -> (Coin -> html) - -> (BL8.ByteString -> html) - -> Handler html -getAvailableBalance layer render alert = - catchRunWalletResourceHtml layer alert id $ do - ValueC r _ <- availableBalance - pure $ render r diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs deleted file mode 100644 index fb1c4a49c57..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs +++ /dev/null @@ -1,488 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction -where - -import Prelude - -import Cardano.Binary - ( DecoderError - ) -import Cardano.Read.Ledger.Tx.CBOR - ( deserializeTx - , serializeTx - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( ErrPostTx - ) -import Cardano.Wallet.Deposit.Pure - ( BIP32Path - , CanSign - , ErrCreatePayment - , InspectTx (..) - ) -import Cardano.Wallet.Deposit.Pure.API.Address - ( NetworkTag (..) - , getNetworkTag - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , availableBalance - , canSign - , createPayment - , getBIP32PathsForOwnedInputs - , inspectTx - , networkTag - , resolveCurrentEraTx - , signTx - , submitTx - ) -import Cardano.Wallet.Deposit.Write - ( Tx - , resolvedTx - ) -import Cardano.Wallet.Read - ( Coin (..) - , Value (..) - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer - ) -import Cardano.Wallet.UI.Deposit.API.Payments - ( NewReceiverValidation (..) - , Password (..) - , Payment (..) - , Receivers - , Signal - , State - , StateA (..) - , Transaction (..) - , step - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - ) -import Control.Monad.Trans - ( MonadIO (..) - , lift - ) -import Control.Monad.Trans.Except - ( ExceptT (..) - , runExceptT - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Functor - ( (<&>) - ) -import Data.Semigroup - ( Sum (..) - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Data.Traversable - ( for - ) -import Servant - ( FromHttpApiData (..) - , Handler - ) - -import qualified Cardano.Wallet.Read.Tx as Read -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Base16.Lazy as BL16 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Monoidal.Strict as MonoidalMap -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL - -data PaymentError - = CreatePaymentError ErrCreatePayment - | DecodingError DecoderError - | StateTransitionImpossible - | PrivateKeyIsMissing - | SubmissionFailed ErrPostTx - deriving (Eq, Show) - -instance ToText PaymentError where - toText = \case - CreatePaymentError e -> "CreatePaymentError: " <> toText e - DecodingError e -> "DecodingError: " <> T.pack (show e) - StateTransitionImpossible -> "The state transition is impossible" - PrivateKeyIsMissing -> "Cannot sign without a private key" - SubmissionFailed e -> "SubmissionFailed: " <> T.pack (show e) - -extractReceivers :: InspectTx -> Receivers -extractReceivers InspectTx{otherOutputs, ourOutputs} = - fold $ do - (addr, coin) <- - otherOutputs - <> (ourOutputs <&> \(addr, _, c) -> (addr, c)) - pure $ MonoidalMap.singleton addr $ Sum $ fromIntegral coin - -mkPayment :: Payment (ExceptT PaymentError WalletResourceM) -mkPayment = - Payment - { unsigned = unsignedPayment - , sign = signPayment - , submit = submitPayment - , receivers = receiversPayment - } - -submitPayment - :: Transaction -> ExceptT PaymentError WalletResourceM () -submitPayment stx = do - let etx = deserializeTransaction stx - liftIO $ print etx - case etx of - Left e -> ExceptT $ pure $ Left $ DecodingError e - Right tx -> do - e <- do - liftIO $ print $ Read.getTxId tx - lift $ submitTx tx - case e of - Left e' -> ExceptT $ pure $ Left $ SubmissionFailed e' - Right () -> pure () - -signPayment - :: Transaction - -> Password - -> ExceptT PaymentError WalletResourceM Transaction -signPayment serializedTx (Password pwd) = do - let eUnsignedTx = deserializeTransaction serializedTx - case eUnsignedTx of - Left e -> ExceptT $ pure $ Left $ DecodingError e - Right unsignedTx -> do - mSignedTx <- lift $ signTx unsignedTx pwd - case mSignedTx of - Nothing -> ExceptT $ pure $ Left PrivateKeyIsMissing - Just signedTx -> do - paths <- lift $ getBIP32PathsForOwnedInputs signedTx - pure $ serializeTransaction paths signedTx - -receiversPayment - :: Transaction -> ExceptT PaymentError WalletResourceM Receivers -receiversPayment stx = do - let etx = deserializeTransaction stx - case etx of - Left e -> ExceptT $ pure $ Left $ DecodingError e - Right tx -> do - rtx <- lift $ resolveCurrentEraTx tx - itx <- lift $ inspectTx rtx - pure $ extractReceivers itx - -unsignedPayment - :: Receivers -> ExceptT PaymentError WalletResourceM Transaction -unsignedPayment receivers = do - er <- lift $ createPayment $ do - (address, Sum amount) <- MonoidalMap.assocs receivers - pure (address, ValueC (CoinC $ fromIntegral amount) mempty) - case er of - Left e -> ExceptT $ pure $ Left $ CreatePaymentError e - Right rtx -> do - paths <- lift $ getBIP32PathsForOwnedInputs $ resolvedTx rtx - pure $ serializeTransaction paths $ resolvedTx rtx - -serializeTransaction - :: [BIP32Path] - -> Tx - -> Transaction -serializeTransaction paths = - conwayEraTransactionExport paths - . T.decodeUtf8 - . B16.encode - . BL.toStrict - . serializeTx - -deserializeTransaction :: Transaction -> Either DecoderError Tx -deserializeTransaction = - deserializeTx - . BL16.decodeLenient - . TL.encodeUtf8 - . TL.fromStrict - . cborHex - -data PaymentHandlerResponse - = ResponseSuccess CanSign (StateA (Transaction, InspectTx)) - | ResponseExceptionPayments PaymentError - deriving (Eq, Show) - -signalHandler - :: SessionLayer WalletResource - -> (BL.ByteString -> html) - -- ^ Function to render the exception as HTML - -> ( Coin - -> PaymentHandlerResponse - -> html - ) - -> State - -> Signal - -> Handler html -signalHandler layer alert render state signal = do - catchRunWalletResourceHtml layer alert id $ do - ValueC available _ <- availableBalance - estate' <- runExceptT $ step mkPayment state signal - case estate' of - Left e -> pure $ render available $ ResponseExceptionPayments e - Right mstate -> - case mstate of - Nothing -> - pure - $ render available - $ ResponseExceptionPayments - StateTransitionImpossible - Just newState -> do - signing <- canSign - er <- for newState $ \stx -> do - let etx = deserializeTransaction stx - case etx of - Left e -> pure $ Left e - Right tx -> do - rtx <- resolveCurrentEraTx tx - itx <- inspectTx rtx - pure $ Right (stx, itx) - case sequence er of - Left e -> - pure - $ render available - $ ResponseExceptionPayments - $ DecodingError e - Right r -> do - pure - $ render available - $ ResponseSuccess signing - $ case r of - x -> x - -conwayEraTransactionExport :: [BIP32Path] -> Text -> Transaction -conwayEraTransactionExport bip32Paths cborHex = - Transaction - { dataType = "Unwitnessed Tx ConwayEra" - , description = "Ledger Cddl Format" - , cborHex - , bip32Paths - } - -data AddressValidationResponse - = ValidAddress Address Bool - | InvalidAddress Text - -data AmountValidationResponse - = ValidAmount Double Bool - | InvalidAmount Text - -tagEq :: NetworkTag -> NetworkTag -> Bool -tagEq MainnetTag MainnetTag = True -tagEq TestnetTag TestnetTag = True -tagEq _ _ = False - -showTag :: NetworkTag -> Text -showTag MainnetTag = "Mainnet" -showTag TestnetTag = "Testnet" - -receiverAddressValidation - :: SessionLayer WalletResource - -> (BL.ByteString -> html) - -> (AddressValidationResponse -> html) - -> NewReceiverValidation - -> Handler html -receiverAddressValidation layer alert render nrv = do - catchRunWalletResourceHtml layer alert id $ do - tag <- networkTag - pure $ render $ addressValidationPure tag nrv - -addressValidationPure - :: NetworkTag -> NewReceiverValidation -> AddressValidationResponse -addressValidationPure tag nrv@NewReceiverValidation{addressValidation} = - case parseUrlPiece <$> addressValidation of - Nothing -> InvalidAddress "Address cannot be empty" - Just (Left e) -> InvalidAddress $ "Invalid address: " <> e - Just (Right addr) - | getNetworkTag addr `tagEq` tag -> - ValidAddress addr - $ case amountValidationPure tag nrv of - ValidAmount _ _ -> True - _ -> False - | otherwise -> - InvalidAddress - $ "Address is not on the " - <> showTag tag - <> " network" - -receiverAmountValidation - :: SessionLayer WalletResource - -> (BL.ByteString -> html) - -> (AmountValidationResponse -> html) - -> NewReceiverValidation - -> Handler html -receiverAmountValidation layer alert render nrv = - catchRunWalletResourceHtml layer alert id $ do - tag <- networkTag - pure $ render $ amountValidationPure tag nrv - -amountValidationPure - :: NetworkTag -> NewReceiverValidation -> AmountValidationResponse -amountValidationPure tag nrv@NewReceiverValidation{amountValidation} = - case parseUrlPiece <$> amountValidation of - Nothing -> InvalidAmount "Amount cannot be empty" - Just (Left e) -> InvalidAmount $ "Invalid amount: " <> e - Just (Right amount) - | amount <= 0 -> InvalidAmount "Amount must be positive" - | otherwise -> ValidAmount amount - $ case addressValidationPure tag nrv of - ValidAddress _ _ -> True - _ -> False - --- x = --- Signed --- ( Transaction --- { dataType = "Unwitnessed Tx ConwayEra" --- , description = "Ledger Cddl Format" --- , cborHex = --- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661 413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba8830 12bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a0f5f6" --- } --- ) --- ( Transaction --- { dataType = "Unwitnessed Tx ConwayEra" --- , description = "Ledger Cddl Fo rmat" --- , cborHex = --- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018 282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a1 00d90102828258202390837b235279492bcf075e3c272bff29affa11b9a8d889d4b726f596f56b835840f605c66ea76391740c413bf07c33b3388c1e30de51e95ce5779405a4aa250febc521c4bdd8f7e0bc2e0556e96247bcf 1354656911c17158b0f5b65834d4ca505825820fb5939a080736db07e626c777c47c8d27f428ab52b3d08a5b163e6988fc743b058408daf8a9a8d4a88a5af76948869cf4f346dbef620a57864a4d9514d5ba3800c0b60b9bd97 6bbb56494e5249cdaef9ba466c6c84360528ca2b7bbaf07ce02d6c0cf5f6" --- } --- , InspectTx --- { ourInputs = --- [ --- ( TxId --- { unTxId = --- SafeHash --- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" --- } --- , TxIx{unTxIx = 0} --- , Coin 1234000000 --- ) --- , --- ( TxId --- { unTxId = --- SafeHash --- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" --- } --- , TxIx{unTxIx = 1} --- , Coin 998765834015 --- ) --- ] --- , otherInputs = [] --- , change = --- [ --- ( Addr --- Testnet --- ( KeyHashObj --- ( KeyHash --- { unKeyHash = "3ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c" --- } --- ) --- ) --- StakeRefNull --- , Coin 998765662002 --- ) --- ] --- , ourOutputs = --- [ --- ( Add --- r --- Testnet --- ( KeyHashObj --- ( KeyHash --- { unKeyHash = "b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea" --- } --- ) --- ) --- StakeRefNull --- , 1 --- , Coin 1234000000 --- ) --- ] --- , otherOutputs = [] --- , fee = Coin 172013 --- } --- ) - --- y = --- Submitted --- ( Transaction --- { dataType = "Unwitnessed Tx ConwayEra" --- , description = "Ledger Cddl Format" --- , cborHex = --- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a0f5f6" --- } --- ) --- ( Transaction --- { dataType = "Unwitnessed Tx ConwayEra" --- , description = "Ledger Cddl Format" --- , cborHex = --- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a100d90102828258202390837b235279492bcf075e3c272bff29affa11b9a8d889d4b726f596f56b835840f605c66ea76391740c413bf07c33b3388c1e30de51e95ce5779405a4aa250febc521c4bdd8f7e0bc2e0556e96247bcf1354656911c17158b0f5b65834d4ca505825820fb5939a080736db07e626c777c47c8d27f428ab52b3d08a5b163e6988fc743b058408daf8a9a8d4a88a5af76948869cf4f346dbef620a57864a4d9514d5ba3800c0b60b9bd976bbb56494e5249cdaef9ba466c6c84360528ca2b7bbaf07ce02d6c0cf5f6" --- } --- , InspectTx --- { ourInputs = [] --- , otherInputs = --- [ --- ( TxId --- { unTxId = --- SafeHash --- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" --- } --- , TxIx{unTxIx = 0} --- ) --- , --- ( TxId --- { unTxId = --- SafeHash --- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" --- } --- , TxIx{unTxIx = 1} --- ) --- ] --- , change = --- [ --- ( Addr --- Testnet --- ( KeyHashObj --- ( KeyHash --- { unKeyHash = "3ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c" --- } --- ) --- ) --- StakeRefNull --- , Coin 998765662002 --- ) --- ] --- , ourOutputs = --- [ --- ( Addr --- Testnet --- ( KeyHashObj --- ( KeyHash --- { unKeyHash = "b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea" --- } --- ) --- ) --- StakeRefNull --- , 1 --- , Coin 1234000000 --- ) --- ] --- , otherOutputs = [] --- , fee = Coin 172013 --- } --- ) diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Wallet.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Wallet.hs deleted file mode 100644 index bfc06d0a9d9..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Handlers/Wallet.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Redundant <$>" #-} - -module Cardano.Wallet.UI.Deposit.Handlers.Wallet -where - -import Prelude - -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv (slotToUTCTime) - ) -import Cardano.Wallet.Deposit.Pure - ( Credentials - , Customer - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( createMnemonicFromWords - , credentialsFromEncodedXPub - , credentialsFromMnemonics - ) -import Cardano.Wallet.Deposit.Read - ( slotFromChainPoint - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , availableBalance - , getWalletTip - , networkTag - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic (..) - , PostWalletViaXPub (..) - ) -import Cardano.Wallet.UI.Common.Layer - ( Push (Push) - , SessionLayer (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceHtml - , walletPresence - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent - ) -import Cardano.Wallet.UI.Deposit.Types.Wallet - ( Status (..) - ) -import Control.Monad.Trans - ( MonadIO (..) - ) -import Servant - ( Handler - ) - -import qualified Data.ByteString.Lazy.Char8 as BL - -getWallet - :: SessionLayer WalletResource - -> (WalletPresent -> html) -- success report - -> Handler html -getWallet layer render = do - presence <- walletPresence layer - pure $ render presence - -initWalletWithXPub - :: SessionLayer WalletResource - -> (BL.ByteString -> html) - -> (() -> html) - -> (WalletResourceM ()) - -> Handler html -initWalletWithXPub l@SessionLayer{sendSSE} alert render initWallet = do - liftIO $ sendSSE $ Push "wallet" - r <- catchRunWalletResourceHtml l alert render initWallet - liftIO $ sendSSE $ Push "wallet" - pure r - -postMnemonicWallet - :: SessionLayer WalletResource - -> (Credentials -> Customer -> WalletResourceM ()) - -> (BL.ByteString -> html) - -> (() -> html) - -> PostWalletViaMnemonic - -> Handler html -postMnemonicWallet - l - initWallet - alert - render - (PostWalletViaMnemonic mnemonic passphrase customers) = do - case createMnemonicFromWords mnemonic of - Left e -> pure $ alert $ BL.pack $ show e - Right mnemonic' -> do - let credentials = credentialsFromMnemonics mnemonic' passphrase - initWalletWithXPub l alert render - $ initWallet credentials - $ fromIntegral customers - -postXPubWallet - :: SessionLayer WalletResource - -> (Credentials -> Customer -> WalletResourceM ()) - -> (BL.ByteString -> html) - -> (() -> html) - -> PostWalletViaXPub - -> Handler html -postXPubWallet - l - initWallet - alert - render - (PostWalletViaXPub xpubText customers) = - case credentialsFromEncodedXPub xpubText of - Left e -> pure $ alert $ BL.pack $ show e - Right credentials -> - initWalletWithXPub l alert render - $ initWallet credentials - $ fromIntegral customers - -walletIsLoading - :: SessionLayer WalletResource - -> (WalletPresent -> html) - -> Handler html -walletIsLoading layer render = render <$> walletPresence layer - -deleteWalletHandler - :: SessionLayer WalletResource - -> WalletResourceM () - -- ^ deleteWallet - -> (BL.ByteString -> html) - -> (() -> html) - -> Handler html -deleteWalletHandler layer deleteWallet alert render = - catchRunWalletResourceHtml layer alert render deleteWallet - -getStatusRest :: NetworkEnv IO x -> WalletResourceM Status -getStatusRest nenv = do - tip <- getWalletTip - slotToTime <- liftIO $ slotToUTCTime nenv - Status - <$> pure tip - <*> pure (slotToTime $ slotFromChainPoint tip) - <*> availableBalance - <*> networkTag -getStatus - :: NetworkEnv IO x - -> SessionLayer WalletResource - -> (BL.ByteString -> html) - -> (Status -> html) - -> Handler html -getStatus nenv layer alert render = do - catchRunWalletResourceHtml layer alert id $ do - render <$> getStatusRest nenv diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Common.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Common.hs deleted file mode 100644 index 3c45951bcda..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Common.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Wallet.UI.Deposit.Html.Common - ( downTimeH - , timeH - , slotH - , txIdH - , showTime - , showTimeSecs - , withOriginH - , valueH - , lovelaceH - , modalElementH - , chainPointToSlotH - , networkTagH - , addressH - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure.API.Address - ( encodeAddress - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Address - , NetworkTag (..) - , Slot - , TxId - , WithOrigin (..) - ) -import Cardano.Wallet.Read - ( ChainPoint (..) - , Coin (..) - , SlotNo (..) - , Value (..) - , hashFromTxId - ) -import Cardano.Wallet.Read.Hash - ( hashToStringAsHex - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( WithCopy (..) - , dataBsDismiss_ - , truncatableText - ) -import Cardano.Wallet.UI.Common.Html.Modal - ( ModalData (..) - , mkModal - ) -import Data.Ord - ( Down (..) - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Data.Time - ( UTCTime - , defaultTimeLocale - , formatTime - ) -import Lucid - ( Html - , HtmlT - , ToHtml (..) - , button_ - , class_ - , span_ - ) -import Numeric - ( showFFloatAlt - ) -import Numeric.Natural - ( Natural - ) - -showTime :: UTCTime -> String -showTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M" - -showTimeSecs :: UTCTime -> String -showTimeSecs = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" - -withOriginH :: (a -> Html ()) -> WithOrigin a -> Html () -withOriginH f = \case - Origin -> "Origin" - At a -> f a - -timeH :: UTCTime -> Html () -timeH = toHtml . showTime - -downTimeH :: DownTime -> Html () -downTimeH (Down time) = withOriginH timeH time - -slotH :: Slot -> Html () -slotH = \case - Origin -> "Origin" - At (SlotNo s) -> toHtml $ show s - -chainPointToSlotH - :: ChainPoint - -> Html () -chainPointToSlotH cp = case cp of - GenesisPoint -> toHtml ("Genesis" :: Text) - BlockPoint (SlotNo n) _ -> toHtml $ show n - -networkTagH :: NetworkTag -> Html () -networkTagH = toHtml . showTag - -showTag :: NetworkTag -> Text -showTag MainnetTag = "Mainnet" -showTag TestnetTag = "Testnet" - -txIdH :: TxId -> Html () -txIdH txId = - truncatableText WithCopy ("tx-id-text-" <> toText (take 16 h)) - $ toHtml h - where - h = - hashToStringAsHex - $ hashFromTxId - txId - -valueH :: Value -> Html () -valueH (ValueC (CoinC c) _) = lovelaceH $ fromIntegral c - -lovelaceH :: Natural -> Html () -lovelaceH c = do - span_ $ toHtml $ showLovelaceAsAda c - span_ [class_ "opacity-25"] "₳" - -showLovelaceAsAda :: Integral a => a -> String -showLovelaceAsAda c = - showFFloatAlt @Double (Just 2) (fromIntegral c / 1_000_000) "" - -modalElementH :: Maybe Text -> Maybe Text -> Html () -modalElementH (Just t) (Just b) = - mkModal - $ ModalData - { modalTitle = toHtml t - , modalBody = toHtml b - , modalFooter = - button_ - [ class_ "btn btn-secondary" - , dataBsDismiss_ "modal" - ] - "Dismiss" - } -modalElementH _ _ = mempty - -addressH :: Monad m => WithCopy -> Address -> HtmlT m () -addressH copy addr = - truncatableText copy ("address-text-" <> encodedAddr) - $ toHtml encodedAddr - where - encodedAddr = encodeAddress addr diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/About.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/About.hs deleted file mode 100644 index a1788414225..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/About.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Html.Pages.About where - -import Prelude - -import Cardano.Wallet.UI.Common.Html.Pages.Template.Footer - ( footerH - ) -import Lucid - ( HtmlT - , p_ - ) - -aboutH :: Monad m => HtmlT m () -aboutH = do - p_ "Cardano Deposit Wallet web UI, pre-alpha version" - footerH diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses.hs deleted file mode 100644 index 27e8a6d37b6..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Addresses -where - -import Prelude - -import Cardano.Wallet.Deposit.IO - ( WalletPublicIdentity (..) - ) -import Cardano.Wallet.Deposit.Pure.API.Address - ( encodeAddress - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxInclude_ - , hxPost_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( AlertH - , WithCopy - , linkText - , truncatableText - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( AssocRow - , Striped (..) - , Width (..) - , box - , record - , simpleField - , sseH - ) -import Cardano.Wallet.UI.Deposit.API - ( addressesLink - , customerAddressLink - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Addresses.Transactions - ( transactionsElementH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent (..) - , onWalletPresentH - ) -import Cardano.Wallet.UI.Lib.ListOf - ( ListOf - ) -import Cardano.Wallet.UI.Type - ( WHtml - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Data.Time - ( UTCTime - ) -import Lucid - ( Html - , HtmlT - , ToHtml (..) - , class_ - , div_ - , id_ - , input_ - , min_ - , name_ - , style_ - , type_ - , value_ - ) -import Lucid.Html5 - ( max_ - , size_ - , step_ - ) -import Servant - ( Link - ) - -addressesH :: WHtml () -addressesH = do - sseH addressesLink "addresses" ["wallet"] - -customerAddressH :: Monad m => WithCopy -> Address -> HtmlT m () -customerAddressH copy addr = - truncatableText copy ("address-text-" <> encodedAddr) - $ toHtml encodedAddr - where - encodedAddr = encodeAddress addr - -addressElementH - :: UTCTime -> UTCTime -> AlertH -> WalletPresent -> Html () -addressElementH now origin = onWalletPresentH $ \case - WalletPublicIdentity _xpub customers -> - div_ [id_ "view-control"] $ do - div_ [class_ "row mt-2 gx-0"] $ do - box "Selection" mempty - $ div_ [class_ "col"] - $ record (Just 11) Full Striped - $ do - selectCustomerH - "#customer-address" - (Just "#view-control") - customerAddressLink - $ fromIntegral customers - simpleField "Address" - $ div_ - [ id_ "customer-address" - ] - mempty - transactionsElementH now origin - -selectCustomerH - :: Monad m - => Text - -- ^ CSS selector for the target element - -> Maybe Text - -- ^ HTMX include - -> Link - -- ^ post link - -> Int - -- ^ Number of tracked users - -> ListOf (AssocRow m) -selectCustomerH identifier include link trackedUsers = - simpleField "Customer Number" - $ div_ [class_ "d-flex justify-content-end align-items-center"] - $ input_ - $ [ id_ "select-customer" - , type_ "number" - , hxTarget_ identifier - , class_ "form-control m-1 p-1" - , hxTrigger_ "load, change" - , hxPost_ $ linkText link - , min_ "0" - , max_ $ toText $ trackedUsers - 1 - , step_ "1" - , name_ "customer" - , value_ "0" - , size_ "5" - , style_ "width: 7em" - ] - <> maybe [] (\x -> [hxInclude_ x]) include diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs deleted file mode 100644 index 7d214c273c1..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Addresses.Transactions -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( ValueTransfer - , received - , spent - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( linkText - , tdEnd - , thEnd - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( Striped (..) - , Width (..) - , box - , record - , simpleField - ) -import Cardano.Wallet.UI.Deposit.API - ( customerHistoryLink - ) -import Control.Monad - ( forM_ - , when - ) -import Lucid - ( Html - , HtmlT - , ToHtml (..) - , button_ - , checked_ - , class_ - , data_ - , div_ - , i_ - , id_ - , input_ - , name_ - , option_ - , scope_ - , select_ - , selected_ - , style_ - , table_ - , tbody_ - , thead_ - , tr_ - , type_ - , value_ - ) - -import Cardano.Wallet.Deposit.Read - ( Slot - , TxId - , WithOrigin - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxInclude_ - , hxPost_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - ( TransactionHistoryParams (..) - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( slotH - , timeH - , txIdH - , valueH - , withOriginH - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime (..) - , pattern YearMonthDay - ) - -import qualified Cardano.Wallet.Read as Read -import qualified Data.Text.Class as T - -chainPointToSlotH - :: Read.ChainPoint - -> Html () -chainPointToSlotH cp = case cp of - Read.GenesisPoint -> toHtml ("Genesis" :: Text) - Read.BlockPoint (Read.SlotNo n) _ -> toHtml $ show n - -txSummaryH - :: TransactionHistoryParams - -> (WithOrigin UTCTime, (Slot, TxId, ValueTransfer)) - -> Html () -txSummaryH - TransactionHistoryParams{..} - (time, (slot, txId, value)) = do - tr_ [scope_ "row"] $ do - when txHistorySlot - $ tdEnd - $ slotH slot - when txHistoryUTC - $ tdEnd - $ withOriginH timeH time - when txHistoryReceived - $ tdEnd - $ valueH - $ received value - when txHistorySpent - $ tdEnd - $ valueH - $ spent value - tdEnd $ txIdH txId - -customerHistoryH - :: Monad m - => TransactionHistoryParams - -> [(WithOrigin UTCTime, (Slot, TxId, ValueTransfer))] - -> HtmlT m () -customerHistoryH params@TransactionHistoryParams{..} txs = - table_ - [ class_ "table table-sm table-borderless table-striped table-hover m-0" - ] - $ do - thead_ - $ tr_ - [ scope_ "row" - , class_ "sticky-top my-1" - , style_ "z-index: 1" - ] - $ do - when txHistorySlot - $ thEnd (Just 7) "Slot" - when txHistoryUTC - $ thEnd (Just 10) "Time" - when txHistoryReceived - $ thEnd (Just 7) "Deposit" - when txHistorySpent - $ thEnd (Just 7) "Withdrawal" - thEnd Nothing "Id" - tbody_ - $ mapM_ (toHtml . txSummaryH params) txs - -yearOf :: UTCTime -> Integer -yearOf UTCTime{utctDay = YearMonthDay year _ _} = year - -monthOf :: UTCTime -> Int -monthOf UTCTime{utctDay = YearMonthDay _ month _} = month - -monthsH :: UTCTime -> Html () -monthsH now = do - select_ - [ class_ "form-select w-auto m-1 p-1" - , id_ "select-month" - , name_ "start-month" - , style_ "background-image: none" - ] - $ forM_ [1 .. 12] - $ \month -> do - let select = - if month == monthOf now - then ([selected_ ""] <>) - else id - option_ (select [value_ $ T.toText month]) - $ toHtml - $ T.toText month - -yearsH :: UTCTime -> UTCTime -> Html () -yearsH now origin = do - let firstYear = yearOf origin - lastYear = yearOf now - select_ - [ class_ "form-select w-auto m-1 p-1" - , id_ "select-year" - , name_ "start-year" - , style_ "background-image: none" - ] - $ forM_ [firstYear .. lastYear] - $ \year -> do - let select = - if year == lastYear - then ([selected_ ""] <>) - else id - option_ (select [value_ $ T.toText year]) - $ toHtml - $ T.toText year - -transactionsViewControls :: UTCTime -> UTCTime -> Html () -transactionsViewControls now origin = - div_ [class_ "collapse", id_ "columns-control"] $ do - record Nothing Auto NotStriped $ do - simpleField "UTC" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-utc" - , hxTrigger_ "change" - , name_ "utc" - , value_ "" - , checked_ - ] - simpleField "Slot" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-slot" - , name_ "slot" - , value_ "" - ] - simpleField "Deposit" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-deposit" - , name_ "received" - , value_ "" - , checked_ - ] - simpleField "Withdrawal" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-withdrawal" - , name_ "spent" - , value_ "" - ] - simpleField "Sorting" - $ div_ - [ class_ "d-flex justify-content-end align-items-center" - ] - $ select_ - [ class_ "form-select w-auto m-1 p-1" - , id_ "select-sorting" - , name_ "sorting" - , style_ "background-image: none" - ] - $ do - option_ [selected_ "", value_ "desc"] "Descending" - option_ [value_ "asc"] "Ascending" - simpleField "From" - $ div_ - [ class_ "d-flex justify-content-end align-items-center" - ] - $ do - yearsH now origin - monthsH now - -transactionsElementH :: UTCTime -> UTCTime -> Html () -transactionsElementH now origin = do - div_ - [ class_ "row mt-2 gx-0" - , hxTrigger_ - "load\ - \, change from:#toggle-utc\ - \, change from:#select-customer\ - \, change from:#toggle-slot\ - \, change from:#toggle-deposit\ - \, change from:#toggle-withdrawal\ - \, change from:#select-sorting\ - \, change from:#select-month\ - \, change from:#select-year" - , hxInclude_ "#view-control" - , hxPost_ $ linkText customerHistoryLink - , hxTarget_ "#transactions" - ] - $ do - let configure = - div_ [class_ "d-flex justify-content-end p-0"] $ do - let toggle = button_ - [ class_ "btn p-0" - , type_ "button" - , data_ "bs-toggle" "collapse" - , data_ "bs-target" "#columns-control" - ] - $ div_ - $ do - i_ [class_ "bi bi-gear"] mempty - div_ $ do - div_ - [class_ "d-flex justify-content-end"] - toggle - div_ [class_ "mt-1"] - $ transactionsViewControls now origin - box "Transactions" configure $ do - div_ [class_ "row gx-0"] $ do - div_ - [ class_ "col" - , id_ "transactions" - ] - mempty diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Customers.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Customers.hs deleted file mode 100644 index 79d76c3beb0..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Customers.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Customers - ( scrollableDepositsCustomers - , depositByCustomerH - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Address - , WithOrigin - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxInclude_ - , hxPost_ - , hxSwap_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( linkText - , tdEnd - , thEnd - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( box - ) -import Cardano.Wallet.UI.Deposit.API.Common - ( Expand (..) - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( valueH - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( Paginate (..) - , PaginateM - ) -import Control.Lens - ( _1 - , view - ) -import Control.Monad - ( when - ) -import Data.List - ( sortOn - ) -import Data.Map.Strict - ( Map - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) -import Lucid - ( Attribute - , Html - , ToHtml (..) - ) -import Lucid.Html5 - ( button_ - , class_ - , colspan_ - , div_ - , i_ - , id_ - , input_ - , name_ - , scope_ - , style_ - , table_ - , tbody_ - , td_ - , thead_ - , tr_ - , type_ - , value_ - ) -import Servant - ( Link - , ToHttpApiData (toUrlPiece) - ) - -import qualified Cardano.Wallet.UI.Common.Html.Scrolling as Scrolling -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -scrollableDepositsCustomers - :: Monad m - => DepositsParams - -> (Maybe (WithOrigin UTCTime) -> Maybe Customer -> Link) - -> (Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe Expand -> Link) - -> DownTime - -> PaginateM m Customer (Map Customer (Maybe Address, ValueTransfer)) - -> Scrolling.Configuration m Customer -scrollableDepositsCustomers - params@DepositsParams{depositsSpent} - depositsCustomersPaginatingLink - depositsTxIdsLink - (Down time) - Paginate{previousIndex, nextIndex, pageAtIndex, minIndex} = - Scrolling.Configuration{..} - where - scrollableWidget :: [Attribute] -> Html () -> Html () - scrollableWidget attrs content = do - let attrs' = - [ class_ "table table-sm table-borderless table-striped table-hover m-0" - ] - table_ (attrs' <> attrs) - $ do - thead_ [class_ "bg-primary"] - $ tr_ - [ scope_ "row" - , class_ "sticky-top my-1" - , style_ "z-index: 2" - ] - $ do - thEnd (Just 6) "Customer" - thEnd (Just 7) "Deposit" - when depositsSpent - $ thEnd (Just 7) "Spent" - content - scrollableContainer = table_ - retrieveContent customer attrs = do - mxs <- pageAtIndex customer - case mxs of - Nothing -> pure mempty - Just (_, xs) -> - pure - $ tbody_ attrs - $ mapM_ - ( \transfers -> - depositByCustomerH - params - depositsTxIdsLink - Nothing - (Down time) - transfers - mempty - ) - $ sortOn (view _1) - $ Map.assocs xs - uniqueScrollingId = "deposit-customers" - presentFieldName = "customers-paginating-presence" - controlSelector = "#view-control" - renderIndex = toUrlPiece - updateURL c = - linkText - $ depositsCustomersPaginatingLink - (Just time) - (Just c) - renderIdOfIndex = T.replace " " "-" . toUrlPiece - -depositByCustomerH - :: DepositsParams - -> (Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe Expand -> Link) - -> Maybe Expand - -> DownTime - -> (Customer, (Maybe Address, ValueTransfer)) - -> ([Attribute] -> Html ()) - -> Html () -depositByCustomerH - DepositsParams{depositsSpent} - depositsTxIdsLink - mexpand - (Down time) - (customer, (_addr, ValueTransferC{received, spent})) - widget - | expand = do - let trId = T.pack $ "customers-tx-ids-" <> show customer - tr_ - [ id_ trId - ] - $ do - let spentColumn = if depositsSpent then succ else id - columns = - T.pack - $ show - $ spentColumn (2 :: Int) - bar = - div_ $ do - div_ $ toHtml $ "Cutomer: " <> show customer - close = - button_ - [ class_ "btn p-1" - , type_ "button" - , hxTarget_ $ "#" <> trId - , hxSwap_ "outerHTML" - , hxPost_ $ txIdsPost (Just Collapse) - , hxInclude_ "#view-control" - ] - $ i_ [class_ "bi bi-x"] mempty - td_ [colspan_ columns, class_ "p-0"] $ box bar close $ do - widget [class_ "ps-1"] - input_ - [ type_ "hidden" - , name_ "tx-ids" - , value_ $ toUrlPiece time - ] - | otherwise = do - let trId = T.pack $ "customers-tx-ids-" <> show customer - tr_ - [ scope_ "row" - , hxTrigger_ "click" - , hxTarget_ "this" - , hxSwap_ "outerHTML" - , hxPost_ $ txIdsPost (Just Expand) - , hxInclude_ "#view-control" - , id_ trId - ] - $ do - tdEnd $ toHtml $ show customer - tdEnd $ valueH received - when depositsSpent - $ tdEnd - $ valueH spent - where - txIdsPost = - linkText - . depositsTxIdsLink - (Just time) - (Just customer) - expand = Just Expand == mexpand diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Page.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Page.hs deleted file mode 100644 index 5a6817a4d47..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Page.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Page - ( depositsH - , depositsElementH - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.IO - ( WalletPublicIdentity (..) - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxInclude_ - , hxPost_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( AlertH - , linkText - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( Striped (..) - , Width (..) - , box - , record - , simpleField - , sseH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent (..) - , onWalletPresentH - ) -import Cardano.Wallet.UI.Lib.Discretization - ( Window (..) - ) -import Cardano.Wallet.UI.Type - ( WHtml - ) -import Control.Monad - ( forM_ - ) -import Data.Text.Class - ( ToText (..) - ) -import Data.Time - ( DayOfWeek (..) - ) -import Lucid - ( Html - , ToHtml (..) - , button_ - , class_ - , data_ - , div_ - , i_ - , id_ - , input_ - , name_ - , option_ - , select_ - , selected_ - , style_ - , type_ - , value_ - ) -import Servant - ( Link - , ToHttpApiData (toUrlPiece) - ) - -depositsH :: Link -> WHtml () -depositsH depositsLink = do - sseH depositsLink "deposits-page" ["wallet"] - -depositsViewControls :: Html () -depositsViewControls = - div_ [class_ "collapse", id_ "columns-control"] $ do - record Nothing Auto NotStriped $ do - simpleField "Week Start" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ select_ - [ class_ "form-select w-auto m-1 p-1" - , id_ "select-first-week-day" - , name_ "first-week-day" - , style_ "background-image: none" - ] - $ forM_ [Sunday, Monday] - $ \day -> do - let selected = case day of - Monday -> (selected_ "" :) - _ -> id - option_ (selected [value_ $ toUrlPiece day]) - $ toHtml - $ show day - simpleField "Slot" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-slot" - , name_ "slot" - , value_ "" - ] - simpleField "Window" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ select_ - [ class_ "form-select w-auto m-1 p-1" - , id_ "select-window" - , name_ "window" - , style_ "background-image: none" - ] - $ forM_ [Minute5 .. Year] - $ \window -> do - let selected = case window of - Day -> (selected_ "" :) - _ -> id - option_ (selected [value_ $ toUrlPiece window]) - $ toHtml - $ toText window - simpleField "Spent" - $ div_ - [ class_ "d-flex justify-content-end align-items-center form-check" - ] - $ input_ - [ class_ "form-check-input" - , type_ "checkbox" - , id_ "toggle-spent" - , name_ "spent" - , value_ "" - ] - -depositsElementH - :: Link - -> AlertH - -> WalletPresent - -> Html () -depositsElementH depositsHistoryLink = onWalletPresentH $ \case - WalletPublicIdentity _xpub _customers -> - div_ - [ class_ "row mt-3 gx-0" - ] - $ do - let configure = do - div_ [class_ "d-flex justify-content-end"] $ do - let toggle = - button_ - [ class_ "btn p-0" - , type_ "button" - , data_ "bs-toggle" "collapse" - , data_ "bs-target" "#columns-control" - ] - $ do - i_ [class_ "bi bi-gear"] mempty - div_ - [ id_ "view-control" - , hxTrigger_ - "load\ - \, change from:#select-first-week-day\ - \, change from:#select-customer\ - \, change from:#toggle-slot\ - \, change from:#select-window\ - \, change from:#toggle-spent\ - \" - , hxInclude_ "#view-control , #deposits" - , hxPost_ $ linkText depositsHistoryLink - , hxTarget_ "#deposits" - ] - $ do - div_ [class_ "d-flex justify-content-end"] - toggle - div_ [class_ "mt-1"] - depositsViewControls - box "Deposits by Time" configure $ do - div_ [class_ "row gx-0"] - $ div_ - [ class_ "col" - , id_ "deposits" - ] - mempty diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Times.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Times.hs deleted file mode 100644 index 2bae01ca4fa..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/Times.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Times - ( depositH - , scrollableDeposits - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( Slot - , WithOrigin (..) - ) -import Cardano.Wallet.Read - ( SlotNo (..) - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxInclude_ - , hxPost_ - , hxSwap_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( linkText - , tdEnd - , thEnd - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( box - ) -import Cardano.Wallet.UI.Deposit.API.Common - ( Expand (..) - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( downTimeH - , valueH - ) -import Cardano.Wallet.UI.Lib.Discretization - ( nextDiscretizedTime - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( Paginate (..) - , PaginateM - ) -import Control.Monad - ( when - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Data.Hashable - ( Hashable (..) - ) -import Data.Map.Strict - ( Map - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) -import Lucid - ( Attribute - , Html - , ToHtml (..) - , button_ - , class_ - , colspan_ - , div_ - , i_ - , id_ - , input_ - , name_ - , scope_ - , style_ - , table_ - , tbody_ - , td_ - , thead_ - , tr_ - , type_ - , value_ - ) -import Servant - ( Link - , ToHttpApiData (toUrlPiece) - ) - -import qualified Cardano.Wallet.UI.Common.Html.Scrolling as Scrolling -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -scrollableDeposits - :: MonadIO m - => (Maybe (WithOrigin UTCTime) -> Link) - -> (Maybe (WithOrigin UTCTime) -> Maybe Expand -> Link) - -> DepositsParams - -> PaginateM - m - DownTime - (Map DownTime (Maybe Slot, ValueTransfer)) - -> Scrolling.Configuration m DownTime -scrollableDeposits - depositsHistoryPageLink - depositsCustomersLink - params@DepositsParams{depositsSpent, depositsSlot} - Paginate{nextIndex, previousIndex, pageAtIndex, minIndex} = - Scrolling.Configuration{..} - where - scrollableWidget :: [Attribute] -> Html () -> Html () - scrollableWidget attrs content = do - let attrs' = - [ class_ "border-top table table-striped table-hover m-0" - ] - table_ (attrs' <> attrs) - $ do - thead_ [class_ "bg-primary"] - $ tr_ - [ scope_ "row" - , class_ "sticky-top my-1" - , style_ "z-index: 1" - ] - $ do - thEnd (Just 7) "Time" - when depositsSlot - $ thEnd (Just 5) "Slot" - thEnd (Just 7) "Deposit" - when depositsSpent - $ thEnd (Just 7) "Spent" - content - scrollableContainer = table_ - retrieveContent time attrs = do - mds <- pageAtIndex time - case mds of - Nothing -> pure $ toHtml $ "No deposits for index " <> show time - Just (_, ds) -> - pure - $ tbody_ attrs - $ mapM_ - ( \window -> - depositH - params - Nothing - depositsCustomersLink - window - mempty - ) - $ Map.assocs ds - uniqueScrollingId = "deposits" - presentFieldName = "times-paginating-presence" - controlSelector = "#view-control" - renderIndex (Down t) = toUrlPiece t - updateURL (Down t) = linkText . depositsHistoryPageLink . Just $ t - renderIdOfIndex (Down t) = toUrlPiece $ abs $ hash t - -depositH - :: DepositsParams - -> Maybe Expand - -> (Maybe (WithOrigin UTCTime) -> Maybe Expand -> Link) - -> (DownTime, (Maybe Slot, ValueTransfer)) - -> ([Attribute] -> Html ()) - -> Html () -depositH - DepositsParams - { depositsSlot - , depositsSpent - , depositsCustomers - , depositsWindow - , depositsFirstWeekDay - } - mexpand - depositsCustomersLink - (dTime@(Down time), (slot, ValueTransferC{received, spent})) - widget - | expanded = do - let - trId = T.pack $ "customers-" <> show (hash time) - tr_ - [ id_ trId - ] - $ do - let depositColumn = if depositsSpent then succ else id - slotColumn = if depositsSlot then succ else id - columns = - T.pack - $ show - $ depositColumn - $ slotColumn (2 :: Int) - -- This number refers to the number of columns - -- in the container table. - bar = do - div_ - $ toHtml - $ "From: " - <> downTimeH - ( fmap - ( nextDiscretizedTime - depositsFirstWeekDay - depositsWindow - ) - <$> dTime - ) - div_ - $ toHtml - $ "To: " <> downTimeH dTime - close = - button_ - [ class_ "btn p-1" - , type_ "button" - , hxTarget_ $ "#" <> trId - , hxSwap_ "outerHTML" - , hxPost_ $ customerPost $ Just Collapse - , hxInclude_ "#view-control" - ] - $ i_ [class_ "bi bi-x"] mempty - td_ [colspan_ columns, class_ "p-0"] $ box bar close $ do - widget [class_ "ps-1"] - input_ - [ type_ "hidden" - , name_ "customers" - , value_ $ toUrlPiece time - ] - | otherwise = do - tr_ - [ scope_ "row" - , hxTrigger_ "click" - , hxTarget_ "this" - , hxSwap_ "outerHTML" - , hxPost_ $ customerPost (Just Expand) - , hxInclude_ "#view-control" - ] - $ do - tdEnd $ do - toHtml $ case time of - Origin -> "Origin" - At t -> show t - when depositsSlot - $ tdEnd - $ toHtml - $ case slot of - Just Origin -> "Origin" - Just (At (SlotNo t)) -> show t - Nothing -> "unresolved" - tdEnd $ valueH received - when depositsSpent - $ tdEnd - $ valueH spent - where - customerPost mexpand' = - linkText $ depositsCustomersLink (Just time) mexpand' - expanded = maybe (time `elem` depositsCustomers) (== Expand) mexpand diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/TxIds.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/TxIds.hs deleted file mode 100644 index 2c77d5fa701..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Deposits/TxIds.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use foldMap" #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.TxIds - ( scrollableDepositsCustomersTxIds - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.Read - ( TxId - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( linkText - , tdEnd - , thEnd - ) -import Cardano.Wallet.UI.Deposit.API - ( depositsTxIdsPaginatingLink - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( txIdH - , valueH - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( Paginate (..) - , PaginateM - ) -import Control.Lens - ( _1 - , view - , (<&>) - ) -import Control.Monad - ( when - ) -import Data.Foldable - ( fold - ) -import Data.List - ( sortOn - ) -import Data.Map.Strict - ( Map - ) -import Data.Ord - ( Down (..) - ) -import Lucid - ( Attribute - , Html - , class_ - , scope_ - , style_ - , table_ - , tbody_ - , thead_ - , tr_ - ) -import Servant - ( ToHttpApiData (toUrlPiece) - ) - -import qualified Cardano.Wallet.UI.Common.Html.Scrolling as Scrolling -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -scrollableDepositsCustomersTxIds - :: Monad m - => DepositsParams - -> DownTime - -> Customer - -> PaginateM m TxId (Map TxId ValueTransfer) - -> Scrolling.Configuration m TxId -scrollableDepositsCustomersTxIds - params@DepositsParams{depositsSpent} - (Down time) - customer - Paginate - { previousIndex - , nextIndex - , pageAtIndex - , minIndex - } = - Scrolling.Configuration{..} - where - scrollableWidget :: [Attribute] -> Html () -> Html () - scrollableWidget attrs content = do - let attrs' = - [ class_ "table-sm table-borderless table table-striped table-hover m-0" - ] - table_ (attrs' <> attrs) - $ do - thead_ [class_ "bg-primary"] - $ tr_ - [ scope_ "row" - , class_ "sticky-top my-1" - , style_ "z-index: 2" - ] - $ do - thEnd Nothing "Transaction" - thEnd (Just 7) "Deposit" - when depositsSpent - $ thEnd (Just 7) "Spent" - content - scrollableContainer = table_ - retrieveContent txId attrs = do - mxs <- pageAtIndex txId - pure $ fold $ mxs <&> \(_, xs) -> - tbody_ attrs - $ mapM_ (depositByTxIdH params) - $ sortOn (view _1) - $ Map.assocs xs - uniqueScrollingId = "deposit-customers-tx-ids" - presentFieldName = "tx-ids-paginating-presence" - controlSelector = "#view-control" - renderIndex = toUrlPiece - updateURL txId = - linkText - $ depositsTxIdsPaginatingLink - (Just time) - (Just customer) - (Just txId) - renderIdOfIndex = T.replace " " "-" . toUrlPiece - -depositByTxIdH - :: DepositsParams - -> (TxId, ValueTransfer) - -> Html () -depositByTxIdH - DepositsParams{depositsSpent} - (txId, ValueTransferC{received, spent}) = do - tr_ [scope_ "row"] $ do - tdEnd $ txIdH txId - tdEnd $ valueH received - when depositsSpent - $ tdEnd - $ valueH spent diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs deleted file mode 100644 index c5d43162c4d..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Page - ( Page (..) - , page - , headerElementH - ) -where - -import Prelude - -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( imageOverlay - ) -import Cardano.Wallet.UI.Common.Html.Modal - ( modalsH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( sseH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Settings - ( settingsPageH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Template.Body - ( bodyH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Template.Head - ( PageConfig (..) - , pageFromBodyH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Template.Navigation - ( Navigation (..) - , navigationH - ) -import Cardano.Wallet.UI.Deposit.API - ( Page (..) - , _About - , _Addresses - , _Deposits - , _Payments - , _Settings - , _Wallet - , aboutPageLink - , addressesPageLink - , depositPageLink - , depositsLink - , faviconLink - , homePageLink - , navigationLink - , paymentsLink - , paymentsPageLink - , settingsGetLink - , settingsPageLink - , sseLink - , walletPageLink - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.About - ( aboutH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Addresses - ( addressesH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Page - ( depositsH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page - ( paymentsH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( WalletPresent - , isPresent - , walletH - ) -import Cardano.Wallet.UI.Type - ( WalletType (..) - , runWHtml - ) -import Control.Lens - ( _Just - ) -import Control.Lens.Extras - ( is - ) -import Lucid - ( HtmlT - , renderBS - ) - -page - :: PageConfig - -- ^ Page configuration - -> Page - -- ^ Current page - -> RawHtml -page c p = RawHtml - $ renderBS - $ runWHtml Deposit - $ pageFromBodyH faviconLink c - $ do - bodyH sseLink (headerH p) - $ do - modalsH - imageOverlay - case p of - About -> aboutH - Settings -> settingsPageH settingsGetLink - Wallet -> walletH - Addresses -> addressesH - Deposits -> depositsH depositsLink - Payments -> paymentsH paymentsLink - -headerH :: Monad m => Page -> HtmlT m () -headerH p = sseH (navigationLink $ Just p) "header" ["wallet"] - -headerElementH :: Maybe Page -> WalletPresent -> Monad m => HtmlT m () -headerElementH p wp = - navigationH - mempty - Navigation - { navigationHomePage = homePageLink - , navigationTitle = "Cardano Deposit Wallet" - , navigationFavicon = faviconLink - } - $ [(is' _Wallet, walletPageLink, "Wallet")] - <> [ (is' _Addresses, addressesPageLink, "Addresses") - | isPresent wp - ] - <> [ (is' _Deposits, depositPageLink, "Deposits") - | isPresent wp - ] - <> [ (is' _Payments, paymentsPageLink, "Payments") - | isPresent wp - ] - <> [ (is' _Settings, settingsPageLink, "Settings") - , (is' _About, aboutPageLink, "About") - ] - where - is' l = is (_Just . l) p diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs deleted file mode 100644 index 58f5ace7b46..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs +++ /dev/null @@ -1,570 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page - ( paymentsH - , paymentsElementH - , availableBalanceElementH - , receiverAddressValidationH - , receiverAmountValidationH - , paymentsChangeH - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( CanSign (..) - , InspectTx (..) - ) -import Cardano.Wallet.Deposit.Pure.State.Payment.Inspect - ( transactionBalance - ) -import Cardano.Wallet.Read - ( Coin (..) - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxGet_ - , hxInclude_ - , hxPost_ - , hxSwapOob_ - , hxTarget_ - , hxTrigger_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( WithCopy (..) - , linkText - , tdEnd - , thEnd - , truncatableText - ) -import Cardano.Wallet.UI.Common.Html.Modal - ( mkModalButton - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( Striped (..) - , Width (..) - , alertH - , box - , field - , record - , simpleField - , sseH - ) -import Cardano.Wallet.UI.Deposit.API - ( modalLink - , paymentsBalanceAvailableLink - , paymentsDeleteReceiverLink - , paymentsNewReceiverLink - , paymentsReceiverAddressValidationLink - , paymentsReceiverAmountValidationLink - , paymentsResetLink - , paymentsSignLink - , paymentsSubmitLink - ) -import Cardano.Wallet.UI.Deposit.API.Payments - ( Receivers - , State - , StateA (..) - , Transaction - ) -import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction - ( AddressValidationResponse (..) - , AmountValidationResponse (..) - , PaymentHandlerResponse (..) - , extractReceivers - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( addressH - , lovelaceH - , txIdH - ) -import Cardano.Wallet.UI.Type - ( WHtml - ) -import Control.Monad - ( forM_ - , when - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Maybe - ( fromMaybe - ) -import Data.Semigroup - ( Sum (..) - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Lucid - ( Attribute - , Html - , ToHtml (..) - , button_ - , class_ - , data_ - , div_ - , hidden_ - , i_ - , id_ - , input_ - , name_ - , placeholder_ - , span_ - , style_ - , table_ - , tbody_ - , thead_ - , tr_ - , type_ - , value_ - ) -import Servant - ( Link - ) - -import qualified Data.Aeson as Aeson -import qualified Data.Map.Monoidal.Strict as MonoidalMap -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL - -paymentsH :: Link -> WHtml () -paymentsH paymentsLink = do - sseH paymentsLink "payments-page" ["payments"] - -paymentsChangeH :: Coin -> PaymentHandlerResponse -> Html () -paymentsChangeH balance transaction = do - case transaction of - ResponseExceptionPayments paymentError -> do - setError - $ alertH - $ toText paymentError - ResponseSuccess canSign state -> do - setError mempty - setState [hxSwapOob_ "innerHTML"] $ fst <$> state - case state of - NoState -> do - setReceivers Nothing - setInspection Nothing - setBalance balance Nothing - Unsigned (utx, inspect) -> do - setReceivers $ Just (signatureFormH utx canSign, inspect) - setInspection $ Just (inspect, utx, Nothing) - setBalance balance $ Just inspect - Signed utx (stx, inspect) -> do - setReceivers $ Just (submitH, inspect) - setInspection $ Just (inspect, utx, Just stx) - setBalance balance $ Just inspect - Submitted utx (stx, inspect) -> do - setReceivers $ Just (newH, inspect) - setInspection $ Just (inspect, utx, Just stx) - setBalance balance Nothing - -setError :: Html () -> Html () -setError = div_ [id_ "transaction-error", hxSwapOob_ "innerHTML"] - -setState :: [Attribute] -> State -> Html () -setState attrs state = - div_ ([id_ "payment-state"] <> attrs) - $ input_ - [ hidden_ "" - , name_ "payment-state" - , value_ $ TL.toStrict $ TL.decodeUtf8 $ Aeson.encode state - ] - -setReceivers :: Maybe (Html (), InspectTx) -> Html () -setReceivers mInspect = - div_ [id_ "receivers", hxSwapOob_ "innerHTML"] - $ case mInspect of - Nothing -> receiversH Nothing - Just (canSign, inspect) -> do - receiversH $ Just (extractReceivers inspect) - canSign - -setInspection - :: Maybe (InspectTx, Transaction, Maybe Transaction) - -> Html () -setInspection inspect = do - div_ [id_ "transaction-inspection", hxSwapOob_ "innerHTML"] - $ foldMap transactionInspectionH inspect - -setBalance :: Coin -> Maybe InspectTx -> Html () -setBalance balance mInspect = do - div_ [id_ "available-balance", hxSwapOob_ "innerHTML"] - $ availableBalanceElementH balance - $ case mInspect of - Just inspect -> - Just - $ fromIntegral - $ transactionBalance inspect - _ -> Nothing - -newReceiverH :: Html () -newReceiverH = do - let spanFlex = span_ [class_ "d-flex"] - tbody_ [id_ "new-receiver-form"] - $ tr_ [class_ "border-top pt-2"] - $ do - tdEnd - $ spanFlex - $ do - div_ [id_ "receiver-address-validation"] mempty - input_ - [ class_ "form-control text-end" - , type_ "text" - , name_ "new-receiver-address" - , hxPost_ - $ linkText - paymentsReceiverAddressValidationLink - , hxTarget_ "#receiver-address-validation" - , hxInclude_ "#new-receiver-form" - , hxTrigger_ "input" - , placeholder_ "payment address" - ] - tdEnd - $ spanFlex - $ do - div_ [id_ "receiver-amount-validation"] mempty - input_ - [ class_ "form-control text-end" - , type_ "text" - , name_ "new-receiver-amount" - , hxPost_ - $ linkText - paymentsReceiverAmountValidationLink - , hxTarget_ "#receiver-amount-validation" - , hxInclude_ "#new-receiver-form" - , hxTrigger_ "input" - , placeholder_ "amount in ada" - ] - - tdEnd - $ spanFlex - $ button_ - [ class_ "btn w-100" - , hxPost_ $ linkText paymentsNewReceiverLink - , hxInclude_ "#payment-state , #new-receiver-form" - , hxTarget_ "#none" - , id_ "new-receiver-button" - ] - mempty - -receiversH :: Maybe Receivers -> Html () -receiversH m = do - div_ [class_ "d-flex justify-content-end"] $ do - table_ - [ class_ "table table-sm table-borderless table-hover striped-columns" - ] - $ do - thead_ $ do - tr_ $ do - thEnd Nothing "Address" - thEnd (Just 9) "Amount" - thEnd (Just 5) "Actions" - tbody_ [id_ "payment-state"] - $ forM_ (MonoidalMap.assocs $ fold m) - $ \(address, Sum amount) -> do - tr_ $ do - tdEnd $ do - addressH WithCopy address - tdEnd $ lovelaceH amount - tdEnd - $ button_ - [ hxPost_ - $ linkText - $ paymentsDeleteReceiverLink - $ Just address - , hxInclude_ "#payment-state" - , hxTarget_ "#none" - , class_ "btn w-100" - ] - $ i_ [class_ "bi bi-trash"] mempty - newReceiverH - -ifNotEmpty :: (Foldable t, Monoid b) => t a -> b -> b -ifNotEmpty xs b = if null xs then mempty else b - -transactionInspectionH - :: (InspectTx, Transaction, Maybe Transaction) - -> Html () -transactionInspectionH (InspectTx{..}, utx, mstx) = do - let table = table_ [class_ "table table-sm m-0"] - div_ [class_ ""] $ do - record (Just 7) Full Striped $ do - field [] "unsigned transaction" - $ transactionCBORH "unsigned-transaction-copy" utx - case mstx of - Just stx -> - field [] "signed transaction" - $ transactionCBORH "signed-transaction-copy" stx - Nothing -> pure () - field [] "fee" - $ lovelaceH - $ fromIntegral fee - field [] "our inputs" - $ ifNotEmpty ourInputs - $ table - $ do - thead_ $ do - tr_ $ do - thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Transaction" - thEnd (Just 4) "Index" - thEnd (Just 7) "Amount" - tbody_ - $ forM_ ourInputs - $ \(txId, txIx, CoinC amount) -> do - tr_ $ do - tdEnd $ txIdH txId - tdEnd $ toHtml $ show $ fromEnum txIx - tdEnd $ lovelaceH $ fromIntegral amount - field [] "other inputs" - $ ifNotEmpty otherInputs - $ table - $ do - thead_ $ do - tr_ $ do - thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Transaction" - thEnd (Just 4) "Index" - tbody_ - $ forM_ otherInputs - $ \(txId, txIx) -> do - tr_ $ do - tdEnd $ txIdH txId - tdEnd $ toHtml $ show $ fromEnum txIx - field [] "change" - $ ifNotEmpty change - $ table - $ do - thead_ $ do - tr_ $ do - thEnd Nothing - $ toHtml - $ truncatableText WithoutCopy "" "Change Address" - thEnd (Just 7) "Amount" - tbody_ - $ forM_ change - $ \(addr, CoinC amount) -> do - tr_ $ do - tdEnd $ addressH WithCopy addr - tdEnd $ lovelaceH $ fromIntegral amount - field [] "customer outputs" - $ ifNotEmpty ourOutputs - $ table - $ do - thead_ $ do - tr_ $ do - thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Address" - thEnd (Just 6) "Customer" - thEnd (Just 7) "Amount" - tbody_ - $ forM_ ourOutputs - $ \(addr, customer, CoinC amount) -> do - tr_ $ do - tdEnd $ addressH WithCopy addr - tdEnd $ toHtml $ show customer - tdEnd $ lovelaceH $ fromIntegral amount - field [] "other outputs" - $ ifNotEmpty otherOutputs - $ table - $ do - thead_ $ do - tr_ $ do - thEnd Nothing "Address" - thEnd (Just 7) "Amount" - tbody_ - $ forM_ otherOutputs - $ \(addr, CoinC amount) -> do - tr_ $ do - tdEnd $ addressH WithCopy addr - tdEnd $ lovelaceH $ fromIntegral amount - -transactionCBORH :: Text -> Transaction -> Html () -transactionCBORH copyName cbor = - truncatableText WithCopy copyName - $ toHtml - $ Aeson.encode cbor - -signatureFormH :: Transaction -> CanSign -> Html () -signatureFormH utx = \case - CanSign -> do - div_ [class_ "d-flex justify-content-end"] $ do - div_ [class_ "input-group", style_ "max-width:35em"] $ do - input_ - [ id_ "signature-password" - , class_ "form-control text-end" - , type_ "password" - , name_ "passphrase" - , placeholder_ "passphrase" - ] - button_ - [ class_ "btn btn-secondary" - , hxPost_ $ linkText paymentsSignLink - , hxTarget_ "#none" - , hxInclude_ "#signature-password, #payment-state" - ] - "Sign" - CannotSign -> do - record (Just 15) Full Striped $ do - field [] "unsigned transaction" - $ transactionCBORH "unsigned-transaction-signature-copy" utx - div_ [class_ "d-flex justify-content-end"] $ do - div_ [class_ "input-group", style_ "max-width:35em"] $ do - input_ - [ id_ "signed-transaction" - , class_ "form-control text-end" - , name_ "signed-transaction" - , placeholder_ "signed transaction" - ] - button_ - [ class_ "btn btn-secondary" - , hxPost_ $ linkText paymentsSignLink - , hxInclude_ "#payment-state, #signed-transaction" - , hxTarget_ "#none" - ] - "Accept" - -submitH :: Html () -submitH = do - div_ [class_ "input-group d-flex justify-content-end"] $ do - -- span_ [class_ "input-group-text"] "Submit" - button_ - [ class_ "btn btn-secondary" - , hxPost_ $ linkText paymentsSubmitLink - , hxInclude_ "#payment-state" - , hxTarget_ "#none" - ] - "Submit" - -newH :: Html () -newH = do - div_ [class_ "input-group d-flex justify-content-end"] $ do - -- span_ [class_ "input-group-text"] "New transaction" - button_ - [ class_ "btn btn-secondary" - , hxPost_ $ linkText paymentsResetLink - , hxTarget_ "#none" - ] - "Reset" - -availableBalanceElementH :: Coin -> Maybe Coin -> Html () -availableBalanceElementH balance mTxBalance = - record Nothing Auto Striped $ do - simpleField "Before transaction" - $ div_ [class_ "d-flex justify-content-end"] - $ lovelaceH - $ fromIntegral balance - simpleField "Transaction balance" - $ div_ [class_ "d-flex justify-content-end"] - $ lovelaceH - $ fromIntegral - $ fromMaybe 0 mTxBalance - simpleField "After transaction" - $ div_ [class_ "d-flex justify-content-end"] - $ lovelaceH - $ fromIntegral - $ balance - fromMaybe 0 mTxBalance - -{- restoreH :: Html () -restoreH = div_ [class_ "input-group"] $ do - input_ - [ class_ "form-control" - , type_ "text" - , name_ "restore-transaction" - , placeholder_ "serialized tx" - ] - button_ - [ class_ "btn" - , hxPost_ $ linkText paymentsRestoreLink - , hxTarget_ "#receivers" - , hxInclude_ "#restoration" - ] - $ i_ [class_ "bi bi-upload"] mempty -} - -collapseBtn :: Text -> Html () -collapseBtn identifier = - button_ - [ class_ "btn" - , type_ "button" - , data_ "bs-toggle" "collapse" - , data_ - "bs-target" - $ "#" <> identifier - ] - $ i_ [class_ "bi bi-arrows-collapse"] mempty - -paymentsElementH - :: Html () -paymentsElementH = - div_ - [ class_ "row mt-3 gx-0" - ] - $ do - div_ [id_ "none"] mempty - box "New" mempty - $ do - setState [] NoState - box "Transaction Creation" mempty - $ do - div_ - [ id_ "receivers" - ] - $ receiversH Nothing - div_ [id_ "transaction-error"] mempty - div_ [id_ "copy-transaction"] mempty - box "Wallet Balance" (collapseBtn "available-balance") - $ div_ - [ class_ "collapse d-flex justify-content-end" - , id_ "available-balance" - , hxTrigger_ "load" - , hxGet_ $ linkText paymentsBalanceAvailableLink - , hxInclude_ "#payment-state" - , hxTarget_ "#available-balance" - ] - mempty - box - "Transaction Content" - (collapseBtn "transaction-inspection") - $ div_ - [ class_ "collapse" - , id_ "transaction-inspection" - ] - mempty - -{- box - "Restoration" - (collapseBtn "restoration") - $ div_ - [ class_ "collapse" - , id_ "restoration" - ] - restoreH -} - -receiverAddressValidationH :: AddressValidationResponse -> Html () -receiverAddressValidationH (ValidAddress _ m) = - div_ [id_ "new-receiver-button", hxSwapOob_ "innerHTML"] - $ when m - $ i_ [class_ "bi bi-plus-lg"] mempty -receiverAddressValidationH (InvalidAddress e) = do - validationFailedButton "Invalid Address" $ toText e - div_ [id_ "new-receiver-button"] mempty - -receiverAmountValidationH :: AmountValidationResponse -> Html () -receiverAmountValidationH (ValidAmount _ m) = do - div_ [id_ "new-receiver-button", hxSwapOob_ "innerHTML"] - $ when m - $ i_ [class_ "bi bi-plus-lg"] mempty -receiverAmountValidationH (InvalidAmount e) = do - validationFailedButton "Invalid Amount" $ toText e - div_ [id_ "new-receiver-button"] mempty - -validationFailedButton :: Text -> Text -> Html () -validationFailedButton t e = - mkModalButton - (modalLink (Just t) $ Just e) - [class_ "btn px-1"] - $ i_ [class_ "bi bi-exclamation-triangle text-danger-emphasis"] mempty diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Wallet.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Wallet.hs deleted file mode 100644 index b900997dd50..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Html/Pages/Wallet.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.UI.Deposit.Html.Pages.Wallet -where - -import Prelude - -import Cardano.Address.Derivation - ( XPub - , xpubToBytes - ) -import Cardano.Wallet.Deposit.IO - ( WalletPublicIdentity (..) - ) -import Cardano.Wallet.Deposit.REST - ( ErrDatabase - ) -import Cardano.Wallet.UI.Common.API - ( Visible (..) - ) -import Cardano.Wallet.UI.Common.Html.Htmx - ( hxDelete_ - , hxSwap_ - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( WithCopy (..) - , dataBsDismiss_ - , linkText - , truncatableText - ) -import Cardano.Wallet.UI.Common.Html.Modal - ( ModalData (..) - , mkModal - , mkModalButton - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( Striped (..) - , Width (..) - , box - , record - , simpleField - , sseH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Wallet - ( PostWalletConfig (..) - , newWalletFromMnemonicH - , newWalletFromXPubH - ) -import Cardano.Wallet.UI.Deposit.API - ( walletDeleteLink - , walletDeleteModalLink - , walletLink - , walletMnemonicLink - , walletPostMnemonicLink - , walletPostXPubLink - , walletStatusLink - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( chainPointToSlotH - , networkTagH - , timeH - , valueH - , withOriginH - ) -import Cardano.Wallet.UI.Deposit.Types.Wallet - ( Status (..) - ) -import Cardano.Wallet.UI.Type - ( WHtml - , WalletType (..) - , runWHtml - ) -import Control.Exception - ( SomeException - ) -import Data.ByteString - ( ByteString - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( ToText (..) - ) -import Lucid - ( Html - , HtmlT - , ToHtml (..) - , button_ - , class_ - , div_ - , id_ - , p_ - ) - -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Char8 as BL - -data WalletPresent - = WalletPresent WalletPublicIdentity - | WalletAbsent - | WalletFailedToInitialize ErrDatabase - | WalletVanished SomeException - | WalletInitializing - | WalletClosing - -isPresent :: WalletPresent -> Bool -isPresent = \case - WalletPresent _ -> True - _ -> False -instance Show WalletPresent where - show (WalletPresent x) = "WalletPresent: " <> show x - show WalletAbsent = "WalletAbsent" - show (WalletFailedToInitialize _) = "WalletFailedToInitialize" - show (WalletVanished _) = "WalletVanished" - show WalletInitializing = "WalletInitializing" - show WalletClosing = "WalletClosing" - -walletH :: WHtml () -walletH = sseH walletLink "wallet" ["wallet"] - -pubKeyH :: Monad m => XPub -> HtmlT m () -pubKeyH xpub = - truncatableText WithCopy "public_key" - $ toHtml - $ B16.encode - $ xpubToBytes xpub - -headAndTail :: Int -> ByteString -> ByteString -headAndTail n t = B8.take n t <> " .. " <> B8.takeEnd n t - -deleteWalletButtonH :: Html () -deleteWalletButtonH = - mkModalButton - walletDeleteModalLink - [class_ "btn btn-danger"] - "Delete Wallet" - -deleteWalletModalH :: Html () -deleteWalletModalH = - mkModal - $ ModalData - { modalTitle = "Delete Wallet" - , modalBody = p_ "Are you sure you want to delete this wallet?" - , modalFooter = do - button_ - [ class_ "btn btn-danger" - , hxDelete_ $ linkText walletDeleteLink - , dataBsDismiss_ "modal" - , hxSwap_ "none" - ] - "Delete Wallet" - button_ - [ class_ "btn btn-secondary" - , dataBsDismiss_ "modal" - ] - "Cancel" - } - -walletStatusH :: Status -> Html () -walletStatusH status = do - box "Status" mempty - $ record (Just 13) Full Striped - $ do - simpleField "Tip Slot" $ do - chainPointToSlotH $ tip status - simpleField "Tip Time" $ do - maybe mempty (withOriginH timeH) (tipTime status) - simpleField "Balance" $ valueH $ balance status - simpleField "Network" $ networkTagH $ network status - -walletElementH - :: (BL.ByteString -> Html ()) - -> WalletPresent - -> Html () -walletElementH alert presence = case presence of - WalletPresent (WalletPublicIdentity xpub customers) -> do - div_ [class_ "row mt-2 gx-0"] - $ sseH walletStatusLink "wallet-status" ["wallet-tip"] - div_ [class_ "row mt-2 gx-0"] $ do - box "Public Identity" mempty - $ record (Just 13) Full Striped - $ do - simpleField "Extended Public Key" $ pubKeyH xpub - simpleField "Tracked Addresses" - $ div_ [class_ "d-flex justify-content-end align-items-center"] - $ toHtml - $ toText customers - div_ [class_ "row mt-2 gx-0"] $ do - box "Management" mempty - $ div_ - [class_ "d-flex justify-content-end align-items-center"] - deleteWalletButtonH - div_ [id_ "delete-result"] mempty - WalletAbsent -> runWHtml Deposit $ do - div_ [class_ "row mt-2 gx-0"] - $ newWalletFromMnemonicH walletMnemonicLink - $ PostWalletConfig - { walletDataLink = walletPostMnemonicLink - , passwordVisibility = Just Hidden - , responseTarget = "#post-response" - } - div_ [class_ "row mt-2 gx-0"] - $ newWalletFromXPubH - $ PostWalletConfig - { walletDataLink = walletPostXPubLink - , passwordVisibility = Just Hidden - , responseTarget = "#post-response" - } - div_ [class_ "row mt-2 gx-0"] - $ div_ [id_ "post-response"] mempty - WalletFailedToInitialize err -> - alert - $ "Failed to initialize wallet" - <> BL.pack (show err) - WalletVanished e -> alert $ "Wallet vanished " <> BL.pack (show e) - WalletInitializing -> alert "Wallet is initializing" - WalletClosing -> alert "Wallet is closing" - -onWalletPresentH - :: (WalletPublicIdentity -> Html ()) - -> (BL.ByteString -> Html ()) - -> WalletPresent - -> Html () -onWalletPresentH f alert = \case - WalletPresent wpi -> f wpi - WalletAbsent -> alert "Wallet is absent" - WalletFailedToInitialize err -> - alert - $ "Failed to initialize wallet" - <> BL.pack (show err) - WalletVanished e -> alert $ "Wallet vanished " <> BL.pack (show e) - WalletInitializing -> alert "Wallet is initializing" - WalletClosing -> alert "Wallet is closing" - -data BadgeStyle - = Primary - | Secondary - | Success - | Danger - | Warning - | Info - | Light - | Dark - -renderBadgeStyle :: BadgeStyle -> Text -renderBadgeStyle = \case - Primary -> "primary" - Secondary -> "secondary" - Success -> "success" - Danger -> "danger" - Warning -> "warning" - Info -> "info" - Light -> "light" - Dark -> "dark" diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server.hs deleted file mode 100644 index 596fea3a04d..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.UI.Deposit.Server - ( serveUI - ) where - -import Prelude - -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv (networkEnv) - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - , withSessionLayerRead - ) -import Cardano.Wallet.UI.Common.Handlers.Settings - ( toggleSSE - ) -import Cardano.Wallet.UI.Common.Handlers.SSE - ( Message - , sse - ) -import Cardano.Wallet.UI.Common.Handlers.State - ( getState - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - ) -import Cardano.Wallet.UI.Common.Html.Pages.Settings - ( settingsStateH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Template.Head - ( PageConfig - ) -import Cardano.Wallet.UI.Common.Layer - ( SessionLayer (..) - , UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API - ( UI - , settingsSseToggleLink - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( walletPresence - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( modalElementH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Page - ( Page (..) - , headerElementH - , page - ) -import Cardano.Wallet.UI.Deposit.Server.Addresses - ( serveAddressesPage - , serveCustomerHistory - , serveGetAddress - ) -import Cardano.Wallet.UI.Deposit.Server.Deposits.Customers - ( serveDepositsCustomerPagination - , serveDepositsCustomers - ) -import Cardano.Wallet.UI.Deposit.Server.Deposits.Page - ( serveDepositsPage - ) -import Cardano.Wallet.UI.Deposit.Server.Deposits.Times - ( serveDeposits - , serveDepositsPagination - ) -import Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds - ( serveDepositsCustomersTxIds - , serveDepositsCustomersTxIdsPagination - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( renderSmoothHtml - ) -import Cardano.Wallet.UI.Deposit.Server.Payments.Page - ( servePaymentsBalanceAvailable - , servePaymentsDeleteReceiver - , servePaymentsNewReceiver - , servePaymentsPage - , servePaymentsReceiverAddressValidation - , servePaymentsReceiverAmountValidation - , servePaymentsReset - , servePaymentsSign - , servePaymentsSubmit - ) -import Cardano.Wallet.UI.Deposit.Server.Wallet - ( serveDeleteWallet - , serveDeleteWalletModal - , serveMnemonic - , servePostMnemonicWallet - , servePostXPubWallet - , serveWalletPage - , serveWalletStatus - ) -import Cardano.Wallet.UI.Static - ( favicon - ) -import Control.Tracer - ( Tracer (..) - ) -import Data.Functor - ( ($>) - ) -import Data.Text - ( Text - ) -import Servant - ( Handler - , Server - , (:<|>) (..) - ) -import Servant.Types.SourceT - ( SourceT - ) - -serveUI - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -- ^ Tracer for logging - -> UILayer WalletResource - -- ^ UI layer - -> WalletBootEnv IO - -- ^ Wallet boot environment - -> FilePath - -- ^ Database directory - -> PageConfig - -- ^ Page configuration - -> Server UI -serveUI wtc tr ul env dbDir config = - serveTabPage ul config Wallet - :<|> serveTabPage ul config About - :<|> serveTabPage ul config Settings - :<|> serveTabPage ul config Wallet - :<|> serveTabPage ul config Addresses - :<|> serveTabPage ul config Deposits - :<|> serveTabPage ul config Payments - :<|> serveSSESettings ul - :<|> serveToggleSSE ul - :<|> serveSSE ul - :<|> pure favicon - :<|> serveMnemonic - :<|> serveWalletPage ul - :<|> servePostMnemonicWallet wtc tr env dbDir ul - :<|> servePostXPubWallet wtc tr env dbDir ul - :<|> serveDeleteWallet ul dbDir - :<|> serveDeleteWalletModal ul - :<|> serveGetAddress ul - :<|> serveAddressesPage ul - :<|> serveNavigation ul - :<|> serveCustomerHistory ul - :<|> serveDepositsPage ul - :<|> serveDeposits ul - :<|> serveDepositsPagination ul - :<|> serveDepositsCustomers ul - :<|> serveDepositsCustomerPagination ul - :<|> serveDepositsCustomersTxIds ul - :<|> serveDepositsCustomersTxIdsPagination ul - :<|> servePaymentsPage ul - :<|> servePaymentsNewReceiver ul - :<|> servePaymentsDeleteReceiver ul - :<|> servePaymentsBalanceAvailable ul - :<|> servePaymentsReceiverAddressValidation ul - :<|> servePaymentsReceiverAmountValidation ul - :<|> serveModal ul - :<|> servePaymentsSign ul - :<|> servePaymentsSubmit ul - :<|> servePaymentsReset ul - :<|> serveWalletStatus (networkEnv env) ul - -serveModal - :: UILayer WalletResource - -> Maybe Text - -> Maybe Text - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveModal ul mtitle mbody = withSessionLayer ul $ \_ -> - pure - $ renderSmoothHtml - $ modalElementH mtitle mbody - -serveTabPage - :: UILayer s - -> PageConfig - -> Page - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveTabPage ul config p = withSessionLayer ul $ \_ -> pure $ page config p - -serveNavigation - :: UILayer WalletResource - -> Maybe Page - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveNavigation ul mp = withSessionLayer ul $ \l -> do - wp <- walletPresence l - pure $ renderSmoothHtml $ headerElementH mp wp - -serveSSESettings - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveSSESettings ul = withSessionLayer ul $ \l -> do - getState l (renderSmoothHtml . settingsStateH settingsSseToggleLink) - -serveToggleSSE - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveToggleSSE ul = withSessionLayer ul $ \l -> do - toggleSSE l $> RawHtml "" - -serveSSE - :: UILayer s - -> Maybe RequestCookies - -> Handler (SourceT IO Message) -serveSSE ul = withSessionLayerRead ul (sse . sseConfig) diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Addresses.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Addresses.hs deleted file mode 100644 index 6043871cd35..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Addresses.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Addresses - ( serveCustomerHistory - , serveAddressesPage - , serveGetAddress - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - ) -import Cardano.Wallet.UI.Common.Html.Lib - ( WithCopy (..) - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API.Addresses.Transactions - ( TransactionHistoryParams - ) -import Cardano.Wallet.UI.Deposit.Handlers.Addresses - ( getAddresses - , getCustomerAddress - ) -import Cardano.Wallet.UI.Deposit.Handlers.Addresses.Transactions - ( getCustomerHistory - ) -import Cardano.Wallet.UI.Deposit.Html.Common - ( addressH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Addresses - ( addressElementH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Addresses.Transactions - ( customerHistoryH - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( alert - , origin - , renderSmoothHtml - ) -import Servant - ( Handler - ) - -serveCustomerHistory - :: UILayer WalletResource - -> TransactionHistoryParams - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveCustomerHistory ul params = do - withSessionLayer ul $ \layer -> - renderSmoothHtml - <$> getCustomerHistory - layer - customerHistoryH - alertH - params - -serveGetAddress - :: UILayer WalletResource - -> Customer - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveGetAddress ul c = withSessionLayer ul $ \l -> do - getCustomerAddress - l - (renderSmoothHtml . addressH WithCopy) - alert - c - -serveAddressesPage - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveAddressesPage ul = withSessionLayer ul $ \l -> do - getAddresses l - $ \now -> renderSmoothHtml . addressElementH now origin alertH diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Customers.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Customers.hs deleted file mode 100644 index 86af2296e5d..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Customers.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Deposits.Customers - ( serveDepositsCustomers - , serveDepositsCustomerPagination - ) -where - -import Prelude - -import Cardano.Slotting.Slot - ( WithOrigin (..) - ) -import Cardano.Wallet.Deposit.Map - ( unPatch - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , getTxHistoryByTime - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Html.Scrolling - ( Scrolling (..) - , newScrolling - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API - ( depositsCustomersLink - , depositsCustomersPaginatingLink - , depositsTxIdsLink - ) -import Cardano.Wallet.UI.Deposit.API.Common - ( Expand - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Deposits.Customers - ( depositCustomersHandler - , depositCustomersPaginateM - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceM - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Customers - ( scrollableDepositsCustomers - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Times - ( depositH - ) -import Data.Bifunctor - ( first - ) -import Data.Foldable - ( fold - ) -import Data.Monoid - ( First (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime - ) -import Servant - ( Handler - ) - -depositsCustomersTable - :: DepositsParams - -> DownTime - -> WalletResourceM (Scrolling WalletResourceM Customer) -depositsCustomersTable params time = do - let hs = - depositCustomersPaginateM - params - getTxHistoryByTime - time - 100 - newScrolling - $ scrollableDepositsCustomers - params - depositsCustomersPaginatingLink - depositsTxIdsLink - time - hs - -serveDepositsCustomerPagination - :: UILayer WalletResource - -> DepositsParams - -> (Maybe (WithOrigin UTCTime)) - -> Maybe Customer - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsCustomerPagination ul params (Just time) (Just customer) = - withSessionLayer ul - $ \layer -> do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsCustomersTable params (Down time) - scroll scrolling (depositsCustomersPages params) customer - pure $ renderHtml result -serveDepositsCustomerPagination ul _ _ _ = withSessionLayer ul - $ \_layer -> do - pure - $ renderHtml - $ alertH ("No time or customer provided" :: Text) - -serveDepositsCustomers - :: UILayer WalletResource - -> DepositsParams - -> Maybe (WithOrigin UTCTime) - -> Maybe Expand - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsCustomers ul params mtime mexpand = withSessionLayer ul - $ \layer -> do - fmap renderHtml $ case mtime of - Nothing -> pure $ alertH ("No time provided" :: Text) - Just time -> do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsCustomersTable params (Down time) - pure $ widget scrolling - depositCustomersHandler - layer - ( \window -> - depositH - params - mexpand - depositsCustomersLink - ( Down time - , first getFirst - $ fold - $ unPatch window - ) - result - ) - alertH - params - time diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Page.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Page.hs deleted file mode 100644 index d9d38690c1a..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Page.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Deposits.Page - ( serveDepositsPage - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.REST - ( WalletResource - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API - ( depositsTimesLink - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( walletPresence - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Page - ( depositsElementH - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( renderSmoothHtml - ) -import Servant - ( Handler - ) - -serveDepositsPage - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsPage ul = withSessionLayer ul $ \layer -> do - wp <- walletPresence layer - pure - $ renderSmoothHtml - $ depositsElementH depositsTimesLink alertH wp diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Times.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Times.hs deleted file mode 100644 index 0017674c80b..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/Times.hs +++ /dev/null @@ -1,116 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Deposits.Times - ( serveDepositsPagination - , serveDeposits - ) -where - -import Prelude - -import Cardano.Slotting.Slot - ( WithOrigin (..) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , getTxHistoryByTime - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Html.Scrolling - ( Scrolling (..) - , newScrolling - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API - ( depositsCustomersLink - , depositsTimesPaginatingLink - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Deposits.Times - ( depositsPaginateM - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceM - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Times - ( scrollableDeposits - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( renderSmoothHtml - ) -import Data.Ord - ( Down (..) - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime - ) -import Servant - ( Handler - ) - -serveDeposits - :: UILayer WalletResource - -> DepositsParams - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDeposits ul params = withSessionLayer ul $ \layer -> do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsTable params - pure $ widget scrolling [] - pure $ renderSmoothHtml result - -depositsTable - :: DepositsParams - -> WalletResourceM (Scrolling WalletResourceM DownTime) -depositsTable params = do - let hs = - depositsPaginateM - params - getTxHistoryByTime - 100 - newScrolling - $ scrollableDeposits - depositsTimesPaginatingLink - depositsCustomersLink - params - hs - -serveDepositsPagination - :: UILayer WalletResource - -> DepositsParams - -> Maybe (WithOrigin UTCTime) - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsPagination ul params (Just index) = withSessionLayer ul - $ \layer -> do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsTable params - scroll scrolling (depositsPages params) $ Down index - pure $ renderHtml result -serveDepositsPagination ul _ _ = withSessionLayer ul - $ \_layer -> do - pure - $ renderHtml - $ alertH ("No page index provided" :: Text) diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/TxIds.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/TxIds.hs deleted file mode 100644 index 289577be2f8..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Deposits/TxIds.hs +++ /dev/null @@ -1,168 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds - ( serveDepositsCustomersTxIds - , serveDepositsCustomersTxIdsPagination - ) -where - -import Prelude - -import Cardano.Slotting.Slot - ( WithOrigin (..) - ) -import Cardano.Wallet.Deposit.Map - ( unPatch - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( DownTime - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , getTxHistoryByTime - ) -import Cardano.Wallet.Read - ( TxId - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Html.Scrolling - ( Scrolling (..) - , newScrolling - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API - ( depositsTxIdsLink - ) -import Cardano.Wallet.UI.Deposit.API.Common - ( Expand - ) -import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits - ( DepositsParams (..) - ) -import Cardano.Wallet.UI.Deposit.Handlers.Deposits.TxIds - ( depositCustomersTxIdsHandler - , depositCustomersTxIdsPaginateM - ) -import Cardano.Wallet.UI.Deposit.Handlers.Lib - ( catchRunWalletResourceM - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Customers - ( depositByCustomerH - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.TxIds - ( scrollableDepositsCustomersTxIds - ) -import Data.Bifunctor - ( first - ) -import Data.Foldable - ( fold - ) -import Data.Monoid - ( First (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime - ) -import Servant - ( Handler - ) - -depositsCustomersTxIdsTable - :: DepositsParams - -> DownTime - -> Customer - -> WalletResourceM (Scrolling WalletResourceM TxId) -depositsCustomersTxIdsTable params time customer = do - let hs = - depositCustomersTxIdsPaginateM - params - getTxHistoryByTime - time - customer - 100 - newScrolling - $ scrollableDepositsCustomersTxIds params time customer hs - -serveDepositsCustomersTxIdsPagination - :: UILayer WalletResource - -> DepositsParams - -> Maybe (WithOrigin UTCTime) - -> Maybe Customer - -> Maybe TxId - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsCustomersTxIdsPagination ul params (Just time) (Just customer) (Just txId) = - withSessionLayer ul - $ \layer -> do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsCustomersTxIdsTable params (Down time) customer - scroll scrolling (depositsCustomersTxIdsPages params) txId - pure $ renderHtml result -serveDepositsCustomersTxIdsPagination ul _ _ _ _ = withSessionLayer ul - $ \_layer -> do - pure - $ renderHtml - $ alertH ("No time, customer or txId provided" :: Text) - -serveDepositsCustomersTxIds - :: UILayer WalletResource - -> DepositsParams - -> Maybe (WithOrigin UTCTime) - -> Maybe Customer - -> Maybe Expand - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDepositsCustomersTxIds ul params (Just time) (Just customer) mexpand = - withSessionLayer ul $ \layer -> do - fmap renderHtml $ do - result <- catchRunWalletResourceM layer $ do - scrolling <- depositsCustomersTxIdsTable params (Down time) customer - pure $ widget scrolling - depositCustomersTxIdsHandler - layer - ( \txIds -> - depositByCustomerH - params - depositsTxIdsLink - mexpand - (Down time) - ( customer - , first getFirst - $ fold - $ unPatch txIds - ) - result - ) - alertH - params - time - customer -serveDepositsCustomersTxIds ul _ _ _ _ = withSessionLayer ul - $ \_layer -> do - pure - $ renderHtml - $ alertH ("No time or customer provided" :: Text) diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Lib.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Lib.hs deleted file mode 100644 index 6e406b93246..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Lib.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Lib - ( alert - , origin - , renderSmoothHtml - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Time - ( originTime - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Data.Time - ( UTCTime - ) -import Data.Time.Clock.POSIX - ( posixSecondsToUTCTime - ) -import Lucid - ( Html - , ToHtml (..) - , class_ - , div_ - ) - -alert :: ToHtml a => a -> RawHtml -alert = renderHtml . alertH - -renderSmoothHtml :: Html () -> RawHtml -renderSmoothHtml response = - renderHtml - $ div_ [class_ "smooth"] - $ toHtml response - -origin :: UTCTime -origin = posixSecondsToUTCTime $ fromIntegral originTime diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs deleted file mode 100644 index 0262506b6d4..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs +++ /dev/null @@ -1,195 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Server.Payments.Page - ( servePaymentsPage - , servePaymentsNewReceiver - , servePaymentsDeleteReceiver - , servePaymentsBalanceAvailable - , servePaymentsReceiverAddressValidation - , servePaymentsReceiverAmountValidation - , servePaymentsSign - , servePaymentsSubmit - , servePaymentsReset - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.REST - ( WalletResource - ) -import Cardano.Wallet.Deposit.Write - ( Address - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - ) -import Cardano.Wallet.UI.Deposit.API.Payments - ( AddReceiverForm (..) - , NewReceiver (..) - , NewReceiverValidation - , Signal (..) - , SignatureForm (..) - , State - , StateA (..) - , signatureFormState - ) -import Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance - ( getAvailableBalance - ) -import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction - ( receiverAddressValidation - , receiverAmountValidation - , signalHandler - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page - ( availableBalanceElementH - , paymentsChangeH - , paymentsElementH - , receiverAddressValidationH - , receiverAmountValidationH - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( renderSmoothHtml - ) -import Servant - ( Handler - ) - -servePaymentsPage - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsPage ul = withSessionLayer ul $ \_layer -> do - pure $ renderSmoothHtml paymentsElementH - -servePaymentsNewReceiver - :: UILayer WalletResource - -> AddReceiverForm - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsNewReceiver ul (AddReceiverForm (NewReceiver receiver) state) = - withSessionLayer ul $ \layer -> do - renderHtml - <$> signalHandler - layer - alertH - paymentsChangeH - state - (AddReceiver receiver) - -servePaymentsDeleteReceiver - :: UILayer WalletResource - -> State - -> Maybe Address - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsDeleteReceiver ul state (Just receiver) = - withSessionLayer ul $ \layer -> do - renderHtml - <$> signalHandler - layer - alertH - paymentsChangeH - state - (DeleteReceiver receiver) -servePaymentsDeleteReceiver _ _ _ = - error "servePaymentsDeleteReceiver: receiver-number is required" - -servePaymentsBalanceAvailable - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsBalanceAvailable ul = withSessionLayer ul $ \layer -> do - renderSmoothHtml - <$> getAvailableBalance - layer - (`availableBalanceElementH` Nothing) - alertH - -servePaymentsReceiverAddressValidation - :: UILayer WalletResource - -> NewReceiverValidation - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsReceiverAddressValidation ul receiver = withSessionLayer ul - $ \layer -> do - renderHtml - <$> receiverAddressValidation - layer - alertH - receiverAddressValidationH - receiver - -servePaymentsReceiverAmountValidation - :: UILayer WalletResource - -> NewReceiverValidation - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsReceiverAmountValidation ul amount = withSessionLayer ul - $ \layer -> do - renderHtml - <$> receiverAmountValidation - layer - alertH - receiverAmountValidationH - amount - -servePaymentsSign - :: UILayer WalletResource - -> SignatureForm - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsSign ul r = -- SignatureForm{signatureFormState, signaturePassword} = - withSessionLayer ul $ \layer -> do - renderHtml - <$> signalHandler - layer - alertH - paymentsChangeH - (signatureFormState r) - (case r of - SignatureForm _ s -> Sign s - ExternalSignatureForm _ s -> ExternallySign s - ) - -servePaymentsSubmit - :: UILayer WalletResource - -> State - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsSubmit ul state = - withSessionLayer ul $ \layer -> do - renderHtml - <$> signalHandler - layer - alertH - paymentsChangeH - state - Submit - -servePaymentsReset - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePaymentsReset ul = - withSessionLayer ul $ \layer -> do - renderHtml - <$> signalHandler - layer - alertH - paymentsChangeH - NoState - Reset diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Wallet.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Wallet.hs deleted file mode 100644 index 1bf72a71888..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Server/Wallet.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Wallet.UI.Deposit.Server.Wallet -where - -import Prelude - -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , deleteWallet - , initWallet - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic - , PostWalletViaXPub - ) -import Cardano.Wallet.UI.Common.Handlers.Session - ( withSessionLayer - ) -import Cardano.Wallet.UI.Common.Handlers.Wallet - ( pickMnemonic - ) -import Cardano.Wallet.UI.Common.Html.Html - ( RawHtml (..) - , renderHtml - ) -import Cardano.Wallet.UI.Common.Html.Pages.Lib - ( alertH - , rogerH - ) -import Cardano.Wallet.UI.Common.Html.Pages.Wallet - ( mnemonicH - ) -import Cardano.Wallet.UI.Common.Layer - ( UILayer (..) - ) -import Cardano.Wallet.UI.Cookies - ( CookieResponse - , RequestCookies - , sessioning - ) -import Cardano.Wallet.UI.Deposit.Handlers.Wallet - ( deleteWalletHandler - , getStatus - , getWallet - , postMnemonicWallet - , postXPubWallet - ) -import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet - ( deleteWalletModalH - , walletElementH - , walletStatusH - ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( alert - , renderSmoothHtml - ) -import Control.Monad.Trans - ( MonadIO (..) - ) -import Control.Tracer - ( Tracer (..) - ) -import Data.Text - ( Text - ) -import Servant - ( Handler - ) - -serveMnemonic - :: Maybe Bool - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveMnemonic hintOrClean = - sessioning - $ renderSmoothHtml . mnemonicH - <$> liftIO (pickMnemonic 15 hintOrClean) - -serveWalletPage - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveWalletPage ul = withSessionLayer ul $ \layer -> do - getWallet layer $ \presence -> - renderSmoothHtml $ walletElementH alertH presence - -servePostMnemonicWallet - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> WalletBootEnv IO - -> FilePath - -> UILayer WalletResource - -> PostWalletViaMnemonic - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePostMnemonicWallet wtc tr env dbDir ul request = - withSessionLayer ul $ \layer -> do - postMnemonicWallet layer initWallet' alert ok request - where - ok _ = renderHtml . rogerH @Text $ "ok" - initWallet' = initWallet wtc tr env dbDir - -servePostXPubWallet - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> WalletBootEnv IO - -> FilePath - -> UILayer WalletResource - -> PostWalletViaXPub - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -servePostXPubWallet wtc tr env dbDir ul request = - withSessionLayer ul $ \layer -> do - postXPubWallet layer initWallet' alert ok request - where - ok _ = renderHtml . rogerH @Text $ "ok" - initWallet' = initWallet wtc tr env dbDir - -serveDeleteWallet - :: UILayer WalletResource - -> FilePath - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDeleteWallet ul dbDir = withSessionLayer ul - $ \l -> deleteWalletHandler l (deleteWallet dbDir) alert ok - where - ok _ = renderHtml . rogerH @Text $ "ok" - -serveDeleteWalletModal - :: UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveDeleteWalletModal ul = withSessionLayer ul $ \_ -> - pure $ renderSmoothHtml deleteWalletModalH - -serveWalletStatus - :: NetworkEnv IO x - -> UILayer WalletResource - -> Maybe RequestCookies - -> Handler (CookieResponse RawHtml) -serveWalletStatus nenv ul = withSessionLayer ul $ \l -> - renderHtml <$> getStatus nenv l alertH walletStatusH diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Payments.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Payments.hs deleted file mode 100644 index 7d22d2a4527..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Payments.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.UI.Deposit.Types.Payments - ( Receiver (..) - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure.API.Address - ( decodeAddress - , encodeAddress - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Numeric.Natural - ( Natural - ) -import Web.HttpApiData - ( FromHttpApiData (parseUrlPiece) - , ToHttpApiData (toUrlPiece) - ) - -import qualified Data.Text as T - --- | A receiver of a payment. -data Receiver = Receiver - { address :: Address - -- ^ The address of the receiver. - , amount :: Natural - -- ^ The amount of lovelace to send to the receiver. - } - deriving (Eq, Show) - -instance FromHttpApiData Receiver where - parseUrlPiece t = case T.splitOn "," t of - [addressText, amountText] -> do - amount :: Natural <- case reads (T.unpack amountText) of - [(n, "")] -> pure n - _ -> Left "Amount must be a number" - address <- parseUrlPiece addressText - pure $ Receiver{address, amount} - _ -> Left "Receiver must be in the format 'address,amount'" - -instance ToHttpApiData Receiver where - toUrlPiece Receiver{address, amount} = - T.intercalate "," - [ encodeAddress address - , T.pack $ show amount - ] - -instance FromHttpApiData Address where - parseUrlPiece t = case decodeAddress t of - Left err -> Left $ T.pack $ show err - Right address -> pure address diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Wallet.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Wallet.hs deleted file mode 100644 index f15c2db9980..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Deposit/Types/Wallet.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Cardano.Wallet.UI.Deposit.Types.Wallet - ( Status (..) - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Read - ( ChainPoint - , NetworkTag - , Value - , WithOrigin - ) -import Data.Time - ( UTCTime - ) - -data Status = Status - { tip :: ChainPoint - , tipTime :: Maybe (WithOrigin UTCTime) - , balance :: Value - , network :: NetworkTag - } diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Discretization.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Discretization.hs deleted file mode 100644 index de3604d9356..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Discretization.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Cardano.Wallet.UI.Lib.Discretization - ( nextDiscretizedTime - , discretizeTime - , Window (..) - ) -where - -import Prelude hiding - ( lookup - ) - -import Data.Text.Class - ( ToText (..) - ) -import Data.Time - ( DayOfWeek - , DiffTime - , NominalDiffTime - , UTCTime (..) - , addUTCTime - , pattern YearMonthDay - , secondsToDiffTime - , weekFirstDay - ) - --- | A time window for discretization. -data Window - = Minute5 - | Minute10 - | Minute15 - | Minute30 - | Hour1 - | Hour2 - | Hour4 - | Hour6 - | Hour12 - | Day - | Week - | Month - | Year - deriving (Eq, Show, Enum, Bounded) - -instance ToText Window where - toText Minute5 = "5 minutes" - toText Minute10 = "10 minutes" - toText Minute15 = "15 minutes" - toText Minute30 = "30 minutes" - toText Hour1 = "1 hour" - toText Hour2 = "2 hours" - toText Hour4 = "4 hours" - toText Hour6 = "6 hours" - toText Hour12 = "12 hours" - toText Day = "1 day" - toText Week = "1 week" - toText Month = "1 month" - toText Year = "1 year" - -discretizeSeconds :: DiffTime -> Integer -> DiffTime -discretizeSeconds t q = - q' * fromIntegral (floor (t / q') :: Integer) - where - q' = secondsToDiffTime q - -minSecondsOfWindow :: Window -> NominalDiffTime -minSecondsOfWindow Minute5 = 5 * 60 -minSecondsOfWindow Minute10 = 10 * 60 -minSecondsOfWindow Minute15 = 15 * 60 -minSecondsOfWindow Minute30 = 30 * 60 -minSecondsOfWindow Hour1 = 3600 -minSecondsOfWindow Hour2 = 2 * 3600 -minSecondsOfWindow Hour4 = 4 * 3600 -minSecondsOfWindow Hour6 = 6 * 3600 -minSecondsOfWindow Hour12 = 12 * 3600 -minSecondsOfWindow Day = 24 * 3600 -minSecondsOfWindow Week = 7 * 24 * 3600 -minSecondsOfWindow Month = 31 * 24 * 3600 -minSecondsOfWindow Year = 366 * 24 * 3600 -- no idea ... - --- | Discretize a time according to a given window. -discretizeTime :: DayOfWeek -> Window -> UTCTime -> UTCTime -discretizeTime _ Year (UTCTime (YearMonthDay y _ _) _) = - UTCTime (YearMonthDay y 1 1) 0 -discretizeTime _ Month (UTCTime (YearMonthDay y m _) _) = - UTCTime (YearMonthDay y m 1) 0 -discretizeTime fdk Week (UTCTime d _) = UTCTime d' 0 - where - d' = weekFirstDay fdk d -discretizeTime _ Day (UTCTime d _) = UTCTime d 0 -discretizeTime _ Hour12 (UTCTime d t) = - UTCTime d (discretizeSeconds t $ 12 * 3600) -discretizeTime _ Hour6 (UTCTime d t) = - UTCTime d (discretizeSeconds t $ 6 * 3600) -discretizeTime _ Hour4 (UTCTime d t) = - UTCTime d (discretizeSeconds t $ 4 * 3600) -discretizeTime _ Hour2 (UTCTime d t) = - UTCTime d (discretizeSeconds t $ 2 * 3600) -discretizeTime _ Hour1 (UTCTime d t) = UTCTime d (discretizeSeconds t 3600) -discretizeTime _ Minute30 (UTCTime d t) = UTCTime d (discretizeSeconds t 1800) -discretizeTime _ Minute15 (UTCTime d t) = UTCTime d (discretizeSeconds t 900) -discretizeTime _ Minute10 (UTCTime d t) = UTCTime d (discretizeSeconds t 600) -discretizeTime _ Minute5 (UTCTime d t) = UTCTime d (discretizeSeconds t 300) - --- | Compute the next discretized time after a given time. This will work on non --- discretized times as well, but will potentially bread on the last day of 2025 --- as addGregorianMonthsRollOver (-1) "2016-12-31" == "2016-12-01" --- OTOH when used after discretization it will be fine -nextDiscretizedTime :: DayOfWeek -> Window -> UTCTime -> UTCTime -nextDiscretizedTime fdk window time = - -- subtract 2 seconds to jump past a leap second - discretizeTime - fdk - window - ( addUTCTime - (minSecondsOfWindow window + 2) - timeDiscretizedOnce - ) - where - timeDiscretizedOnce = discretizeTime fdk window time diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Map.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Map.hs deleted file mode 100644 index c3f0674d520..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Map.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Cardano.Wallet.UI.Lib.Pagination.Map - ( mkStrictMapPaginate - , Paginate (..) - ) -where - -import Prelude - -import Cardano.Wallet.UI.Lib.Pagination.Type - ( MkPaginatePure - , Paginate (..) - ) -import Data.Map.Strict - ( Map - ) - -import qualified Data.Map.Strict as Map - --- | Compute the next key in the given map after given number of elements. -next :: Ord k => Int -> Map k a -> k -> Maybe k -next n m start' = - fmap fst - $ Map.lookupMin - $ Map.drop n - $ Map.dropWhileAntitone (< start') m - -dropEnd :: Int -> Map k a -> Map k a -dropEnd n xs = Map.take (Map.size xs - n) xs - --- | Compute the previous key in the given map after given number of elements. -previous :: Ord k => Int -> Map k a -> k -> Maybe k -previous n m start' = - fmap fst - $ Map.lookupMax - $ dropEnd n - $ Map.takeWhileAntitone (<= start') m - --- | Extract a page of elements from the given map starting from the given key. -nextPage :: Ord k => Int -> k -> Map k a -> Maybe (Int, Map k a) -nextPage n start' s = - let - r = Map.take n . Map.dropWhileAntitone (< start') $ s - in - case length r of - 0 -> Nothing - l -> Just (l, r) - --- | Compute the minimum key in the given map. -minKey :: Map k a -> Maybe k -minKey = fmap fst . Map.lookupMin - --- | Make a 'Paginate' for a strict map. -mkStrictMapPaginate :: Ord k => MkPaginatePure k (Map k a) -mkStrictMapPaginate pageSize a = - Paginate - { nextIndex = next pageSize a - , previousIndex = previous pageSize a - , pageAtIndex = \k -> nextPage pageSize k a - , minIndex = minKey a - } diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/TimedSeq.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/TimedSeq.hs deleted file mode 100644 index 17ae6bae883..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/TimedSeq.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Cardano.Wallet.UI.Lib.Pagination.TimedSeq - ( Paginate (..) - , mkTimedSeqPaginate - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Map.Timed - ( TimedSeq - , minKey - , takeAfter - , takeUpTo - ) -import Cardano.Wallet.UI.Lib.Pagination.Type - ( MkPaginatePure - , Paginate (..) - ) - -mkTimedSeqPaginate - :: (Ord q, Monoid a, Ord k) - => (k -> q) - -> MkPaginatePure k (TimedSeq k a) -mkTimedSeqPaginate proj pageSize a = - Paginate - { nextIndex = next pageSize proj a - , previousIndex = previous pageSize proj a - , pageAtIndex = \k -> nextPage pageSize proj k a - , minIndex = minKey a - } - -next - :: (Monoid a, Ord q, Ord k) - => Int - -> (k -> q) - -> TimedSeq k a - -> k - -> Maybe k -next n proj s start' = snd $ takeAfter proj (Just start') (Just n) s - -previous - :: (Ord q, Monoid a, Ord k) - => Int - -> (k -> q) - -> TimedSeq k a - -> k - -> Maybe k -previous n proj s start' = snd $ takeUpTo proj (Just start') (Just n) s - -nextPage - :: (Ord q, Monoid a, Ord k) - => Int - -> (k -> q) - -> k - -> TimedSeq k a - -> Maybe (Int, TimedSeq k a) -nextPage n proj start' s = - Just - $ (\(result, _) -> (length result, result)) - $ takeAfter proj (Just start') (Just n) s diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Type.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Type.hs deleted file mode 100644 index ba097c2121b..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Pagination/Type.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Wallet.UI.Lib.Pagination.Type - ( Paginate (..) - , PaginatePure - , MkPaginatePure - , PaginateM - , MkPaginateM - ) -where - -import Prelude - -import Control.Monad.Identity - ( Identity - ) - --- | A type-level tag for the monadic paginators. -data M - --- | A type-level tag for the pure paginators. -data P - --- | A type-level function todistinguish between the pure and monadic paginators. -type family T f m a where - T M m a = m a - T P m a = a - --- | A closure of a value of type 'a' that can be paginated using a key of type 'k'. -data Paginate r m k a = Paginate - { nextIndex :: k -> T r m (Maybe k) - , previousIndex :: k -> T r m (Maybe k) - , pageAtIndex :: k -> T r m (Maybe (Int, a)) - , minIndex :: T r m (Maybe k) - } - -type PaginatePure k a = Paginate P Identity k a - -type MkPaginatePure k a = Int -> a -> PaginatePure k a - -type PaginateM m k a = Paginate M m k a - -type MkPaginateM m k a = Int -> Paginate M m k a diff --git a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Time/Direction.hs b/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Time/Direction.hs deleted file mode 100644 index af09ee08396..00000000000 --- a/lib/ui/src/deposit/Cardano/Wallet/UI/Lib/Time/Direction.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Cardano.Wallet.UI.Lib.Time.Direction where - -import Prelude hiding - ( span - ) - -import Data.List - ( sortBy - ) -import Data.Ord - ( Down (..) - , comparing - ) -import Data.Time - ( UTCTime (..) - , addGregorianMonthsClip - , fromGregorian - ) - -data Direction = Asc | Desc - -sortByDirection :: Ord b => Direction -> (a -> b) -> [a] -> [a] -sortByDirection Asc f = sortBy (comparing f) -sortByDirection Desc f = sortBy (comparing (Down . f)) - -data Match b = Match b | NoMatch | DirectionMatch - -match :: (b -> a) -> a -> a -> Match b -> a -match check no checkD = \case - Match w -> check w - NoMatch -> no - DirectionMatch -> checkD - -filterByDirection :: Ord b => Direction -> b -> (a -> Match b) -> [a] -> [a] -filterByDirection Asc w f = filter (match (>= w) False False . f) -filterByDirection Desc w f = filter (match (<= w) False True . f) - -utcTimeByDirection :: Direction -> Int -> Int -> UTCTime -utcTimeByDirection dir year month = - UTCTime (correction day) 0 - where - day = fromGregorian (fromIntegral year) month 1 - correction = case dir of - Asc -> id - Desc -> addGregorianMonthsClip 1 From 1c5af269272a64665660d85d3b4a1e7142aa5f21 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 26 Feb 2025 15:58:57 +0000 Subject: [PATCH 3/4] Remove cardano-deposit-wallet library --- cabal.project | 4 - lib/deposit-wallet/LICENSE | 177 ------- .../cardano-deposit-wallet.cabal | 269 ---------- lib/deposit-wallet/data/swagger.json | 114 ---- .../exe/cardano-deposit-wallet.hs | 4 - lib/deposit-wallet/external-signing.md | 109 ---- .../Cardano/Wallet/Deposit/HTTP/Server.hs | 168 ------ .../Cardano/Wallet/Deposit/HTTP/Types/API.hs | 59 --- .../Cardano/Wallet/Deposit/HTTP/Types/JSON.hs | 228 -------- .../Deposit/HTTP/Types/JSON/Encoding.hs | 81 --- .../Wallet/Deposit/HTTP/Types/OpenAPI.hs | 247 --------- .../rest/Cardano/Wallet/Deposit/REST.hs | 491 ------------------ .../rest/Cardano/Wallet/Deposit/REST/Catch.hs | 45 -- .../rest/Cardano/Wallet/Deposit/REST/Start.hs | 86 --- .../Wallet/Deposit/REST/Wallet/Create.hs | 32 -- .../spec/cardano-deposit-wallet.lagda.md | 418 --------------- lib/deposit-wallet/spec/openapi/index.html | 17 - .../src/Cardano/Wallet/Deposit/IO.hs | 417 --------------- .../src/Cardano/Wallet/Deposit/IO/DB.hs | 17 - .../src/Cardano/Wallet/Deposit/IO/DB/Real.hs | 61 --- .../src/Cardano/Wallet/Deposit/IO/DB/Stub.hs | 2 - .../Cardano/Wallet/Deposit/IO/Network/Mock.hs | 97 ---- .../Wallet/Deposit/IO/Network/NodeToClient.hs | 86 --- .../Cardano/Wallet/Deposit/IO/Network/Type.hs | 100 ---- .../src/Cardano/Wallet/Deposit/IO/Resource.hs | 228 -------- .../Wallet/Deposit/IO/Resource/Event.hs | 48 -- .../src/Cardano/Wallet/Deposit/Map.hs | 305 ----------- .../src/Cardano/Wallet/Deposit/Map/Timed.hs | 265 ---------- .../src/Cardano/Wallet/Deposit/Pure.hs | 138 ----- .../Wallet/Deposit/Pure/API/Address.hs | 210 -------- .../Wallet/Deposit/Pure/API/TxHistory.hs | 168 ------ .../Cardano/Wallet/Deposit/Pure/Balance.hs | 131 ----- .../Wallet/Deposit/Pure/State/Creation.hs | 196 ------- .../Wallet/Deposit/Pure/State/Payment.hs | 344 ------------ .../Deposit/Pure/State/Payment/Inspect.hs | 128 ----- .../Wallet/Deposit/Pure/State/Rolling.hs | 117 ----- .../Wallet/Deposit/Pure/State/Signing.hs | 72 --- .../Wallet/Deposit/Pure/State/Submissions.hs | 55 -- .../Wallet/Deposit/Pure/State/TxHistory.hs | 108 ---- .../Cardano/Wallet/Deposit/Pure/State/Type.hs | 127 ----- .../Wallet/Deposit/Pure/Submissions.hs | 105 ---- .../src/Cardano/Wallet/Deposit/Pure/UTxO.hs | 30 -- .../src/Cardano/Wallet/Deposit/Read.hs | 137 ----- .../src/Cardano/Wallet/Deposit/Testing/DSL.hs | 422 --------------- .../Wallet/Deposit/Testing/DSL/ByTime.hs | 244 --------- .../Wallet/Deposit/Testing/DSL/Types.hs | 25 - .../src/Cardano/Wallet/Deposit/Time.hs | 148 ------ .../src/Cardano/Wallet/Deposit/Write.hs | 222 -------- .../src/Cardano/Wallet/Deposit/Write/Keys.hs | 80 --- .../test/scenario/Test/Scenario/Blockchain.hs | 144 ----- .../Scenario/Wallet/Deposit/Exchanges.lhs | 1 - .../Scenario/Wallet/Deposit/Exchanges.lhs.md | 229 -------- .../Test/Scenario/Wallet/Deposit/Run.hs | 118 ----- .../test/scenario/test-suite-scenario.hs | 10 - .../Wallet/Deposit/HTTP/JSON/JSONSpec.hs | 186 ------- .../Wallet/Deposit/HTTP/OpenAPISpec.hs | 55 -- .../Cardano/Wallet/Deposit/Map/TimedSpec.hs | 429 --------------- .../Wallet/Deposit/Pure/API/AddressSpec.hs | 143 ----- .../Deposit/Pure/API/TransactionSpec.hs | 239 --------- .../unit/Cardano/Wallet/Deposit/PureSpec.hs | 346 ------------ .../unit/Cardano/Wallet/Deposit/RESTSpec.hs | 250 --------- .../Cardano/Wallet/Deposit/Write/KeysSpec.hs | 114 ---- lib/deposit-wallet/test/unit/Spec.hs | 1 - .../test/unit/test-suite-unit.hs | 15 - nix/project-package-list.nix | 2 +- 65 files changed, 1 insertion(+), 9663 deletions(-) delete mode 100644 lib/deposit-wallet/LICENSE delete mode 100644 lib/deposit-wallet/cardano-deposit-wallet.cabal delete mode 100644 lib/deposit-wallet/data/swagger.json delete mode 100644 lib/deposit-wallet/exe/cardano-deposit-wallet.hs delete mode 100644 lib/deposit-wallet/external-signing.md delete mode 100644 lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs delete mode 100644 lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs delete mode 100644 lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs delete mode 100644 lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs delete mode 100644 lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs delete mode 100644 lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs delete mode 100644 lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs delete mode 100644 lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs delete mode 100644 lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs delete mode 100644 lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md delete mode 100644 lib/deposit-wallet/spec/openapi/index.html delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs delete mode 100644 lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs delete mode 100644 lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs delete mode 120000 lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs delete mode 100644 lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md delete mode 100644 lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs delete mode 100644 lib/deposit-wallet/test/scenario/test-suite-scenario.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs delete mode 100644 lib/deposit-wallet/test/unit/Spec.hs delete mode 100644 lib/deposit-wallet/test/unit/test-suite-unit.hs diff --git a/cabal.project b/cabal.project index c4ff25d98e3..3c57b26e920 100644 --- a/cabal.project +++ b/cabal.project @@ -65,7 +65,6 @@ packages: lib/cardano-api-extra/ lib/crypto-primitives/ lib/coin-selection/ - lib/deposit-wallet/ lib/delta-chain/ lib/delta-store/ lib/delta-table/ @@ -293,9 +292,6 @@ package cardano-wallet-integration package cardano-wallet-test-utils tests: True -package cardano-deposit-wallet - tests: True - package std-gen-seed tests: True diff --git a/lib/deposit-wallet/LICENSE b/lib/deposit-wallet/LICENSE deleted file mode 100644 index f433b1a53f5..00000000000 --- a/lib/deposit-wallet/LICENSE +++ /dev/null @@ -1,177 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS diff --git a/lib/deposit-wallet/cardano-deposit-wallet.cabal b/lib/deposit-wallet/cardano-deposit-wallet.cabal deleted file mode 100644 index 8d4bea54d21..00000000000 --- a/lib/deposit-wallet/cardano-deposit-wallet.cabal +++ /dev/null @@ -1,269 +0,0 @@ -cabal-version: 3.6 -build-type: Simple -name: cardano-deposit-wallet -version: 0.2025.1.9 -synopsis: A wallet for the Cardano blockchain. -description: Please see README.md -homepage: https://github.com/cardano-foundation/cardano-wallet -license: Apache-2.0 -license-file: LICENSE -author: Cardano Foundation (High Assurance Lab) -maintainer: hal@cardanofoundation.org -copyright: 2023 Cardano Foundation -category: Web -data-files: data/swagger.json -extra-source-files: - spec/**/*.lagda.md - -common language - default-language: Haskell2010 - default-extensions: - NoImplicitPrelude - OverloadedStrings - -common opts-lib - ghc-options: - -Wall -Wcompat -Wredundant-constraints -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wunused-imports -Wunused-packages - - if flag(release) - ghc-options: -O2 -Werror - -common opts-exe - import: opts-lib - ghc-options: -threaded -rtsopts - -common no-delta-table-on-windows - if !os(windows) - build-depends: delta-table - other-modules: Cardano.Wallet.Deposit.IO.DB.Real - - else - other-modules: Cardano.Wallet.Deposit.IO.DB.Stub - -flag release - description: Enable optimization and `-Werror` - default: False - manual: True - -library - import: language, opts-lib, no-delta-table-on-windows - hs-source-dirs: src - build-depends: - , async - , base - , base16-bytestring - , base58-bytestring - , bech32 - , bech32-th - , bytestring - , cardano-addresses - , cardano-balance-tx - , cardano-crypto - , cardano-crypto-class - , cardano-ledger-api - , cardano-ledger-core - , cardano-strict-containers - , cardano-wallet - , cardano-wallet-network-layer - , cardano-wallet-primitive - , cardano-wallet-read - , containers - , contra-tracer - , customer-deposit-wallet-pure - , delta-store - , delta-types - , digest - , fingertree - , int-cast - , io-classes - , lens - , MonadRandom - , monoidal-containers - , mtl - , OddWord - , operational - , text - , time - , transformers - - exposed-modules: - Cardano.Wallet.Deposit.IO - Cardano.Wallet.Deposit.IO.DB - Cardano.Wallet.Deposit.IO.Network.Mock - Cardano.Wallet.Deposit.IO.Network.NodeToClient - Cardano.Wallet.Deposit.IO.Network.Type - Cardano.Wallet.Deposit.IO.Resource - Cardano.Wallet.Deposit.IO.Resource.Event - Cardano.Wallet.Deposit.Map - Cardano.Wallet.Deposit.Map.Timed - Cardano.Wallet.Deposit.Pure - Cardano.Wallet.Deposit.Pure.API.Address - Cardano.Wallet.Deposit.Pure.API.TxHistory - Cardano.Wallet.Deposit.Pure.Balance - Cardano.Wallet.Deposit.Pure.State.Creation - Cardano.Wallet.Deposit.Pure.State.Payment - Cardano.Wallet.Deposit.Pure.State.Payment.Inspect - Cardano.Wallet.Deposit.Pure.State.Rolling - Cardano.Wallet.Deposit.Pure.State.Signing - Cardano.Wallet.Deposit.Pure.State.Submissions - Cardano.Wallet.Deposit.Pure.State.TxHistory - Cardano.Wallet.Deposit.Pure.State.Type - Cardano.Wallet.Deposit.Pure.Submissions - Cardano.Wallet.Deposit.Pure.UTxO - Cardano.Wallet.Deposit.Read - Cardano.Wallet.Deposit.Testing.DSL - Cardano.Wallet.Deposit.Testing.DSL.ByTime - Cardano.Wallet.Deposit.Testing.DSL.Types - Cardano.Wallet.Deposit.Time - Cardano.Wallet.Deposit.Write - Cardano.Wallet.Deposit.Write.Keys - -test-suite scenario - import: language, opts-exe - type: exitcode-stdio-1.0 - hs-source-dirs: test/scenario - main-is: test-suite-scenario.hs - build-tool-depends: markdown-unlit:markdown-unlit - ghc-options: -pgmL markdown-unlit - build-depends: - , base - , bytestring - , cardano-crypto - , cardano-wallet-test-utils - , containers - , contra-tracer - , cardano-deposit-wallet - , delta-store - , hspec - - other-modules: - Test.Scenario.Blockchain - Test.Scenario.Wallet.Deposit.Exchanges - Test.Scenario.Wallet.Deposit.Run - -library http - import: language, opts-lib - visibility: public - hs-source-dirs: http - build-depends: - , aeson - , aeson-pretty - , base - , bytestring - , cardano-wallet-read - , contra-tracer - , cardano-deposit-wallet - , cardano-deposit-wallet:rest - , http-media - , insert-ordered-containers - , lens - , memory - , openapi3 - , servant - , servant-server - , text - , text-class - - exposed-modules: - Cardano.Wallet.Deposit.HTTP.Server - Cardano.Wallet.Deposit.HTTP.Types.API - Cardano.Wallet.Deposit.HTTP.Types.JSON - Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding - Cardano.Wallet.Deposit.HTTP.Types.OpenAPI - -library rest - import: language, opts-lib - visibility: public - hs-source-dirs: rest - build-depends: - , base - , bytestring - , cardano-addresses - , cardano-crypto - , cardano-ledger-byron - , contra-tracer - , crypto-primitives - , cardano-deposit-wallet - , customer-deposit-wallet-pure - , deepseq - , delta-store - , directory - , filepath - , memory - , serialise - , servant-server - , text - , transformers - - exposed-modules: - Cardano.Wallet.Deposit.REST - Cardano.Wallet.Deposit.REST.Catch - Cardano.Wallet.Deposit.REST.Start - Cardano.Wallet.Deposit.REST.Wallet.Create - -test-suite unit - import: language, opts-exe - type: exitcode-stdio-1.0 - hs-source-dirs: test/unit - main-is: test-suite-unit.hs - ghc-options: -Wno-unused-packages - build-depends: - , aeson - , aeson-pretty - , base - , base58-bytestring - , base16-bytestring - , bech32 - , bech32-th - , bytestring - , cardano-addresses - , address-derivation-discovery - , cardano-crypto - , cardano-crypto-class - , cardano-ledger-api - , cardano-ledger-core - , cardano-ledger-core:testlib - , cardano-ledger-shelley - , cardano-slotting - , cardano-wallet-read == 1.0.0.0 - , cardano-wallet-test-utils - , containers - , contra-tracer - , cardano-deposit-wallet - , customer-deposit-wallet-pure == 0.1.0.0 - , cardano-deposit-wallet:http - , cardano-deposit-wallet:rest - , data-default - , directory - , hspec - , hspec-golden - , lens - , openapi3 - , pretty-simple - , QuickCheck - , serialise - , temporary - , text - , time - , transformers - , with-utf8 - - build-tool-depends: hspec-discover:hspec-discover - other-modules: - Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec - Cardano.Wallet.Deposit.HTTP.OpenAPISpec - Cardano.Wallet.Deposit.Map.TimedSpec - Cardano.Wallet.Deposit.Pure.API.AddressSpec - Cardano.Wallet.Deposit.Pure.API.TransactionSpec - Cardano.Wallet.Deposit.PureSpec - Cardano.Wallet.Deposit.RESTSpec - Cardano.Wallet.Deposit.Write.KeysSpec - Paths_cardano_deposit_wallet - Spec - -executable cardano-deposit-wallet - import: language, opts-exe - hs-source-dirs: exe - build-depends: base - main-is: cardano-deposit-wallet.hs diff --git a/lib/deposit-wallet/data/swagger.json b/lib/deposit-wallet/data/swagger.json deleted file mode 100644 index 11fdc9e2081..00000000000 --- a/lib/deposit-wallet/data/swagger.json +++ /dev/null @@ -1,114 +0,0 @@ -{ - "components": { - "schemas": { - "ApiT Address": { - "format": "hex", - "type": "string" - }, - "ApiT ChainPoint": { - "oneOf": [ - { - "enum": [ - "genesis" - ], - "type": "string" - }, - { - "properties": { - "header_hash": { - "description": "Hash (Blake2b_256) of a block header.", - "format": "hex", - "maxLength": 64, - "minLength": 64, - "type": "string" - }, - "slot_no": { - "maximum": 1.8446744073709551615e19, - "minimum": 0, - "type": "integer" - } - }, - "type": "object" - } - ] - }, - "ApiT Customer": { - "maximum": 2147483647, - "minimum": 0, - "type": "integer" - }, - "ApiT CustomerList": { - "items": { - "properties": { - "address": { - "format": "hex", - "type": "string" - }, - "customer": { - "maximum": 2147483647, - "minimum": 0, - "type": "integer" - } - }, - "type": "object" - }, - "type": "array" - } - } - }, - "info": { - "description": "This is the API for the deposit wallet", - "license": { - "name": "Apache 2", - "url": "https://www.apache.org/licenses/LICENSE-2.0.html" - }, - "title": "Cardano Deposit Wallet API", - "version": "0.0.0.1" - }, - "openapi": "3.0.0", - "paths": { - "/customers": { - "parameters": [ - { - "in": "path", - "name": "customerId", - "schema": { - "$ref": "#/components/schemas/ApiT Customer" - } - } - ], - "put": { - "responses": { - "200": { - "content": { - "application/json": { - "schema": { - "$ref": "#/components/schemas/ApiT Address" - } - } - }, - "description": "Ok" - } - }, - "summary": "Add customer" - } - }, - "/network/local-tip": { - "get": { - "responses": { - "200": { - "content": { - "application/json": { - "schema": { - "$ref": "#/components/schemas/ApiT ChainPoint" - } - } - }, - "description": "Ok" - } - }, - "summary": "Obtain the chain point until which the wallet is synchronized against the network" - } - } - } -} \ No newline at end of file diff --git a/lib/deposit-wallet/exe/cardano-deposit-wallet.hs b/lib/deposit-wallet/exe/cardano-deposit-wallet.hs deleted file mode 100644 index 0e8df19982e..00000000000 --- a/lib/deposit-wallet/exe/cardano-deposit-wallet.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Prelude - -main :: IO () -main = pure () diff --git a/lib/deposit-wallet/external-signing.md b/lib/deposit-wallet/external-signing.md deleted file mode 100644 index 258f82acd9f..00000000000 --- a/lib/deposit-wallet/external-signing.md +++ /dev/null @@ -1,109 +0,0 @@ -# Signing via external tools. - -Here are instructions how to derive respective keys via cardano-addresses, then sign -transactions CBOR and send the updated CBOR using cardano-cli - -Assumptions: -User have either mnemonic, *phrase.prv*, or extended account private key, *acct.xsk*. -User know which credential payment index is going to be used, *ix*. -Unsigned or partially signed CBOR of tx is available. - -Goal is to construct CBOR that is input CBOR with properly added witness from the credential signing key -being a dual of the input credential payment verificiation key. - -1. In case of missing *acct.xsk* it can be derived as follows: -```bash -$ cat phrase.prv -attract flight range human visual record trade mango chunk enough satoshi galaxy grit van shrug - -$ cardano-address key from-recovery-phrase Shelley < phrase.prv > root.xsk -$ root.xsk -$ cat root.xsk -root_xsk1dqh2lewgwnfzf0kreek8c2zx9csq2d8nh9ku5tvkkxjzypuy5402qnxrl3htj84qxchuxueg3nt7uv50v2mj9vynpdckslyvc24qqxeysye4h2c0cgdemujn8mcprgcstgjvkep30ygu4p3ch983chukqvusp4yk - -$ cardano-address key child 1857H/1815H/0H < root.xsk > acct.xsk -$ cat acct.xsk -acct_xsk10zeunvvghchkcg8w6achyn3usv642alx8f57rv9kzdzt7yuy540xs4r08lwq576a3v822z9jv8v7kjkjpqxdqtjzt4ukh6w8f57vg0fv6dzaq33pps7hwe5f70cztch0z7kj0552felguwn6n2u74h248g5na6u5 -``` - -2. Deriving extended verification keys and signing keys for role=0 and address ix=0, and hash that is credential -```bash -$ cardano-address key child 0/0 < acct.xsk > key.xsk -$ cat key.xsk -addr_xsk14pwgnh4q757kgfjn2w83prmh27kj58ety3acvt0jvx2lwxvy540gmd5gug2egr9dlzv4z04nm9jd26al494w9t6qhlzf07re2myu9mv7syp6aym49c0d97lfg8y0c36vgjv54qnwte6rz3f6x0ltnjqfwcnufn8e - -$ cardano-address key public --with-chain-code < key.xsk > key.xvk -$ cat key.xvk -addr_xvk1dkqjgyp2tdq0a0tre7qlhprdr88r497k072q0726lhux4xyfxtcfaqgr46fh2ts76ta7jswgl3r5c3yef2pxuhn5x9zn5vl7h8yqjas27h22j - -$ cardano-address key hash < key.xvk -addr_vkh1k70phz25qm9g6uxxguw8znnepqc5uu2mqx9yd7ea8yc7urscytf -$ cardano-address key hash --hex < key.xvk -b79e1b895406ca8d70c6471c714e7908314e715b018a46fb3d3931ee -``` - -3. Constructing enterprise address for preprod using *key.xvk* -```bash -$ cardano-address address payment --network-tag testnet < key.xvk -addr_test1vzmeuxuf2srv4rtscer3cu2w0yyrznn3tvqc53hm85unrmsg4m9cg -``` - -4. Mapping *key.xsk* to the key suitable for cardano-cli -```bash -$ cardano-cli key convert-cardano-address-key --shelley-payment-key --signing-key-file key.xsk --out-file key.skey -$ cat key.skey -{ - "type": "PaymentExtendedSigningKeyShelley_ed25519_bip32", - "description": "", - "cborHex": "5880a85c89dea0f53d642653538f108f7757ad2a1f2b247b862df26195f71984a55e8db688e215940cadf899513eb3d964d56bbfa96ae2af40bfc497f87956c9c2ed6d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f09e8103ae93752e1ed2fbe941c8fc474c44994a826e5e7431453a33feb9c80976" -} -``` -Remark: *cborHex* contains: -- prefix 5880 staking that the bytestring is 128 bytes -- signing key (64 bytes) -- verification key (32 bytes) -- chain code (32 bytes) -One can confirm this using `cardano-address key inspect`, `cardano-address key public` and `cardano-address key private` options - -5. The corresponding verification key -```bash -$ cardano-cli key verification-key --signing-key-file key.skey --verification-key-file key.vkey -$ cat key.vkey -{ - "type": "PaymentExtendedVerificationKeyShelley_ed25519_bip32", - "description": "", - "cborHex": "58406d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f09e8103ae93752e1ed2fbe941c8fc474c44994a826e5e7431453a33feb9c80976" -} -``` -Remark: *cborHex* contains: -- prefix 5840 staking that the bytestring is 64 bytes -- verification key (32 bytes) -- chain code (32 bytes) - -6. The corresponding key hash (the same like in point 2 above) -```bash -$ cardano-cli address key-hash --payment-verification-key-file key.vkey -b79e1b895406ca8d70c6471c714e7908314e715b018a46fb3d3931ee -``` - -7. Signing using cardano-cli. Here let's assume we have unsigned tx and we will use the above keys. -```bash -$ cat tx.unsigned -{ - "type":"Unwitnessed Tx ConwayEra", - "description":"Ledger Cddl Format", - "cborHex":"84a400d90102818258204fe1968fc521dffe2bb9799b9c6548e38cd5e1a593c7d43a251eeb92deadc3fe00018282581d60d23d12a37c21b84c8c7838d4bbda848fe7a6b7bfc3f54212238912ec1a000f424082581d601cbb2cdd51437bb9f43bdd1214984e8b2794e0cff25f47ba187494041b0000000253fa1907021a000288b9031a0498a97aa0f5f6"} - -$ cardano-cli conway transaction sign --signing-key-file key.skey --testnet-magic 1 --tx-body-file tx.unsigned --out-file tx.signed -$ cat tx.signed -{ - "type": "Witnessed Tx ConwayEra", - "description": "Ledger Cddl Format", - "cborHex": "84a400d90102818258204fe1968fc521dffe2bb9799b9c6548e38cd5e1a593c7d43a251eeb92deadc3fe00018282581d60d23d12a37c21b84c8c7838d4bbda848fe7a6b7bfc3f54212238912ec1a000f424082581d601cbb2cdd51437bb9f43bdd1214984e8b2794e0cff25f47ba187494041b0000000253fa1907021a000288b9031a0498a97aa100d90102818258206d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f058401a4757dc289f97684339ec766d1fcddfe1ebd50a53d7cccbb71b265e784dd6eb4bf87d5b6c2383e66f1a679f2ac0d97add6a890779096f0802690518223a8c04f5f6" -} -``` - -8. Submitting the signed tx -```bash -$ cardano-cli conway transaction submit --tx-file tx.signed --testnet-magic 1 -``` diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs deleted file mode 100644 index e16def75ebe..00000000000 --- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs +++ /dev/null @@ -1,168 +0,0 @@ --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Implementation of our HTTP API. -module Cardano.Wallet.Deposit.HTTP.Server - ( api - , server - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.HTTP.Types.API - ( API - ) -import Cardano.Wallet.Deposit.HTTP.Types.JSON - ( Address - , ApiT (..) - , Customer - ) -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( createMnemonicFromWords - , credentialsFromEncodedXPub - , credentialsFromMnemonics - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , customerAddress - , listCustomers - ) -import Cardano.Wallet.Deposit.REST.Catch - ( catchRunWalletResourceM - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic (..) - , PostWalletViaXPub (..) - ) -import Control.Tracer - ( Tracer - ) -import Data.Functor - ( ($>) - ) -import Data.Proxy - ( Proxy (..) - ) -import Servant - ( Handler - , NoContent (..) - , err500 - , (:<|>) (..) - ) -import Servant.Server - ( Server - ) - -import qualified Cardano.Wallet.Deposit.REST as REST - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} -api :: Proxy API -api = Proxy - -server - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> FilePath - -> WalletBootEnv IO - -> WalletResource - -> Server API -server wtc tr dbDir wb r = - listCustomerH r - :<|> queryAddressH r - :<|> createWalletViaMnemonic wtc tr dbDir wb r - :<|> createWalletViaXPub wtc tr dbDir wb r - -createWalletViaMnemonic - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> FilePath - -> WalletBootEnv IO - -> WalletResource - -> PostWalletViaMnemonic - -> Handler NoContent -createWalletViaMnemonic - wtc - tracer - dir - boot - resource - (PostWalletViaMnemonic mnemonics' passphrase' users') = do - case createMnemonicFromWords mnemonics' of - Left e -> fail $ show e - Right someMnemonic -> do - let - initWallet :: WalletResourceM () - initWallet = - REST.initWallet - wtc - tracer - boot - dir - (credentialsFromMnemonics someMnemonic passphrase') - (fromIntegral users') - onlyOnWalletIntance resource initWallet $> NoContent - -createWalletViaXPub - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> FilePath - -> WalletBootEnv IO - -> WalletResource - -> PostWalletViaXPub - -> Handler NoContent -createWalletViaXPub - wtc - tracer - dir - boot - resource - (PostWalletViaXPub xpubText users') = do - result <- onlyOnWalletIntance resource initWallet - case result of - Left e -> fail e - Right () -> pure NoContent - where - initWallet :: WalletResourceM (Either String ()) - initWallet = case credentialsFromEncodedXPub xpubText of - Left e -> pure $ Left $ show e - Right credentials -> - Right - <$> REST.initWallet - wtc - tracer - boot - dir - credentials - (fromIntegral users') - -listCustomerH - :: WalletResource - -> Handler (ApiT [(Customer, Address)]) -listCustomerH wr = ApiT <$> onlyOnWalletIntance wr listCustomers - -queryAddressH - :: WalletResource - -> ApiT Customer - -> Handler (ApiT Address) -queryAddressH wr (ApiT customer) = do - mAddr <- onlyOnWalletIntance wr $ customerAddress customer - case mAddr of - Nothing -> fail $ "Address not found for customer " <> show customer - Just a -> pure $ ApiT a - -onlyOnWalletIntance - :: WalletResource - -> WalletResourceM a - -> Handler a -onlyOnWalletIntance wr = catchRunWalletResourceM wr err500 diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs deleted file mode 100644 index 0732c56fde9..00000000000 --- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Servant Type for our HTTP API. -module Cardano.Wallet.Deposit.HTTP.Types.API - ( API - , NetworkAPI - ) -where - -import Cardano.Wallet.Deposit.HTTP.Types.JSON - ( Address - , ApiT - , ChainPoint - , Customer - , CustomerList - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic - , PostWalletViaXPub - ) -import Servant.API - ( Capture - , Get - , JSON - , Put - , PutNoContent - , ReqBody - , StdMethod (..) - , Verb - , (:<|>) - , (:>) - ) - -{----------------------------------------------------------------------------- - API -------------------------------------------------------------------------------} - -type API = - "customers" - :> Get '[JSON] (ApiT CustomerList) - :<|> "customers" - :> Capture "customerId" (ApiT Customer) - :> Put '[JSON] (ApiT Address) - :<|> "mnemonics" - :> ReqBody '[JSON] PostWalletViaMnemonic - :> PutNoContent - :<|> "xpub" - :> ReqBody '[JSON] PostWalletViaXPub - :> PutNoContent - -type NetworkAPI = - "network" - :> "local-tip" - :> Verb 'GET 200 '[JSON] (ApiT ChainPoint) diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs deleted file mode 100644 index 7fe975c6234..00000000000 --- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Data types with a JSON schema. -module Cardano.Wallet.Deposit.HTTP.Types.JSON - ( ApiT (..) - - -- * Re-exports - , Address - , Customer - , CustomerList - , ChainPoint (..) - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding - ( ViaText (..) - ) -import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI - ( addressSchema - , chainPointSchema - , customerListSchema - , customerSchema - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - ) -import Cardano.Wallet.Deposit.Read - ( Address - , ChainPoint (..) - ) -import Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic - , PostWalletViaXPub - ) -import Control.Applicative - ( (<|>) - ) -import Data.Aeson - ( FromJSON (..) - , ToJSON (..) - , object - , withObject - , withText - , (.:) - , (.=) - ) -import Data.Aeson.Types - ( Parser - ) -import Data.Bifunctor - ( first - ) -import Data.ByteArray.Encoding - ( Base (Base16) - , convertFromBase - , convertToBase - ) -import Data.ByteString.Short - ( fromShort - , toShort - ) -import Data.OpenApi - ( NamedSchema (..) - , ToSchema (..) - ) -import Data.Text - ( Text - ) -import Data.Text.Class - ( FromText (..) - , TextDecodingError (..) - , ToText (..) - , getTextDecodingError - ) -import Servant - ( FromHttpApiData (..) - ) - -import qualified Cardano.Wallet.Read as Read -import qualified Cardano.Wallet.Read.Hash as Hash -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -{----------------------------------------------------------------------------- - Additional type definitions -------------------------------------------------------------------------------} - -type CustomerList = [(Customer, Address)] - -{----------------------------------------------------------------------------- - ApiT -------------------------------------------------------------------------------} - -newtype ApiT a = ApiT {unApiT :: a} - deriving (Eq, Ord, Show) - -{----------------------------------------------------------------------------- - JSON encodings -------------------------------------------------------------------------------} - --- Address -instance ToText (ApiT Address) where - toText = - T.decodeUtf8 - . convertToBase Base16 - . fromShort - . Read.toShortByteString - . unApiT - -instance FromText (ApiT Address) where - fromText t = do - bytes <- - first textDecodingError - . convertFromBase Base16 - $ T.encodeUtf8 t - maybe (Left errInvalidAddress) (Right . ApiT) - . Read.fromShortByteString - $ toShort bytes - where - errInvalidAddress = TextDecodingError $ "Invalid address: " <> show t - textDecodingError = TextDecodingError . show - --- FIXME: Bech32 encodings -deriving via ViaText (ApiT Address) instance FromJSON (ApiT Address) -deriving via ViaText (ApiT Address) instance ToJSON (ApiT Address) - -instance ToSchema (ApiT Address) where - declareNamedSchema _ = do - pure - $ NamedSchema - (Just "ApiT Address") - addressSchema - --- Customer -instance FromHttpApiData (ApiT Customer) where - parseUrlPiece = fmap (ApiT . toEnum) . fromText' - -instance FromJSON (ApiT Customer) where - parseJSON = fmap (ApiT . toEnum) . parseJSON - -instance ToJSON (ApiT Customer) where - toJSON = toJSON . fromEnum . unApiT - -instance ToSchema (ApiT Customer) where - declareNamedSchema _ = do - pure - $ NamedSchema - (Just "ApiT Customer") - customerSchema - --- | 'fromText' but with a simpler error type. -fromText' :: FromText a => Text -> Either Text a -fromText' = first (T.pack . getTextDecodingError) . fromText - -instance ToJSON (ApiT (Customer, Address)) where - toJSON (ApiT (c, a)) = - object - [ "customer" .= toJSON (ApiT c) - , "address" .= toJSON (ApiT a) - ] - -instance FromJSON (ApiT (Customer, Address)) where - parseJSON = withObject "ApiT (Customer, Address)" $ \obj -> do - customerApiT <- obj .: "customer" - addressApiT <- obj .: "address" - pure $ ApiT (unApiT customerApiT, unApiT addressApiT) - -instance FromJSON (ApiT CustomerList) where - parseJSON l = do - custoList <- (parseJSON l :: Parser [ApiT (Customer, Address)]) - pure $ ApiT (unApiT <$> custoList) - -instance ToJSON (ApiT CustomerList) where - toJSON (ApiT cl) = toJSON (toJSON . ApiT <$> cl) - -instance ToSchema (ApiT CustomerList) where - declareNamedSchema _ = do - pure - $ NamedSchema - (Just "ApiT CustomerList") - customerListSchema - -instance ToJSON (ApiT ChainPoint) where - toJSON (ApiT Read.GenesisPoint) = "genesis" - toJSON (ApiT (Read.BlockPoint{slotNo, headerHash})) = - object - [ "slot_no" - .= Read.unSlotNo slotNo - , "header_hash" - .= Hash.hashToTextAsHex headerHash - ] - -instance FromJSON (ApiT ChainPoint) where - parseJSON payload = parseOrigin payload <|> parseSlot payload - where - parseOrigin = withText "genesis" $ \txt -> - if txt == "genesis" - then pure $ ApiT Read.GenesisPoint - else fail "'genesis' is expected." - parseSlot = withObject "slot_no" $ \obj -> do - slotNo <- Read.SlotNo <$> obj .: "slot_no" - headerHashText <- obj .: "header_hash" - headerHash <- - case Hash.hashFromTextAsHex headerHashText of - Nothing -> fail "invalid 'header_hash'" - Just hash -> pure hash - pure $ ApiT Read.BlockPoint{slotNo, headerHash} - -instance ToSchema (ApiT ChainPoint) where - declareNamedSchema _ = do - pure - $ NamedSchema - (Just "ApiT ChainPoint") - chainPointSchema - -instance FromJSON PostWalletViaMnemonic - -instance FromJSON PostWalletViaXPub diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs deleted file mode 100644 index 2100be31f2e..00000000000 --- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Utilities for mapping data types to/from JSON. --- -module Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding - ( Custom (..) - , customOptions - , ViaText (..) - ) where - -import Prelude - -import Data.Aeson - ( FromJSON (..) - , GFromJSON - , GToJSON' - , Options (..) - , ToJSON (..) - , Value - , Zero - , camelTo2 - , defaultOptions - , genericParseJSON - , genericToJSON - , withText - ) -import Data.Aeson.Types - ( Parser - ) -import Data.Text.Class - ( FromText (..) - , ToText (toText) - ) -import GHC.Generics - ( Generic - , Rep - ) - -{----------------------------------------------------------------------------- - Generics -------------------------------------------------------------------------------} -newtype Custom a = Custom {unCustom :: a} - -instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Custom a) - where - parseJSON = fmap Custom . genericParseJSON customOptions - -instance (Generic a, GToJSON' Value Zero (Rep a)) => ToJSON (Custom a) - where - toJSON = genericToJSON customOptions . unCustom - -customOptions :: Options -customOptions = defaultOptions - { fieldLabelModifier = camelTo2 '_' . dropWhile (== '_') - , omitNothingFields = True - } - -{----------------------------------------------------------------------------- - Text -------------------------------------------------------------------------------} -newtype ViaText a = ViaText {unViaText :: a} - -instance FromText a => FromJSON (ViaText a) where - parseJSON = fmap ViaText . fromTextJSON "" -instance ToText a => ToJSON (ViaText a) where - toJSON = toTextJSON . unViaText - -eitherToParser :: Show s => Either s a -> Parser a -eitherToParser = either (fail . show) pure - -toTextJSON :: ToText a => a -> Value -toTextJSON = toJSON . toText - -fromTextJSON :: FromText a => String -> Value -> Parser a -fromTextJSON n = withText n (eitherToParser . fromText) diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs deleted file mode 100644 index 5e75480cd89..00000000000 --- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.HTTP.Types.OpenAPI - ( generateOpenapi3 - , apiSchema - , depositPaths - , depositDefinitions - - , customerSchema - , addressSchema - , customerListSchema - , chainPointSchema - ) where - -import Prelude - -import Control.Lens - ( At (..) - , (&) - , (.~) - , (?~) - ) -import Data.Aeson.Encode.Pretty - ( encodePretty - ) -import Data.HashMap.Strict.InsOrd - ( InsOrdHashMap - ) -import Data.OpenApi - ( Definitions - , HasComponents (..) - , HasContent (..) - , HasDescription (..) - , HasEnum (..) - , HasFormat (..) - , HasGet (..) - , HasIn (..) - , HasInfo (..) - , HasItems (..) - , HasLicense (license) - , HasMaxLength (..) - , HasMaximum (..) - , HasMinLength (..) - , HasMinimum (..) - , HasName (..) - , HasOneOf (..) - , HasParameters (..) - , HasPaths (..) - , HasProperties (..) - , HasPut (..) - , HasSchema (..) - , HasSchemas (..) - , HasSummary (..) - , HasTitle (..) - , HasType (..) - , HasUrl (..) - , HasVersion (..) - , License - , OpenApi - , OpenApiItems (..) - , OpenApiType (..) - , Operation - , ParamLocation (..) - , PathItem - , Reference (..) - , Referenced (..) - , Schema - , URL (..) - , _Inline - ) -import Data.Word - ( Word64 - ) -import Network.HTTP.Media - ( MediaType - ) - -import qualified Data.ByteString.Lazy.Char8 as BL - -generateOpenapi3 :: BL.ByteString -generateOpenapi3 = encodePretty apiSchema - -apiSchema :: OpenApi -apiSchema :: OpenApi = - mempty - & info . title .~ "Cardano Deposit Wallet API" - & info . version .~ "0.0.0.1" - & info . description ?~ "This is the API for the deposit wallet" - & info . license ?~ license' - & paths .~ depositPaths - & components . schemas .~ depositDefinitions - -license' :: License -license' = - "Apache 2" - & url ?~ URL "https://www.apache.org/licenses/LICENSE-2.0.html" - -depositPaths :: InsOrdHashMap FilePath PathItem -depositPaths = - [ getCustomersListPath - , putCustomerPath - , getLocalTipPath - ] - -depositDefinitions :: Definitions Schema -depositDefinitions = - [ ("ApiT Customer", customerSchema) - , ("ApiT Address", addressSchema) - , ("ApiT CustomerList", customerListSchema) - , ("ApiT ChainPoint", chainPointSchema) - ] - --- | Paths -jsonMediaType :: MediaType -jsonMediaType = "application/json" - -getCustomersListPath :: (FilePath, PathItem) -getCustomersListPath = ("/customers", pathItem) - where - pathItem :: PathItem - pathItem = mempty & get ?~ operation - operation :: Operation - operation = - mempty - & summary ?~ summary' - & at 200 ?~ at200 - summary' = "Obtain the list of customers" - at200 = - "Ok" - & _Inline . content . at jsonMediaType - ?~ (mempty & schema ?~ Ref (Reference "ApiT CustomerList")) - -putCustomerPath :: (FilePath, PathItem) -putCustomerPath = ("/customers", pathItem) - where - pathItem :: PathItem - pathItem = - mempty - & put ?~ operation - & parameters - .~ [ Inline - $ mempty - & in_ .~ ParamPath - & name .~ "customerId" - & schema ?~ Ref (Reference "ApiT Customer") - ] - operation :: Operation - operation = - mempty - & summary ?~ summary' - & at 200 ?~ at200 - summary' = "Add customer" - at200 = - "Ok" - & _Inline . content . at jsonMediaType - ?~ (mempty & schema ?~ Ref (Reference "ApiT Address")) - --- | Input/Output type schemas -customerSchema :: Schema -customerSchema = - mempty - & type_ ?~ OpenApiInteger - & minimum_ ?~ 0 - & maximum_ ?~ 2147483647 - -addressSchema :: Schema -addressSchema = - mempty - & type_ ?~ OpenApiString - & format ?~ "hex" - -customerListItemSchema :: Schema -customerListItemSchema = - mempty - & type_ ?~ OpenApiObject - & properties - .~ [ ("customer", Inline customerSchema) - , ("address", Inline addressSchema) - ] - -customerListSchema :: Schema -customerListSchema = - mempty - & type_ ?~ OpenApiArray - & items - ?~ OpenApiItemsObject - (Inline customerListItemSchema) - -getLocalTipPath :: (FilePath, PathItem) -getLocalTipPath = ("/network/local-tip", pathItem) - where - pathItem :: PathItem - pathItem = mempty & get ?~ operation - operation :: Operation - operation = - mempty - & summary ?~ summary' - & at 200 ?~ at200 - summary' = "Obtain the chain point until which the wallet is synchronized against the network" - at200 = - "Ok" - & _Inline . content . at jsonMediaType - ?~ (mempty & schema ?~ Ref (Reference "ApiT ChainPoint")) - -chainPointSchema :: Schema -chainPointSchema = - mempty - & oneOf ?~ [Inline chainPointOriginSchema, Inline chainPointAtSlotSchema] - -chainPointOriginSchema :: Schema -chainPointOriginSchema = - mempty - & type_ ?~ OpenApiString - & enum_ ?~ ["genesis"] - -chainPointAtSlotSchema :: Schema -chainPointAtSlotSchema = - mempty - & type_ ?~ OpenApiObject - & properties - .~ [ ("slot_no", Inline slotSchema) - , ("header_hash", Inline headerHashSchema) - ] - -slotSchema :: Schema -slotSchema = - mempty - & type_ ?~ OpenApiInteger - & minimum_ ?~ 0 - & maximum_ ?~ fromIntegral (maxBound :: Word64) - -headerHashSchema :: Schema -headerHashSchema = - blake2b_256Schema - & description ?~ "Hash (Blake2b_256) of a block header." - -blake2b_256Schema :: Schema -blake2b_256Schema = - mempty - & type_ ?~ OpenApiString - & format ?~ "hex" - & minLength ?~ (32 * hexCharactersPerByte) - & maxLength ?~ (32 * hexCharactersPerByte) - -hexCharactersPerByte :: Integer -hexCharactersPerByte = 2 diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs deleted file mode 100644 index 66ba07ddd35..00000000000 --- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs +++ /dev/null @@ -1,491 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- 'IO'-based interface to the Deposit Wallet --- where the wallet is treated as a mutable resource (~ REST). --- This interface can be mapped one-to-one to a HTTP interface. -module Cardano.Wallet.Deposit.REST - ( -- * Types - WalletResource - , WalletResourceM - , ErrDatabase (..) - , ErrLoadingDatabase (..) - , ErrCreatingDatabase (..) - , ErrWalletResource (..) - - -- * Running - , runWalletResourceM - - -- * Operations - - -- ** Initialization - , initWallet - , loadWallet - - -- ** Mapping between customers and addresses - , listCustomers - , customerAddress - , addressToCustomer - - -- ** Reading from the blockchain - , getWalletTip - , availableBalance - , getTxHistoryByCustomer - , getTxHistoryByTime - , WalletIO.ResolveAddress - - -- ** Writing to the blockchain - , createPayment - , getBIP32PathsForOwnedInputs - , signTx - , walletExists - , walletPublicIdentity - , deleteWallet - , deleteTheDepositWalletOnDisk - - -- * Internals - , inspectTx - , onWalletInstance - , networkTag - , resolveCurrentEraTx - , canSign - , submitTx - ) where - -import Prelude - -import Cardano.Address.Derivation - ( xpubToBytes - ) -import Cardano.Crypto.Wallet - ( XPrv - , XPub (..) - , unXPrv - , unXPub - , xprv - , xpub - ) -import Cardano.Wallet.Address.BIP32 - ( BIP32Path - ) -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv - , WalletPublicIdentity - , genesisData - ) -import Cardano.Wallet.Deposit.IO.Resource - ( ErrResourceExists (..) - , ErrResourceMissing (..) - ) -import Cardano.Wallet.Deposit.Pure - ( CanSign - , Credentials - , CurrentEraResolvedTx - , Customer - , ErrCreatePayment - , InspectTx - , Passphrase - , Word31 - , fromCredentialsAndGenesis - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( accountXPubFromCredentials - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Codec.Serialise - ( Serialise (..) - , deserialise - , serialise - ) -import Control.DeepSeq - ( deepseq - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Control.Monad.Trans.Class - ( lift - ) -import Control.Monad.Trans.Except - ( ExceptT (..) - , runExceptT - ) -import Control.Monad.Trans.Reader - ( ReaderT (..) - , ask - ) -import Control.Tracer - ( Tracer (..) - ) -import Cryptography.Hash.Blake - ( blake2b160 - ) -import Data.Bifunctor - ( first - ) -import Data.ByteArray.Encoding - ( Base (..) - , convertToBase - ) -import Data.ByteString - ( ByteString - ) -import Data.List - ( isPrefixOf - ) -import Data.Store - ( Store (..) - , newStore - ) -import System.Directory - ( listDirectory - , removeFile - ) -import System.FilePath - ( () - ) - -import qualified Cardano.Wallet.Deposit.IO as WalletIO -import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network -import qualified Cardano.Wallet.Deposit.IO.Resource as Resource -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BL - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} - --- | Error indicating that the database could not be loaded. -data ErrLoadingDatabase - = ErrDatabaseNotFound FilePath - | ErrDatabaseCorrupted FilePath - | ErrMultipleDatabases [FilePath] - deriving (Show, Eq) - --- | Error indicating that the database could not be created. -newtype ErrCreatingDatabase - = ErrDatabaseAlreadyExists FilePath - deriving (Show, Eq) - --- | Error indicating that the database could not be loaded or created. -data ErrDatabase - = ErrLoadingDatabase ErrLoadingDatabase - | ErrCreatingDatabase ErrCreatingDatabase - deriving (Show, Eq) - --- | Mutable resource that may hold a 'WalletInstance'. -type WalletResource = - Resource.Resource ErrDatabase WalletIO.WalletInstance - --- | Error indicating that the 'WalletResource' does not hold a wallet. -data ErrWalletResource - = ErrNoWallet (Resource.ErrResourceMissing ErrDatabase) - | ErrWalletPresent - (Resource.ErrResourceExists ErrDatabase WalletIO.WalletInstance) - -instance Show ErrWalletResource where - show = \case - ErrNoWallet e -> case e of - ErrNotInitialized -> "Wallet is not initialized" - ErrStillInitializing -> "Wallet is still initializing" - ErrVanished e' -> "Wallet absent and vanished: " <> show e' - ErrFailedToInitialize e' -> - "Wallet failed to initialize (no wallet): " - <> show e' - ErrClosing -> "Wallet is closing" - ErrWalletPresent e -> case e of - ErrAlreadyInitializing -> "Wallet is already initializing" - ErrAlreadyInitialized _ -> "Wallet is already initialized" - ErrAlreadyVanished e' -> "Wallet vanished: " <> show e' - ErrAlreadyFailedToInitialize e' -> - "Wallet failed to initialize (wallet present): " - <> show e' - ErrAlreadyClosing -> "Wallet is already closing" - --- | Monad for acting on a 'WalletResource'. -type WalletResourceM = - ReaderT WalletResource (ExceptT ErrWalletResource IO) - --- | Run a 'WalletResourceM' action on a 'WalletResource'. -runWalletResourceM - :: WalletResourceM a - -> WalletResource - -> IO (Either ErrWalletResource a) -runWalletResourceM action resource = - runExceptT (runReaderT action resource) - --- | Run an 'IO' function on the 'WalletInstance'. -onWalletInstance - :: (WalletIO.WalletInstance -> IO a) - -> WalletResourceM a -onWalletInstance action = ReaderT $ \resource -> - ExceptT - $ first ErrNoWallet <$> Resource.onResource action resource - -{----------------------------------------------------------------------------- - Initialization -------------------------------------------------------------------------------} - --- | Prefix for deposit wallets on disk. -depositPrefix :: String -depositPrefix = "deposit-" - --- | Scan a directory for deposit wallets. -scanDirectoryForDepositPrefix :: FilePath -> IO [FilePath] -scanDirectoryForDepositPrefix dir = do - files <- listDirectory dir - pure $ filter (depositPrefix `isPrefixOf`) files - -deleteTheDepositWalletOnDisk :: FilePath -> IO () -deleteTheDepositWalletOnDisk dir = do - ds <- scanDirectoryForDepositPrefix dir - case ds of - [d] -> removeFile (dir d) - _ -> pure () - --- | Try to open an existing wallet -findTheDepositWalletOnDisk - :: WalletBootEnv IO - -> FilePath - -- ^ Path to the wallet database directory - -> (Either ErrLoadingDatabase WalletIO.WalletStore -> IO a) - -- ^ Action to run if the wallet is found - -> IO a -findTheDepositWalletOnDisk env dir action = do - ds <- scanDirectoryForDepositPrefix dir - case ds of - [d] -> do - (credentials, customers) <- - deserialise <$> BL.readFile (dir d) - let state = - fromCredentialsAndGenesis - credentials - (fromIntegral @Int customers) - (genesisData env) - store <- newStore - writeS store state - action $ Right store - [] -> action $ Left $ ErrDatabaseNotFound dir - ds' -> action $ Left $ ErrMultipleDatabases ((dir ) <$> ds') - -instance Serialise XPub where - encode = encode . unXPub - decode = do - b <- decode - case xpub b of - Right x -> pure x - Left e -> fail e - -instance Serialise XPrv where - encode = encode . unXPrv - decode = do - b :: ByteString <- decode - case xprv b of - Right x -> pure x - Left e -> fail e - -instance Serialise Credentials - --- | Try to create a new wallet -createTheDepositWalletOnDisk - :: Tracer IO String - -- ^ Tracer for logging - -> FilePath - -- ^ Path to the wallet database directory - -> Credentials - -- ^ Id of the wallet - -> Word31 - -- ^ Maximum customer index - -> (Maybe WalletIO.WalletStore -> IO a) - -- ^ Action to run if the wallet is created - -> IO a -createTheDepositWalletOnDisk _tr dir credentials users action = do - ds <- scanDirectoryForDepositPrefix dir - case ds of - [] -> do - let fp = dir depositPrefix <> hashWalletId credentials - BL.writeFile fp - $ serialise (credentials, fromIntegral users :: Int) - store <- newStore - action $ Just store - _ -> do - action Nothing - where - hashWalletId :: Credentials -> String - hashWalletId = - B8.unpack - . convertToBase Base16 - . blake2b160 - . xpubToBytes - . accountXPubFromCredentials - --- | Load an existing wallet from disk. -loadWallet - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> WalletIO.WalletBootEnv IO - -- ^ Environment for the wallet - -> FilePath - -- ^ Path to the wallet database directory - -> WalletResourceM () -loadWallet wtc bootEnv dir = do - let action - :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b) - action f = findTheDepositWalletOnDisk bootEnv dir $ \case - Right wallet -> - Right - <$> WalletIO.withWalletLoad wtc - (WalletIO.WalletEnv bootEnv wallet) - f - Left e -> pure $ Left $ ErrLoadingDatabase e - resource <- ask - lift - $ ExceptT - $ first ErrWalletPresent - <$> Resource.putResource action resource - --- | Initialize a new wallet from an 'XPub'. -initWallet - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -- ^ Tracer for logging - -> WalletIO.WalletBootEnv IO - -- ^ Environment for the wallet - -> FilePath - -- ^ Path to the wallet database directory - -> Credentials - -- ^ Id of the wallet - -> Word31 - -- ^ Max number of users ? - -> WalletResourceM () -initWallet wtc tr bootEnv dir credentials users = do - let action - :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b) - action f = createTheDepositWalletOnDisk tr dir credentials users $ \case - Just wallet -> do - fmap Right - $ WalletIO.withWalletInit wtc - (WalletIO.WalletEnv bootEnv wallet) - credentials - users - $ \i -> do - addresses <- map snd <$> WalletIO.listCustomers i - addresses `deepseq` f i - Nothing -> - pure - $ Left - $ ErrCreatingDatabase - $ ErrDatabaseAlreadyExists dir - resource <- ask - lift - $ ExceptT - $ first ErrWalletPresent - <$> Resource.putResource action resource - -deleteWallet :: FilePath -> WalletResourceM () -deleteWallet dir = do - resource <- ask - lift - $ ExceptT - $ first ErrNoWallet - <$> Resource.closeResource resource - liftIO $ deleteTheDepositWalletOnDisk dir - -walletExists :: FilePath -> IO Bool -walletExists dir = do - r <- scanDirectoryForDepositPrefix dir - case r of - [] -> pure False - _ -> pure True - -walletPublicIdentity :: WalletResourceM WalletPublicIdentity -walletPublicIdentity = onWalletInstance WalletIO.walletPublicIdentity - -{----------------------------------------------------------------------------- - Operations -------------------------------------------------------------------------------} - --- | List all tracked customers addresses. -listCustomers :: WalletResourceM [(Customer, Address)] -listCustomers = onWalletInstance WalletIO.listCustomers - --- | Retrieve the address for a customer if it's tracked by the wallet. -customerAddress :: Customer -> WalletResourceM (Maybe Address) -customerAddress = onWalletInstance . WalletIO.customerAddress - -addressToCustomer :: WalletResourceM WalletIO.ResolveAddress -addressToCustomer = onWalletInstance WalletIO.addressToCustomer - -{----------------------------------------------------------------------------- - Operations - Reading from the blockchain -------------------------------------------------------------------------------} -getWalletTip :: WalletResourceM Read.ChainPoint -getWalletTip = onWalletInstance WalletIO.getWalletTip - -availableBalance :: WalletResourceM Read.Value -availableBalance = onWalletInstance WalletIO.availableBalance - -getTxHistoryByCustomer - :: WalletResourceM ByCustomer -getTxHistoryByCustomer = onWalletInstance WalletIO.getTxHistoryByCustomer - -getTxHistoryByTime - :: WalletResourceM ByTime -getTxHistoryByTime = onWalletInstance WalletIO.getTxHistoryByTime - -networkTag :: WalletResourceM Read.NetworkTag -networkTag = onWalletInstance WalletIO.networkTag - -{----------------------------------------------------------------------------- - Operations - Writing to blockchain -------------------------------------------------------------------------------} - -createPayment - :: [(Address, Read.Value)] - -> WalletResourceM (Either ErrCreatePayment CurrentEraResolvedTx) -createPayment = onWalletInstance . WalletIO.createPayment - -getBIP32PathsForOwnedInputs - :: Write.Tx - -> WalletResourceM [BIP32Path] -getBIP32PathsForOwnedInputs = - onWalletInstance . WalletIO.getBIP32PathsForOwnedInputs - -canSign :: WalletResourceM CanSign -canSign = onWalletInstance WalletIO.canSign - -signTx - :: Write.Tx - -> Passphrase - -> WalletResourceM (Maybe Write.Tx) -signTx tx = onWalletInstance . WalletIO.signTx tx - -inspectTx - :: CurrentEraResolvedTx - -> WalletResourceM InspectTx -inspectTx = onWalletInstance . WalletIO.inspectTx - -resolveCurrentEraTx :: Write.Tx -> WalletResourceM CurrentEraResolvedTx -resolveCurrentEraTx = onWalletInstance . WalletIO.resolveCurrentEraTx - -submitTx :: Write.Tx -> WalletResourceM (Either Network.ErrPostTx ()) -submitTx = onWalletInstance . WalletIO.submitTx diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs deleted file mode 100644 index b4a331c9b7b..00000000000 --- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Cardano.Wallet.Deposit.REST.Catch - ( catchRunWalletResourceM - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.REST - ( WalletResource - , WalletResourceM - , runWalletResourceM - ) -import Control.Exception - ( SomeException (..) - , try - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Control.Monad.Trans.Except - ( throwE - ) -import Servant - ( Handler (..) - , ServerError (..) - ) - -import qualified Data.ByteString.Lazy.Char8 as BL - --- | Catch and run a 'WalletResourceM' action, converting any exceptions to --- 'ServerError'. -catchRunWalletResourceM - :: WalletResource - -> ServerError - -> WalletResourceM a - -> Handler a -catchRunWalletResourceM s se f = do - er <- liftIO $ try $ runWalletResourceM f s - case er of - Right (Right a) -> - pure a - Right (Left e) -> - Handler $ throwE $ se{errBody = BL.pack $ show e} - Left (SomeException e) -> - Handler $ throwE $ se{errBody = BL.pack $ show e} diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs deleted file mode 100644 index 89236c97bf6..00000000000 --- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.REST.Start - ( loadDepositWalletFromDisk - , newBootEnv - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv (..) - ) -import Cardano.Wallet.Deposit.IO.Network.NodeToClient - ( CardanoBlock - , NetworkLayer - , StandardCrypto - , fromNetworkLayer - ) -import Cardano.Wallet.Deposit.REST - ( WalletResource - , loadWallet - , runWalletResourceM - , walletExists - ) -import Control.Monad - ( when - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Control.Monad.Trans.Except - ( ExceptT (..) - , runExceptT - ) -import Control.Tracer - ( Tracer - , stdoutTracer - , traceWith - ) -import Data.Functor.Contravariant - ( (>$<) - ) - -import qualified Cardano.Chain.Genesis as Byron -import qualified Cardano.Wallet.Deposit.Read as Read - -lg :: (MonadIO m, Show a) => Tracer IO String -> String -> a -> m () -lg tr p x = liftIO $ traceWith tr $ p <> ": " <> show x - -loadDepositWalletFromDisk - :: Tracer IO () - -- ^ Tracer for wallet tip changes - -> Tracer IO String - -> FilePath - -> WalletBootEnv IO - -> WalletResource - -> IO () -loadDepositWalletFromDisk wtc tr dir env resource = do - result <- flip runWalletResourceM resource $ do - test <- liftIO $ walletExists dir - when test $ do - lg tr "Loading wallet from" dir - loadWallet wtc env dir - lg tr "Wallet loaded from" dir - pure test - case result of - Left e -> error $ show e - Right _ -> pure () - -newBootEnv - :: Maybe FilePath - -> NetworkLayer IO (CardanoBlock StandardCrypto) - -> IO (WalletBootEnv IO) -newBootEnv genesisFile nl = do - eGenesisData <- runExceptT $ case genesisFile of - Nothing -> ExceptT $ pure $ Right Read.mockGenesisDataMainnet - Just file -> fst <$> Byron.readGenesisData file - case eGenesisData of - Left e -> error $ show e - Right genesisData' -> - return - $ WalletBootEnv - (show >$< stdoutTracer) - genesisData' - (fromNetworkLayer nl) diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs deleted file mode 100644 index 715b4d413ab..00000000000 --- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} - -module Cardano.Wallet.Deposit.REST.Wallet.Create - ( PostWalletViaMnemonic (..) - , PostWalletViaXPub (..) - ) -where - -import Prelude - -import Data.Text - ( Text - ) -import GHC.Generics - ( Generic - ) - --- | Data for a request to create a wallet via a mnemonic. -data PostWalletViaMnemonic = PostWalletViaMnemonic - { mnemonics :: Text - , password :: Text - , trackedCustomers :: Int - } - deriving (Generic) - --- | Data for a request to create a wallet via an extended public key. -data PostWalletViaXPub = PostWalletViaXPub - { xpub :: Text - , trackedCustomers :: Int - } - deriving (Generic) diff --git a/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md b/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md deleted file mode 100644 index f2c62a03439..00000000000 --- a/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md +++ /dev/null @@ -1,418 +0,0 @@ -# Specification: Customer Deposit Wallet - -## Synopsis - -🚧 DRAFT 2023-10-18 - -This document specifies the core functionality of a **customer deposit wallet**, -or **deposit wallet** for short. - -A customer deposit wallet allows you to track the origin of incoming funds: -Each customer is assigned a unique address belonging to the wallet; -a deposit made at this address is treated as originating from the customer. - -Technically, each customer is represented by a numerical index (natural number). -Essentially, the deposit wallet manages a mapping between indices and addresses, -and tracks incoming funds for each known address. - -# Setup - -This document is a [literate Agda][lagda] file: It contains prose that -describes and explains the specification, but it also contains definitions -and logical properties that can be checked by the proof assistant [Agda][]. - -We use Agda because we plan to create a **machine-checked proof** -that our implementation adheres to this specification. -Specifically, we plan to implement the core functionality in Agda, -i.e. the functionality specificied in this document, and export -the code to Haskell using [agda2hs][] so that the core functionality -can be embedded in a full software application. - - [agda]: https://github.com/agda/agda - [lagda]: https://agda.readthedocs.io/en/v2.6.4/tools/literate-programming.html - [agda2hs]: https://github.com/agda/agda2hs - -## Imports - -In order to formulate the specification, we need to import standard vocabulary: - -```agda -open import Haskell.Prelude -open import Relation.Nullary using (¬_) -open import Data.Product using () renaming (_×_ to both) -``` - -We also define a few conveniences: - -A predicate `_∈_` that records whether an item is an element of a list - -```agda -_∈_ : ∀ {a : Set} {{_ : Eq a}} → a → List a → Set -x ∈ xs = elem x xs ≡ True -``` - -The logical combinator "if and only if" - -```agda -_⟷_ : Set → Set → Set -x ⟷ y = both (x → y) (y → x) -``` - -```agda -isJust : ∀ {a : Set} → Maybe a → Bool -isJust (Just _) = True -isJust Nothing = False -``` - -```agda -isSubsetOf : ∀ {a : Set} {{_ : Eq a}} → List a → List a → Bool -isSubsetOf xs ys = all (λ x → elem x ys) xs -``` - -# Specification - -## Overview - -This specification of a **customer deposit wallet** -amounts to the specification of an abstract data type `WalletState`, -which represents the entire state of such a wallet. - -The goal of this document is to specify the operations -on this abstract data type and the logical properties that relate them. - -We define a `module` `DepositWallet` which is parametrized by -several definitions from the Cardano ledger, -but also by the abstract data type `WalletState` that we wish to specify. - -```agda -module - DepositWallet - (WalletState : Set) - (Address : Set) - {{_ : Eq Address}} - (Slot : Set) - (TxId : Set) - (Tx : Set) - (Value : Set) - {{_ : Eq Value}} - (PParams : Set) - where -``` - -## Operations - -We now list all auxiliary data types and all -operations supported by the abstract data type `WalletState`. -This list is meant for reference -— we will explain each of them in detail in the subsequent sections. - -Auxiliary data types: - -```agda - Customer = Nat - - record ValueTransfer : Set where - field - spent : Value - received : Value - - open ValueTransfer - - TxSummary : Set - TxSummary = Slot × TxId × ValueTransfer -``` - -Operations: - -```agda - record Operations : Set where - field - - listCustomers : WalletState → List (Customer × Address) - createAddress : Customer → WalletState → (Address × WalletState) - - availableBalance : WalletState → Value - applyTx : Tx → WalletState → WalletState - - getCustomerHistory : WalletState → Customer → List TxSummary - - createPayment - : List (Address × Value) - → PParams → WalletState → Maybe Tx -``` - -## Properties - -In subsequent sections, we will specify the properties that -the operations should satisfy. - -The following record collects the properties: - -```agda - record Properties - (O : Operations) - : Set₁ - where - open Operations O -``` - -(For some reason, it needs to be in `Set₁`.) - -### Mapping between Customers and Address - -The type `Customer` denotes a unique identier for a customer. -For reasons explained later, we choose to represent this type -as numerical indices, i.e. natural numbers: - - Customer = Nat - -The mapping between customers and addresses will be queried and established with -the following operations: - - listCustomers : WalletState → List (Customer × Address) - createAddress : Customer → WalletState → (Address × WalletState) - -Here, `listCustomers` lists all customer/address pairs that have been mapped to each other so far. -In turn, `createAddress` adds a new customer/address to the mapping. - -In order to express how these functions are related, we define - -```agda - knownCustomer : Customer → WalletState → Bool - knownCustomer c = elem c ∘ map fst ∘ listCustomers - - knownCustomerAddress : Address → WalletState → Bool - knownCustomerAddress address = elem address ∘ map snd ∘ listCustomers -``` - -Here, a `knownCustomer` is a `Customer` that appears in the result of `listCustomers`, -while `knownCustomerAddress` is an `Address` that appears in the result. -Note that a deposit wallet may own additional `Addresses` not included here, -such as change addresses — but these addresses are not customer addresses. - -The two operations are related by the property - -```agda - field - - prop_create-get - : ∀(c : Customer) (s0 : WalletState) - → let (address , s1) = createAddress c s0 - in knownCustomerAddress address s1 ≡ True -``` - -### Address derivation - -For compatibility with hardware wallets and the [BIP-32][] standard, -we derive the `Address` of each customer from the root private key -of the wallet in a deterministic fashion: - -```agda - deriveAddress : WalletState → (Customer → Address) - - prop_create-derive - : ∀(c : Customer) (s0 : WalletState) - → let (address , _) = createAddress c s0 - in deriveAddress s0 c ≡ address -``` - -Specifically, in the notation of [BIP-32][], we use - - deriveAddress : WalletState → Nat → Address - deriveAddress s ix = rootXPrv s / 1857' / 1815' / 0' / 0 / ix - -Here, `1857` is a new “purpose” identifier; we cannot reuse the [CIP-1852][] standard, because it behaves differently when discovering funds in blocks. - - [bip-32]: https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki - [cip-1852]: https://cips.cardano.org/cips/cip1852/ - -This method of deriving addresses is also the reason why we choose -a concrete representation of `Customer` as a natural number. - -### Applying transactions - -TODO: Specification of total wallet funds. -Amounts to rewrite of the original wallet specification -by Edsko and Duncan in Agda. To be specified in a separate document. - - availableBalance : WalletState → Value - applyTx : Tx → WalletState → WalletState - -### Tracking incoming funds - -Beyond assigning an address to a customer, -the new wallet state returned by `createAddress` -also tracks this address whenever new blocks are incorporated into the wallet state. -For this purpose of tracking, we introduce an operation - - getCustomerHistory : WalletState → Customer → List TxSummary - -which returns a list of transaction summaries. For a given transaction, such a summary reports the total `Value` spend or received at a specific address. - - record ValueTransfer : Set where - field - spent : Value - received : Value - - open ValueTransfer - - TxSummary : Set - TxSummary = Slot × TxId × ValueTransfer - -Note that `Value` includes both native coins (ADA) and -user-defined assets, such as stablecoins NFTs. -Also note that the customer deposit wallet does not support -delegation and reward accounts, and the `spent` value -can only be spent from transaction outputs. - -The function `getCustomerHistory` allows users to detect incoming -transfers by observing the `received` value. - -The behavior of this function is best specified in terms of a function - -```agda - summarize : WalletState → Tx → List (Address × TxSummary) - - getAddressSummary - : Address → List (Address × TxSummary) → List TxSummary - getAddressSummary address = - map snd ∘ filter (λ x → fst x == address) -``` - -which summarizes a single transaction. Specifically, the result of `getCustomerHistory` an aggregate of all previous transaction summaries. - -```agda - field - prop_getAddressHistory-summary - : ∀ (s : WalletState) - (c : Customer) - (address : Address) - (tx : Tx) - → (c , address) ∈ listCustomers s - → getCustomerHistory (applyTx tx s) c - ≡ (getAddressSummary address (summarize s tx)) - ++ getCustomerHistory s c -``` - -Importantly, we only track an address if and only if it is a `knownCustomerAddress`. - -```agda - prop_tx-known-address - : ∀ (address : Address) - (s : WalletState) - (tx : Tx) - → (knownCustomerAddress address s ≡ True) - ⟷ (address ∈ map fst (summarize s tx)) -``` - -### Creating transactions - -Finally, we expose an operation - - createPayment - : List (Address × Value) - → PParams → WalletState → Maybe Tx - -which constructs and signs a transaction that sends given values to given addresses. -Here, `PParams` are protocol parameters needed for computation the fee to -include in the `Tx`. - -First, this function will succeed in creating a transaction if there are sufficient -funds available: - -```agda - - field - totalValue : List (Address × Value) → Value - -- totalValue = mconcat ∘ map snd - - maxFee : Value -- maximum fee of a transaction - exceeds : Value → Value → Set - _<>_ : Value → Value → Value - - prop_createPayment-success - : ∀ (s : WalletState) - (pp : PParams) - (destinations : List (Address × Value)) - → exceeds (availableBalance s) (totalValue destinations <> maxFee) - → isJust (createPayment destinations pp s) ≡ True -``` - -TODO: The above statement cannot hold as written, -but it would be highly desirable to have something in this spirit. -(This would be part of a separate specification file -related to `balanceTransaction`.) -Aside from insufficient funds, reasons for failure include: - -* Wallet UTxO is poor - * Few UTxO which are too close to minimum ADA quantity - * UTxO with too many native assets -* Destinations are poor - * `Value` does not carry minimum ADA quantity - * `Value` size too large (native assets, `Datum`, …) -* Combination of both: - * Too many UTxO with small ADA amount - that we need to cover a large `Value` payment. - Example: "Have 1 million x 1 ADA coins, want to send 1 x 1'000'000 ADA coin." - -Second, the transaction sends funds as indicated - -```agda - field - outputs : Tx → List (Address × Value) - - field - prop_createPayment-pays - : ∀ (s : WalletState) - (pp : PParams) - (destinations : List (Address × Value)) - (tx : Tx) - → createPayment destinations pp s ≡ Just tx - → isSubsetOf (outputs tx) destinations ≡ True -``` - -Third, and most importantly, the operation `createPayment` never creates a transaction -whose `received` summary for any tracked index/address pair is non-zero. -In other words, `createPayment` uses change addresses that are distinct -from any address obtained via `createAddress`. - -That said, `createPayment` is free to contribute to the `spent` summary of any address -— the deposit wallet spends funds from any address as it sees fit. - -In other words, we have - -```agda - getAddress : (Address × Value) → Address - getAddress = fst - - field - prop_createPayment-not-known - : ∀ (address : Address) - (s : WalletState) - (pp : PParams) - (destinations : List (Address × Value)) - (tx : Tx) - → knownCustomerAddress address s ≡ True - → createPayment destinations pp s ≡ Just tx - → ¬(address ∈ map getAddress (outputs tx)) -``` - -## Derived Properties - -TODO -From the properties above, one can prove various other properties. -However, this requires and induction principle on `WalletState`, -where we can be certain that other operations do not interfere -with the given ones. - -```agda -{- -prop_getAddressHistory-unknown : Set -prop_getAddressHistory-unknown - = ∀ (s : WalletState) - (addr : Address) - → knownAddress addr s ≡ False - → getAddressHistory addr s ≡ [] --} -``` - diff --git a/lib/deposit-wallet/spec/openapi/index.html b/lib/deposit-wallet/spec/openapi/index.html deleted file mode 100644 index 75d1ff89a92..00000000000 --- a/lib/deposit-wallet/spec/openapi/index.html +++ /dev/null @@ -1,17 +0,0 @@ - - - - Customer Deposit Wallet API - - - - - - - - - - - - - diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs deleted file mode 100644 index 3bec178e0a2..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs +++ /dev/null @@ -1,417 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} - -module Cardano.Wallet.Deposit.IO - ( -- * Types - WalletEnv (..) - , WalletStore - , WalletBootEnv (..) - , WalletPublicIdentity (..) - , WalletInstance - - -- * Operations - - -- ** Initialization - , withWalletInit - , Word31 - , withWalletLoad - , walletPublicIdentity - - -- ** Mapping between customers and addresses - , listCustomers - , customerAddress - , addressToCustomer - , ResolveAddress - - -- ** Reading from the blockchain - , getWalletTip - , availableBalance - , getTxHistoryByCustomer - , getTxHistoryByTime - , getCustomerDeposits - , getAllDeposits - - -- ** Writing to the blockchain - - -- *** Create transactions - , createPayment - , inspectTx - - -- *** Sign transactions - , getBIP32PathsForOwnedInputs - , signTx - - -- *** Submit transactions - , submitTx - , listTxsInSubmission - - -- * Internals - , onWalletState - , networkTag - , readWalletState - , resolveCurrentEraTx - , canSign - ) where - -import Prelude - -import Cardano.Wallet.Address.BIP32 - ( BIP32Path - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv (slotToUTCTime) - ) -import Cardano.Wallet.Deposit.Pure - ( Credentials - , CurrentEraResolvedTx - , Customer - , ValueTransfer - , WalletPublicIdentity (..) - , WalletState - , Word31 - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - , LookupTimeFromSlot - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( CanSign - ) -import Cardano.Wallet.Deposit.Read - ( Address - , TxId - , WithOrigin - ) -import Cardano.Wallet.Network.Checkpoints.Policy - ( defaultPolicy - ) -import Control.Tracer - ( Tracer - , contramap - , traceWith - ) -import Data.Bifunctor - ( first - ) -import Data.List.NonEmpty - ( NonEmpty - ) -import Data.Map.Strict - ( Map - ) -import Data.Time - ( UTCTime - ) - -import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network -import qualified Cardano.Wallet.Deposit.Pure as Wallet -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Control.Concurrent.Async as Async -import qualified Data.DBVar as DBVar -import qualified Data.Delta as Delta - ( Replace (..) - ) -import qualified Data.Delta.Update as Delta -import qualified Data.Store as Store - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} - --- | The environment needed to initialize a wallet, before a database is --- connected. -data WalletBootEnv m = WalletBootEnv - { logger :: Tracer m WalletLog - -- ^ Logger for the wallet. - , genesisData :: Read.GenesisData - -- ^ Genesis data for the wallet. - , networkEnv :: Network.NetworkEnv m (Read.EraValue Read.Block) - -- ^ Network environment for the wallet. - } - --- | The wallet store type. -type WalletStore = Store.UpdateStore IO Wallet.DeltaWalletState - --- | The full environment needed to run a wallet. -data WalletEnv m = WalletEnv - { bootEnv :: WalletBootEnv m - -- ^ The boot environment. - , store :: WalletStore - -- ^ The store for the wallet. - } - -data WalletInstance = WalletInstance - { env :: WalletEnv IO - , walletState :: DBVar.DBVar IO Wallet.DeltaWalletState - } - -{----------------------------------------------------------------------------- - Helpers -------------------------------------------------------------------------------} - --- | Convenience to apply an 'Update' to the 'WalletState' via the 'DBLayer'. -onWalletState - :: WalletInstance - -> Delta.Update Wallet.DeltaWalletState r - -> IO r -onWalletState WalletInstance{walletState} = - Delta.onDBVar walletState - --- FIXME: Propagation of exceptions from Pure to IO. - --- | Convenience to read the 'WalletState'. --- --- Use 'onWalletState' if you want to use the result in an atomic update. -readWalletState :: WalletInstance -> IO WalletState -readWalletState WalletInstance{walletState} = - DBVar.readDBVar walletState - -{----------------------------------------------------------------------------- - Operations - Initialization -------------------------------------------------------------------------------} - --- | Initialize a new wallet in the given environment. -withWalletInit - :: Tracer IO () -- wallet tip changes - -> WalletEnv IO - -> Credentials - -> Word31 - -> (WalletInstance -> IO a) - -> IO a -withWalletInit - wtc - env@WalletEnv - { bootEnv = WalletBootEnv{genesisData} - , .. - } - credentials - customers - action = do - walletState <- - DBVar.initDBVar store - $ Wallet.fromCredentialsAndGenesis - credentials - customers - genesisData - withWalletDBVar wtc env walletState action - --- | Load an existing wallet from the given environment. -withWalletLoad - :: Tracer IO () -- wallet tip changes - -> WalletEnv IO - -> (WalletInstance -> IO a) - -> IO a -withWalletLoad wtc env@WalletEnv{..} action = do - walletState <- DBVar.loadDBVar store - withWalletDBVar wtc env walletState action - -withWalletDBVar - :: Tracer IO () -- wallet tip changes - -> WalletEnv IO - -> DBVar.DBVar IO Wallet.DeltaWalletState - -> (WalletInstance -> IO a) - -> IO a -withWalletDBVar - wtc - env@WalletEnv{bootEnv = WalletBootEnv{logger, networkEnv}} - walletState - action = do - let w = WalletInstance{env, walletState} - Async.withAsync (doChainSync w) $ \_ -> action w - where - doChainSync = Network.chainSync networkEnv trChainSync . chainFollower - trChainSync = contramap (\_ -> WalletLogDummy) logger - chainFollower w = - Network.ChainFollower - { checkpointPolicy = defaultPolicy - , readChainPoints = do - walletTip <- Wallet.getWalletTip <$> readWalletState w - pure - [ walletTip - , Read.GenesisPoint - ] - , rollForward = rollForward w wtc - , rollBackward = rollBackward w - } - -{----------------------------------------------------------------------------- - Operations -------------------------------------------------------------------------------} -listCustomers :: WalletInstance -> IO [(Customer, Address)] -listCustomers w = - Wallet.listCustomers <$> readWalletState w - -customerAddress :: Customer -> WalletInstance -> IO (Maybe Address) -customerAddress c w = Wallet.customerAddress c <$> readWalletState w - -walletPublicIdentity :: WalletInstance -> IO WalletPublicIdentity -walletPublicIdentity w = do - state <- readWalletState w - pure - $ WalletPublicIdentity - { pubXpub = Wallet.walletXPub state - , pubNextUser = Wallet.trackedCustomers state - } - -type ResolveAddress = Address -> Maybe Customer - -addressToCustomer :: WalletInstance -> IO ResolveAddress -addressToCustomer w = do - state <- readWalletState w - pure $ flip Wallet.addressToCustomer state - -{----------------------------------------------------------------------------- - Operations - Reading from the blockchain -------------------------------------------------------------------------------} -getWalletTip :: WalletInstance -> IO Read.ChainPoint -getWalletTip w = - Wallet.getWalletTip <$> readWalletState w - -availableBalance :: WalletInstance -> IO Read.Value -availableBalance w = - Wallet.availableBalance <$> readWalletState w - -getTxHistoryByCustomer :: WalletInstance -> IO ByCustomer -getTxHistoryByCustomer w = - Wallet.getTxHistoryByCustomer <$> readWalletState w - -getTxHistoryByTime :: WalletInstance -> IO ByTime -getTxHistoryByTime w = Wallet.getTxHistoryByTime <$> readWalletState w - -getCustomerDeposits - :: WalletInstance - -> Customer - -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> IO (Map TxId ValueTransfer) -getCustomerDeposits w c i = - Wallet.getCustomerDeposits c i <$> readWalletState w - -getAllDeposits - :: WalletInstance - -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> IO (Map Customer ValueTransfer) -getAllDeposits w i = - Wallet.getAllDeposits i <$> readWalletState w - -rollForward - :: WalletInstance - -> Tracer IO () -- wallet tip changes - -> NonEmpty (Read.EraValue Read.Block) - -> tip - -> IO () -rollForward w wtc blocks _nodeTip = do - timeFromSlot <- slotResolver w - onWalletState w - $ Delta.update - $ Delta.Replace - . Wallet.rollForwardMany - timeFromSlot - blocks - traceWith wtc () - x <- readWalletState w - x `seq` pure () - -rollBackward - :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint -rollBackward w point = do - timeFromSlot <- slotResolver w - onWalletState w - $ Delta.updateWithResult - $ first Delta.Replace . Wallet.rollBackward timeFromSlot point - --- | Compute a slot resolver for the given slots. -slotResolver - :: WalletInstance - -> IO LookupTimeFromSlot -slotResolver w = do - slotToUTCTime - $ networkEnv - $ bootEnv - $ env w - -networkTag :: WalletInstance -> IO Read.NetworkTag -networkTag w = do - Wallet.networkTag <$> readWalletState w - -{----------------------------------------------------------------------------- - Operations - Constructing transactions -------------------------------------------------------------------------------} - -createPayment - :: [(Address, Read.Value)] - -> WalletInstance - -> IO (Either Wallet.ErrCreatePayment CurrentEraResolvedTx) -createPayment a w = do - timeTranslation <- Network.getTimeTranslation network - pparams <- - Network.currentPParams network - Wallet.createPayment pparams timeTranslation a <$> readWalletState w - where - network = networkEnv $ bootEnv $ env w - -inspectTx - :: CurrentEraResolvedTx - -> WalletInstance - -> IO Wallet.InspectTx -inspectTx tx w = flip Wallet.inspectTx tx <$> readWalletState w - -resolveCurrentEraTx - :: Write.Tx - -> WalletInstance - -> IO CurrentEraResolvedTx -resolveCurrentEraTx tx w = - Wallet.resolveCurrentEraTx tx <$> readWalletState w - -{----------------------------------------------------------------------------- - Operations - Signing transactions -------------------------------------------------------------------------------} - -canSign :: WalletInstance -> IO CanSign -canSign w = do - Wallet.canSign <$> readWalletState w - -getBIP32PathsForOwnedInputs - :: Write.Tx -> WalletInstance -> IO [BIP32Path] -getBIP32PathsForOwnedInputs a w = - Wallet.getBIP32PathsForOwnedInputs a <$> readWalletState w - -signTx - :: Write.Tx -> Wallet.Passphrase -> WalletInstance -> IO (Maybe Write.Tx) -signTx a b w = Wallet.signTx a b <$> readWalletState w - -{----------------------------------------------------------------------------- - Operations - Pending transactions -------------------------------------------------------------------------------} - -submitTx - :: Write.Tx -> WalletInstance -> IO (Either Network.ErrPostTx ()) -submitTx tx w = do - e <- Network.postTx network tx - case e of - Right _ -> do - onWalletState w - $ Delta.update - $ Delta.Replace . Wallet.addTxSubmission tx - pure $ Right () - _ -> pure e - where - network = networkEnv $ bootEnv $ env w - -listTxsInSubmission :: WalletInstance -> IO [Write.Tx] -listTxsInSubmission w = - Wallet.listTxsInSubmission <$> readWalletState w - -{----------------------------------------------------------------------------- - Logging -------------------------------------------------------------------------------} -data WalletLog - = WalletLogDummy - deriving (Show) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs deleted file mode 100644 index e332dacf206..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Cardano.Wallet.Deposit.IO.DB - ( -#ifndef mingw32_HOST_OS - module Cardano.Wallet.Deposit.IO.DB.Real -#endif - ) - -where - -#ifdef mingw32_HOST_OS -import Cardano.Wallet.Deposit.IO.DB.Stub - () -#else -import Cardano.Wallet.Deposit.IO.DB.Real -#endif diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs deleted file mode 100644 index 3d4e4e85b73..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - -module Cardano.Wallet.Deposit.IO.DB.Real - ( Connection - , withSqliteFile - , withSqliteInMemory - , SqlM - , runSqlM - , DBLog (..) - ) where - -import Prelude - -import Control.Tracer - ( Tracer - , traceWith - ) -import Database.Table.SQLite.Simple - ( Connection - , SqlM - , runSqlM - , withConnection - ) - -{----------------------------------------------------------------------------- - SqlContext -------------------------------------------------------------------------------} - --- | Acquire and release an SQLite 'Connection' in memory. -withSqliteInMemory - :: Tracer IO DBLog - -- ^ Logging - -> (Connection -> IO a) - -- ^ Action to run - -> IO a -withSqliteInMemory tr = withSqliteFile tr ":memory:" - --- | Acquire and release an SQLite 'Connection' from a file. -withSqliteFile - :: Tracer IO DBLog - -- ^ Logging - -> FilePath - -- ^ Database file - -> (Connection -> IO a) - -- ^ Action to run - -> IO a -withSqliteFile tr filepath action = - withConnection filepath $ \conn -> do - traceWith tr $ MsgStartConnection filepath - result <- action conn - traceWith tr $ MsgDoneConnection filepath - pure result - -{------------------------------------------------------------------------------- - Logging --------------------------------------------------------------------------------} - -data DBLog - = MsgStartConnection FilePath - | MsgDoneConnection FilePath - deriving (Show, Eq) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs deleted file mode 100644 index ec9a50f4454..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Cardano.Wallet.Deposit.IO.DB.Stub () -where diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs deleted file mode 100644 index ee3726965dc..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Mock implementation of a 'NetworkEnv'. -module Cardano.Wallet.Deposit.IO.Network.Mock - ( newNetworkEnvMock - ) where - -import Prelude - -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv (..) - ) -import Cardano.Wallet.Network - ( ChainFollower (..) - ) -import Control.Concurrent.Class.MonadSTM - ( MonadSTM - , atomically - , modifyTVar - , newTVarIO - , readTVar - , readTVarIO - , writeTVar - ) -import Control.Monad - ( forever - ) -import Control.Monad.Class.MonadTimer - ( MonadDelay - , threadDelay - ) -import Data.Foldable - ( for_ - ) -import Data.List.NonEmpty - ( NonEmpty ((:|)) - ) - -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Time as Time -import qualified Cardano.Wallet.Deposit.Write as Write - -{----------------------------------------------------------------------------- - Mock implementation of 'NetworkEnv' -------------------------------------------------------------------------------} -newNetworkEnvMock - :: (MonadDelay m, MonadSTM m) - => m (NetworkEnv m (Read.Block Read.Conway)) -newNetworkEnvMock = do - mchain <- newTVarIO [] - mtip <- newTVarIO Read.GenesisPoint - mfollowers <- newTVarIO [] - - let registerAndUpdate follower = do - _ <- rollBackward follower Read.GenesisPoint - (chain, tip) <- atomically $ do - modifyTVar mfollowers (follower :) - (,) <$> readTVar mchain <*> readTVar mtip - case reverse chain of - [] -> pure () - (b : bs) -> rollForward follower (b :| bs) tip - - let forgeBlock tx = atomically $ do - tipOld <- readTVar mtip - let txRead = Write.toConwayTx tx - blockNew = Read.mockNextBlock tipOld [txRead] - tipNew = Read.getChainPoint blockNew - writeTVar mtip tipNew - modifyTVar mchain (blockNew :) - pure (blockNew, tipNew) - - let broadcast block tip = do - followers <- readTVarIO mfollowers - for_ followers $ \follower -> - rollForward follower (block :| []) tip - - pure - NetworkEnv - { chainSync = \_ follower -> do - registerAndUpdate follower - forever $ threadDelay 1000000 - , postTx = \tx -> do - (block, tip) <- forgeBlock tx - broadcast block tip - -- brief delay to account for asynchronous chain followers - threadDelay 100 - pure $ Right () - , currentPParams = - pure $ Read.EraValue Read.mockPParamsConway - , getTimeTranslation = - pure $ Time.toTimeTranslationPure Time.mockTimeInterpreter - , slotToUTCTime = pure Time.unsafeUTCTimeOfSlot - } diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs deleted file mode 100644 index d6f8632980e..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Real implementation of a 'NetworkEnv'. -module Cardano.Wallet.Deposit.IO.Network.NodeToClient - ( fromNetworkLayer - , NetworkLayer - , CardanoBlock - , StandardCrypto - ) where - -import Prelude - -import Cardano.Ledger.Api - ( StandardCrypto - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( ErrPostTx (..) - , NetworkEnv (..) - , mapBlock - ) -import Cardano.Wallet.Deposit.Time - ( toTimeTranslation - ) -import Cardano.Wallet.Network - ( NetworkLayer - , mapChainFollower - ) -import Cardano.Wallet.Primitive.Ledger.Shelley - ( CardanoBlock - ) -import Cardano.Wallet.Primitive.Slotting - ( snapshot - ) -import Cardano.Wallet.Read - ( chainPointFromChainTip - ) -import Control.Monad.Trans.Except - ( runExceptT - , withExceptT - ) -import Control.Tracer - ( nullTracer - ) - -import qualified Cardano.Read.Ledger.Block.Block as Read -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Time as Time -import qualified Cardano.Wallet.Network as NetworkLayer - -{----------------------------------------------------------------------------- - NodeToClient 'NetworkEnv' -------------------------------------------------------------------------------} - --- | Translate the old NetworkLayer to the new NetworkEnv interface -fromNetworkLayer - :: NetworkLayer.NetworkLayer IO Read.ConsensusBlock - -> NetworkEnv IO (Read.EraValue Read.Block) -fromNetworkLayer nl = mapBlock Read.fromConsensusBlock $ - NetworkEnv - { chainSync = \_tr follower -> do - -- TODO: Connect tracer - let follower' = mapChainFollower id id chainPointFromChainTip id follower - NetworkLayer.chainSync nl nullTracer follower' - return $ error "impossible: chainSync returned" - -- TODO: We can change the error type of 'NetworkLayer.postTx' it - -- doesn't need the ErrPostTxEraUnsupported case - , postTx = runExceptT . withExceptT translateErrPostTx . NetworkLayer.postTx nl - , currentPParams = - NetworkLayer.currentPParams nl - , getTimeTranslation = toTimeTranslation (NetworkLayer.timeInterpreter nl) - , slotToUTCTime = Time.slotToUTCTime <$> snapshot ti - } - - where - ti = NetworkLayer.timeInterpreter nl - - translateErrPostTx :: NetworkLayer.ErrPostTx -> ErrPostTx - translateErrPostTx = \case - NetworkLayer.ErrPostTxValidationError errorText -> ErrPostTxValidationError errorText - NetworkLayer.ErrPostTxMempoolFull -> ErrPostTxMempoolFull - NetworkLayer.ErrPostTxEraUnsupported _era -> - error "translateErrPostTx: ErrPostTxEraUnsupported should be impossible" diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs deleted file mode 100644 index 8e3d92cff59..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv (..) - , ErrPostTx (..) - , mapBlock - , ChainFollower (..) - ) where - -import Prelude - -import Cardano.Wallet.Deposit.Read - ( Slot - , WithOrigin - ) -import Cardano.Wallet.Network - ( ChainFollower (..) - , mapChainFollower - ) -import Control.Monad.Class.MonadTime - ( UTCTime - ) -import Control.Tracer - ( Tracer - ) -import Data.List.NonEmpty - ( NonEmpty - ) -import Data.Text - ( Text - ) -import Data.Void - ( Void - ) -import GHC.Generics - ( Generic - ) - -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Time as Time -import qualified Cardano.Wallet.Deposit.Write as Write - -{----------------------------------------------------------------------------- - Type -------------------------------------------------------------------------------} - -data NetworkEnv m block = NetworkEnv - { chainSync - :: Tracer m ChainFollowLog - -> ChainFollower m Read.ChainPoint Read.ChainPoint (NonEmpty block) - -> m Void - -- ^ Run the chain-sync mini-protocol (forever). - , postTx - :: Write.Tx - -> m (Either ErrPostTx ()) - -- ^ Post a transaction to the Cardano network. - , currentPParams - :: m (Read.EraValue Read.PParams) - -- ^ Current protocol paramters. - , getTimeTranslation - :: m Time.TimeTranslation - -- ^ Get the current 'TimeInterpreter' from the Cardano node. - , slotToUTCTime - :: m (Slot -> (Maybe (WithOrigin UTCTime))) - - } - -mapBlock - :: Functor m - => (block1 -> block2) - -> NetworkEnv m block1 - -> NetworkEnv m block2 -mapBlock f env@NetworkEnv{chainSync} = env - { chainSync = \tr follower -> - chainSync tr (mapChainFollower id id id (fmap f) follower) - } - -{------------------------------------------------------------------------------- - Errors --------------------------------------------------------------------------------} - --- | Error while trying to send a transaction to the network. -data ErrPostTx - = ErrPostTxValidationError Text - | ErrPostTxMempoolFull - deriving (Eq, Show, Generic) - -{------------------------------------------------------------------------------- - Logging --------------------------------------------------------------------------------} - --- | Higher level log of a chain follower. --- -- Includes computed statistics about synchronization progress. -data ChainFollowLog - = -- = MsgChainSync (ChainSyncLog BlockHeader ChainPoint) - - -- | MsgFollowStats (FollowStats Rearview) - MsgStartFollowing - deriving (Eq, Show, Generic) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs deleted file mode 100644 index 1f3168023b0..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use void" #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Implementation of a 'Resource' (think REST) which can be initialized. -module Cardano.Wallet.Deposit.IO.Resource - ( Resource - , withResource - , ErrResourceMissing (..) - , onResource - , ErrResourceExists (..) - , putResource - , ResourceStatus (..) - , readStatus - , closeResource - ) where - -import Prelude - -import Control.Concurrent - ( forkFinally - ) -import Control.Concurrent.Class.MonadSTM - ( MonadSTM (..) - , TVar - , atomically - , readTVar - , writeTVar - ) -import Control.Monad - ( void - ) -import Control.Monad.Class.MonadThrow - ( MonadThrow (..) - , SomeException - ) - -{----------------------------------------------------------------------------- - Resource -------------------------------------------------------------------------------} - --- | Mutable resource (think REST) that holds a reference of type @a@ --- that has to be initialized with a 'with…' function. -data Resource e a = Resource - { content :: TVar IO (ResourceStatus e a) - , waitForEndOfLife :: IO (Either (Either SomeException e) ()) - -- ^ Wait until the 'Resource' is out of scope. - } - --- | Possible status of the content of a 'Resource'. -data ResourceStatus e a - = Closed - | Opening - | Open a - | FailedToOpen e - | Vanished SomeException - | Closing - deriving (Show) - -instance Functor (ResourceStatus e) where - fmap _ Closed = Closed - fmap _ Opening = Opening - fmap f (Open a) = Open (f a) - fmap _ (Vanished e) = Vanished e - fmap _ (FailedToOpen e) = FailedToOpen e - fmap _ Closing = Closing - --- | Read the status of a 'Resource'. -readStatus :: Resource e a -> STM IO (ResourceStatus e a) -readStatus resource = readTVar (content resource) - --- | Make a 'Resource' that can be initialized later. --- --- Once the 'Resource' has been initialized, --- it will also be cleaned up once the 'withResource' function has finished. --- --- If the 'Resource' vanishes because of an exception, --- the 'withResource' will /not/ be interrupted. --- You can use 'getStatus' to poll the current status. -withResource - :: (Resource e a -> IO b) - -- ^ Action to perform on the 'Resource'. - -> IO b - -- ^ Result of the action. -withResource action = do - content <- newTVarIO Closed - let waitForEndOfLife = atomically $ do - state <- readTVar content - case state of - Closing -> pure $ Right () - Vanished e -> pure $ Left $ Left e - FailedToOpen e -> pure $ Left $ Right e - _ -> retry - resource = Resource{content, waitForEndOfLife} - action resource `finally` closeResource resource - --- | Error condition for 'onResource'. -data ErrResourceMissing e - = -- | The 'Resource' has not been initialized yet. - ErrNotInitialized - | -- | The 'Resource' is currently being initialized. - ErrStillInitializing - | -- | The 'Resource' has not been initialized yet. - ErrVanished SomeException - | -- | The 'Resource' has vanished due to an unhandled exception. - ErrFailedToInitialize e - -- | The 'Resource' has failed to initialize. - | ErrClosing - -- | The 'Resource is currently being closed. - deriving (Show) - --- | Perform an action on a 'Resource' if it is initialized. -onResource - :: (a -> IO b) - -- ^ Action to perform on the initialized 'Resource'. - -> Resource e a - -- ^ The 'Resource' to act on. - -> IO (Either (ErrResourceMissing e) b) -onResource action resource = do - eContent <- readTVarIO $ content resource - case eContent of - Closed -> pure $ Left ErrNotInitialized - Opening -> pure $ Left ErrStillInitializing - Open a -> Right <$> action a - Vanished e -> pure $ Left $ ErrVanished e - FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e - Closing -> pure $ Left ErrClosing - -closeResource :: Resource e a -> IO (Either (ErrResourceMissing e) ()) -closeResource resource = do - r <- atomically $ do - status <- readTVar $ content resource - case status of - Closed -> pure $ Right () - Opening -> pure $ Left ErrStillInitializing - Open _ -> do - writeTVar (content resource) Closing - pure $ Right () - Vanished e -> pure $ Left $ ErrVanished e - FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e - Closing -> pure $ Left ErrClosing - case r of - Right () -> waitForClose resource - Left e' -> pure $ Left e' - -waitForClose :: Resource e a -> IO (Either (ErrResourceMissing e) ()) -waitForClose resource = do - e <- atomically $ do - status <- readTVar (content resource) - case status of - Closed -> pure $ Right () - Vanished e -> pure $ Left $ ErrVanished e - FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e - _ -> retry - case e of - Right () -> pure $ Right () - Left e' -> pure $ Left e' - --- | Error condition for 'putResource'. -data ErrResourceExists e a - = -- | The resource 'a' is currently being initialized. - ErrAlreadyInitializing - | -- | The resource 'a' has already been initialized. - ErrAlreadyInitialized a - | -- | The resource 'a' has vanished. - ErrAlreadyVanished SomeException - | -- | The resource 'a' has failed to initialize. - ErrAlreadyFailedToInitialize e - | -- | The resource 'a' is currently being closed. - ErrAlreadyClosing - deriving (Show) - --- | Initialize a 'Resource' using a @with…@ function. --- This @with…@ function will be called with an argument that does --- not terminate until 'withResource' terminates. --- The function can logically fail returning a 'Left' value. --- Exceptions will be caught and stored in the 'Resource' as well -putResource - :: (forall b. (a -> IO b) -> IO (Either e b)) - -- ^ Function to initialize the resource 'a' - -> Resource e a - -- ^ The 'Resource' to initialize. - -> IO (Either (ErrResourceExists e a) ()) -putResource start resource = do - forking <- atomically $ do - ca :: ResourceStatus e a <- readTVar (content resource) - case ca of - FailedToOpen e -> pure $ Left $ ErrAlreadyFailedToInitialize e - Vanished e -> pure $ Left $ ErrAlreadyVanished e - Opening -> pure $ Left ErrAlreadyInitializing - Open a -> pure $ Left $ ErrAlreadyInitialized a - Closed -> do - writeTVar (content resource) Opening - pure $ Right forkInitialization - Closing -> pure $ Left ErrAlreadyClosing - case forking of - Left e -> pure $ Left e - Right action -> Right <$> action - where - controlInitialization = do - r <- start run - atomically $ case r of - Right (Right ()) -> do - writeTVar (content resource) Closed - Right (Left (Left e)) -> do - writeTVar (content resource) (Vanished e) - Right (Left (Right e)) -> do - writeTVar (content resource) (FailedToOpen e) - Left e -> do - writeTVar (content resource) (FailedToOpen e) - - forkInitialization = void $ forkFinally controlInitialization vanish - - run a = do - atomically $ writeTVar (content resource) (Open a) - waitForEndOfLife resource - - vanish (Left e) = do - atomically $ writeTVar (content resource) (Vanished e) - vanish (Right _) = - pure () -- waitForEndOfLife has succeeded diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs deleted file mode 100644 index 0cdb58e3008..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Cardano.Wallet.Deposit.IO.Resource.Event - ( onResourceChange - ) where - -import Prelude - -import Cardano.Wallet.Deposit.IO.Resource - ( Resource - , ResourceStatus (..) - , readStatus - ) -import Control.Concurrent.Async - ( withAsync - ) -import Control.Concurrent.Class.MonadSTM - ( MonadSTM (..) - , atomically - ) -import Control.Monad - ( void - ) -import Control.Monad.Cont - ( ContT (..) - ) -import Control.Monad.Fix - ( fix - ) - --- | Run an action whenever the status of a 'Resource' changes. -onResourceChange - :: (ResourceStatus e a -> IO ()) - -> Resource e a - -> ContT x IO () -onResourceChange f resource = do - void $ ContT $ withAsync $ ($ Closed) $ fix $ \loop lastStatus -> do - status <- atomically $ do - status <- readStatus resource - case (status, lastStatus) of - (Closed, Closed) -> retry - (Opening, Opening) -> retry - (Open _a, Open _a') -> retry -- this is something to think about - (FailedToOpen _e, FailedToOpen _e') -> retry - (Vanished _e, Vanished _e') -> retry - (Closing, Closing) -> retry - _ -> pure () - pure status - f status - loop status diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs deleted file mode 100644 index 556e8354aec..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Cardano.Wallet.Deposit.Map - ( -- * Type - Map (..) - - -- * Keys - , W - , F - - -- * Patch management - , unPatch - , forgetPatch - - -- * Accessors - , OpenF - , open - , PatchF - , patch - , ValueF - , value - - -- * Lookup - , lookupMap - , lookupFinger - - -- * Construction - , singletonMap - , singletonFinger - - -- * Conversion - , toFinger - - -- * Modification - , onMap - , onFinger - , Peel - ) -where - -import Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) - , TimedSeq - , extractInterval - , fmapTimedSeq - , singleton - ) -import Data.Kind - ( Type - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap - ) -import Data.Monoid - ( Last (..) - ) -import Prelude hiding - ( lookup - ) - -import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq -import qualified Data.Map.Monoidal.Strict as MonoidalMap - --- | Infix form of MonoidalMap type -type (^^^) = MonoidalMap - -infixr 5 ^^^ - --- | A phantom type for tuples of mappings from 'k' tupled with a spurious monoid --- 'w'. This is used to keep track of the patches applied to the map. -data W (w :: Type) (k :: Type) - --- | A phantom type for a finger tree of mappings from 'k' tupled with a spurious --- monoid 'w'. -data F (w :: Type) (k :: Type) - --- | A nested monoidal map. Every nesting can also be patched with a monoid 'w'. -data Map :: [Type] -> Type -> Type where - Value - :: v - -> Map '[] v - -- ^ A leaf node with a value. - Map - :: w - -> k ^^^ Map ks v - -> Map (W w k ': ks) v - -- ^ A node with a patch 'w' and a nested monoidal map. - Finger - :: w - -> TimedSeq k (Map ks v) - -> Map (F w k ': ks) v - -- ^ A node with a patch 'w' and a nested finger tree of maps. - -deriving instance Show v => Show (Map '[] v) - -deriving instance - ( Show w - , Show k - , Show (Map ks v) - ) - => Show (Map (W w k ': ks) v) - -deriving instance Eq v => Eq (Map '[] v) - -deriving instance - ( Eq w - , Eq k - , Eq (Map ks v) - ) - => Eq (Map (W w k ': ks) v) - -deriving instance - ( Show w - , Show k - , Show (Map ks v) - ) - => Show (Map (F w k ': ks) v) - -deriving instance - ( Eq w - , Eq k - , Eq (Map ks v) - ) - => Eq (Map (F w k ': ks) v) - -instance Functor (Map '[]) where - fmap f (Value v) = Value (f v) - -instance Functor (Map xs) => Functor (Map (W w x : xs)) where - fmap f (Map w m) = Map w $ fmap (fmap f) m - -instance - (Functor (Map xs), forall a. Monoid (Map xs a)) - => Functor (Map (F w x : xs)) - where - fmap f (Finger w m) = Finger w $ fmapTimedSeq (fmap f) m - -instance Monoid v => Monoid (Map '[] v) where - mempty = Value mempty - -instance - ( Monoid (Map ks v) - , Ord k - , Monoid w - ) - => Monoid (Map (W w k : ks) v) - where - mempty = Map mempty mempty - -instance (Monoid (Map xs v), Monoid w, Eq x) => Monoid (Map (F w x : xs) v) where - mempty = Finger mempty mempty - -instance Semigroup v => Semigroup (Map '[] v) where - Value a <> Value b = Value (a <> b) - -instance - ( Ord x - , Semigroup (Map xs v) - , Semigroup w - ) - => Semigroup (Map (W w x : xs) v) - where - Map w a <> Map w' b = Map (w <> w') (a <> b) - -instance - (Monoid w, Monoid (Map xs v), Eq x) - => Semigroup (Map (F w x : xs) v) - where - Finger wa a <> Finger wb b = Finger (wa <> wb) (a <> b) - -instance Foldable (Map '[]) where - foldMap f (Value v) = f v - -instance (Foldable (Map xs), Ord x) => Foldable (Map (F w x : xs)) where - foldMap f (Finger _ m) = foldMap (foldMap f) m - -instance (Foldable (Map xs), Ord x) => Foldable (Map (W w x : xs)) where - foldMap f (Map _ m) = foldMap (foldMap f) m - -type family UnPatchF xs where - UnPatchF (Map (W w x ': xs) v) = - Map (W () x ': xs) (w, v) - UnPatchF (Map (F w x ': xs) v) = - Map (F () x ': xs) (w, v) - --- | Push the patch down to the leaves of the map. -unPatch - :: ( y ~ Map (x : ks) v - , Functor (Map ks) - , Monoid (Map ks v) - , Monoid (Map ks (w, v)) - , w ~ PatchF x - ) - => y - -> UnPatchF y -unPatch (Map w m) = Map () $ fmap (fmap (w,)) m -unPatch (Finger w m) = Finger () $ fmapTimedSeq (fmap (w,)) m - -type family ForgetPatchF xs where - ForgetPatchF (Map (W w x ': xs) v) = - Map (W () x ': xs) v - ForgetPatchF (Map (F w x ': xs) v) = - Map (F () x ': xs) v - --- | Forget the patch of any map layer. -forgetPatch - :: (y ~ Map (x : ks) v) - => y - -> ForgetPatchF y -forgetPatch ((Map _ m)) = Map () m -forgetPatch ((Finger _ m)) = Finger () m - -type family PatchF x where - PatchF (W w x) = w - PatchF (F w x) = w - --- | Extract the patch from any map layer. -patch :: Map (x : xs) v -> PatchF x -patch (Map w _) = w -patch (Finger w _) = w - -type family ValueF x where - ValueF (Map '[] v) = v - ValueF (Map (W w x ': xs) v) = x ^^^ Map xs v - ValueF (Map (F w x ': xs) v) = TimedSeq x (Map xs v) - --- | Extract the value from any map layer. -value :: Map xs v -> ValueF (Map xs v) -value (Map _ m) = m -value (Finger _ m) = m -value (Value v) = v - -type family OpenF xs where - OpenF (Map (W w x ': xs) v) = (w, x ^^^ Map xs v) - OpenF (Map (F w x ': xs) v) = (w, TimedSeq x (Map xs v)) - --- | Open any map layer and return the patch as well. -open :: Map (x : xs) v -> OpenF (Map (x : xs) v) -open (Map w m) = (w, m) -open (Finger w m) = (w, m) - --- | Construct a map layer with a single key-value pair. -singletonMap - :: w -> k -> Map xs v -> Map (W w k ': xs) v -singletonMap w k = Map w . MonoidalMap.singleton k - --- | Construct a finger layer with a single key-value pair. -singletonFinger - :: Monoid (Map xs v) => w -> k -> Map xs v -> Map (F w k ': xs) v -singletonFinger w k m = - Finger w $ singleton $ Timed (Last (Just k)) m - -toFinger - :: (Monoid (Map ks a), Eq k) => Map (W w k : ks) a -> Map (F w k : ks) a -toFinger (Map w m) = Finger w $ TimedSeq.fromList $ do - (k, v) <- MonoidalMap.toList m - pure $ Timed (Last (Just k)) v - --- | Lookup a value in first layer of the map and return the patch as well. -lookupMap - :: (Ord k) => k -> Map (W w k : ks) a -> Maybe (w, Map ks a) -lookupMap k (Map w m) = (w,) <$> MonoidalMap.lookup k m - --- | Lookup for an interval of keys in the finger tree and return the patch as well. -lookupFinger - :: (Ord k, Monoid (Map ks a)) - => k - -> k - -> Map (F w k : ks) a - -> Maybe (w, Map ks a) -lookupFinger k1 k2 (Finger w m) = do - case extractInterval k1 k2 m of - Timed (Last Nothing) _ -> Nothing - Timed _ m' -> Just (w, m') - --- | Apply a function to the nested monoidal map keeping the patch. -onMap - :: Map (W w k : ks) a - -> (MonoidalMap k (Map ks a) -> MonoidalMap k (Map ks a)) - -> Map (W w k : ks) a -onMap (Map w m) f = Map w $ f m - --- | Apply a function to the nested finger tree keeping the patch. -onFinger - :: Map (F w k : ks) a - -> (TimedSeq k (Map ks a) -> TimedSeq k (Map ks a)) - -> Map (F w k : ks) a -onFinger (Finger w m) f = Finger w $ f m - -type family Peel x where - Peel (Map (W w k : xs) v) = Map xs v - Peel (Map (F w k : xs) v) = Map xs v - Peel (Map '[] v) = v diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs deleted file mode 100644 index d8e5efc8082..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.Deposit.Map.Timed - ( - -- * Timed - Timed (..) - -- * TimedSeq - , TimedSeq - -- ** Construction - , fromList - , singleton - -- ** Destruction - , toList - -- ** Query - , takeAfter - , takeUpTo - , extractInterval - , minKey - , maxKey - -- ** Modification - , dropAfter - , dropBefore - -- ** Functor - , fmapTimedSeq - ) -where - -import Prelude hiding - ( null - ) - -import Data.Bifunctor - ( Bifunctor (..) - ) -import Data.FingerTree - ( FingerTree - , Measured (..) - , ViewL (..) - , ViewR (..) - , dropUntil - , fmap' - , split - , takeUntil - , viewl - , viewr - , (<|) - ) -import Data.Function - ( (&) - ) -import Data.Monoid - ( Last (..) - ) - -import qualified Data.FingerTree as FingerTree -import qualified Data.Foldable as F - --- | A value paired with a timestamp. -data Timed t a = Timed - { time :: Last t - , monoid :: a - } - deriving (Eq, Ord, Show, Functor, Foldable) - -instance Semigroup a => Semigroup (Timed t a) where - Timed t1 a1 <> Timed t2 a2 = Timed (t1 <> t2) (a1 <> a2) - -instance Monoid a => Monoid (Timed t a) where - mempty = Timed mempty mempty - -instance Monoid a => Measured (Timed t a) (Timed t a) where - measure = id - --- | A sequence of timed values with a monoidal annotation as itself. --- These values have a semigroup instance that will collapse adjacent values --- with the same timestamp. --- It's up to the user to maintain the invariant that --- the sequence is sorted by timestamp. -newtype TimedSeq t a = TimedSeq - { unTimedSeq :: FingerTree (Timed t a) (Timed t a) - } - deriving (Eq, Show) - -fmapTimedSeq - :: (Monoid a1, Monoid a2) => (a1 -> a2) -> TimedSeq t a1 -> TimedSeq t a2 -fmapTimedSeq f = TimedSeq . fmap' (fmap f) . unTimedSeq - -singleton :: Monoid a => Timed t a -> TimedSeq t a -singleton = TimedSeq . FingerTree.singleton - -instance Monoid a => Measured (Timed t a) (TimedSeq t a) where - measure = measure . unTimedSeq - -instance Foldable (TimedSeq t) where - foldMap f = foldMap (f . monoid) . unTimedSeq - -onFingerTree - :: ( FingerTree (Timed t a) (Timed t a) - -> FingerTree (Timed t a) (Timed t a) - ) - -> TimedSeq t a - -> TimedSeq t a -onFingerTree f = TimedSeq . f . unTimedSeq - -instance (Semigroup a, Monoid a, Eq t) => Semigroup (TimedSeq t a) where - TimedSeq a <> TimedSeq b = case (viewr a, viewl b) of - (EmptyR, _) -> TimedSeq b - (_, EmptyL) -> TimedSeq a - (a' :> Timed t1 v1, Timed t2 v2 :< b') - | t1 == t2 -> TimedSeq $ a' <> (Timed t1 (v1 <> v2) <| b') - | otherwise -> TimedSeq $ a <> b - -instance (Monoid a, Eq t) => Monoid (TimedSeq t a) where - mempty = TimedSeq FingerTree.empty - --- | Construct a 'TimedSeq' from a list of 'Timed' values. -fromList :: (Monoid a, Eq t) => [Timed t a] -> TimedSeq t a -fromList = mconcat . fmap singleton - --- | Convert a 'TimedSeq' to a list of 'Timed' values. --- This is not the inverse of 'fromList' as some values may have been merged. But --- fromList . toList == id. -toList :: TimedSeq t a -> [Timed t a] -toList = F.toList . unTimedSeq - -takeAfterElement - :: (Monoid a, Ord q) - => (t -> q) - -> TimedSeq t a - -> Maybe (Timed t a, TimedSeq t a) -takeAfterElement bucket (TimedSeq tseq) = case viewl tseq of - EmptyL -> Nothing - hd :< _ -> - let - (taken, rest) = - split (\q -> (bucket <$> time q) > (bucket <$> time hd)) tseq - in - Just (measure taken, TimedSeq rest) - -takeBeforeElement - :: (Monoid a, Ord q) - => (t -> q) - -> TimedSeq t a - -> Maybe (Timed t a, TimedSeq t a) -takeBeforeElement bucket (TimedSeq tseq) = case viewr tseq of - EmptyR -> Nothing - _ :> hd -> - let - (rest, taken) = - split (\q -> (bucket <$> time q) >= (bucket <$> time hd)) tseq - in - Just (measure taken, TimedSeq rest) - -takeAfterElements - :: (Monoid a, Ord q, Ord t) - => (t -> q) - -> Maybe Int - -> TimedSeq t a - -> (TimedSeq t a, Maybe t) -takeAfterElements _dt (Just 0) (TimedSeq tseq) = - ( mempty - , case viewl tseq of - EmptyL -> Nothing - Timed (Last hd) _ :< _ -> hd - ) -takeAfterElements bucket mn tseq = - case takeAfterElement bucket tseq of - Just (v, rest) -> - first (onFingerTree (v <|)) - $ takeAfterElements bucket (subtract 1 <$> mn) rest - _ -> (mempty, Nothing) - -takeBeforeElements - :: (Monoid a, Ord q, Ord t) - => (t -> q) - -> Maybe Int - -> TimedSeq t a - -> (TimedSeq t a, Maybe t) -takeBeforeElements _dt (Just 0) (TimedSeq tseq) = - ( mempty - , case viewr tseq of - EmptyR -> Nothing - _ :> Timed (Last hd) _ -> hd - ) -takeBeforeElements bucket mn tseq = case takeBeforeElement bucket tseq of - Just (v, rest) -> - first (onFingerTree (v <|)) - $ takeBeforeElements bucket (subtract 1 <$> mn) rest - _ -> (mempty, Nothing) - --- | Extract the first n elements from a timed seq after and including --- a given start time after applying a bucketing function. --- The result is a map of the extracted elements and the next time to start from. -takeAfter - :: (Monoid a, Ord q, Ord t) - => (t -> q) - -- ^ A function to bucket the timestamps. - -> Maybe t - -- ^ The start time to extract elements from. - -> Maybe Int - -- ^ The number of elements to extract. - -> TimedSeq t a - -- ^ The timed sequence to extract elements from. - -> (TimedSeq t a, Maybe t) -takeAfter bucket mstart mcount = - takeAfterElements bucket mcount - . onFingerTree - ( dropUntil - ( \q -> mstart & maybe True (\t -> time q >= Last (Just t)) - ) - ) - --- | Extract the last n elements from a timed seq before and excluding --- a given start time after applying a bucketing function. --- The result is a map of the extracted elements and the next time to start from. -takeUpTo - :: (Monoid a, Ord q, Ord t) - => (t -> q) - -- ^ A function to bucket the timestamps. - -> Maybe t - -- ^ The start time to extract elements from. - -> Maybe Int - -- ^ The number of elements to extract. - -> TimedSeq t a - -- ^ The timed sequence to extract elements from. - -> (TimedSeq t a, Maybe t) -takeUpTo bucket mstart mcount = - takeBeforeElements bucket mcount - . onFingerTree - ( takeUntil - (\q -> mstart & maybe False (\t -> time q > Last (Just t))) - ) - --- | Try to extract the first element time from a tseq. -minKey :: Monoid a => TimedSeq t a -> Maybe t -minKey (TimedSeq tseq) = case viewl tseq of - Timed (Last (Just t)) _ :< _ -> Just t - _ -> Nothing - --- | Try to extract the last element time from a tseq. -maxKey :: Monoid a => TimedSeq t a -> Maybe t -maxKey (TimedSeq tseq) = case viewr tseq of - _ :> Timed (Last (Just t)) _ -> Just t - _ -> Nothing - --- | Extract all elements from a tseq that are within the given time interval. -extractInterval - :: (Monoid a, Ord t) => t -> t -> TimedSeq t a -> Timed t a -extractInterval t0 t1 (TimedSeq tseq) = - measure - $ takeUntil (\q -> time q > Last (Just t1)) - $ dropUntil (\q -> time q >= Last (Just t0)) tseq - --- | Drop all elements from a tseq that are after the given time. -dropAfter :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a -dropAfter t = onFingerTree $ takeUntil (\q -> time q > Last (Just t)) - --- | Drop all elements from a tseq that are before the given time. -dropBefore :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a -dropBefore t = onFingerTree $ dropUntil (\q -> time q >= Last (Just t)) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs deleted file mode 100644 index 6de8e6a07e3..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.Pure - ( -- * Types - WalletState - , DeltaWalletState - , WalletPublicIdentity (..) - - -- * Creation - , Credentials (..) - , fromCredentialsAndGenesis - - -- * Operations - - -- ** Mapping between customers and addresses - , Customer - , listCustomers - , addressToCustomer - , deriveAddress - , knownCustomer - , knownCustomerAddress - , isCustomerAddress - , fromRawCustomer - , customerAddress - , trackedCustomers - , walletXPub - - -- ** Reading from the blockchain - , Word31 - , getWalletTip - , availableBalance - , availableUTxO - , rollForwardMany - , rollForwardOne - , rollBackward - , ValueTransfer (..) - , getTxHistoryByCustomer - , getTxHistoryByTime - , getEraSlotOfBlock - , getCustomerDeposits - , getAllDeposits - , networkTag - - -- ** Writing to the blockchain - , ErrCreatePayment (..) - , createPayment - , resolveCurrentEraTx - , CurrentEraResolvedTx - , BIP32Path (..) - , DerivationType (..) - , ResolvedTx (..) - , canSign - , CanSign (..) - , getBIP32PathsForOwnedInputs - , Passphrase - , signTx - , addTxSubmission - , listTxsInSubmission - , inspectTx - , InspectTx (..) - ) where - -import Cardano.Wallet.Address.BIP32 - ( BIP32Path (..) - , DerivationType (..) - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( CanSign (..) - , Credentials (..) - , WalletPublicIdentity (..) - , canSign - , fromCredentialsAndGenesis - ) -import Cardano.Wallet.Deposit.Pure.State.Payment - ( CurrentEraResolvedTx - , ErrCreatePayment (..) - , createPayment - , resolveCurrentEraTx - ) -import Cardano.Wallet.Deposit.Pure.State.Payment.Inspect - ( InspectTx (..) - , inspectTx - ) -import Cardano.Wallet.Deposit.Pure.State.Rolling - ( rollBackward - , rollForwardMany - , rollForwardOne - ) -import Cardano.Wallet.Deposit.Pure.State.Signing - ( Passphrase - , getBIP32PathsForOwnedInputs - , signTx - ) -import Cardano.Wallet.Deposit.Pure.State.Submissions - ( addTxSubmission - , availableBalance - , availableUTxO - , listTxsInSubmission - ) -import Cardano.Wallet.Deposit.Pure.State.TxHistory - ( getAllDeposits - , getCustomerDeposits - , getTxHistoryByCustomer - , getTxHistoryByTime - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( Customer - , DeltaWalletState - , WalletState - , addressToCustomer - , customerAddress - , deriveAddress - , fromRawCustomer - , getWalletTip - , isCustomerAddress - , knownCustomer - , knownCustomerAddress - , listCustomers - , networkTag - , trackedCustomers - , walletXPub - ) -import Cardano.Wallet.Deposit.Pure.UTxO.Tx - ( ResolvedTx (..) - ) -import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer - ( ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Read - ( getEraSlotOfBlock - ) -import Data.Word.Odd - ( Word31 - ) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs deleted file mode 100644 index 70c5785db3a..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.Deposit.Pure.API.Address - ( encodeAddress - , decodeAddress - , DecodingError (..) - , NetworkTag (..) - , getNetworkTag - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Read - ( Address - , NetworkTag (..) - ) -import Cardano.Wallet.Primitive.Ledger.Shelley - ( StandardCrypto - ) -import Cardano.Wallet.Read.Address - ( toShortByteString - ) -import Codec.Binary.Bech32 - ( DataPart - , HumanReadablePart - , dataPartFromBytes - , dataPartToBytes - , decodeLenient - ) -import Control.Arrow - ( ArrowChoice (..) - ) -import Control.Monad - ( (>=>) - ) -import Control.Monad.State.Strict - ( evalStateT - ) -import Data.ByteString - ( ByteString - ) -import Data.ByteString.Base58 - ( bitcoinAlphabet - , decodeBase58 - , encodeBase58 - ) -import Data.Text - ( Text - ) - -import qualified Cardano.Ledger.Address as SH -import qualified Cardano.Ledger.Address as SL -import qualified Cardano.Ledger.BaseTypes as SL -import qualified Codec.Binary.Bech32 as Bech32 -import qualified Codec.Binary.Bech32.TH as Bech32 -import qualified Data.ByteString.Short as B8 -import qualified Data.Text.Encoding as T - -data AddressFlavor a b - = Bootstrap - {bootstrapFlavor :: a} - | Shelley - {shelleyFlavor :: b} - deriving (Eq, Show) - -withAddressFlavor - :: (a -> c) - -> (b -> c) - -> AddressFlavor a b - -> c -withAddressFlavor f _ (Bootstrap x) = f x -withAddressFlavor _ g (Shelley x) = g x - --- | Errors that can occur when decoding an 'Address'. -data DecodingError - = InvalidBech32Encoding Bech32.DecodingError - | InvalidBase58Encoding - | InvalidHumanReadablePart HumanReadablePart - | InvalidDataPart DataPart - | AddressFlavorMismatch - | AddressDecodingError String - | AddressNetworkMismatch - deriving (Eq, Show) - -humanPart :: NetworkTag -> HumanReadablePart -humanPart = \case - MainnetTag -> [Bech32.humanReadablePart|addr|] - TestnetTag -> [Bech32.humanReadablePart|addr_test|] - -decodeBase58Address - :: ByteString - -> Either - DecodingError - ( AddressFlavor - ByteString - (ByteString, HumanReadablePart) - ) -decodeBase58Address = - fmap Bootstrap - . maybe (Left InvalidBase58Encoding) Right - . decodeBase58 bitcoinAlphabet - -decodeBech32Address - :: Text - -> Either - DecodingError - (AddressFlavor ByteString (ByteString, HumanReadablePart)) -decodeBech32Address bech32 = do - (hrp, dataPart) <- left InvalidBech32Encoding $ decodeLenient bech32 - case dataPartToBytes dataPart of - Nothing -> Left $ InvalidDataPart dataPart - Just bytes -> pure $ Shelley (bytes, hrp) - -decodeHumanAddress - :: Text - -> Either - DecodingError - (AddressFlavor ByteString (ByteString, HumanReadablePart)) -decodeHumanAddress t = - decodeBech32Address t - <> decodeBase58Address (T.encodeUtf8 t) - -newtype CatchFail a = CatchFail {runCatchFail :: Either String a} - deriving (Functor, Applicative, Monad) - -instance MonadFail CatchFail where - fail = CatchFail . Left - -ledgerAddressFlavor :: SL.Addr c -> AddressFlavor () () -ledgerAddressFlavor (SL.AddrBootstrap _) = Bootstrap () -ledgerAddressFlavor _ = Shelley () - -ledgerAddressNetworkTag :: SL.Addr c -> NetworkTag -ledgerAddressNetworkTag addr = case SL.getNetwork addr of - SL.Testnet -> TestnetTag - SL.Mainnet -> MainnetTag - --- | Get the network tag of an 'Address'. -getNetworkTag :: Address -> NetworkTag -getNetworkTag = ledgerAddressNetworkTag . SL.decompactAddr - -ledgerDecode - :: ByteString - -> Either DecodingError (SL.Addr StandardCrypto) -ledgerDecode bs = - left AddressDecodingError - $ runCatchFail - $ evalStateT - (SH.decodeAddrStateLenientT @StandardCrypto True True bs) - 0 - -inspectAddress - :: AddressFlavor ByteString (ByteString, HumanReadablePart) - -> Either DecodingError (AddressFlavor Address Address) -inspectAddress (Bootstrap a) = do - r <- ledgerDecode a - case ledgerAddressFlavor r of - Bootstrap () -> - pure (Bootstrap $ SH.compactAddr r) - _ -> Left AddressFlavorMismatch -inspectAddress (Shelley (bytes, hrp)) = do - r <- ledgerDecode bytes - case (ledgerAddressNetworkTag r, ledgerAddressFlavor r) of - (network, Shelley ()) -> - if humanPart network == hrp - then pure (Shelley $ SH.compactAddr r) - else Left AddressNetworkMismatch - _ -> Left AddressFlavorMismatch - -decodeFlavoredAddress - :: Text - -> Either DecodingError (AddressFlavor Address Address) -decodeFlavoredAddress = decodeHumanAddress >=> inspectAddress - --- | Decode an 'Address' from a 'Text' representation. -decodeAddress - :: Text - -- ^ Text to decode - -> Either DecodingError Address -decodeAddress text = withAddressFlavor id id <$> decodeFlavoredAddress text - -addFlavorToAddress :: Address -> AddressFlavor Address Address -addFlavorToAddress x - | SL.isBootstrapCompactAddr x = Bootstrap x - | otherwise = Shelley x - -encodeFlavoredAddress - :: AddressFlavor Address Address - -> Text -encodeFlavoredAddress (Shelley addr) = bech32 - where - bytes = B8.fromShort $ toShortByteString addr - bech32 = Bech32.encodeLenient hrp (dataPartFromBytes bytes) - hrp = humanPart $ getNetworkTag addr -encodeFlavoredAddress (Bootstrap addr) = - T.decodeUtf8 . encodeBase58 bitcoinAlphabet - $ B8.fromShort - $ toShortByteString addr - --- | Encode an 'Address' to a 'Text' representation. -encodeAddress - :: Address - -- ^ Address to encode - -> Text -encodeAddress = encodeFlavoredAddress . addFlavorToAddress diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs deleted file mode 100644 index c01d7159b0c..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} - -module Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - , DownTime - , ResolveAddress - , LookupTimeFromSlot - , TxHistory (..) - , firstJust - , transfers - , rollForward - , rollBackward - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Map - ( F - , Map (..) - , W - , onFinger - , onMap - , singletonFinger - , singletonMap - ) -import Cardano.Wallet.Deposit.Map.Timed - ( TimedSeq - , dropBefore - ) -import Cardano.Wallet.Deposit.Pure.Address - ( Customer - ) -import Cardano.Wallet.Deposit.Pure.Balance - ( ValueTransferMap - ) -import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer - ( ValueTransfer - ) -import Cardano.Wallet.Deposit.Read - ( Address - , WithOrigin (..) - ) -import Cardano.Wallet.Deposit.Time - ( LookupTimeFromSlot - ) -import Cardano.Wallet.Read - ( Slot - , TxId - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Maybe - ( maybeToList - ) -import Data.Monoid - ( First (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) - -import qualified Data.Map.Monoidal.Strict as MonoidalMap - -firstJust :: a -> First a -firstJust = First . Just - -transfers - :: Foldable (Map xs) => Map xs ValueTransfer -> ValueTransfer -transfers = fold - -type DownTime = Down (WithOrigin UTCTime) - -type ByCustomer = - Map - '[ W () Customer - , F (First Address) DownTime - , W (First Slot) TxId - ] - ValueTransfer - -type ByTime = - Map - '[ F () DownTime - , W (First Slot) Customer - , W (First Address) TxId - ] - ValueTransfer - -data TxHistory = TxHistory - { byCustomer :: ByCustomer - , byTime :: ByTime - } - -instance Semigroup TxHistory where - TxHistory a1 b1 <> TxHistory a2 b2 = TxHistory (a1 <> a2) (b1 <> b2) - -instance Monoid TxHistory where - mempty = TxHistory mempty mempty - -type ResolveAddress = Address -> Maybe Customer - -rollForward - :: ValueTransferMap - -> ResolveAddress - -> LookupTimeFromSlot - -> Slot - -> TxHistory - -> TxHistory -rollForward valueTransferMap resolveAddress timeFromSlot slot = - (txHistory' <>) - where - txHistory' = - blockToTxHistory valueTransferMap resolveAddress timeFromSlot slot - -blockToTxHistory - :: ValueTransferMap - -> ResolveAddress - -> LookupTimeFromSlot - -> Slot - -> TxHistory -blockToTxHistory valueTransferMap resolveAddress timeFromSlot slot = - fold $ do - time <- fmap Down $ maybeToList $ timeFromSlot slot - (address, valueTransferByTxId) <- MonoidalMap.toList valueTransferMap - (txId, valueTransfer) <- MonoidalMap.toList valueTransferByTxId - customer <- maybeToList $ resolveAddress address - let byTime = - singletonFinger () time - $ singletonMap (First $ Just slot) customer - $ singletonMap (First $ Just address) txId - $ Value valueTransfer - let byCustomer = - singletonMap () customer - $ singletonFinger (First $ Just address) time - $ singletonMap (First $ Just slot) txId - $ Value valueTransfer - pure $ TxHistory{byCustomer, byTime} - --- | Roll backward the transaction history to a given slot. This function --- relies on the TxHistory to be sorted by time both on the time and --- customer views. -rollBackward - :: LookupTimeFromSlot - -> Slot - -> TxHistory - -> TxHistory -rollBackward timeFromSlot slot TxHistory{byCustomer, byTime} = - TxHistory - { byCustomer = - onMap byCustomer - $ cleanNulls . fmap (`onFinger` takeToSlot) - , byTime = onFinger byTime takeToSlot - } - where - takeToSlot :: Monoid a => TimedSeq DownTime a -> TimedSeq DownTime a - takeToSlot x = maybe x (`forgetAfter` x) $ timeFromSlot slot - forgetAfter t = dropBefore (Down t) - cleanNulls = MonoidalMap.filter (not . null) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs deleted file mode 100644 index 35d56e49140..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | Wallet balance. -module Cardano.Wallet.Deposit.Pure.Balance - ( balance - , availableUTxO - , IsOurs - , applyBlock - , ValueTransferMap - ) where - -import Prelude - -import Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO - ( DeltaUTxO - ) -import Cardano.Wallet.Deposit.Pure.UTxO.Tx - ( IsOurs - , applyTx - , valueTransferFromDeltaUTxO - ) -import Cardano.Wallet.Deposit.Pure.UTxO.UTxO - ( UTxO - , balance - , excluding - ) -import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer - ( ValueTransfer - ) -import Cardano.Wallet.Deposit.Read - ( Address - , TxId - ) -import Cardano.Wallet.Read - ( Block - , IsEra - , getTxId - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap - ) -import Data.Set - ( Set - ) - -import qualified Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO as DeltaUTxO -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Cardano.Wallet.Read as Read -import qualified Data.Map.Monoidal.Strict as MonoidalMap -import qualified Data.Map.Strict as Map - -{----------------------------------------------------------------------------- - Wallet Balance -------------------------------------------------------------------------------} - --- | Available = excluding pending transactions -availableUTxO :: UTxO -> [Write.Tx] -> UTxO -availableUTxO u pending = - u `excluding` used - where - used :: Set Read.TxIn - used = foldMap getUsedTxIn pending - - -- UTxO which have been spent or committed as collateral in a pending - -- transaction are not available to use in future transactions. - getUsedTxIn :: Read.Tx Read.Conway -> Set Read.TxIn - getUsedTxIn tx = - Read.getInputs tx - <> Read.getCollateralInputs tx - -{----------------------------------------------------------------------------- - Applying Blocks -------------------------------------------------------------------------------} - --- | Get the value transfer of a 'DeltaUTxO'. -getDeltaUTxOValueTransfer - :: UTxO - -> DeltaUTxO - -> TxId - -> ValueTransferMap -getDeltaUTxOValueTransfer u du txId = fold $ do - (addr, value) <- Map.assocs $ valueTransferFromDeltaUTxO u du - pure - $ MonoidalMap.singleton addr - $ MonoidalMap.singleton - txId - value - --- | A summary of all value transfers in a block. -type ValueTransferMap = - MonoidalMap Address (MonoidalMap TxId ValueTransfer) - --- | Apply a 'Block' to the 'UTxO'. --- --- Returns both a delta and the new value. -applyBlock - :: IsEra era - => IsOurs Read.CompactAddr - -> Block era - -> UTxO - -> (DeltaUTxO, UTxO, ValueTransferMap) -applyBlock isOurs block u0 = - (DeltaUTxO.appends $ reverse dus, u1, totalValueTransfer) - where - (dus, (u1, totalValueTransfer)) = - mapAccumL' applyTx' (u0, mempty) - $ Read.getEraTransactions block - applyTx' tx (u, total) = - let - (ds, u') = applyTx isOurs tx u - value = getDeltaUTxOValueTransfer u ds (getTxId tx) - total' - | null value = total - | otherwise = total <> value - in - (ds, (u', total')) - -{----------------------------------------------------------------------------- - Helpers -------------------------------------------------------------------------------} - --- | Strict variant of 'mapAccumL'. -mapAccumL' :: (a -> s -> (o, s)) -> s -> [a] -> ([o], s) -mapAccumL' f = go [] - where - go os !s0 [] = (reverse os, s0) - go os !s0 (x : xs) = case f x s0 of - (!o, !s1) -> go (o : os) s1 xs diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs deleted file mode 100644 index 4ca891c21f8..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Wallet.Deposit.Pure.State.Creation - ( WalletPublicIdentity (..) - , fromCredentialsAndGenesis - , deriveAccountXPrv - , Credentials (..) - , credentialsFromMnemonics - , credentialsFromEncodedXPub - , accountXPubFromCredentials - , rootXPrvFromCredentials - , ErrDecodingXPub (..) - , encodedXPubFromCredentials - , canSign - , CanSign (..) - , createMnemonicFromWords - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Address.Derivation - ( xpubFromBytes - , xpubToBytes - ) -import Cardano.Address.Style.Shelley - ( genMasterKeyFromMnemonicShelley - ) -import Cardano.Mnemonic - ( MkSomeMnemonic (..) - , MkSomeMnemonicError - , SomeMnemonic - ) -import Cardano.Wallet.Address.BIP32_Ed25519 - ( XPrv - , XPub - , deriveXPrvHard - , rawSerialiseXPrv - , toXPub - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( WalletState (..) - ) -import Data.Text - ( Text - ) -import Data.Word.Odd - ( Word31 - ) -import GHC.Generics - ( Generic - ) - -import Cardano.Crypto.Wallet - ( xPrvChangePass - ) -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm -import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -data WalletPublicIdentity = WalletPublicIdentity - { pubXpub :: XPub - , pubNextUser :: Word31 - } - deriving (Show) - -data Credentials - = XPubCredentials !XPub - | XPrvCredentials !XPrv !XPub - deriving (Generic, Show, Eq) - -instance Show XPrv where - show = B8.unpack . B16.encode . rawSerialiseXPrv - -instance Eq XPrv where - a == b = rawSerialiseXPrv a == rawSerialiseXPrv b - --- | Get /account/ 'XPub' from credentials if available. --- --- The account public key corresponds to the account --- private key obtained from 'deriveAccountXPrv', --- /not/ the root private key. -accountXPubFromCredentials :: Credentials -> XPub -accountXPubFromCredentials (XPubCredentials xpub) = xpub -accountXPubFromCredentials (XPrvCredentials _ xpub) = xpub - --- | Derive account 'XPrv' from the root 'XPrv'. -deriveAccountXPrv :: XPrv -> XPrv -deriveAccountXPrv xprv = - ( deriveXPrvHard - ( deriveXPrvHard - ( deriveXPrvHard - xprv - 1857 -- Address derivation standard - ) - 1815 -- ADA - ) - 0 -- Account number - ) - --- | Get root 'XPrv' from credentials if available. -rootXPrvFromCredentials :: Credentials -> Maybe XPrv -rootXPrvFromCredentials (XPubCredentials _) = Nothing -rootXPrvFromCredentials (XPrvCredentials xprv _) = Just xprv - -fromCredentialsAndGenesis - :: Credentials -> Word31 -> Read.GenesisData -> WalletState -fromCredentialsAndGenesis credentials customers genesisData = - WalletState - { walletTip = Read.GenesisPoint - , addresses = - Address.fromXPubAndCount - network - (accountXPubFromCredentials credentials) - customers - , utxoHistory = UTxOHistory.fromOrigin initialUTxO - , txHistory = mempty - , submissions = Sbm.empty - , rootXSignKey = rootXPrvFromCredentials credentials - } - where - network = Read.getNetworkId genesisData - initialUTxO = mempty - --- | Simplified version of 'mkSomeMnemonic' that takes a space-separated list of --- words. Entropy and checksum are checked as well. -createMnemonicFromWords - :: Text -> Either (MkSomeMnemonicError '[15, 24]) SomeMnemonic -createMnemonicFromWords = mkSomeMnemonic . T.words - --- | Create 'Credentials' from a mnemonic sentence and a passphrase. -credentialsFromMnemonics - :: SomeMnemonic - -- ^ Mnemonics - -> Text - -- ^ Passphrase - -> Credentials -credentialsFromMnemonics mnemonics passphrase = - let - unencryptedXPrv = - genMasterKeyFromMnemonicShelley - mnemonics - (T.encodeUtf8 mempty) - encryptedXPrv = - xPrvChangePass - B8.empty - (T.encodeUtf8 passphrase) - unencryptedXPrv - in - XPrvCredentials - encryptedXPrv - $ toXPub - $ deriveAccountXPrv unencryptedXPrv - -data CanSign = CanSign | CannotSign - deriving (Eq, Show) - -canSign :: WalletState -> CanSign -canSign WalletState{rootXSignKey} = case rootXSignKey of - Nothing -> CannotSign - Just _ -> CanSign - --- | Create 'Credentials' from an extended public key failures to decode -data ErrDecodingXPub = ErrFromXPubBase16 | ErrFromXPubDecodeKey - deriving (Show, Eq) - --- | Create 'Credentials' from an extended public key encoded in base16. -credentialsFromEncodedXPub - :: Text - -> Either ErrDecodingXPub Credentials -credentialsFromEncodedXPub xpub = case B16.decode (T.encodeUtf8 xpub) of - Left _ -> Left ErrFromXPubBase16 - Right bytes -> case xpubFromBytes bytes of - Nothing -> Left ErrFromXPubDecodeKey - Just key -> Right $ XPubCredentials key - --- | Encode an extended public key to base16. -encodedXPubFromCredentials - :: Credentials - -> Text -encodedXPubFromCredentials (XPubCredentials xpub) = - T.decodeUtf8 - $ B16.encode - $ xpubToBytes xpub -encodedXPubFromCredentials (XPrvCredentials _ xpub) = - encodedXPubFromCredentials (XPubCredentials xpub) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs deleted file mode 100644 index 566e646729f..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.Pure.State.Payment - ( ErrCreatePayment (..) - , createPayment - , createPaymentTxBody - , CurrentEraResolvedTx - , resolveCurrentEraTx - , translateBalanceTxError - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Ledger.Val - ( isAdaOnly - ) -import Cardano.Wallet.Deposit.Pure.State.Submissions - ( availableUTxO - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( WalletState (..) - ) -import Cardano.Wallet.Deposit.Pure.UTxO.Tx - ( ResolvedTx (..) - , resolveInputs - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Cardano.Wallet.Deposit.Write - ( Coin - , Tx - , TxBody (..) - , Value - ) -import Cardano.Wallet.Primitive.Types.Tx.Constraints - ( TxSize (..) - ) -import Cardano.Wallet.Read - ( AssetID (AdaID) - , Coin (..) - , fromEraValue - , injectCoin - , lookupAssetID - , toMaryValue - ) -import Control.Monad.Trans.Except - ( runExceptT - ) -import Data.Bifunctor - ( first - ) -import Data.Digest.CRC32 - ( crc32 - ) -import Data.Fixed - ( E6 - , Fixed - ) -import Data.Text - ( Text - ) -import Data.Text.Class.Extended - ( ToText (..) - ) -import Numeric.Natural - ( Natural - ) - -import qualified Cardano.Read.Ledger.Value as Read.L -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Cardano.Wallet.Read.Hash as Hash -import qualified Control.Monad.Random.Strict as Random -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -data ErrCreatePayment - = ErrCreatePaymentNotRecentEra (Read.EraValue Read.Era) - | ErrNotEnoughAda { shortfall :: Value } - | ErrEmptyUTxO - - | ErrTxOutAdaInsufficient { outputIx :: Int, suggestedMinimum :: Coin } - - -- | Only possible when sending (non-ada) assets. - | ErrTxOutValueSizeExceedsLimit { outputIx :: Int } - - -- | Only possible when sending (non-ada) assets. - | ErrTxOutTokenQuantityExceedsLimit - { outputIx :: Int - , quantity :: Natural - , quantityMaxBound :: Natural - } - - -- | The final balanced tx was too big. Either because the payload was too - -- big to begin with, or because we failed to select enough inputs without - -- making it too big, e.g. due to the UTxO containing lots of dust. - -- - -- We should ideally split out 'TooManyPayments' from this error. - -- We should ideally also be able to create payments even when dust causes - -- us to need preparatory txs. - | ErrTxMaxSizeLimitExceeded{ size :: TxSize, maxSize :: TxSize } - deriving (Eq, Show) - -translateBalanceTxError :: Write.ErrBalanceTx Write.Conway -> ErrCreatePayment -translateBalanceTxError = \case - Write.ErrBalanceTxAssetsInsufficient - Write.ErrBalanceTxAssetsInsufficientError{shortfall} -> - ErrNotEnoughAda - { shortfall = fromLedgerValue shortfall - } - Write.ErrBalanceTxMaxSizeLimitExceeded{size, maxSize} -> - ErrTxMaxSizeLimitExceeded{size, maxSize} - Write.ErrBalanceTxExistingKeyWitnesses _ -> - impossible "ErrBalanceTxExistingKeyWitnesses" - Write.ErrBalanceTxExistingCollateral -> - impossible "ErrBalanceTxExistingCollateral" - Write.ErrBalanceTxExistingTotalCollateral -> - impossible "ErrBalanceTxExistingTotalCollateral" - Write.ErrBalanceTxExistingReturnCollateral -> - impossible "ErrBalanceTxExistingReturnCollateral" - Write.ErrBalanceTxInsufficientCollateral _ -> - impossible "ErrBalanceTxInsufficientCollateral" - Write.ErrBalanceTxAssignRedeemers _ -> - impossible "ErrBalanceTxAssignRedeemers" - Write.ErrBalanceTxInternalError e -> - impossible $ show e - Write.ErrBalanceTxInputResolutionConflicts _ -> - -- We are never creating partialTxs with pre-selected inputs, which - -- means this is impossible. - impossible "conflicting input resolution" - Write.ErrBalanceTxUnresolvedInputs _ -> - -- We are never creating partialTxs with pre-selected inputs, which - -- means this is impossible. - impossible "unresolved inputs" - Write.ErrBalanceTxUnresolvedRefunds _ -> - impossible "unresolved refunds" - Write.ErrBalanceTxOutputError (Write.ErrBalanceTxOutputErrorOf ix info) -> case info of - Write.ErrBalanceTxOutputAdaQuantityInsufficient{minimumExpectedCoin} -> - ErrTxOutAdaInsufficient - { outputIx = ix - , suggestedMinimum = minimumExpectedCoin - } - Write.ErrBalanceTxOutputSizeExceedsLimit{} -> - ErrTxOutValueSizeExceedsLimit - { outputIx = ix - } - Write.ErrBalanceTxOutputTokenQuantityExceedsLimit{quantity, quantityMaxBound} -> - ErrTxOutTokenQuantityExceedsLimit - { outputIx = ix - , quantity - , quantityMaxBound - } - Write.ErrBalanceTxUnableToCreateChange - Write.ErrBalanceTxUnableToCreateChangeError{shortfall} -> - ErrNotEnoughAda - { shortfall = injectCoin shortfall - } - Write.ErrBalanceTxUnableToCreateInput -> - ErrEmptyUTxO - - where - fromLedgerValue v = fromEraValue (Read.L.Value v :: Read.L.Value Write.Conway) - - impossible :: String -> a - impossible reason = error $ "impossible: translateBalanceTxError: " <> reason - -instance ToText ErrCreatePayment where - toText = \case - ErrCreatePaymentNotRecentEra era -> - "Cannot create a payment in the era: " <> showT era - ErrNotEnoughAda{shortfall} -> T.unwords - [ "Insufficient funds. Shortfall: ", prettyValue shortfall - ] - ErrEmptyUTxO -> "Wallet has no funds" - ErrTxOutAdaInsufficient{outputIx, suggestedMinimum} -> T.unwords - [ "Ada amount in output " <> showT outputIx - , "is below the required minimum." - , "Suggested minimum amount:", prettyCoin suggestedMinimum - ] - ErrTxMaxSizeLimitExceeded{size, maxSize} -> T.unlines - [ "Exceeded the maximum size limit when creating the transaction." - <> " (size: ", prettyTxSize size, " max size: ", prettyTxSize maxSize <> ")" - , "\nPotential solutions:" - , "1) Make fewer payments at the same time." - , "2) Send smaller amounts of ada in total." - , "3) Fund wallet with more ada." - , "4) Make preparatory payments to yourself to coalesce dust into" - , "larger UTxOs." - ] - ErrTxOutValueSizeExceedsLimit{outputIx} -> T.unwords - [ "The size of the value of output", showT outputIx, "is too large." - , "Try sending fewer assets or splitting them over multiple outputs." - ] - ErrTxOutTokenQuantityExceedsLimit{outputIx, quantity, quantityMaxBound} -> T.unwords - [ "The asset quantity of ", showT quantity, "in output" - , showT outputIx, ", is larger than the maximum allowed" - , "limit", showT quantityMaxBound <> "." - ] - where - showT :: Show a => a -> Text - showT = T.pack . show - - prettyTxSize :: TxSize -> Text - prettyTxSize (TxSize s) = T.pack (show s) - - prettyValue :: Value -> Text - prettyValue v - | isAdaOnly (toMaryValue v) = prettyCoin (CoinC $ lookupAssetID AdaID v) - | otherwise = T.pack (show v) - - prettyCoin :: Coin -> Text - prettyCoin c = T.pack (show c') <> "₳" - where - c' :: Fixed E6 - c' = toEnum $ fromEnum c - -type CurrentEraResolvedTx = ResolvedTx Read.Conway - -resolveCurrentEraTx :: Tx -> WalletState -> CurrentEraResolvedTx -resolveCurrentEraTx tx w = resolveInputs (availableUTxO w) tx - -createPayment - :: Read.EraValue Read.PParams - -> Write.TimeTranslation - -> [(Address, Write.Value)] - -> WalletState - -> Either ErrCreatePayment CurrentEraResolvedTx -createPayment pp tt destinations w = - createPaymentTxBody pp tt (mkPaymentTxBody w destinations) w - --- | Create a payment to a list of destinations. -createPaymentTxBody - :: Read.EraValue Read.PParams - -> Write.TimeTranslation - -> TxBody - -> WalletState - -> Either ErrCreatePayment CurrentEraResolvedTx -createPaymentTxBody - (Read.EraValue (Read.PParams pparams :: Read.PParams era)) - timeTranslation - txBody - state = - case Read.theEra :: Read.Era era of - Read.Conway -> - first translateBalanceTxError - $ flip resolveCurrentEraTx state - <$> createPaymentConway - pparams - timeTranslation - txBody - state - era' -> Left $ ErrCreatePaymentNotRecentEra (Read.EraValue era') - -mkPaymentTxBody - :: WalletState -> [(Address, Write.Value)] -> Write.TxBody -mkPaymentTxBody w destinations = - Write.TxBody - { spendInputs = mempty - , collInputs = mempty - , txouts = - Map.fromList - $ zip [(toEnum 0) ..] - $ map (uncurry Write.mkTxOut) destinations - , collRet = Nothing - , expirySlot = Just . computeExpirySlot $ walletTip w - } - --- | In the Conway era: Create a payment to a list of destinations. -createPaymentConway - :: Write.PParams Write.Conway - -> Write.TimeTranslation - -> TxBody - -> WalletState - -> Either (Write.ErrBalanceTx Write.Conway) Write.Tx -createPaymentConway pparams timeTranslation body w = - fmap (Read.Tx . fst) - . flip Random.evalRand (pilferRandomGen w) - . runExceptT - . balance - (availableUTxO w) - (addresses w) - . mkPartialTx - $ body - where - mkPartialTx :: Write.TxBody -> Write.PartialTx Write.Conway - mkPartialTx txbody = - Write.PartialTx - { tx = Read.unTx $ Write.mkTx txbody - , extraUTxO = mempty :: Write.UTxO Write.Conway - , redeemers = mempty - , stakeKeyDeposits = Write.StakeKeyDepositMap mempty - , timelockKeyWitnessCounts = Write.TimelockKeyWitnessCounts mempty - } - - balance utxo addressState = - Write.balanceTx - pparams - timeTranslation - Write.AllKeyPaymentCredentials - (Write.constructUTxOIndex $ Write.toConwayUTxO utxo) - (changeAddressGen addressState) - () - - changeAddressGen s = - Write.ChangeAddressGen - { Write.genChangeAddress = - first Read.decompactAddr . Address.newChangeAddress s - , Write.maxLengthChangeAddress = - Read.decompactAddr $ Address.mockMaxLengthChangeAddress s - } - --- | Use entropy contained in the current 'WalletState' --- to construct a pseudorandom seed. --- (NOT a viable source of cryptographic randomness.) --- --- Possible downsides of this approach: --- --- 1. security/privacy --- 2. concurrency --- 3. retries for different coin selections -pilferRandomGen :: WalletState -> Random.StdGen -pilferRandomGen = - Random.mkStdGen . fromEnum . fromChainPoint . walletTip - where - fromChainPoint (Read.GenesisPoint) = 0 - fromChainPoint (Read.BlockPoint _ headerHash) = - crc32 $ Hash.hashToBytes headerHash - --- | Compute an expiry slot from a current 'ChainPoint'. -computeExpirySlot :: Read.ChainPoint -> Read.SlotNo -computeExpirySlot Read.GenesisPoint = 0 -computeExpirySlot (Read.BlockPoint slotNo _) = - slotNo + hour - where - hour = 60 * 60 diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs deleted file mode 100644 index 9cb26bbdc46..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Wallet.Deposit.Pure.State.Payment.Inspect - ( inspectTx - , CurrentEraResolvedTx - , InspectTx (..) - , transactionBalance - ) where - -import Prelude - -import Cardano.Read.Ledger.Tx.Fee - ( Fee (..) - , getEraFee - ) -import Cardano.Read.Ledger.Tx.Output - ( Output (..) - ) -import Cardano.Read.Ledger.Tx.Outputs - ( Outputs (..) - , getEraOutputs - ) -import Cardano.Wallet.Deposit.Pure.Address - ( Customer - , isChangeAddress - ) -import Cardano.Wallet.Deposit.Pure.State.Payment - ( CurrentEraResolvedTx - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( WalletState (..) - , addressToCustomer - ) -import Cardano.Wallet.Deposit.Pure.UTxO.Tx - ( ResolvedTx (..) - ) -import Cardano.Wallet.Deposit.Read - ( Address - , TxId - ) -import Cardano.Wallet.Read - ( Coin (..) - , Conway - , TxIx - , Value (..) - , getCompactAddr - , getInputs - , getValue - , mkEraTxOut - , pattern TxIn - ) -import Control.Lens - ( Field2 (_2) - , Field3 (_3) - , to - , (^.) - ) -import Data.Foldable - ( Foldable (..) - , fold - ) -import Data.Monoid - ( Sum (..) - ) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - --- | Inspect the inputs and outputs of a transaction. -data InspectTx = InspectTx - { ourInputs :: [(TxId, TxIx, Coin)] - -- ^ Our inputs. - , otherInputs :: [(TxId, TxIx)] - -- ^ Other inputs, there shouldn't be any. - , change :: [(Address, Coin)] - -- ^ Change outputs. - , ourOutputs :: [(Address, Customer, Coin)] - -- ^ Our outputs. The customer is the owner of the address. There could be - -- reasons the user wants to move funds among customer addresses. - , otherOutputs :: [(Address, Coin)] - -- ^ Other outputs. This is regular money leaving the wallet. - , fee :: Coin - } - deriving (Eq, Show) - --- | Calculate the output balance of a transaction, which is the sum of the --- values of our inputs minus the sum of the values of the change outputs and --- minus the outputs to our customers. -transactionBalance :: InspectTx -> Integer -transactionBalance InspectTx{..} = getSum $ - (ourInputs ^. traverse . _3 . mkSum) - - (change ^. traverse . _2 . mkSum) - - (ourOutputs ^. traverse . _3 . mkSum) - where - mkSum = to (Sum . unCoin) - --- | Inspect a transaction where inputs have been resolved to our UTxO. -inspectTx :: WalletState -> CurrentEraResolvedTx -> InspectTx -inspectTx ws (ResolvedTx tx ourUTxO) = - let - (ourInputs, otherInputs) = fold $ do - in'@(TxIn txId txIx) <- Set.toList $ getInputs tx - case Map.lookup in' ourUTxO of - Just out -> do - let ValueC coins _ = getValue out - pure ([(txId, txIx, coins)], []) - Nothing -> [([], [(txId, txIx)])] - (change, ourOutputs, otherOutputs) = fold $ do - out <- - fmap (mkEraTxOut @Conway . Output) - $ toList - $ (\(Outputs outs) -> outs) - $ getEraOutputs tx - let addr = getCompactAddr out - ValueC coins _ = getValue out - contrib = pure (addr, coins) - if - | isChangeAddress (addresses ws) addr -> [(contrib, [], [])] - | otherwise -> - case addressToCustomer addr ws of - Just customer -> [([], [(addr, customer, coins)], [])] - Nothing -> [([], [], contrib)] - Fee fee = getEraFee tx - in - InspectTx{..} diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs deleted file mode 100644 index 540773f84a4..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs +++ /dev/null @@ -1,117 +0,0 @@ -module Cardano.Wallet.Deposit.Pure.State.Rolling - ( rollForwardMany - , rollForwardOne - , rollBackward - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Pure.Balance - ( ValueTransferMap - ) -import Cardano.Wallet.Deposit.Pure.State.Type -import Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory - ( UTxOHistory - ) -import Cardano.Wallet.Deposit.Read - ( Address - , getEraSlotOfBlock - ) -import Cardano.Wallet.Deposit.Time - ( LookupTimeFromSlot - ) -import Data.Foldable - ( Foldable (..) - , foldl' - ) -import Data.List.NonEmpty - ( NonEmpty - ) - -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import qualified Cardano.Wallet.Deposit.Pure.API.TxHistory as TxHistory -import qualified Cardano.Wallet.Deposit.Pure.Balance as Balance -import qualified Cardano.Wallet.Deposit.Pure.RollbackWindow as Rollback -import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm -import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Data.Delta as Delta - -rollForwardMany - :: LookupTimeFromSlot - -> NonEmpty (Read.EraValue Read.Block) - -> WalletState - -> WalletState -rollForwardMany timeFromSlot blocks w = - foldl' (flip $ rollForwardOne timeFromSlot) w blocks - -rollForwardOne - :: LookupTimeFromSlot - -> Read.EraValue Read.Block - -> WalletState - -> WalletState -rollForwardOne timeFromSlot (Read.EraValue block) w = - w - { walletTip = Read.getChainPoint block - , utxoHistory = utxoHistory' - , submissions = Delta.apply (Sbm.rollForward block) (submissions w) - , txHistory = - TxHistory.rollForward - valueTransfers - (`addressToCustomer` w) - timeFromSlot - (getEraSlotOfBlock block) - (txHistory w) - } - where - (utxoHistory', valueTransfers) = - rollForwardUTxO isOurs block (utxoHistory w) - isOurs :: Address -> Bool - isOurs = Address.isOurs (addresses w) - -rollForwardUTxO - :: Read.IsEra era - => (Address -> Bool) - -> Read.Block era - -> UTxOHistory - -> (UTxOHistory, ValueTransferMap) -rollForwardUTxO isOurs block u = - (UTxOHistory.rollForward slot deltaUTxO u, valueTransfers) - where - (deltaUTxO, _, valueTransfers) = - Balance.applyBlock isOurs block (UTxOHistory.getUTxO u) - slot = Read.getEraSlotNo $ Read.getEraBHeader block - -rollBackward - :: LookupTimeFromSlot - -> Read.ChainPoint - -> WalletState - -> (WalletState, Read.ChainPoint) -rollBackward timeFromSlot targetPoint w = - ( w - { walletTip = actualPoint - , utxoHistory = - UTxOHistory.rollBackward actualSlot (utxoHistory w) - , submissions = - Delta.apply (Sbm.rollBackward actualSlot) (submissions w) - , txHistory = - TxHistory.rollBackward timeFromSlot actualSlot (txHistory w) - } - , actualPoint - ) - where - h = utxoHistory w - - targetSlot = Read.slotFromChainPoint targetPoint - actualSlot = Read.slotFromChainPoint actualPoint - - -- NOTE: We don't keep enough information about - -- the block hashes to roll back to - -- any other point than the target point (or genesis). - actualPoint = - if (targetSlot `Rollback.member` UTxOHistory.getRollbackWindow h) - then -- FIXME: Add test for rollback window of `submissions` - targetPoint - else Read.GenesisPoint diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs deleted file mode 100644 index 4d01c5ab989..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Cardano.Wallet.Deposit.Pure.State.Signing - ( getBIP32PathsForOwnedInputs - , signTx - , Passphrase - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( xPrvChangePass - ) -import Cardano.Wallet.Address.BIP32 - ( BIP32Path (..) - ) -import Cardano.Wallet.Address.BIP32_Ed25519 - ( deriveXPrvBIP32Path - ) -import Cardano.Wallet.Deposit.Pure.State.Submissions - ( availableUTxO - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( WalletState (..) - ) -import Data.Maybe - ( mapMaybe - ) -import Data.Set - ( Set - ) -import Data.Text - ( Text - ) - -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import qualified Cardano.Wallet.Deposit.Pure.UTxO as UTxO -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Data.ByteString as BS -import qualified Data.Text.Encoding as T - -getBIP32PathsForOwnedInputs :: Write.Tx -> WalletState -> [BIP32Path] -getBIP32PathsForOwnedInputs tx w = - getBIP32Paths w $ resolveInputAddresses inputs - where - inputs = Read.getInputs tx <> Read.getCollateralInputs tx - - resolveInputAddresses :: Set Read.TxIn -> [Read.Address] - resolveInputAddresses ins = - map (Read.address . snd) - . UTxO.toList - $ UTxO.restrictedBy (availableUTxO w) ins - -getBIP32Paths :: WalletState -> [Read.Address] -> [BIP32Path] -getBIP32Paths w = - mapMaybe $ Address.getBIP32Path (addresses w) - -type Passphrase = Text - --- | Sign the transaction if 'rootXSignKey' is 'Just'. -signTx :: Write.Tx -> Passphrase -> WalletState -> Maybe Write.Tx -signTx tx passphrase w = signTx' <$> rootXSignKey w - where - signTx' encryptedXPrv = - foldr Write.addSignature tx keys - where - unencryptedXPrv = - xPrvChangePass - (T.encodeUtf8 passphrase) - BS.empty - encryptedXPrv - keys = deriveXPrvBIP32Path unencryptedXPrv - <$> getBIP32PathsForOwnedInputs tx w diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs deleted file mode 100644 index c829a9bc457..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Cardano.Wallet.Deposit.Pure.State.Submissions - ( -- * Txs in submission queue management - addTxSubmission - , listTxsInSubmission - - -- * Balance considering pending transactions - , availableBalance - , availableUTxO - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Pure.Balance - ( balance - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( WalletState (..) - ) -import Cardano.Wallet.Deposit.Read - ( UTxO - ) -import Cardano.Wallet.Read - ( Value - ) - -import qualified Cardano.Wallet.Deposit.Pure.Balance as Balance -import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm -import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Data.Delta as Delta - -addTxSubmission :: Write.Tx -> WalletState -> WalletState -addTxSubmission tx w = - w - { submissions = Delta.apply (Sbm.add tx) (submissions w) - } - -listTxsInSubmission :: WalletState -> [Write.Tx] -listTxsInSubmission = Sbm.listInSubmission . submissions - --- | Compute the available balance from the current 'WalletState' considering --- the pending transactions in the submission queue. -availableBalance :: WalletState -> Value -availableBalance = balance . availableUTxO - --- | Compute the available UTxO from the current 'WalletState' considering --- the pending transactions in the submission queue. -availableUTxO :: WalletState -> UTxO -availableUTxO w = - Balance.availableUTxO utxo pending - where - pending = listTxsInSubmission w - utxo = UTxOHistory.getUTxO $ utxoHistory w diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs deleted file mode 100644 index 572a75bc6a5..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} - -module Cardano.Wallet.Deposit.Pure.State.TxHistory - ( getTxHistoryByCustomer - , getTxHistoryByTime - , getEraSlotOfBlock - , getCustomerDeposits - , getAllDeposits - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Wallet.Deposit.Map - ( Map - , W - , lookupMap - , value - ) -import Cardano.Wallet.Deposit.Map.Timed - ( Timed - , TimedSeq - , extractInterval - , monoid - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - , DownTime - , TxHistory (..) - ) -import Cardano.Wallet.Deposit.Pure.State.Type - ( Customer - , WalletState (..) - ) -import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer - ( ValueTransfer (..) - ) -import Cardano.Wallet.Deposit.Read - ( TxId - , WithOrigin (..) - , getEraSlotOfBlock - ) -import Data.FingerTree - ( Measured (..) - ) -import Data.Foldable - ( Foldable (..) - , fold - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap (..) - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) - -import qualified Data.Map.Strict as Map - -getTxHistoryByCustomer :: WalletState -> ByCustomer -getTxHistoryByCustomer state = byCustomer $ txHistory state - -getTxHistoryByTime :: WalletState -> ByTime -getTxHistoryByTime state = byTime $ txHistory state - -getCustomerDeposits - :: Customer - -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> WalletState - -> Map.Map TxId ValueTransfer -getCustomerDeposits c interval s = fold $ do - fmap (wonders interval . value . snd) - $ lookupMap c - $ getTxHistoryByCustomer s - -getAllDeposits - :: Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> WalletState - -> Map.Map Customer ValueTransfer -getAllDeposits interval s = - wonders interval - $ value - $ getTxHistoryByTime s - -wonders - :: (Ord k, Monoid w, Foldable (Map xs), Monoid (Map xs ValueTransfer)) - => Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> TimedSeq DownTime (Map (W w k : xs) ValueTransfer) - -> Map.Map k ValueTransfer -wonders interval = - getMonoidalMap - . monoid - . fmap (fmap fold . value) - . extractInterval' interval - where - extractInterval' - :: Monoid a - => Maybe (WithOrigin UTCTime, WithOrigin UTCTime) - -> TimedSeq (DownTime) a - -> Timed (DownTime) a - extractInterval' Nothing = measure - extractInterval' (Just (t1, t2)) = extractInterval (Down t1) (Down t2) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs deleted file mode 100644 index 5868d614a89..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE StrictData #-} -module Cardano.Wallet.Deposit.Pure.State.Type - ( -- * Types - WalletState (..) - , DeltaWalletState - , Customer - - -- * Operations - , listCustomers - , customerAddress - , addressToCustomer - , deriveAddress - , knownCustomer - , knownCustomerAddress - , isCustomerAddress - , fromRawCustomer - , trackedCustomers - , walletXPub - , getUTxO - , getWalletTip - , networkTag - ) where - -import Prelude hiding - ( lookup - ) - -import Cardano.Crypto.Wallet - ( XPrv - , XPub - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( TxHistory (..) - ) -import Cardano.Wallet.Deposit.Read - ( NetworkTag - ) -import Cardano.Wallet.Deposit.Write - ( Address - ) -import Data.Word.Odd - ( Word31 - ) - -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm -import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxO as UTxO -import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Data.Delta as Delta -import qualified Data.List as L -import qualified Data.Map.Strict as Map - -type Customer = Address.Customer - -data WalletState = WalletState - { walletTip :: Read.ChainPoint - -- ^ The wallet includes information from all blocks until - -- and including this one. - , addresses :: Address.AddressState - -- ^ Addresses and public keys known to this wallet. - , utxoHistory :: UTxOHistory.UTxOHistory - -- ^ UTxO of this wallet, with support for rollbacks. - , txHistory :: TxHistory - -- ^ (Summarized) transaction history of this wallet. - , submissions :: Sbm.TxSubmissions - -- ^ Queue of pending transactions. - , rootXSignKey :: Maybe XPrv - -- ^ Maybe a private key for signing transactions. - -- , info :: WalletInfo - } - -type DeltaWalletState = Delta.Replace WalletState - -listCustomers :: WalletState -> [(Customer, Address)] -listCustomers = - Address.listCustomers . addresses - -customerAddress :: Customer -> WalletState -> Maybe Address -customerAddress c = L.lookup c . listCustomers - -addressToCustomer :: Address -> WalletState -> Maybe Customer -addressToCustomer address = - Map.lookup address - . Map.fromList - . fmap (\(a, c) -> (c, a)) - . listCustomers - --- depend on the public key only, not on the entire wallet state -deriveAddress :: WalletState -> (Customer -> Address) -deriveAddress w = - Address.deriveCustomerAddress - (Address.getNetworkTag as) - (Address.getXPub as) - where - as = addresses w - --- FIXME: More performant with a double index. -knownCustomer :: Customer -> WalletState -> Bool -knownCustomer c = (c `elem`) . map fst . listCustomers - -knownCustomerAddress :: Address -> WalletState -> Bool -knownCustomerAddress address = - Address.knownCustomerAddress address . addresses - -isCustomerAddress :: Address -> WalletState -> Bool -isCustomerAddress address = - flip Address.isCustomerAddress address . addresses - -fromRawCustomer :: Word31 -> Customer -fromRawCustomer = id - --- | Maximum 'Customer' that is being tracked. -trackedCustomers :: WalletState -> Customer -trackedCustomers = (+1) . Address.getMaxCustomer . addresses - -walletXPub :: WalletState -> XPub -walletXPub = Address.getXPub . addresses - -getUTxO :: WalletState -> UTxO.UTxO -getUTxO = UTxOHistory.getUTxO . utxoHistory - -getWalletTip :: WalletState -> Read.ChainPoint -getWalletTip = walletTip - -networkTag :: WalletState -> NetworkTag -networkTag = Address.getNetworkTag . addresses diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs deleted file mode 100644 index 8d05a68e832..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Wallet.Deposit.Pure.Submissions - ( TxSubmissions - , TxSubmissionsStatus - , DeltaTxSubmissions1 - , DeltaTxSubmissions - - , empty - , add - , listInSubmission - , rollForward - , rollBackward - ) where - -import Prelude - -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Cardano.Wallet.Submissions.Operations as Sbm -import qualified Cardano.Wallet.Submissions.Submissions as Sbm -import qualified Cardano.Wallet.Submissions.TxStatus as Sbm -import qualified Data.Delta as Delta -import qualified Data.Map.Strict as Map - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} -type ExpirySlot = WithInfinity Read.Slot - -type TxSubmissions - = Sbm.Submissions () ExpirySlot (Read.TxId, Write.Tx) -type TxSubmissionsStatus - = Sbm.TxStatusMeta () ExpirySlot(Read.TxId, Write.Tx) -type DeltaTxSubmissions1 - = Sbm.Operation () ExpirySlot (Read.TxId, Write.Tx) -type DeltaTxSubmissions - = [DeltaTxSubmissions1] - -instance Delta.Delta DeltaTxSubmissions1 where - type Base DeltaTxSubmissions1 = TxSubmissions - apply = Sbm.applyOperations - -instance Sbm.HasTxId (Read.TxId, Write.Tx) where - type TxId (Read.TxId, Write.Tx) = Read.TxId - txId = fst - --- | Data type used for tracking transactions --- that will never become invalid. -data WithInfinity a - = Finite a - | Infinity - deriving (Eq, Show) - -infinityFromNothing :: Maybe a -> WithInfinity a -infinityFromNothing Nothing = Infinity -infinityFromNothing (Just x) = Finite x - -instance Ord a => Ord (WithInfinity a) where - compare (Finite x) (Finite y) = compare x y - compare Infinity (Finite _) = GT - compare (Finite _) Infinity = LT - compare Infinity Infinity = EQ - -instance Functor WithInfinity where - fmap f (Finite x) = Finite (f x) - fmap _ Infinity = Infinity - -{----------------------------------------------------------------------------- - Operations -------------------------------------------------------------------------------} --- | Empty collection of transaction in submission. -empty :: TxSubmissions -empty = Sbm.mkEmpty (Finite Read.Origin) - --- | Add a /new/ transaction to the local submission pool. -add :: Write.Tx -> DeltaTxSubmissions -add tx = [ Sbm.AddSubmission expiry (txId, tx) () ] - where - txId = Read.getTxId tx - expiry = - fmap Read.At - . infinityFromNothing - . Read.invalidHereafter - $ Read.getValidityInterval tx - --- | List of transactions that are in submission, in no particular order. -listInSubmission :: TxSubmissions -> [Write.Tx] -listInSubmission submissions = do - Sbm.InSubmission _ (_, tx) <- Map.elems (Sbm.transactions submissions) - pure tx - --- | Rollforward the transactions that are in submission -rollForward :: Read.IsEra era => Read.Block era -> DeltaTxSubmissions -rollForward block = [ Sbm.RollForward slot txids ] - where - slot = Finite $ Read.slotFromChainPoint $ Read.getChainPoint block - txids = map ((slot,) . Read.getTxId) $ Read.getEraTransactions block - --- | Roll backward the transactions that are in submission -rollBackward :: Read.Slot -> DeltaTxSubmissions -rollBackward slot = [ Sbm.RollBack (Finite slot) ] diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs deleted file mode 100644 index 494643d9ce9..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Cardano.Wallet.Deposit.Pure.UTxO - ( UTxO - , balance - , excluding - , restrictedBy - , filterByAddress - , toList - - , DeltaUTxO - , excludingD - , receiveD - , null - ) where - -import Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO - ( DeltaUTxO - , excludingD - , null - , receiveD - ) -import Cardano.Wallet.Deposit.Pure.UTxO.UTxO - ( UTxO - , balance - , excluding - , filterByAddress - , restrictedBy - ) -import Data.Map.Strict - ( toList - ) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs deleted file mode 100644 index 25463a01fcd..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} - --- | Indirection module that re-exports types --- used for reading data from the blockchain, --- from all eras. --- --- TODO: Match this up with the @Read@ hierarchy. -module Cardano.Wallet.Deposit.Read - ( Read.IsEra (..) - , Read.Era (..) - , Read.EraValue (..) - , Read.Conway - , Read.getEra - - , Read.SlotNo (..) - , Read.ChainPoint (..) - , Read.Slot - , Read.WithOrigin (..) - , Read.slotFromChainPoint - - , Address - , KeyHash - , NetworkTag (..) - , mkEnterpriseAddress - , Addr - , compactAddr - , decompactAddr - - , Ix - , Read.TxIn - , Read.TxOut - , address - , Read.Value - , Read.lessOrEqual - , UTxO - - , Read.TxId - , Read.Tx (..) - , Read.utxoFromEraTx - , Read.getCollateralInputs - , Read.getInputs - , Read.getValidityInterval - , Read.getTxId - , Read.invalidHereafter - - , Read.Block - , Read.getChainPoint - , Read.getEraBHeader - , Read.getEraSlotNo - , Read.getEraTransactions - , mockNextBlock - , Read.mockRawHeaderHash - - , Read.ChainTip (..) - , Read.getChainTip - , Read.prettyChainTip - - , Read.PParams (..) - , Read.mockPParamsConway - - , Read.GenesisData - , Read.GenesisHash - , Read.mockGenesisDataMainnet - - , Read.NetworkId (Read.Mainnet, Read.Testnet) - , Read.getNetworkId - , getEraSlotOfBlock - ) where - -import Prelude - -import Cardano.Ledger.Address - ( Addr - , compactAddr - , decompactAddr - ) -import Cardano.Wallet.Address.Encoding - ( Credential (..) - , EnterpriseAddr (..) - , KeyHash - , NetworkTag (..) - , compactAddrFromEnterpriseAddr - ) -import Cardano.Wallet.Read.Block.Gen - ( mkBlockEra - ) -import Cardano.Wallet.Read.Block.Gen.BlockParameters - ( BlockParameters (..) - ) -import Data.Map - ( Map - ) - -import qualified Cardano.Wallet.Read as Read - -{----------------------------------------------------------------------------- - Type definitions - with dummies -------------------------------------------------------------------------------} - --- | Synonym for readability. --- The ledger specifications define @Addr@. --- Byron addresses are represented by @Addr_bootstrap@. -type Address = Read.CompactAddr - --- | Make an enterprise address from a given network and key hash. -mkEnterpriseAddress :: NetworkTag -> KeyHash -> Address -mkEnterpriseAddress network = - compactAddrFromEnterpriseAddr - . EnterpriseAddrC network - . KeyHashObj - -type Ix = Read.TxIx - -address :: Read.TxOut -> Address -address = Read.getCompactAddr - -type UTxO = Map Read.TxIn Read.TxOut - -{----------------------------------------------------------------------------- - Block -------------------------------------------------------------------------------} --- | Create a new block from a sequence of transaction. -mockNextBlock - :: Read.ChainPoint -> [Read.Tx Read.Conway] -> Read.Block Read.Conway -mockNextBlock old txs = - mkBlockEra BlockParameters{slotNumber,blockNumber,txs} - where - blockNumber = Read.BlockNo $ Read.unSlotNo slotNumber - slotNumber = case old of - Read.GenesisPoint -> Read.SlotNo 0 - Read.BlockPoint{slotNo = n} -> succ n - -getEraSlotOfBlock :: Read.IsEra era => Read.Block era -> Read.Slot -getEraSlotOfBlock = Read.At . Read.getEraSlotNo . Read.getEraBHeader diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs deleted file mode 100644 index 6b8373f1d89..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs +++ /dev/null @@ -1,422 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.Testing.DSL - ( Scenario (..) - , ScenarioP - , existsTx - , deposit - , deposit_ - , withdrawal - , block - , rollForward - , rollBackward - , historyByTime - , historyByCustomer - , newHistoryByTime - , availableBalance - , assert - , interpret - , InterpreterState (..) - , spend - , sign - , utxo - , wallet - , balance - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure - ( Customer - , ResolvedTx (..) - , WalletState - , getTxHistoryByTime - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - , LookupTimeFromSlot - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( createMnemonicFromWords - , credentialsFromMnemonics - ) -import Cardano.Wallet.Deposit.Pure.State.Payment - ( createPaymentTxBody - ) -import Cardano.Wallet.Deposit.Read - ( Address - , ChainPoint (..) - , EraValue (..) - , UTxO - , getChainPoint - , mockNextBlock - , slotFromChainPoint - ) -import Cardano.Wallet.Deposit.Testing.DSL.ByTime - ( ByTimeM - , ByTimeMContext (..) - ) -import Cardano.Wallet.Deposit.Testing.DSL.Types - ( BlockI (..) - , TxI (..) - , UnspentI (..) - ) -import Cardano.Wallet.Deposit.Write - ( Block - , Tx - , TxBody - , addTxIn - , addTxOut - , emptyTxBody - , mkAda - , mkTx - , mkTxOut - , txOutsL - ) -import qualified Cardano.Wallet.Deposit.Write as Write -import Cardano.Wallet.Read - ( Coin (..) - , Slot - , Value (..) - , WithOrigin - , getTxId - , pattern TxIn - ) -import Control.Lens - ( At (..) - , Field1 (_1) - , Field2 (_2) - , Ixed (..) - , Lens' - , lens - , use - , uses - , zoom - , (%=) - , (.=) - , (^?) - ) -import Control.Monad - ( void - , (>=>) - ) -import Control.Monad.Operational - ( ProgramT - , ProgramViewT (..) - , singleton - , viewT - ) -import Control.Monad.Reader - ( MonadIO (..) - , runReader - ) -import Control.Monad.State - ( MonadState (..) - , MonadTrans (..) - , StateT - , evalStateT - , execStateT - , modify - ) -import Data.List - ( mapAccumL - ) -import Data.Map - ( Map - ) -import Data.Maybe - ( fromJust - ) -import Data.Text - ( Text - ) -import Data.Time - ( UTCTime - ) - -import qualified Cardano.Wallet.Deposit.Pure as Wallet -import qualified Cardano.Wallet.Deposit.Time as Time -import qualified Cardano.Wallet.Read as Read -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set - -data Scenario p a where - ResetWallet :: Int -> Text -> Text -> Scenario p () - ExistsTx :: Scenario p TxI - Deposit :: TxI -> Customer -> Int -> Scenario p UnspentI - Spend :: TxI -> Address -> Int -> Scenario p () - Withdrawal :: TxI -> UnspentI -> Scenario p () - CreateBlock :: [TxI] -> Scenario p (BlockI) - RollForward :: [BlockI] -> Scenario p () - RollBackward :: Maybe BlockI -> Scenario p () - HistoryByTime :: Scenario p ByTime - HistoryByCustomer :: Scenario p ByCustomer - NewHistoryByTime :: ByTimeM ByTime -> Scenario p ByTime - AvailableBalance :: Scenario p Int - Sign :: Tx -> Text -> Scenario p Tx - Balance :: TxI -> Scenario p Tx - UTxO :: UnspentI -> Scenario p UTxO - Assert :: p -> Scenario p () - -type ScenarioP p m = ProgramT (Scenario p) m - -wallet :: Int -> Text -> Text -> ScenarioP p m () -wallet customers seed passphrase = - singleton (ResetWallet customers seed passphrase) - -existsTx :: ScenarioP p m TxI -existsTx = singleton ExistsTx - -deposit :: TxI -> Customer -> Int -> ScenarioP p m UnspentI -deposit tx customer value = singleton (Deposit tx customer value) - -deposit_ :: Monad m => TxI -> Customer -> Int -> ScenarioP p m () -deposit_ tx customer value = void $ deposit tx customer value - -spend :: TxI -> Address -> Int -> ScenarioP p m () -spend tx addr value = singleton (Spend tx addr value) - -withdrawal :: TxI -> UnspentI -> ScenarioP p m () -withdrawal tx unspent = singleton (Withdrawal tx unspent) - -block :: [TxI] -> ScenarioP p m BlockI -block txs = singleton (CreateBlock txs) - -rollForward :: [BlockI] -> ScenarioP p m () -rollForward blocks = singleton (RollForward blocks) - -rollBackward :: Maybe BlockI -> ScenarioP p m () -rollBackward slot = singleton (RollBackward slot) - -historyByTime :: ScenarioP p m ByTime -historyByTime = singleton HistoryByTime - -historyByCustomer :: ScenarioP p m ByCustomer -historyByCustomer = singleton HistoryByCustomer - -newHistoryByTime :: ByTimeM ByTime -> ScenarioP p m ByTime -newHistoryByTime = singleton . NewHistoryByTime - -availableBalance :: ScenarioP p m Int -availableBalance = singleton AvailableBalance - -sign :: Tx -> Text -> ScenarioP p m Write.Tx -sign tx pass = singleton (Sign tx pass) - -balance :: TxI -> ScenarioP p m Tx -balance tx = singleton (Balance tx) - -utxo :: UnspentI -> ScenarioP p m UTxO -utxo = singleton . UTxO - -assert :: p -> ScenarioP p m () -assert = singleton . Assert - -rollForwardBlocks - :: LookupTimeFromSlot - -> [BlockI] - -> (WalletState, InterpreterState) - -> (WalletState, InterpreterState) -rollForwardBlocks timeOf blocks (w, interpreter@InterpreterState{..}) = - ( w' - , interpreter{iBlocks = newIBlocks, iBlockPoints = newIBlockPoints} - ) - where - w' = Wallet.rollForwardMany timeOf (NE.fromList blocks') w - ((newIBlocks, newIBlockPoints), blocks') = - mapAccumL - rollForwardBlock - (iBlocks, iBlockPoints) - blocks - rollForwardBlock (iBlocksCurrent, iBlockPointsCurrent) blockI = - ( - ( Map.insert blockPoint newBlock iBlocksCurrent - , Map.insert blockI blockPoint iBlockPointsCurrent - ) - , EraValue newBlock - ) - where - txs = iBlockContents Map.! blockI - newBlock = mockNextBlock startPoint txs - blockPoint = getChainPoint newBlock - startPoint = - maybe GenesisPoint fst - $ Map.lookupMax iBlocksCurrent - -rollBackwardBlock - :: LookupTimeFromSlot - -> Maybe BlockI - -> (WalletState, InterpreterState) - -> (WalletState, InterpreterState) -rollBackwardBlock timeOf Nothing (w, interpreter) = - ( fst $ Wallet.rollBackward timeOf GenesisPoint w - , interpreter{iBlocks = mempty, iBlockPoints = mempty} - ) -rollBackwardBlock timeOf (Just blockI) (w, interpreter@InterpreterState{..}) = - case Map.lookup blockI iBlockPoints of - Just keep -> - ( w' - , interpreter{iBlocks = newIBlocks, iBlockPoints = newIBlockPoints} - ) - where - w' = fst $ Wallet.rollBackward timeOf keep w - newIBlocks = Map.takeWhileAntitone (<= keep) iBlocks - newIBlockPoints = Map.filter (<= keep) iBlockPoints - Nothing -> (w, interpreter) - -data InterpreterState = InterpreterState - { iTxs :: Map TxI TxBody - , iBlockContents :: Map BlockI [Tx] - , iBlockPoints :: Map BlockI ChainPoint - , iBlocks :: Map ChainPoint Block - } - deriving (Show) - -iTxsL :: Lens' InterpreterState (Map TxI TxBody) -iTxsL = lens iTxs (\s x -> s{iTxs = x}) - -iBlockContentsL :: Lens' InterpreterState (Map BlockI [Tx]) -iBlockContentsL = lens iBlockContents (\s x -> s{iBlockContents = x}) - -iBlockPointsL :: Lens' InterpreterState (Map BlockI ChainPoint) -iBlockPointsL = lens iBlockPoints (\s x -> s{iBlockPoints = x}) - -newTxId :: Monad m => StateT InterpreterState m TxI -newTxId = zoom iTxsL $ do - txs <- get - let z = maybe 0 fst $ Map.lookupMax txs - txId = z + 1 - put $ Map.insert txId emptyTxBody txs - return txId - -newBlockId :: Monad m => StateT InterpreterState m BlockI -newBlockId = zoom iBlockContentsL $ do - blocks <- get - let z = maybe 0 fst $ Map.lookupMax blocks - blockId = z + 1 - put $ Map.insert blockId [] blocks - return blockId - -freshInterpreterState :: InterpreterState -freshInterpreterState = InterpreterState mempty mempty mempty mempty - -unsafeCustomerAddress - :: Wallet.WalletState -> Customer -> Write.Address -unsafeCustomerAddress w = fromJust . flip Wallet.customerAddress w - -interpret - :: (MonadIO m, MonadFail m) - => WalletState - -> (p -> m ()) - -> (Slot -> WithOrigin UTCTime) - -> ScenarioP - p - (StateT (WalletState, InterpreterState) m) - () - -> m () -interpret w runP slotTimes p = flip evalStateT w $ do - walletState <- get - (walletState', _) <- - lift - $ execStateT - (go p) - (walletState, freshInterpreterState) - put walletState' - where - go = viewT >=> eval - eval (ResetWallet customers seed passphrase :>>= k) = do - Right mnemonics <- pure $ createMnemonicFromWords seed - let new = - Wallet.fromCredentialsAndGenesis - (credentialsFromMnemonics mnemonics passphrase) - (fromIntegral customers) - Read.mockGenesisDataMainnet - id .= (new, freshInterpreterState) - go $ k () - eval (Return x) = return x - eval (ExistsTx :>>= k) = do - txId <- zoom _2 newTxId - go $ k txId - eval (Deposit tx customer value :>>= k) = do - customerAddresses <- uses _1 unsafeCustomerAddress - let v = mkAda $ fromIntegral value - txOut = mkTxOut (customerAddresses customer) v - Just txBody <- use (_2 . iTxsL . at tx) - let (txBody', tix) = addTxOut txOut txBody - _2 . iTxsL . ix tx .= txBody' - go $ k $ UnspentI (tx, tix) - eval (Withdrawal tx (UnspentI (tx', tix)) :>>= k) = do - Just txId <- uses (_2 . iTxsL . at tx') $ fmap (getTxId . mkTx) - _2 . iTxsL . ix tx %= \txBody -> addTxIn (TxIn txId tix) txBody - go $ k () - eval (Spend tx address value :>>= k) = do - Just txBody <- use (_2 . iTxsL . at tx) - let (txBody', _tix) = - addTxOut (mkTxOut address (mkAda $ fromIntegral value)) txBody - _2 . iTxsL . ix tx .= txBody' - go $ k () - eval (CreateBlock txs :>>= k) = do - blockId <- zoom _2 newBlockId - send <- - uses (_2 . iTxsL) - $ flip Map.restrictKeys - $ Set.fromList txs - _2 . iBlockContentsL . ix blockId .= (mkTx <$> Map.elems send) - go $ k blockId - eval (RollForward blocks :>>= k) = do - modify $ rollForwardBlocks (fmap Just slotTimes) blocks - go $ k () - eval (RollBackward blockKeep :>>= k) = do - modify $ rollBackwardBlock (fmap Just slotTimes) blockKeep - go $ k () - eval (HistoryByTime :>>= k) = do - v <- uses _1 getTxHistoryByTime - go $ k v - eval (HistoryByCustomer :>>= k) = do - v <- uses _1 Wallet.getTxHistoryByCustomer - go $ k v - eval (NewHistoryByTime m :>>= k) = do - customerAddresses <- uses _1 unsafeCustomerAddress - txIds' <- uses (_2 . iTxsL) $ (Map.!) . fmap (getTxId . mkTx) - blockSlots <- - uses (_2 . iBlockPointsL) $ (Map.!) . fmap slotFromChainPoint - go - $ k - $ runReader m - $ ByTimeMContext txIds' customerAddresses slotTimes blockSlots - eval (AvailableBalance :>>= k) = do - ValueC (CoinC v) _ <- uses _1 Wallet.availableBalance - go $ k $ fromIntegral v - eval (Sign tx pass :>>= k) = do - Just stx <- uses _1 $ Wallet.signTx tx pass - go $ k stx - eval (Balance tx :>>= k) = do - Just txBody <- use (_2 . iTxsL . at tx) - ws <- use _1 - let etx = - createPaymentTxBody - (Read.EraValue Read.mockPParamsConway) - (Time.toTimeTranslationPure Time.mockTimeInterpreter) - txBody - ws - ResolvedTx btx _ <- case etx of - Left e -> fail $ "createPaymentTxBody failed: " <> show e - Right tx' -> return tx' - go $ k btx - eval (UTxO (UnspentI (tx, tix)) :>>= k) = do - Just txBody <- use (_2 . iTxsL . at tx) - let txId = getTxId $ mkTx txBody - Just txOut <- pure $ txBody ^? txOutsL . ix tix - go $ k $ Map.singleton (TxIn txId tix) txOut - eval (Assert assertion :>>= k) = do - lift $ runP assertion - go $ k () diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs deleted file mode 100644 index f77db89bbcf..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use let" #-} - -module Cardano.Wallet.Deposit.Testing.DSL.ByTime - ( -- * ByTime - ByTimeM - , ByTimeMContext (..) - , ByTime - - -- * At time - , atBlock - , atSlot - , newByTime - - -- * For customer - , forCustomer - - -- * In tx - , inTx - - -- * Value transfer - , deposited - , withdrawn - , byCustomerFromByTime - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Map - ( F - , Map (..) - , W - , toFinger - ) -import Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (received, spent) - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( ByCustomer - , ByTime - , DownTime - , firstJust - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Cardano.Wallet.Deposit.Testing.DSL.Types - ( BlockI - , TxI - ) -import Cardano.Wallet.Deposit.Write - ( mkAda - ) -import Cardano.Wallet.Read - ( Slot - , TxId - , WithOrigin (..) - ) -import Control.Monad.Reader - ( Reader - , asks - ) -import Control.Monad.State - ( State - , StateT - , execState - , execStateT - , modify' - ) -import Control.Monad.Trans - ( MonadTrans (..) - ) -import Data.Foldable - ( Foldable (..) - ) -import Data.Map.Monoidal.Strict - ( MonoidalMap - ) -import Data.Monoid - ( First - ) -import Data.Ord - ( Down (..) - ) -import Data.Time - ( UTCTime - ) - -import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq -import qualified Cardano.Wallet.Deposit.Map.Timed as TimeSeq -import qualified Data.Map.Monoidal.Strict as MonoidalMap - -byCustomerFromByTime :: ByTime -> ByCustomer -byCustomerFromByTime (Finger () xs) = Map () xs' - where - xs' - :: MonoidalMap - Customer - (Map '[F (First Address) DownTime, W (First Slot) TxId] ValueTransfer) - xs' = fold $ do - Timed t (Map slot ys) <- TimeSeq.toList xs - (customer, Map addr kv) <- MonoidalMap.toList ys - pure - $ MonoidalMap.singleton customer - $ Finger addr - $ TimedSeq.singleton (Timed t $ Map slot kv) - --- ------------------------------------------------------------------------------- --- -- AtTime --- ------------------------------------------------------------------------------- - -data ByTimeMContext = ByTimeMContext - { txIdOfTxI :: TxI -> TxId - , addrOfCustomer :: Customer -> Address - , timeOfSlot :: Slot -> WithOrigin UTCTime - , slotOfBlock :: BlockI -> Slot - } - -type ByTimeM = Reader ByTimeMContext - -atBlock - :: BlockI - -> StateT - (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer)) - ByTimeM - () - -> StateT - ( MonoidalMap - DownTime - (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer) - ) - ByTimeM - () -atBlock b v = do - slotOf <- asks slotOfBlock - atSlot (slotOf b) v - -atSlot - :: Slot - -> StateT - (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer)) - ByTimeM - () - -> StateT - ( MonoidalMap - DownTime - (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer) - ) - ByTimeM - () -atSlot t v = do - timeOf <- asks timeOfSlot - txs <- lift $ newCustomers t v - modify' $ MonoidalMap.insert (Down $ timeOf t) txs - -newByTime - :: StateT - ( MonoidalMap - DownTime - (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer) - ) - ByTimeM - () - -> ByTimeM ByTime -newByTime v = toFinger . Map () <$> execStateT v mempty - --- ------------------------------------------------------------------------------- --- -- Customer --- ------------------------------------------------------------------------------- - -forCustomer - :: Customer - -> StateT - (MonoidalMap TxId (Map '[] ValueTransfer)) - ByTimeM - () - -> StateT - (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer)) - ByTimeM - () -forCustomer c v = do - addrOf <- asks addrOfCustomer - txs <- lift $ newTxIds (addrOf c) v - modify' $ MonoidalMap.insert c txs - -newCustomers - :: Slot - -> StateT - (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer)) - ByTimeM - () - -> ByTimeM - (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer) -newCustomers slot v = Map (firstJust slot) <$> execStateT v mempty - -------------------------------------------------------------------------------- --- Tx -------------------------------------------------------------------------------- - -inTx - :: TxI - -> State ValueTransfer () - -> StateT - (MonoidalMap TxId (Map '[] ValueTransfer)) - ByTimeM - () -inTx tx v = do - w <- pure $ newValueTransferP v - txIdOf <- asks txIdOfTxI - modify' $ MonoidalMap.insert (txIdOf tx) w - -newTxIds - :: Address - -> StateT - (MonoidalMap TxId (Map '[] ValueTransfer)) - ByTimeM - () - -> ByTimeM (Map '[W (First Address) TxId] ValueTransfer) -newTxIds addr v = Map (firstJust addr) <$> execStateT v mempty - -------------------------------------------------------------------------------- --- Value transfer -------------------------------------------------------------------------------- - -deposited :: Int -> State ValueTransfer () -deposited n = modify' $ \s -> s{received = mkAda $ fromIntegral n} - -withdrawn :: Int -> State ValueTransfer () -withdrawn n = modify' $ \s -> s{spent = mkAda $ fromIntegral n} - -newValueTransferP - :: State ValueTransfer () - -> Map '[] ValueTransfer -newValueTransferP v = Value $ execState v mempty diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs deleted file mode 100644 index 5ea04bbe213..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Wallet.Deposit.Testing.DSL.Types where - -import Prelude - -import Cardano.Wallet.Deposit.Read - ( Ix - ) - -newtype TxI = TxI Int - deriving (Eq, Ord, Show, Num) - -newtype UnspentI = UnspentI (TxI, Ix) - deriving (Eq, Ord, Show) - -newtype BlockI = BlockI Int - deriving (Eq, Ord, Show, Num) - -newtype TimeI = TimeI Int - deriving (Eq, Ord, Show) diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs deleted file mode 100644 index b47596e6b2b..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Indirection module that re-exports types --- related to computations involving Slots and wall-clock times. --- --- TODO: Absorb this into a definition of 'TimeInterpreter'. -module Cardano.Wallet.Deposit.Time - ( -- * from Primitive - TimeInterpreter - , PastHorizonException - , mockTimeInterpreter - - , slotToUTCTime - - -- * from Write - , Write.TimeTranslation - , toTimeTranslation - , toTimeTranslationPure - - -- * wishlist - , LookupTimeFromSlot - , unsafeUTCTimeOfSlot - , unsafeSlotOfUTCTime - , systemStartMainnet - , originTime - - ) where - -import Prelude - -import Cardano.Wallet.Primitive.Slotting - ( PastHorizonException - , StartTime (..) - , hoistTimeInterpreter - , interpretQuery - , mkSingleEraInterpreter - ) -import Cardano.Wallet.Primitive.Slotting.TimeTranslation - ( toTimeTranslation - , toTimeTranslationPure - ) -import Cardano.Wallet.Primitive.Types.SlottingParameters - ( ActiveSlotCoefficient (..) - , EpochLength (..) - , SlotLength (..) - , SlottingParameters (..) - ) -import Cardano.Wallet.Read - ( Slot - , SlotNo (..) - , WithOrigin (..) - ) -import Data.Functor.Identity - ( Identity (..) - ) -import Data.IntCast - ( intCastMaybe - ) -import Data.Quantity - ( Quantity (..) - ) -import Data.Time.Clock - ( UTCTime (..) - ) -import Data.Time.Clock.POSIX - ( posixSecondsToUTCTime - , utcTimeToPOSIXSeconds - ) - -import qualified Cardano.Wallet.Primitive.Slotting as Primitive -import qualified Cardano.Wallet.Read as Read -import qualified Cardano.Write.Tx as Write - -{----------------------------------------------------------------------------- - TimeInterpreter -------------------------------------------------------------------------------} -type TimeInterpreter = Primitive.TimeInterpreter (Either PastHorizonException) - -mockTimeInterpreter :: Primitive.TimeInterpreter Identity -mockTimeInterpreter = hoistTimeInterpreter (pure . runIdentity) $ - mkSingleEraInterpreter - (StartTime $ UTCTime (toEnum 0) 0) - mockSlottingParameters - -mockSlottingParameters :: SlottingParameters -mockSlottingParameters = SlottingParameters - { getSlotLength = SlotLength 1 - , getEpochLength = EpochLength 21_600 - , getActiveSlotCoefficient = ActiveSlotCoefficient 1 - , getSecurityParameter = Quantity 2_160 - } - -{----------------------------------------------------------------------------- - TimeInterpreter -------------------------------------------------------------------------------} - -type LookupTimeFromSlot = Slot -> Maybe (WithOrigin UTCTime) - --- | Look up the UTCTime corresponding to the start of the provided `Slot`. --- --- TODO: Check roundtrip properties once we need to implement the corresponding 'utcTimeToSlot'. -slotToUTCTime :: TimeInterpreter -> LookupTimeFromSlot -slotToUTCTime _ti Origin = Just Origin -slotToUTCTime ti (At s) = either (const Nothing) (Just . At) . interpretQuery ti . Primitive.slotToUTCTime =<< convertSlotNo s - where - convertSlotNo :: SlotNo -> Maybe Primitive.SlotNo - convertSlotNo (SlotNo n) = Primitive.SlotNo <$> intCastMaybe n - --- TODO: Rename to mainnetUTCTimeOfSlot --- TODO: Move to tests? -unsafeUTCTimeOfSlot :: Slot -> Maybe (WithOrigin UTCTime) -unsafeUTCTimeOfSlot Origin = Just Origin -unsafeUTCTimeOfSlot (At (SlotNo n)) = - Just . At - $ posixSecondsToUTCTime - $ fromIntegral pt - where - pts = fromIntegral n - byronSlots - pt = - if pts >= 0 - then shelleyTime + pts - else shelleyTime + pts * 20 - -unsafeSlotOfUTCTime :: UTCTime -> Read.Slot -unsafeSlotOfUTCTime t - | origin = Origin - | byron = At $ SlotNo $ fromIntegral $ (pt - originTime) `div` 20 - | otherwise = At $ SlotNo $ fromIntegral $ pt - shelleyTime + byronSlots - where - pt = floor $ utcTimeToPOSIXSeconds t - origin = pt < originTime - byron = pt < shelleyTime - -byronSlots :: Integer -byronSlots = 4_924_800 - -shelleyTime :: Integer -shelleyTime = 1_596_491_091 - -originTime :: Integer -originTime = shelleyTime - byronSlots * 20 - -systemStartMainnet :: UTCTime -systemStartMainnet = posixSecondsToUTCTime $ fromIntegral originTime diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs deleted file mode 100644 index 9d9784b3bf3..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Indirection module that re-exports types --- used for writing transactions to the blockchain, --- in the most recent and the next future eras. --- --- TODO: Match this up with the @Write@ hierarchy. -module Cardano.Wallet.Deposit.Write - ( -- * Basic types - Address - , Value - , TxId - , Tx - , Block - , mkTx - , TxBody (..) - , TxIn - , TxOut - , Coin - - -- * Transaction balancing - , Write.IsRecentEra - , Write.Conway - , L.PParams - , Write.UTxOAssumptions (..) - , Write.ChangeAddressGen (..) - , Write.StakeKeyDepositLookup (..) - , Write.TimelockKeyWitnessCounts (..) - , Write.UTxOIndex - , Write.constructUTxOIndex - , Write.UTxO - , toConwayUTxO - , Write.PartialTx (..) - , Write.ErrBalanceTx (..) - , Write.ErrBalanceTxAssetsInsufficientError (..) - , Write.ErrBalanceTxInsufficientCollateralError (..) - , Write.ErrBalanceTxInternalError (..) - , Write.ErrBalanceTxOutputError (..) - , Write.ErrBalanceTxOutputErrorInfo (..) - , Write.ErrBalanceTxUnableToCreateChangeError (..) - , Write.ErrAssignRedeemers (..) - , Write.balanceTx - - -- * Signing - , addSignature - - -- ** Time interpreter - , Write.TimeTranslation - - -- * Helper functions - , mkAda - , mkTxOut - , txOutsL - , toConwayTx - , addTxIn - , addTxOut - , emptyTxBody - , UTxO.resolvedTx - , UTxO.resolvedInputs - ) where - -import Prelude - -import Cardano.Ledger.Coin - ( Coin - ) -import Cardano.Read.Ledger.Tx.Output - ( Output (..) - ) -import Cardano.Wallet.Address.BIP32_Ed25519 - ( XPrv - , sign - , toXPub - ) -import Cardano.Wallet.Deposit.Read - ( Address - , Ix - , SlotNo (..) - , TxId - , TxIn - , TxOut - , Value - ) -import Cardano.Wallet.Deposit.Write.Keys - ( signedDSIGNfromXSignature - , vkeyFromXPub - ) -import Cardano.Wallet.Read.Tx - ( toConwayOutput - ) -import Control.Lens - ( Lens' - , lens - , (%~) - , (&) - , (.~) - ) -import Data.Map - ( Map - ) -import Data.Maybe.Strict - ( StrictMaybe (..) - , maybeToStrictMaybe - ) -import Data.Sequence.Strict - ( StrictSeq - , fromList - ) -import Data.Set - ( Set - ) - -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.Api.Tx.In as L -import qualified Cardano.Ledger.Slot as L -import qualified Cardano.Wallet.Deposit.Pure.UTxO.Tx as UTxO -import qualified Cardano.Wallet.Read as Read -import qualified Cardano.Wallet.Read.Hash as Hash -import qualified Cardano.Write.Eras as Write -import qualified Cardano.Write.Tx as Write -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} -type Tx = Read.Tx Read.Conway - -type Block = Read.Block Read.Conway - -{----------------------------------------------------------------------------- - Signing -------------------------------------------------------------------------------} --- | Add a signature to the transaction using the private key -addSignature :: XPrv -> Tx -> Tx -addSignature xprv tx@(Read.Tx ledgerTx) = - Read.Tx - (ledgerTx & (L.witsTxL . L.addrTxWitsL) %~ Set.insert witnessVKey) - where - txHash = Read.hashFromTxId $ Read.getTxId tx - xpub = toXPub xprv - xsign = sign xprv (Hash.hashToBytes txHash) - witnessVKey = - L.WitVKey (vkeyFromXPub xpub) (signedDSIGNfromXSignature xsign) - -{----------------------------------------------------------------------------- - Convenience TxBody -------------------------------------------------------------------------------} - -data TxBody = TxBody - { spendInputs :: Set TxIn - , collInputs :: Set TxIn - , txouts :: Map Ix TxOut - , collRet :: Maybe TxOut - , expirySlot :: Maybe SlotNo - } - deriving (Show) - -txOutsL :: Lens' TxBody (Map Ix TxOut) -txOutsL = lens txouts (\s a -> s{txouts = a}) - -nextIx :: TxBody -> Ix -nextIx = maybe minBound (succ . fst) . Map.lookupMax . txouts - -addTxOut :: TxOut -> TxBody -> (TxBody, Ix) -addTxOut txout txbody = (txBody', txIx) - where - txBody' = txbody & txOutsL .~ Map.insert txIx txout (txouts txbody) - txIx = nextIx txbody - -addTxIn :: TxIn -> TxBody -> TxBody -addTxIn txin txbody = txbody{spendInputs = Set.insert txin (spendInputs txbody)} - -emptyTxBody :: TxBody -emptyTxBody = TxBody mempty mempty mempty Nothing Nothing - --- | Inject a number of ADA, i.e. a million lovelace. -mkAda :: Integer -> Value -mkAda = Read.injectCoin . Read.CoinC . (* 1000000) - -mkTxOut :: Address -> Value -> TxOut -mkTxOut = Read.mkBasicTxOut - -toConwayTx :: Tx -> Read.Tx Read.Conway -toConwayTx = id - -mkTx :: TxBody -> Tx -mkTx txbody = Read.Tx $ L.mkBasicTx txBody - where - txBody :: L.TxBody L.Conway - txBody = - L.mkBasicTxBody - & L.inputsTxBodyL .~ Set.map toLedgerTxIn (spendInputs txbody) - & L.collateralInputsTxBodyL - .~ Set.map toLedgerTxIn (collInputs txbody) - & L.outputsTxBodyL .~ toLedgerTxOuts (txouts txbody) - & L.collateralReturnTxBodyL - .~ toLedgerMaybeTxOut (collRet txbody) - & L.vldtTxBodyL - .~ L.ValidityInterval - SNothing - (toLedgerSlotNo <$> maybeToStrictMaybe (expirySlot txbody)) - -toLedgerSlotNo :: SlotNo -> L.SlotNo -toLedgerSlotNo (SlotNo n) = L.SlotNo (fromInteger $ fromIntegral n) - -toLedgerTxIn :: TxIn -> L.TxIn L.StandardCrypto -toLedgerTxIn = id - -toLedgerTxOuts :: Map Ix TxOut -> StrictSeq (L.TxOut L.Conway) -toLedgerTxOuts = fromList . map (toConwayTxOut . snd) . Map.toAscList - -toLedgerMaybeTxOut :: Maybe TxOut -> StrictMaybe (L.TxOut L.Conway) -toLedgerMaybeTxOut = fmap toConwayTxOut . maybeToStrictMaybe - -toConwayTxOut :: TxOut -> L.TxOut L.Conway -toConwayTxOut txout = - case toConwayOutput txout of - Output o -> o - -toConwayUTxO :: Map TxIn TxOut -> Write.UTxO L.Conway -toConwayUTxO = Write.UTxO . Map.map toConwayTxOut diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs deleted file mode 100644 index 2fa7c1c413e..00000000000 --- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Module for converting key types from --- @Cardano.Ledger@ with key types from @Cardano.Crypto.Wallet@. --- --- TODO: Match this up with the @Write@ hierarchy. -module Cardano.Wallet.Deposit.Write.Keys - ( enterpriseAddressFromVKey - , vkeyFromXPub - , signedDSIGNfromXSignature - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( xpubPublicKey - ) -import Cardano.Ledger.Keys - ( SignedDSIGN - , VKey (..) - ) -import Cardano.Wallet.Address.BIP32_Ed25519 - ( XPub - , XSignature - , rawSerialiseXSignature - ) -import Cardano.Wallet.Deposit.Read - ( Address - ) -import Data.Maybe - ( fromMaybe - ) - -import qualified Cardano.Crypto.DSIGN as DSIGN -import qualified Cardano.Ledger.Address as L -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.BaseTypes as L -import qualified Cardano.Ledger.Credential as L -import qualified Cardano.Ledger.Hashes as L -import qualified Cardano.Ledger.Keys as L - -{----------------------------------------------------------------------------- - Key conversion -------------------------------------------------------------------------------} --- | Create an enterprise address from a ledger 'VKey'. -enterpriseAddressFromVKey - :: L.Network - -> VKey 'L.Witness L.StandardCrypto - -> Address -enterpriseAddressFromVKey network = - mkEnterpriseAddress - . L.coerceKeyRole - . L.hashKey - where - mkEnterpriseAddress h = - L.compactAddr - $ L.Addr network (L.KeyHashObj h) L.StakeRefNull - --- | Convert 'XPub' to a ledger verification key. -vkeyFromXPub :: XPub -> VKey 'L.Witness L.StandardCrypto -vkeyFromXPub = - VKey - . fromMaybe impossible - . DSIGN.rawDeserialiseVerKeyDSIGN - . xpubPublicKey - where - impossible = error "impossible: Cannot convert XPub to VKey" - --- | Convert 'XSignature' to a ledger signature. -signedDSIGNfromXSignature - :: XSignature - -> SignedDSIGN L.StandardCrypto - (L.Hash L.StandardCrypto L.EraIndependentTxBody) -signedDSIGNfromXSignature = - DSIGN.SignedDSIGN - . fromMaybe impossible - . DSIGN.rawDeserialiseSigDSIGN - . rawSerialiseXSignature - where - impossible = error "impossible: Cannot convert XSignature to SignedDSIGN" diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs b/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs deleted file mode 100644 index 821f04bbec4..00000000000 --- a/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RecordWildCards #-} - -{-| -Copyright: © 2024 Cardano Foundation -License: Apache-2.0 - -Mock implementation of a blockchain for the purpose of testing. - -TODO: -* Make the blockchain more real. --} -module Test.Scenario.Blockchain - ( assert - - , ScenarioEnv - , withScenarioEnvMock - , withWalletEnvMock - - , Faucet - , ada - , payFromFaucet - - , signTx - , submitTx - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( XPrv - ) -import Cardano.Wallet.Deposit.IO.Network.Mock - ( newNetworkEnvMock - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv (..) - , mapBlock - ) -import Cardano.Wallet.Deposit.Pure - ( BIP32Path - ) -import Control.Concurrent - ( threadDelay - ) -import Control.Tracer - ( nullTracer - ) -import Data.Store - ( newStore - ) -import GHC.Stack - ( HasCallStack - ) - -import qualified Cardano.Wallet.Deposit.IO as Wallet -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Data.Map.Strict as Map - -{----------------------------------------------------------------------------- - Logic -------------------------------------------------------------------------------} - -assert :: HasCallStack => Bool -> IO () -assert True = pure () -assert False = error "Assertion failed!" - -{----------------------------------------------------------------------------- - Environment -------------------------------------------------------------------------------} --- | Environment for scenarios. -data ScenarioEnv = ScenarioEnv - { genesisData :: Read.GenesisData - , networkEnv :: NetworkEnv IO (Read.EraValue Read.Block) - , faucet :: Faucet - } - --- | Acquire and release a mock environment for a blockchain -withScenarioEnvMock :: (ScenarioEnv -> IO a) -> IO a -withScenarioEnvMock action = do - networkEnv <- mapBlock Read.EraValue <$> newNetworkEnvMock - action - $ ScenarioEnv - { genesisData = Read.mockGenesisDataMainnet - , networkEnv - , faucet = Faucet{xprv = error "TODO: Faucet xprv"} - } - --- | Acquire and release a mock environment for a wallet. -withWalletEnvMock - :: ScenarioEnv - -> (Wallet.WalletEnv IO -> IO a) - -> IO a -withWalletEnvMock ScenarioEnv{..} action = do - database <- newStore - let walletEnv = Wallet.WalletEnv - Wallet.WalletBootEnv - { Wallet.logger = nullTracer - , Wallet.genesisData = genesisData - , Wallet.networkEnv = networkEnv - } - database - action walletEnv - -{----------------------------------------------------------------------------- - Faucet -------------------------------------------------------------------------------} -newtype Faucet = Faucet - { xprv :: XPrv - } - -ada :: Integer -> Write.Value -ada = Write.mkAda - -payFromFaucet :: ScenarioEnv -> [(Write.Address, Write.Value)] -> IO () -payFromFaucet env destinations = - submitTx env tx - where - toTxOut (addr, value) = Write.mkTxOut addr value - txBody = Write.TxBody - { Write.spendInputs = mempty - , Write.collInputs = mempty - , Write.txouts = - Map.fromList $ zip [toEnum 0..] $ map toTxOut destinations - , Write.collRet = Nothing - , Write.expirySlot = Nothing - } - tx = signTx (xprv (faucet env)) [] $ Write.mkTx txBody - -{----------------------------------------------------------------------------- - Transaction submission -------------------------------------------------------------------------------} - -signTx :: XPrv -> [BIP32Path] -> Write.Tx -> Write.Tx -signTx _ _ = id - -submitTx :: ScenarioEnv -> Write.Tx -> IO () -submitTx env tx = do - _ <- postTx (networkEnv env) tx - - -- Wait a short while to give the tx time to make it on-chain. - threadDelay 500_000 diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs deleted file mode 120000 index daac8bef83a..00000000000 --- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs +++ /dev/null @@ -1 +0,0 @@ -Exchanges.lhs.md \ No newline at end of file diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md deleted file mode 100644 index 1d22927004d..00000000000 --- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md +++ /dev/null @@ -1,229 +0,0 @@ -# Use case: Centralized Exchange - -This document describes how a centralized exchange (CEX) can use the Deposit Wallet to - -1. Assign an address to a customer ID. -2. Track deposits at this address. -3. Track deposits at all addresses. -4. Create payments to a different wallet. - -# Scenarios, Haskell - -In this section, we describe the scenarios using Haskell. - -```haskell -module Test.Scenario.Wallet.Deposit.Exchanges - ( scenarioRestore - , scenarioStart - , scenarioCreateAddressList - , scenarioTrackDepositOne - , scenarioTrackDepositAll - , scenarioCreatePayment - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( XPrv - , XPub - ) -import Cardano.Wallet.Deposit.IO - ( WalletEnv - , WalletInstance - ) -import Cardano.Wallet.Deposit.Pure - ( Customer - , ValueTransfer (..) - , Credentials (..) - , ResolvedTx (..) - ) -import Cardano.Wallet.Deposit.Read - ( Address - , Value - , TxId - , lessOrEqual - ) -import Control.Tracer - ( nullTracer - ) -import Test.Scenario.Blockchain - ( ScenarioEnv - , ada - , assert - , payFromFaucet - , signTx - , submitTx - ) - -import qualified Cardano.Wallet.Deposit.IO as Wallet -import qualified Data.Map as Map -``` - -We use a function `depositFundsAt` to make a deposit at a given address. - -```haskell -depositFundsAt :: ScenarioEnv -> Address -> Value -> IO () -depositFundsAt env address value = payFromFaucet env [(address, value)] -``` - -We ignore the mapping from TxId when retrieving the customer history -```haskell -getCustomerDeposits :: Customer -> WalletInstance -> IO [(TxId, ValueTransfer)] -getCustomerDeposits customer w = - Map.toList <$> Wallet.getCustomerDeposits w customer Nothing -``` - -## 0. Start a Wallet - -A `WalletInstance` denotes a mutable wallet that is actively synchronizing to the blockchain, continuously writes its state to a database file, and responds to queries. - -In order to create a fresh wallet, or in order to restore a wallet from its public key all the way from genesis, use the function `withWalletInit`. In addition to the public key, this function expects a number which equals the numerically largest customer ID previously handled with this wallet. - -```haskell -scenarioRestore - :: XPub -> WalletEnv IO -> IO () -scenarioRestore xpub env = do - let knownCustomerCount = 127 - Wallet.withWalletInit nullTracer env (XPubCredentials xpub) knownCustomerCount $ \w -> do - value <- Wallet.availableBalance w - assert $ value == ada 0 -``` - -In order to load the wallet state from a database file and resume operation from that state use the function `withWalletLoad`. - -```haskell -scenarioStart - :: WalletEnv IO -> IO () -scenarioStart env = - Wallet.withWalletLoad nullTracer env $ \w -> do - value <- Wallet.availableBalance w - assert $ value == ada 0 -``` - -## 1. Assign an address to a customer ID - -A `Customer` is represented by a numeric customer ID. -Given such a customer ID, the function `customerAddress` will create an address and add the association between the customer and this address to the wallet state. - -(The mapping from customer ID to address is deterministic and based on the [BIP-32][] address derivation scheme.) - - [bip-32]: https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki - - -The function `listCustomers` returns the associations between customers and addresses recorded in the current wallet state. - -```haskell -scenarioCreateAddressList - :: WalletInstance -> IO () -scenarioCreateAddressList w = do - let customer = 31 - Just address <- Wallet.customerAddress customer w - customers <- Wallet.listCustomers w - assert $ (customer, address) `elem` customers -``` - -## 2. Track deposits at this address - -As soon as an association between customer and address has been added to the wallet state using `customerAddress`, the wallet will track deposits sent to this address. - -The function `getCustomerDeposits` returns a summary for each transaction that is related to this customer. For every summary, the `received` field records the total deposit made by the customer at this address in this transaction. - -(The `spent` field has informative purpose only, and records whether the wallet has moved any funds out of this address.) - -The following scenario illustrates how `getCustomerDeposits` records deposits: - -```haskell -scenarioTrackDepositOne - :: ScenarioEnv -> WalletInstance -> IO () -scenarioTrackDepositOne env w = do - Just address <- Wallet.customerAddress customer w - - -- no deposits - txsummaries0 <- getCustomerDeposits customer w - assert $ null txsummaries0 - - -- first deposit - depositFundsAt env address coin - txsummaries1 <- getCustomerDeposits customer w - assert $ map (received . snd) txsummaries1 == [coin] - - -- second deposit - depositFundsAt env address coin - txsummaries2 <- getCustomerDeposits customer w - assert $ map (received . snd) txsummaries2 == [coin, coin] - where - customer = 7 :: Customer - coin = ada 12 -``` - -## 3. Track deposits at all addresses - -A centralized exchange typically wants to monitor all transactions in a recent time window for activity in order to synchronize customer deposits on the blockchain ledger with the exchange ledger recording customer balances. - -This is a task for the `getCustomerHistories` function — it returns a mapping from customers to `TxSummaries` that record the entire activity within the given time interval. - -The time interval is specified by a `from` and a `to` point on the blockchain. We note that the `from` argument is exclusive while the `to` argument is inclusive. -We use the type `ChainPoint` to specify points on the blockchain — this type uses both a slot number and a block header to uniquely identify a block. We do this in order to allow atomic operations — in the event that the `to` or `from` point are no longer part of the consensus chain, the `getCustomerHistories` functions throws an exception. - -The wallet is synchronized to a particular point on the blockchain — use `getWalletTip` to query it. - -```haskell -scenarioTrackDepositAll - :: ScenarioEnv -> WalletInstance -> IO () -scenarioTrackDepositAll env w = do - Just address1 <- Wallet.customerAddress customer1 w - Just address2 <- Wallet.customerAddress customer2 w - - depositFundsAt env address1 coin - depositFundsAt env address2 coin - depositFundsAt env address1 (coin <> coin) - - history <- Wallet.getAllDeposits w Nothing - assert $ - Map.map received history - == - Map.fromList - [ (customer1, coin <> coin <> coin) - , (customer2, coin) - ] - where - customer1, customer2 :: Customer - customer1 = 1 - customer2 = 2 - coin = ada 3 -``` - -## 4. Create payments to a different wallet - -The `createPayment` function allows you to move funds from one wallet to other addresses, e.g. in order to process customer withdrawals. If the wallet has sufficient funds, this function creates a transaction body which sends the given values to the given addresses. - -The transaction body needs to be signed. Given a transaction body, the function `getBIP32PathsForOwnedInputs` will provide you with all [BIP-32][] address derivation paths of all inputs that are owned by the wallet, and which therefore require a signature. - -```haskell -scenarioCreatePayment - :: XPrv -> ScenarioEnv -> Address -> WalletInstance -> IO () -scenarioCreatePayment xprv env destination w = do - -- deposit some funds at customer address - Just address1 <- Wallet.customerAddress customer w - depositFundsAt env address1 (coin <> coin) - value1 <- Wallet.availableBalance w - assert $ value1 == (coin <> coin) - - -- createPayment - Right (ResolvedTx txUnsigned _) <- Wallet.createPayment [(destination, coin)] w - paths <- Wallet.getBIP32PathsForOwnedInputs txUnsigned w - let tx = signTx xprv paths txUnsigned - submitTx env tx - - -- funds have been moved out of the wallet - value2 <- Wallet.availableBalance w - assert $ (value2 <> coin) `lessOrEqual` value1 - - -- but the original deposit amount is still recorded - txsummaries <- getCustomerDeposits customer w - assert $ value1 `elem` map (received . snd) txsummaries - where - customer :: Customer - customer = 17 - coin = ada 5 -``` diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs deleted file mode 100644 index ea0e8193178..00000000000 --- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs +++ /dev/null @@ -1,118 +0,0 @@ --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Execute usage scenarios for the deposit wallet. -module Test.Scenario.Wallet.Deposit.Run - ( main - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( XPrv - , XPub - , generate - , toXPub - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( Credentials (..) - ) -import Control.Tracer - ( nullTracer - ) -import Test.Hspec - ( SpecWith - , describe - , it - ) -import Test.Hspec.Extra - ( aroundAll - , hspecMain - ) -import Test.Scenario.Blockchain - ( ScenarioEnv - , ada - , assert - , payFromFaucet - , withScenarioEnvMock - , withWalletEnvMock - ) - -import qualified Cardano.Wallet.Deposit.IO as Wallet -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Short as SBS -import qualified Test.Scenario.Wallet.Deposit.Exchanges as Exchanges - -main :: IO () -main = - hspecMain - $ aroundAll withScenarioEnvMock scenarios - -scenarios :: SpecWith ScenarioEnv -scenarios = do - describe "Scenarios for centralized exchanges" $ do - it "0. Restore a wallet" $ \env -> - withWalletEnvMock env - $ Exchanges.scenarioRestore xpub - - it "0. Start a wallet" $ \env -> - withWalletEnvMock env $ \w -> do - Exchanges.scenarioRestore xpub w - Exchanges.scenarioStart w - - it "1. Assign an address to a customer ID" $ \env -> do - withWalletEnvMock env $ \walletEnv -> - Wallet.withWalletInit - nullTracer - walletEnv - (XPubCredentials $ freshXPub 1) - 32 - Exchanges.scenarioCreateAddressList - - it "4. Create payments to a different wallet" $ \env -> do - withWalletEnvMock env $ \walletEnv -> - Wallet.withWalletInit nullTracer - walletEnv (XPubCredentials xpub) 32 - $ Exchanges.scenarioCreatePayment xprv env mockAddress - - describe "Temporary tests" $ do - it "Wallet receives funds that are sent to customer address" $ \env -> do - withWalletEnvMock env $ \walletEnv -> - Wallet.withWalletInit - nullTracer - walletEnv - (XPubCredentials $ freshXPub 0) - 8 - $ testBalance env - -xpub :: XPub -xpub = toXPub xprv - -xprv :: XPrv -xprv = generate (B8.pack "random seed for a testing xpub lala") B8.empty - -freshXPub :: Integer -> XPub -freshXPub i = - toXPub - $ generate - (B8.pack $ "random seed for a testing xpub lala" <> show i) - B8.empty - -mockAddress :: Read.Address -mockAddress = - Read.mkEnterpriseAddress - Read.MainnetTag - (SBS.pack $ replicate 32 0) - -testBalance - :: ScenarioEnv -> Wallet.WalletInstance -> IO () -testBalance env w = do - Just address <- Wallet.customerAddress customer w - payFromFaucet env [(address, coin)] - value <- Wallet.availableBalance w - assert $ coin == value - where - customer = 7 - coin = ada 12 diff --git a/lib/deposit-wallet/test/scenario/test-suite-scenario.hs b/lib/deposit-wallet/test/scenario/test-suite-scenario.hs deleted file mode 100644 index 9c2e55cbedf..00000000000 --- a/lib/deposit-wallet/test/scenario/test-suite-scenario.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import Prelude - -import qualified Test.Scenario.Wallet.Deposit.Run - ( main - ) - -main :: IO () -main = Test.Scenario.Wallet.Deposit.Run.main diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs deleted file mode 100644 index 56371cb0951..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec - ( spec - ) where - -import Prelude - -import Cardano.Wallet.Deposit.HTTP.Types.JSON - ( Address - , ApiT (..) - , ChainPoint (..) - , Customer - , CustomerList - ) -import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI - ( addressSchema - , chainPointSchema - , customerListSchema - , customerSchema - , depositDefinitions - ) -import Cardano.Wallet.Deposit.Pure - ( Word31 - , fromRawCustomer - ) -import Cardano.Wallet.Deposit.Read - ( NetworkTag (MainnetTag, TestnetTag) - , mkEnterpriseAddress - ) -import Data.Aeson - ( FromJSON (..) - , ToJSON (..) - , Value - , decode - , encode - ) -import Data.Aeson.Encode.Pretty - ( encodePretty - ) -import Data.OpenApi - ( Definitions - , Schema - , validateJSON - ) -import Data.Word - ( Word64 - ) -import Test.Hspec - ( Expectation - , Spec - , describe - , it - , shouldBe - ) -import Test.QuickCheck - ( Arbitrary (..) - , Gen - , Property - , Testable - , arbitrarySizedBoundedIntegral - , chooseInt - , counterexample - , elements - , forAll - , frequency - , property - , shrinkIntegral - , vectorOf - , (===) - ) - -import qualified Cardano.Wallet.Read as Read -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Short as SBS -import qualified Data.List as L - -spec :: Spec -spec = do - describe "JSON serialization & deserialization" $ do - it "ApiT Address" $ property $ - prop_jsonRoundtrip @(ApiT Address) - it "ApiT Customer" $ property $ - prop_jsonRoundtrip @(ApiT Customer) - it "ApiT CustomerList" $ property $ - prop_jsonRoundtrip @(ApiT CustomerList) - it "ApiT ChainPoint" $ property $ - prop_jsonRoundtrip @(ApiT ChainPoint) - describe "schema checks" $ do - it "ApiT Address" - $ jsonMatchesSchema genApiTAddress depositDefinitions addressSchema - it "ApiT Customer" - $ jsonMatchesSchema genApiTCustomer depositDefinitions customerSchema - it "ApiT CustomerList" - $ jsonMatchesSchema genApiTCustomerList depositDefinitions customerListSchema - it "ApiT ChainPoint" - $ jsonMatchesSchema genApiTChainPoint depositDefinitions chainPointSchema - -jsonMatchesSchema - :: (ToJSON a, Show a) - => Gen a - -> Definitions Schema - -> Schema - -> Property -jsonMatchesSchema gen defs schema = - forAll gen - $ counterExampleJSON "validate" - $ validateInstance defs schema - where - validate :: Definitions Schema -> Schema -> Value -> Expectation - validate defs' sch' x = validateJSON defs' sch' x `shouldBe` [] - - validateInstance :: ToJSON a => Definitions Schema -> Schema -> a -> Expectation - validateInstance defs' sch' = validate defs' sch' . toJSON - - counterExampleJSON - :: (Testable prop, ToJSON a) - => String - -> (a -> prop) - -> a - -> Property - counterExampleJSON t f x = - counterexample - ("Failed to " <> t <> ":\n" <> BL.unpack (encodePretty $ toJSON x)) - $ f x - -prop_jsonRoundtrip :: (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property -prop_jsonRoundtrip val = - decode (encode val) === Just val - -genAddress :: Gen Address -genAddress = do - network <- elements [MainnetTag, TestnetTag] - keyhashCred <- SBS.pack <$> vectorOf 28 arbitrary - pure $ mkEnterpriseAddress network keyhashCred - -genApiTAddress :: Gen (ApiT Address) -genApiTAddress = ApiT <$> genAddress - -genApiTCustomer :: Gen (ApiT Customer) -genApiTCustomer = - ApiT . fromRawCustomer <$> arbitrary - -genApiTCustomerList :: Gen (ApiT CustomerList) -genApiTCustomerList = do - listLen <- chooseInt (0, 100) - let genPair = (,) <$> (unApiT <$> arbitrary) <*> (unApiT <$> arbitrary) - vectors <- vectorOf listLen genPair - let uniqueCustomer = L.nubBy (\a b -> fst a == fst b) - let uniqueAddr = L.nubBy (\a b -> snd a == snd b) - pure $ ApiT $ uniqueAddr $ uniqueCustomer vectors - -genApiTChainPoint :: Gen (ApiT ChainPoint) -genApiTChainPoint = ApiT <$> genChainPoint - -genChainPoint :: Gen Read.ChainPoint -genChainPoint = frequency - [ ( 1, pure Read.GenesisPoint) - , (40, Read.BlockPoint <$> genReadSlotNo <*> genHeaderHash) - ] - where - genReadSlotNo = Read.SlotNo . fromIntegral <$> (arbitrary :: Gen Word64) - genHeaderHash = elements mockHashes - -mockHashes :: [Read.RawHeaderHash] -mockHashes = map Read.mockRawHeaderHash [0..2] - -instance Arbitrary (ApiT Address) where - arbitrary = genApiTAddress - -instance Arbitrary (ApiT Customer) where - arbitrary = genApiTCustomer - -instance Arbitrary (ApiT CustomerList) where - arbitrary = genApiTCustomerList - -instance Arbitrary (ApiT ChainPoint) where - arbitrary = genApiTChainPoint - -instance Arbitrary Word31 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs deleted file mode 100644 index bb9d4c0e73e..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Cardano.Wallet.Deposit.HTTP.OpenAPISpec - ( spec - ) where - -import Prelude - -import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI - ( generateOpenapi3 - ) -import Paths_cardano_deposit_wallet - ( getDataDir - , getDataFileName - ) -import System.Directory - ( doesDirectoryExist - , doesFileExist - ) -import Test.Hspec - ( Spec - , describe - , it - , shouldReturn - ) -import Test.Hspec.Golden - ( Golden (..) - ) - -import qualified Data.ByteString.Lazy.Char8 as BL - -spec :: Spec -spec = do - describe "data dir" $ do - it "should exist" $ do - f <- getDataDir - doesDirectoryExist f `shouldReturn` True - describe "swagger.yaml" $ do - it "should be generated" $ do - f <- getDataFileName "data/swagger.json" - doesFileExist f `shouldReturn` True - it "contains the actual schema" $ do - f <- getDataFileName "data/swagger.json" - let output' = generateOpenapi3 - pure $ swaggerGolden f $ BL.unpack output' - -swaggerGolden :: FilePath -> String -> Golden String -swaggerGolden goldenPath output_ = - Golden - { output = output_ - , encodePretty = show - , writeToFile = writeFile - , readFromFile = readFile - , goldenFile = goldenPath - , actualFile = Nothing - , failFirstTime = False - } diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs deleted file mode 100644 index dac6c96651c..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs +++ /dev/null @@ -1,429 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Wallet.Deposit.Map.TimedSpec where - -import Prelude - -import Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) - , TimedSeq - , dropAfter - , dropBefore - , fromList - , maxKey - , minKey - , takeAfter - , takeUpTo - , toList - ) -import Data.List - ( sort - , unfoldr - ) -import Data.Monoid - ( Last (..) - , Sum (..) - ) -import Data.Time - ( UTCTime (..) - , defaultTimeLocale - , parseTimeOrError - , pattern YearMonthDay - ) -import Test.Hspec - ( Spec - , describe - , it - , shouldBe - , shouldNotBe - ) - -type UTimed = Timed UTCTime (Sum Int) - -type UTimedSeq = TimedSeq UTCTime (Sum Int) - -t :: String -> UTCTime -t = - parseTimeOrError False defaultTimeLocale "%Y-%m-%d %H:%M:%S" - -mkTimed :: String -> Int -> UTimed -mkTimed s i = Timed (Last $ Just $ t s) (Sum i) - -t0 :: UTimed -t0 = mkTimed "2021-01-01 00:00:00" 1 - -t1 :: UTimed -t1 = mkTimed "2021-01-02 00:00:00" 2 - -t2 :: UTimed -t2 = mkTimed "2021-02-01 00:00:00" 3 - -t3 :: UTimed -t3 = mkTimed "2021-02-02 00:00:00" 4 - -t4 :: UTimed -t4 = mkTimed "2022-02-03 00:00:00" 5 - -t5 :: UTimed -t5 = mkTimed "2022-02-03 12:00:00" 6 - -t6 :: UTimed -t6 = mkTimed "2022-03-03 12:00:00" 7 - -t7 :: UTimed -t7 = mkTimed "2022-03-05 12:00:00" 8 - -ts :: [UTimed] -ts = sort [t0, t1, t2, t3, t4, t5, t6, t7] - -result - :: [UTimed] - -> Maybe UTimed - -> (UTimedSeq, Maybe UTCTime) -result included next = (fromList included, nextTime) - where - nextTime = do - Timed x _ <- next - getLast x - -results :: [[UTimed]] -> [UTimedSeq] -results = fmap fromList - -byYear :: UTCTime -> Integer -byYear (UTCTime (YearMonthDay y _ _) _) = y - -byMonth :: UTCTime -> (Integer, Int) -byMonth (UTCTime (YearMonthDay y m _) _) = (y, m) - -byDay :: UTCTime -> (Integer, Int, Int) -byDay (UTCTime (YearMonthDay y m d) _) = (y, m, d) - -scroll - :: (TimedSeq t a -> Maybe t) - -> ( (t -> q) - -> Maybe t - -> Maybe Int - -> TimedSeq t a - -> (TimedSeq t a, Maybe t) - ) - -> (t -> q) - -> Int - -> TimedSeq t a - -> [TimedSeq t a] -scroll boot extract bucket count pager = unfoldr f $ boot pager - where - f Nothing = Nothing - f (Just start) = case extract bucket (Just start) (Just count) pager of - (m, Just next) -> Just (m, Just next) - (m, Nothing) -> Just (m, Nothing) - -spec :: Spec -spec = do - describe "takeAfter" $ do - it "can extract without start" $ do - takeAfter - byDay - Nothing - (Just 1) - (fromList ts) - `shouldBe` result [t0] (Just t1) - it "can extract without count" $ do - takeAfter - byDay - (Just $ t "2021-01-01 00:00:00") - Nothing - (fromList ts) - `shouldBe` result [t0, t1, t2, t3, t4 <> t5, t6, t7] Nothing - it "can extract 1 day" $ do - takeAfter - byDay - (Just $ t "2021-01-01 00:00:00") - (Just 1) - (fromList ts) - `shouldBe` result [t0] (Just t1) - it "can extract 2 days" $ do - takeAfter - byDay - (Just $ t "2021-01-01 00:00:00") - (Just 2) - (fromList ts) - `shouldBe` result [t0, t1] (Just t2) - it "can extract 5 days" $ do - takeAfter - byDay - (Just $ t "2021-01-01 00:00:00") - (Just 5) - (fromList ts) - `shouldBe` result [t0, t1, t2, t3, t4 <> t5] (Just t6) - it "can extract 1 month" $ do - takeAfter - byMonth - (Just $ t "2021-01-01 00:00:00") - (Just 1) - (fromList ts) - `shouldBe` result [t0 <> t1] (Just t2) - - it "can extract 2 months" $ do - takeAfter - byMonth - (Just $ t "2021-01-01 00:00:00") - (Just 2) - (fromList ts) - `shouldBe` result [t0 <> t1, t2 <> t3] (Just t4) - - it "can extract 3 months" $ do - takeAfter - byMonth - (Just $ t "2021-01-01 00:00:00") - (Just 3) - (fromList ts) - `shouldBe` result [t0 <> t1, t2 <> t3, t4 <> t5] (Just t6) - - it "can extract 1 year" $ do - takeAfter - byYear - (Just $ t "2021-01-01 00:00:00") - (Just 1) - (fromList ts) - `shouldBe` result [t0 <> t1 <> t2 <> t3] (Just t4) - - it "can extract 2 years" $ do - takeAfter - byYear - (Just $ t "2021-01-01 00:00:00") - (Just 2) - (fromList ts) - `shouldBe` result [t0 <> t1 <> t2 <> t3, t4 <> t5 <> t6 <> t7] Nothing - - it "can extract 3 years" $ do - takeAfter - byYear - (Just $ t "2021-01-01 00:00:00") - (Just 3) - (fromList ts) - `shouldBe` result [t0 <> t1 <> t2 <> t3, t4 <> t5 <> t6 <> t7] Nothing - - it "can extract 1 day after t0" $ do - takeAfter - byDay - (Just $ t "2021-01-01 00:00:01") - (Just 1) - (fromList ts) - `shouldBe` result [t1] (Just t2) - - it "can extract 1 month after t0" $ do - takeAfter - byMonth - (Just $ t "2021-01-01 00:00:01") - (Just 1) - (fromList ts) - `shouldBe` result [t1] (Just t2) - - it "can extract 1 year after t0" $ do - takeAfter - byYear - (Just $ t "2021-01-01 00:00:01") - (Just 1) - (fromList ts) - `shouldBe` result [t1 <> t2 <> t3] (Just t4) - describe "takeBefore" $ do - it "can extract without start" $ do - takeUpTo - byDay - Nothing - (Just 1) - (fromList ts) - `shouldBe` result [t7] (Just t6) - it "can extract without count" $ do - takeUpTo - byDay - (Just $ t "2022-03-05 12:00:00") - Nothing - (fromList ts) - `shouldBe` result [t7, t6, t4 <> t5, t3, t2, t1, t0] Nothing - it "can extract 1 day" $ do - takeUpTo - byDay - (Just $ t "2022-03-05 12:00:00") - (Just 1) - (fromList ts) - `shouldBe` result [t7] (Just t6) - it "can extract 2 days" $ do - takeUpTo - byDay - (Just $ t "2022-03-05 12:00:00") - (Just 2) - (fromList ts) - `shouldBe` result [t7, t6] (Just t5) - it "can extract 3 days" $ do - takeUpTo - byDay - (Just $ t "2022-03-05 12:00:00") - (Just 3) - (fromList ts) - `shouldBe` result [t7, t6, t4 <> t5] (Just t3) - it "can extract 1 month" $ do - takeUpTo - byMonth - (Just $ t "2022-03-05 12:00:00") - (Just 1) - (fromList ts) - `shouldBe` result [t6 <> t7] (Just t5) - it "can extract 2 months" $ do - takeUpTo - byMonth - (Just $ t "2022-03-05 12:00:00") - (Just 2) - (fromList ts) - `shouldBe` result [t6 <> t7, t4 <> t5] (Just t3) - it "can extract 2 years" $ do - takeUpTo - byYear - (Just $ t "2022-03-05 12:00:00") - (Just 2) - (fromList ts) - `shouldBe` result - [t4 <> t5 <> t6 <> t7, t0 <> t1 <> t2 <> t3] - Nothing - it "can extract 1 day before t7" $ do - takeUpTo - byDay - (Just $ t "2022-03-05 11:59:59") - (Just 1) - (fromList ts) - `shouldBe` result [t6] (Just t5) - it "can extract 1 month before t6" $ do - takeUpTo - byMonth - (Just $ t "2022-03-03 11:59:59") - (Just 1) - (fromList ts) - `shouldBe` result [t4 <> t5] (Just t3) - it "can extract 1 year before t4" $ do - takeUpTo - byYear - (Just $ t "2022-01-02 23:59:59") - (Just 1) - (fromList ts) - `shouldBe` result [t0 <> t1 <> t2 <> t3] Nothing - - describe "TimedSeq scroll" $ do - it "can consume scrolling forward by 1 day" $ do - scroll minKey takeAfter byDay 1 (fromList ts) - `shouldBe` results - [ [t0] - , [t1] - , [t2] - , [t3] - , [t4 <> t5] - , [t6] - , [t7] - ] - it "can consume scrolling backward by 1 day" $ do - scroll maxKey takeUpTo byDay 1 (fromList ts) - `shouldBe` results - [ [t7] - , [t6] - , [t4 <> t5] - , [t3] - , [t2] - , [t1] - , [t0] - ] - it "can consume scrolling forward by 1 month" $ do - scroll minKey takeAfter byMonth 1 (fromList ts) - `shouldBe` results - [ [t0 <> t1] - , [t2 <> t3] - , [t4 <> t5] - , [t6 <> t7] - ] - it "can consume scrolling backward by 1 month" $ do - scroll maxKey takeUpTo byMonth 1 (fromList ts) - `shouldBe` results - [ [t6 <> t7] - , [t4 <> t5] - , [t2 <> t3] - , [t0 <> t1] - ] - it "can consume scrolling forward by 1 year" $ do - scroll minKey takeAfter byYear 1 (fromList ts) - `shouldBe` results - [ [t0 <> t1 <> t2 <> t3] - , [t4 <> t5 <> t6 <> t7] - ] - it "can consume scrolling backward by 1 year" $ do - scroll maxKey takeUpTo byYear 1 (fromList ts) - `shouldBe` results - [ [t4 <> t5 <> t6 <> t7] - , [t0 <> t1 <> t2 <> t3] - ] - - describe "dropAfter function" $ do - it "works on empty" $ do - dropAfter @UTCTime @() (t "2021-01-01 00:00:00") (fromList []) - `shouldBe` fromList [] - it "drop a single" $ do - dropAfter (t "2021-01-01 00:00:00") (fromList [t0]) - `shouldBe` fromList [t0] - it "take one and drop the second, early cut" $ do - dropAfter (t "2021-01-01 00:00:00") (fromList [t0, t1]) - `shouldBe` fromList [t0] - it "take one and drop the second, late cut" $ do - dropAfter (t "2021-01-01 23:59:59") (fromList [t0, t1]) - `shouldBe` fromList [t0] - it "can take all" $ do - dropAfter (t "2021-01-02 00:00:00") (fromList [t0, t1]) - `shouldBe` fromList [t0, t1] - - describe "dropBefore function" $ do - it "works on empty" $ do - dropBefore @UTCTime @() (t "2021-01-01 00:00:00") (fromList []) - `shouldBe` fromList [] - it "drop a single" $ do - dropBefore (t "2021-01-01 00:00:01") (fromList [t0]) - `shouldBe` fromList [] - it "take second and drop the first, early cut" $ do - dropBefore (t "2021-01-01 00:00:01") (fromList [t0, t1]) - `shouldBe` fromList [t1] - it "take the second and drop the first, late cut" $ do - dropBefore (t "2021-01-02 00:00:00") (fromList [t0, t1]) - `shouldBe` fromList [t1] - it "can take all" $ do - dropBefore (t "2021-01-01 00:00:00") (fromList [t0, t1]) - `shouldBe` fromList [t0, t1] - - describe "TimedSeq semigroup" $ do - it "can append two sequences of distinct times" $ do - fromList [t0, t1] <> fromList [t2, t3] - `shouldBe` fromList [t0, t1, t2, t3] - it "can append two sequences of overlapping edges in time" $ do - fromList [t0, t1] <> fromList [t1, t2] - `shouldBe` fromList - [ t0 - , Timed (time t1) (monoid t1 <> monoid t1) - , t2 - ] - it "is used in fromList" $ do - fromList [t0, t1, t1, t2] - `shouldBe` fromList - [ t0 - , Timed (time t1) (monoid t1 <> monoid t1) - , t2 - ] - describe "fromList" $ do - it "is the inverse of toList for different ts" $ do - fromList (toList (fromList ts)) `shouldBe` fromList ts - it "is the inverse of toList for overlapping ts" $ do - let ts' = [t0, t1, t1, t2] - fromList (toList (fromList ts')) - `shouldBe` fromList ts' - - describe "toList" $ do - it "is not the inverse of fromList for overlapping ts" $ do - let ts' = [t0, t1, t1, t2] - toList (fromList ts') `shouldNotBe` ts' diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs deleted file mode 100644 index e4e57fee8b4..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Cardano.Wallet.Deposit.Pure.API.AddressSpec - ( spec - ) -where - -import Prelude - -import Cardano.Wallet.Deposit.Pure.API.Address - ( DecodingError (..) - , decodeAddress - , encodeAddress - ) -import Cardano.Wallet.Read.Address - ( isBootstrapCompactAddr - , toShortByteString - ) -import Control.Monad - ( forM_ - ) -import Data.ByteString.Base58 - ( bitcoinAlphabet - , decodeBase58 - , encodeBase58 - ) -import Data.Either - ( isLeft - , isRight - ) -import Data.Function - ( (&) - ) -import Data.Maybe - ( isJust - ) -import Data.Text - ( Text - ) -import Test.Cardano.Ledger.Core.Arbitrary - () -import Test.Hspec - ( Spec - , describe - , it - , shouldBe - ) -import Test.QuickCheck - ( Arbitrary (..) - , Gen - , checkCoverage - , counterexample - , cover - , elements - , forAll - , label - , oneof - , property - , (===) - ) - -import qualified Codec.Binary.Bech32 as Bech32 -import qualified Codec.Binary.Bech32.TH as Bech32 -import qualified Data.ByteString.Short as SBS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -spec :: Spec -spec = do - describe "address codec" $ do - it "rountrips correctly on random addresses" $ forAll arbitrary $ \x -> - decodeAddress (encodeAddress x) - === Right x - - it "decodeAddress text = Right addr ==> encodeAddress addr == text" - $ checkCoverage $ forAll genArbitrarilyEncodedAddress $ \text -> do - let getErrorLabel e = case e of - InvalidBech32Encoding _e -> "invalid bech32 encoding" - InvalidBase58Encoding -> "invalid base58 encoding" - InvalidHumanReadablePart _hrp -> "invalid hrp" - InvalidDataPart _ -> "invalid data part" - AddressFlavorMismatch -> "flavor mismatch" - AddressDecodingError _ -> "decoding error" - AddressNetworkMismatch -> "network mismatch" - - let res = decodeAddress text - case res of - Right addr -> label "success" $ encodeAddress addr === text - Left e -> label (getErrorLabel e) $ property True - & cover 0.2 (isLeft res) "failure" - & cover 0.2 (isRight res) "success" - - it "isBootstrapAddr decides whether bech32 or base58 encoding is used" - $ forAll arbitrary $ \addr -> - let - isBase58 = isJust . decodeBase58 bitcoinAlphabet . T.encodeUtf8 - isBech32 = isRight . Bech32.decodeLenient - - encodedAddr = encodeAddress addr - in - if isBootstrapCompactAddr addr - then property $ isBase58 encodedAddr - else property $ isBech32 encodedAddr - & counterexample (T.unpack encodedAddr) - - it "roundtrips correctly on some addresses from online examples" - $ do - let testCases = - [ "addr1z92l7rnra7sxjn5qv5fzc4fwsrrm29mgkleqj9a0y46j5lyjz4gwd3njhyqwntdkcm8rrgapudajydteywgtuvl6etjs9nqzg5" - , "addr_test1wppg9l6relcpls4u667twqyggkrpfrs5cdge9hhl9cv2upchtch0h" - , "37btjrVyb4KDXBNC4haBVPCrro8AQPHwvCMp3RFhhSVWwfFmZ6wwzSK6JK1hY6wHNmtrpTf1kdbva8TCneM2YsiXT7mrzT21EacHnPpz5YyUdj64na" - ] - forM_ testCases $ \addr -> - encodeAddress <$> decodeAddress addr - `shouldBe` Right addr - - it "fails to decode addresses where the network tag doesn't match the bech32 hrp" $ do - let secretlyMainnetAddr = "addr_test1z92l7rnra7sxjn5qv5fzc4fwsrrm29mgkleqj9a0y46j5lyjz4gwd3njhyqwntdkcm8rrgapudajydteywgtuvl6etjshn59kk" - decodeAddress secretlyMainnetAddr - `shouldBe` Left AddressNetworkMismatch - --- | Generate 'Text' heavily biased towards values of incorrectly encoded --- addresses -genArbitrarilyEncodedAddress :: Gen Text -genArbitrarilyEncodedAddress = oneof - [ encodeAddrBech32 <$> genAddrHrp <*> arbitrary - , encodeAddrBase58 <$> arbitrary - ] - where - encodeAddrBech32 hrp addr = Bech32.encodeLenient hrp dataPart - where - bytes = SBS.fromShort $ toShortByteString addr - dataPart = Bech32.dataPartFromBytes bytes - - genAddrHrp = elements - [ [Bech32.humanReadablePart|addr|] - , [Bech32.humanReadablePart|addr_test|] - , [Bech32.humanReadablePart|notaddr|] - ] - - encodeAddrBase58 = T.decodeUtf8 - . encodeBase58 bitcoinAlphabet - . SBS.fromShort - . toShortByteString diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs deleted file mode 100644 index 66a08b50583..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Cardano.Wallet.Deposit.Pure.API.TransactionSpec - ( spec - ) -where - -import Prelude - -import Cardano.Ledger.Api - ( ppMaxTxSizeL - , ppMaxValSizeL - ) -import Cardano.Ledger.BaseTypes - ( EpochSize (..) - ) -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger -import qualified Cardano.Ledger.Shelley.LedgerState as Ledger -import qualified Cardano.Ledger.Shelley.Rules as Ledger -import qualified Cardano.Slotting.EpochInfo as Slotting -import Cardano.Slotting.Time - ( SlotLength - , SystemStart (..) - , mkSlotLength - ) -import qualified Cardano.Wallet.Deposit.Pure.Address as Address -import Cardano.Wallet.Deposit.Pure.API.Address - ( encodeAddress - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( accountXPubFromCredentials - , createMnemonicFromWords - , credentialsFromMnemonics - ) -import Cardano.Wallet.Deposit.PureSpec - ( testOnWallet - ) -import Cardano.Wallet.Deposit.Read - ( Address - , Conway - , NetworkTag (..) - , UTxO - , mkEnterpriseAddress - ) -import Cardano.Wallet.Deposit.Testing.DSL - ( assert - , balance - , block - , deposit - , existsTx - , rollForward - , sign - , spend - , utxo - , wallet - ) -import Cardano.Wallet.Deposit.Write - ( Tx - ) -import qualified Cardano.Wallet.Deposit.Write as Write -import Cardano.Wallet.Read - ( NetworkId (..) - ) -import qualified Cardano.Wallet.Read as Read -import Control.Lens - ( (&) - , (.~) - ) -import qualified Data.ByteString.Short as SBS -import Data.Default - ( Default (..) - ) -import Data.Maybe - ( fromMaybe - ) -import Data.Text - ( Text - ) -import qualified Data.Text.Lazy as TL -import Data.Time.Clock.POSIX - ( posixSecondsToUTCTime - ) -import Test.Cardano.Ledger.Core.Arbitrary - () -import Test.Hspec - ( Spec - , describe - , it - , shouldBe - ) -import Text.Pretty.Simple - ( pShow - ) - -address :: Address -address = mockAddress - -mockAddress :: Address -mockAddress = - mkEnterpriseAddress - MainnetTag - (SBS.toShort "12345678901234567890123456789012") - -defaultPParams :: Ledger.PParams Conway -defaultPParams = - def - & ppMaxTxSizeL .~ 16_384 - & ppMaxValSizeL .~ 1_000_000_000 - --- | Create a new ledger env from given protocol parameters. -newLedgerEnv :: Ledger.PParams Conway -> Ledger.LedgerEnv Conway -newLedgerEnv protocolParams = - Ledger.LedgerEnv - { Ledger.ledgerSlotNo = 0 - , -- NOTE: This can probably stay at 0 forever. This is used internally by the - -- node's mempool to keep track of transaction seen from peers. Transactions - -- in Hydra do not go through the node's mempool and follow a different - -- consensus path so this will remain unused. - Ledger.ledgerIx = minBound - , -- NOTE: This keeps track of the ledger's treasury and reserve which are - -- both unused in Hydra. There might be room for interesting features in the - -- future with these two but for now, we'll consider them empty. - Ledger.ledgerAccount = Ledger.AccountState mempty mempty - , Ledger.ledgerPp = protocolParams - , Ledger.ledgerMempool = False - } - -defaultLedgerEnv :: Ledger.LedgerEnv Conway -defaultLedgerEnv = newLedgerEnv defaultPParams - -defaultGlobals :: Ledger.Globals -defaultGlobals = - Ledger.Globals - { Ledger.epochInfo = Slotting.fixedEpochInfo epochSize slotLength - , Ledger.slotsPerKESPeriod = 20 - , Ledger.stabilityWindow = 33 - , Ledger.randomnessStabilisationWindow = 33 - , Ledger.securityParameter = 10 - , Ledger.maxKESEvo = 10 - , Ledger.quorum = 5 - , Ledger.maxLovelaceSupply = 45 * 1000 * 1000 * 1000 * 1000 * 1000 - , Ledger.activeSlotCoeff = - Ledger.mkActiveSlotCoeff . unsafeBoundRational $ 0.9 - , Ledger.networkId = Ledger.Mainnet - , Ledger.systemStart = SystemStart $ posixSecondsToUTCTime 0 - } - where - unsafeBoundRational r = - fromMaybe (error $ "Could not convert from Rational: " <> show r) - $ Ledger.boundRational r - -epochSize :: EpochSize -epochSize = EpochSize 100 - -slotLength :: SlotLength -slotLength = mkSlotLength 1 - -applyTx - :: UTxO - -> Write.Tx - -> Either - (Ledger.ApplyTxError Conway) - () -applyTx utxos (Read.Tx tx) = - case Ledger.applyTx defaultGlobals defaultLedgerEnv memPoolState tx of - Left err -> Left err - Right _ -> Right () - where - memPoolState = - Ledger.LedgerState - { Ledger.lsUTxOState = - def{Ledger.utxosUtxo = Write.toConwayUTxO utxos} - , Ledger.lsCertState = def - } -newtype Ledger = Ledger - { validate :: Tx -> Either (Ledger.ApplyTxError Conway) () - } - -ledgerFrom :: UTxO -> Ledger -ledgerFrom = Ledger . applyTx - -accepts :: Ledger -> Tx -> IO () -accepts l t = case validate l t of - Left err -> - error - $ TL.unpack - $ "Transaction was not accepted by the ledger: \n" - <> pShow defaultPParams - <> "\n" - <> pShow t - <> "\n" - <> pShow err - Right _ -> pure () - -mnemonics :: Text -mnemonics = "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" - -spec :: Spec -spec = do - describe "balanced transaction" $ do - it "has correct witness for one tx-in" - $ testOnWallet - $ do - wallet 17 mnemonics "passphrase" - tx1 <- existsTx - u1 <- deposit tx1 1 100 - b1 <- block [tx1] - rollForward [b1] - spending <- existsTx - spend spending address 10 - balanced <- balance spending - utxos <- utxo u1 - signedTx <- sign balanced "passphrase" - assert $ ledgerFrom utxos `accepts` signedTx - - -- cat root1.prv - -- | cardano-address key child 1857H/1815H/0H/0/0 \ - -- | cardano-address key public --with-chain-code \ - -- | cardano-address address payment --network-tag mainnet - describe "generated address match golden cases" $ do - it "with empty passphrase in mainnet" $ do - let - Right seed = createMnemonicFromWords mnemonics - address0 = "addr1v8th5554xvd2us9hwh72p3yt9rg7uw9v7tk49t3yw3wrcgc3drxft" - creds = credentialsFromMnemonics seed mempty - xpub = accountXPubFromCredentials creds - addr = - encodeAddress - $ snd - $ head - $ Address.listCustomers - $ Address.fromXPubAndCount Mainnet xpub 1 - - addr `shouldBe` address0 diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs deleted file mode 100644 index efb3844c038..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NumericUnderscores #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Property tests for the deposit wallet. -module Cardano.Wallet.Deposit.PureSpec - ( spec - , testOnWallet - ) where - -import Prelude - -import Cardano.Mnemonic - ( SomeMnemonic - ) -import Cardano.Wallet.Deposit.Pure - ( Credentials - ) -import Cardano.Wallet.Deposit.Pure.API.TxHistory - ( LookupTimeFromSlot - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( createMnemonicFromWords - , credentialsFromMnemonics - ) -import Cardano.Wallet.Deposit.Testing.DSL - ( InterpreterState (..) - , ScenarioP - , assert - , availableBalance - , block - , deposit - , deposit_ - , existsTx - , historyByCustomer - , historyByTime - , interpret - , newHistoryByTime - , rollBackward - , rollForward - , withdrawal - ) -import Cardano.Wallet.Deposit.Testing.DSL.ByTime - ( atBlock - , byCustomerFromByTime - , deposited - , forCustomer - , inTx - , newByTime - , withdrawn - ) -import Cardano.Wallet.Deposit.Time - ( unsafeUTCTimeOfSlot - ) -import Control.Monad.Trans.State - ( StateT - ) -import Data.Maybe - ( fromJust - ) -import Data.Time - ( UTCTime - ) -import Test.Hspec - ( Spec - , describe - , it - , shouldBe - ) -import Test.QuickCheck - ( Property - , (.&&.) - , (=/=) - , (===) - ) - -import qualified Cardano.Wallet.Deposit.Pure as Wallet -import qualified Cardano.Wallet.Deposit.Pure.UTxO as UTxO -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Cardano.Wallet.Deposit.Write as Write -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - -timeFromSlot :: LookupTimeFromSlot -timeFromSlot = unsafeUTCTimeOfSlot - -unsafeTimeForSlot :: Read.Slot -> Read.WithOrigin UTCTime -unsafeTimeForSlot = fromJust . timeFromSlot - -testOnWallet - :: ScenarioP - (IO ()) - (StateT (Wallet.WalletState, InterpreterState) IO) - () - -> IO () -testOnWallet = - interpret - emptyWalletWith17Addresses - id - unsafeTimeForSlot - -spec :: Spec -spec = do - describe "UTxO availableBalance" $ do - it - "rollForward twice" - prop_availableBalance_rollForward_twice - it - "rollBackward . rollForward" - prop_availableBalance_rollForward_rollBackward - describe "history by time" $ do - it "is empty after initialization" - $ testOnWallet - $ do - ht0 <- historyByTime - assert $ ht0 `shouldBe` mempty - hc0 <- historyByCustomer - assert $ hc0 `shouldBe` mempty - it "reports a tx after a rollforward" - $ testOnWallet - $ do - tx1 <- existsTx - deposit_ tx1 1 100 - b1 <- block [tx1] - rollForward [b1] - h1 <- historyByTime - h1' <- newHistoryByTime $ newByTime $ do - atBlock b1 $ do - forCustomer 1 $ do - inTx tx1 $ deposited 100 - assert $ h1 `shouldBe` h1' - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` byCustomerFromByTime h1' - balance <- availableBalance - assert $ balance `shouldBe` 100_000_000 - it "reports multiple blocks after a rollforward" - $ testOnWallet - $ do - tx1 <- existsTx - deposit_ tx1 1 100 - b1 <- block [tx1] - tx2 <- existsTx - deposit_ tx2 1 200 - b2 <- block [tx2] - rollForward [b1, b2] - h1 <- historyByTime - h1' <- newHistoryByTime $ newByTime $ do - atBlock b1 $ do - forCustomer 1 $ do - inTx tx1 $ deposited 100 - atBlock b2 $ do - forCustomer 1 $ do - inTx tx2 $ deposited 200 - assert $ h1 `shouldBe` h1' - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` byCustomerFromByTime h1' - balance <- availableBalance - assert $ balance `shouldBe` 300_000_000 - it "reports withdrawals in separate blocks from deposits" - $ testOnWallet - $ do - tx1 <- existsTx - w1 <- deposit tx1 1 100 - b1 <- block [tx1] - tx2 <- existsTx - withdrawal tx2 w1 - b2 <- block [tx2] - rollForward [b1, b2] - h1 <- historyByTime - h1' <- newHistoryByTime $ newByTime $ do - atBlock b1 $ do - forCustomer 1 $ do - inTx tx1 $ deposited 100 - atBlock b2 $ do - forCustomer 1 $ do - inTx tx2 $ withdrawn 100 - assert $ h1 `shouldBe` h1' - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` byCustomerFromByTime h1' - balance <- availableBalance - assert $ balance `shouldBe` 0 - it "reports withdrawals in the same block as deposits" - $ testOnWallet - $ do - tx1 <- existsTx - w1 <- deposit tx1 1 100 - tx2 <- existsTx - withdrawal tx2 w1 - b1 <- block [tx1, tx2] - rollForward [b1] - h1 <- historyByTime - h1' <- newHistoryByTime $ newByTime $ do - atBlock b1 $ do - forCustomer 1 $ do - inTx tx1 $ deposited 100 - inTx tx2 $ withdrawn 100 - assert $ h1 `shouldBe` h1' - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` byCustomerFromByTime h1' - balance <- availableBalance - assert $ balance `shouldBe` 0 - - it "is empty after a full rollback" - $ testOnWallet - $ do - tx1 <- existsTx - deposit_ tx1 1 100 - b1 <- block [tx1] - rollForward [b1] - rollBackward Nothing - h1 <- historyByTime - assert $ h1 `shouldBe` mempty - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` mempty - balance <- availableBalance - assert $ balance `shouldBe` 0 - it "contains the blocks not rolled back after a partial rollback" - $ testOnWallet - $ do - tx1 <- existsTx - deposit_ tx1 1 100 - b1 <- block [tx1] - tx2 <- existsTx - deposit_ tx2 1 200 - b2 <- block [tx2] - rollForward [b1, b2] - rollBackward $ Just b1 - h1 <- historyByTime - h1' <- newHistoryByTime $ newByTime $ do - atBlock b1 $ do - forCustomer 1 $ do - inTx tx1 $ deposited 100 - assert $ h1 `shouldBe` h1' - hc1 <- historyByCustomer - assert $ hc1 `shouldBe` byCustomerFromByTime h1' - balance <- availableBalance - assert $ balance `shouldBe` 100_000_000 - -{----------------------------------------------------------------------------- - Properties -------------------------------------------------------------------------------} -prop_availableBalance_rollForward_twice :: Property -prop_availableBalance_rollForward_twice = - Wallet.availableBalance w2 === Write.mkAda 3 - where - w0 = emptyWalletWith17Addresses - Just addr1 = Wallet.customerAddress 1 w0 - Just addr2 = Wallet.customerAddress 2 w0 - - tx1 = payFromFaucet [(addr1, Write.mkAda 1)] - block1 = Read.mockNextBlock Read.GenesisPoint [tx1] - chainPoint1 = Read.getChainPoint block1 - w1 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block1) w0 - - tx2 = payFromFaucet [(addr2, Write.mkAda 2)] - block2 = Read.mockNextBlock chainPoint1 [tx2] - w2 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block2) w1 - -prop_availableBalance_rollForward_rollBackward :: Property -prop_availableBalance_rollForward_rollBackward = - Wallet.availableBalance - (fst $ Wallet.rollBackward timeFromSlot chainPoint0 w3) - === Wallet.availableBalance w0 - .&&. Wallet.availableBalance - (fst $ Wallet.rollBackward timeFromSlot chainPoint1 w3) - === Wallet.availableBalance w1 - .&&. Wallet.availableBalance - (fst $ Wallet.rollBackward timeFromSlot chainPoint2 w3) - === Wallet.availableBalance w2 - .&&. Wallet.availableBalance w3 - =/= Wallet.availableBalance w2 - .&&. Wallet.availableBalance w3 - `Read.lessOrEqual` Wallet.availableBalance w2 - where - w0 = emptyWalletWith17Addresses - Just addr1 = Wallet.customerAddress 1 w0 - Just addr2 = Wallet.customerAddress 2 w0 - chainPoint0 = Read.GenesisPoint - - tx1 = payFromFaucet [(addr1, Write.mkAda 1)] - block1 = Read.mockNextBlock chainPoint0 [tx1] - w1 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block1) w0 - chainPoint1 = Read.getChainPoint block1 - - tx2 = payFromFaucet [(addr2, Write.mkAda 2)] - block2 = Read.mockNextBlock chainPoint1 [tx2] - chainPoint2 = Read.getChainPoint block2 - w2 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block2) w1 - - tx3 = spendOneTxOut (Wallet.availableUTxO w2) - block3 = Read.mockNextBlock chainPoint2 [tx3] - w3 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block3) w2 - -emptyWalletWith17Addresses :: Wallet.WalletState -emptyWalletWith17Addresses = - Wallet.fromCredentialsAndGenesis testCredentials 17 testGenesis - -seed :: SomeMnemonic -seed = case createMnemonicFromWords - "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" - of - Right seed' -> seed' - Left e -> error $ show e - -testCredentials :: Credentials -testCredentials = - credentialsFromMnemonics seed mempty - -{----------------------------------------------------------------------------- - Test blockchain -------------------------------------------------------------------------------} - -testGenesis :: Read.GenesisData -testGenesis = Read.mockGenesisDataMainnet - -spendOneTxOut :: UTxO.UTxO -> Write.Tx -spendOneTxOut utxo = - Write.mkTx txBody - where - txBody = - Write.TxBody - { Write.spendInputs = Set.singleton . fst . head $ Map.toList utxo - , Write.collInputs = mempty - , Write.txouts = Map.empty - , Write.collRet = Nothing - , Write.expirySlot = Nothing - } - -payFromFaucet :: [(Write.Address, Write.Value)] -> Write.Tx -payFromFaucet destinations = - Write.mkTx txBody - where - toTxOut (addr, value) = Write.mkTxOut addr value - txBody = - Write.TxBody - { Write.spendInputs = mempty - , Write.collInputs = mempty - , Write.txouts = - Map.fromList $ zip [toEnum 0 ..] $ map toTxOut destinations - , Write.collRet = Nothing - , Write.expirySlot = Nothing - } diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs deleted file mode 100644 index 76d394b15d3..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Cardano.Wallet.Deposit.RESTSpec - ( spec - ) -where - -import Prelude - -import Cardano.Crypto.Wallet - ( sign - , verify - , xPrvChangePass - ) -import Cardano.Mnemonic - ( SomeMnemonic - ) -import Cardano.Wallet.Deposit.IO - ( WalletBootEnv (WalletBootEnv) - ) -import Cardano.Wallet.Deposit.IO.Resource - ( ErrResourceMissing (..) - , withResource - ) -import Cardano.Wallet.Deposit.Pure.State.Creation - ( Credentials - , accountXPubFromCredentials - , createMnemonicFromWords - , credentialsFromMnemonics - , deriveAccountXPrv - , rootXPrvFromCredentials - ) -import Cardano.Wallet.Deposit.REST - ( ErrCreatingDatabase (..) - , ErrDatabase (..) - , ErrLoadingDatabase (..) - , ErrWalletResource (..) - , WalletResourceM - , availableBalance - , initWallet - , loadWallet - , runWalletResourceM - , walletExists - ) -import Codec.Serialise - ( deserialise - , serialise - ) -import Control.Concurrent - ( threadDelay - ) -import Control.Monad.IO.Class - ( MonadIO (..) - ) -import Control.Monad.Trans.Cont - ( cont - , evalCont - ) -import Control.Tracer - ( nullTracer - ) -import Data.ByteString - ( ByteString - ) -import Data.Maybe - ( fromJust - ) -import Data.Text - ( Text - ) -import System.IO.Temp - ( withSystemTempDirectory - ) -import Test.Hspec - ( Spec - , describe - , it - , shouldBe - ) -import Test.QuickCheck - ( Gen - , arbitrary - , elements - , forAll - , listOf - , (===) - ) - -import qualified Cardano.Wallet.Deposit.Read as Read -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -fakeBootEnv :: WalletBootEnv IO -fakeBootEnv = WalletBootEnv nullTracer Read.mockGenesisDataMainnet undefined - -seed :: SomeMnemonic -Right seed = - createMnemonicFromWords - "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" - -credentials :: Credentials -credentials = credentialsFromMnemonics seed mempty - -letItInitialize :: WalletResourceM () -letItInitialize = liftIO $ threadDelay 100000 - -onSuccess :: (Show e, MonadFail m) => Either e a -> (a -> m b) -> m b -onSuccess (Left e) _ = fail $ show e -onSuccess (Right a) f = f a - -matchEmptyValue :: Show e => Either e Read.Value -> IO () -matchEmptyValue x = onSuccess x $ \v -> v `shouldBe` mempty - -withWallet :: WalletResourceM a -> IO (Either ErrWalletResource a) -withWallet f = withResource $ runWalletResourceM f - -withInitializedWallet - :: FilePath - -> WalletResourceM a - -> IO (Either ErrWalletResource a) -withInitializedWallet dir f = withWallet $ do - initWallet nullTracer nullTracer fakeBootEnv dir credentials 0 - letItInitialize - f - -withLoadedWallet - :: FilePath - -> WalletResourceM a - -> IO (Either ErrWalletResource a) -withLoadedWallet dir f = withWallet $ do - loadWallet nullTracer fakeBootEnv dir - letItInitialize - f - -doNothing :: WalletResourceM () -doNothing = pure () - -inADirectory :: (FilePath -> IO a) -> IO a -inADirectory = withSystemTempDirectory "deposit-rest" - -byteStringGen :: Gen ByteString -byteStringGen = B8.pack <$> listOf arbitrary - -textGen :: Gen Text -textGen = T.pack <$> listOf arbitrary - -words15 :: [Text] -words15 = - [ "soap retire song hat major steak stuff daughter half scorpion please brisk decade hill song" - , "sure cannon broom caution artist legend boring reveal scene rubber weapon chest page clog fine" - , "fruit garden saddle upper huge educate fabric ocean bamboo verb iron apple have deposit trap" - ] - -credentialsGen :: Gen (Credentials, Text) -credentialsGen = do - mnemonics' <- elements words15 - case createMnemonicFromWords mnemonics' of - Left e -> error $ "Invalid mnemonics: " <> show e - Right seed' -> do - passphrase' <- textGen - pure (credentialsFromMnemonics seed' passphrase', passphrase') - -spec :: Spec -spec = do - describe "XPub" $ do - it "can be serialised and deserialised" $ do - forAll credentialsGen $ \(credentials', _) -> - deserialise (serialise $ accountXPubFromCredentials credentials') - === accountXPubFromCredentials credentials' - describe "XPrv" $ do - it "can be serialised and deserialised" $ do - forAll credentialsGen $ \(credentials', _) -> - deserialise (serialise $ rootXPrvFromCredentials credentials') - === rootXPrvFromCredentials credentials' - describe "Credentials" $ do - it "can be serialised and deserialised" $ do - forAll credentialsGen $ \(credentials', _) -> - deserialise (serialise credentials') === credentials' - describe "Credentials with mnemonics" $ do - it "can sign and verify a message" $ evalCont $ do - (credentials', passphrase') <- cont $ forAll credentialsGen - message <- cont $ forAll byteStringGen - let - decryptXPrv = - xPrvChangePass (T.encodeUtf8 passphrase') B8.empty - xprv = - deriveAccountXPrv - $ decryptXPrv - $ fromJust - $ rootXPrvFromCredentials credentials' - sig = sign B8.empty xprv message - pure - $ verify (accountXPubFromCredentials credentials') message sig - === True - - describe "REST Deposit interface" $ do - it "can initialize a wallet" - $ inADirectory - $ \dir -> do - val <- withInitializedWallet dir availableBalance - matchEmptyValue val - it "can load an existing wallet" - $ inADirectory - $ \dir -> do - val <- withInitializedWallet dir availableBalance - onSuccess val $ \_ -> do - val' <- withLoadedWallet dir availableBalance - matchEmptyValue val' - it "cannot re-initialize a wallet" - $ inADirectory - $ \dir -> do - val <- withInitializedWallet dir doNothing - onSuccess val $ \_ -> do - val' <- withInitializedWallet dir availableBalance - case val' of - Left - ( ErrNoWallet - ( ErrFailedToInitialize - ( ErrCreatingDatabase - (ErrDatabaseAlreadyExists fp) - ) - ) - ) - | dir == fp -> pure () - Left e -> fail $ show e - Right _ -> fail "Should have failed the query on re-init" - it "cannot load a non-existing wallet" - $ inADirectory - $ \dir -> do - val <- withLoadedWallet dir availableBalance - case val of - Left - ( ErrNoWallet - ( ErrFailedToInitialize - ( ErrLoadingDatabase - (ErrDatabaseNotFound fp) - ) - ) - ) - | dir == fp -> pure () - Left e -> fail $ show e - Right _ -> fail "Should have failed the query on load" - it "can check if a wallet is present on disk" - $ inADirectory - $ \dir -> do - r <- withInitializedWallet dir doNothing - onSuccess r $ \_ -> do - presence <- walletExists dir - presence `shouldBe` True diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs deleted file mode 100644 index 872cbe6c9ed..00000000000 --- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Copyright: © 2024 Cardano Foundation --- License: Apache-2.0 --- --- Property tests for the deposit wallet. -module Cardano.Wallet.Deposit.Write.KeysSpec - ( spec - ) where - -import Prelude - -import Cardano.Crypto.Wallet - ( generate - ) -import Cardano.Wallet.Address.BIP32_Ed25519 - ( XPrv - , XPub - , sign - , toXPub - ) -import "customer-deposit-wallet-pure" Cardano.Wallet.Address.Encoding - ( EnterpriseAddr (..) - , NetworkTag (..) - , compactAddrFromEnterpriseAddr - , credentialFromXPub - ) -import Cardano.Wallet.Deposit.Write.Keys - ( enterpriseAddressFromVKey - , signedDSIGNfromXSignature - , vkeyFromXPub - ) -import Test.Hspec - ( Spec - , describe - , it - ) -import Test.QuickCheck - ( Arbitrary (..) - , Blind (..) - , Property - , elements - , property - , vectorOf - , withMaxSuccess - , (===) - ) - -import qualified Cardano.Crypto.Hash.Blake2b as Hash -import qualified Cardano.Crypto.Hash.Class as Hash -import qualified Cardano.Ledger.BaseTypes as L -import qualified Cardano.Ledger.Hashes as L -import qualified Cardano.Ledger.Keys as L -import qualified Cardano.Wallet.Read as Read -import qualified Data.ByteString as BS - -{----------------------------------------------------------------------------- - Spec -------------------------------------------------------------------------------} -spec :: Spec -spec = do - describe "commutes with ledger" $ do - it "address" $ lessCryptography $ property $ - \xpub networkTag -> - let network = toLedgerNetwork networkTag - in enterpriseAddressFromVKey network (vkeyFromXPub xpub) - === enterpriseAddressFromXPub networkTag xpub - - it "verify" $ lessCryptography $ property $ - \(Blind xprv) hash -> - let xpub = toXPub xprv - xsig = sign xprv (Hash.hashToBytes hash) - in - True === - L.verifySignedDSIGN - (vkeyFromXPub xpub) - hash - (signedDSIGNfromXSignature xsig) - -lessCryptography :: Property -> Property -lessCryptography = withMaxSuccess 20 - -{----------------------------------------------------------------------------- - Helper functions -------------------------------------------------------------------------------} -enterpriseAddressFromXPub :: NetworkTag -> XPub -> Read.CompactAddr -enterpriseAddressFromXPub networkTag = - compactAddrFromEnterpriseAddr - . EnterpriseAddrC networkTag - . credentialFromXPub - -toLedgerNetwork :: NetworkTag -> L.Network -toLedgerNetwork MainnetTag = L.Mainnet -toLedgerNetwork TestnetTag = L.Testnet - -instance Arbitrary NetworkTag where - arbitrary = elements [MainnetTag, TestnetTag] - -instance Arbitrary XPrv where - arbitrary = generate . BS.pack <$> vectorOf 100 arbitrary <*> pure BS.empty - -instance Arbitrary XPub where - arbitrary = toXPub <$> arbitrary - -instance Arbitrary (Hash.Hash Hash.Blake2b_256 L.EraIndependentTxBody) where - arbitrary = do - bytes <- BS.pack <$> vectorOf (32) arbitrary - let Just hash = Hash.hashFromBytes bytes - pure hash diff --git a/lib/deposit-wallet/test/unit/Spec.hs b/lib/deposit-wallet/test/unit/Spec.hs deleted file mode 100644 index 5416ef6a866..00000000000 --- a/lib/deposit-wallet/test/unit/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/lib/deposit-wallet/test/unit/test-suite-unit.hs b/lib/deposit-wallet/test/unit/test-suite-unit.hs deleted file mode 100644 index 66edcab2e95..00000000000 --- a/lib/deposit-wallet/test/unit/test-suite-unit.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -import Prelude - -import Main.Utf8 - ( withUtf8 - ) -import Test.Hspec.Extra - ( hspecMain - ) - -import qualified Spec - -main :: IO () -main = withUtf8 $ hspecMain Spec.spec diff --git a/nix/project-package-list.nix b/nix/project-package-list.nix index fd1ec47c8d5..ceff1329d92 100644 --- a/nix/project-package-list.nix +++ b/nix/project-package-list.nix @@ -1 +1 @@ -[ "address-derivation-discovery" "cardano-api-extra" "cardano-balance-tx" "cardano-coin-selection" "cardano-numeric" "cardano-wallet" "cardano-wallet-api" "cardano-wallet-application-extras" "cardano-wallet-benchmarks" "cardano-wallet-blackbox-benchmarks" "cardano-wallet-buildkite" "cardano-wallet-exe" "cardano-wallet-integration" "cardano-wallet-launcher" "cardano-wallet-network-layer" "cardano-wallet-primitive" "cardano-wallet-secrets" "cardano-wallet-test-utils" "cardano-wallet-ui" "cardano-wallet-unit" "crypto-primitives" "cardano-deposit-wallet" "delta-chain" "delta-store" "delta-table" "delta-types" "faucet" "iohk-monitoring-extra" "local-cluster" "std-gen-seed" "temporary-extra" "text-class" "wai-middleware-logging" ] +[ "address-derivation-discovery" "cardano-api-extra" "cardano-balance-tx" "cardano-coin-selection" "cardano-numeric" "cardano-wallet" "cardano-wallet-api" "cardano-wallet-application-extras" "cardano-wallet-benchmarks" "cardano-wallet-blackbox-benchmarks" "cardano-wallet-buildkite" "cardano-wallet-exe" "cardano-wallet-integration" "cardano-wallet-launcher" "cardano-wallet-network-layer" "cardano-wallet-primitive" "cardano-wallet-secrets" "cardano-wallet-test-utils" "cardano-wallet-ui" "cardano-wallet-unit" "crypto-primitives" "delta-chain" "delta-store" "delta-table" "delta-types" "faucet" "iohk-monitoring-extra" "local-cluster" "std-gen-seed" "temporary-extra" "text-class" "wai-middleware-logging" ] From e2cab0e97d4b4be601e14dd0ef615b6dcd7e3000 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 26 Feb 2025 16:14:17 +0000 Subject: [PATCH 4/4] Remove customer-deposit-wallet-pure dependency --- cabal.project | 1 - 1 file changed, 1 deletion(-) diff --git a/cabal.project b/cabal.project index 3c57b26e920..091ac0a0b2d 100644 --- a/cabal.project +++ b/cabal.project @@ -157,7 +157,6 @@ source-repository-package tag: b5f11bde33585277aa3628b01fe6f5ee8bed2101 --sha256: 0dc0b60vbq1ljwrdxr45nc99c3gdn98myjyd3c9xmlkn8cwpvjwx subdir: - lib/customer-deposit-wallet-pure lib/cardano-wallet-read --------------------------------------------------------------------------------