From be751bfd9d22d38bff94d73430a6338c2618e1dd Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Wed, 4 Sep 2024 15:58:13 +0200 Subject: [PATCH 1/4] Add `Cardano.Wallet.Deposit.IO.Resource` --- .../customer-deposit-wallet.cabal | 1 + .../src/Cardano/Wallet/Deposit/IO/Resource.hs | 165 ++++++++++++++++++ 2 files changed, 166 insertions(+) create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 58a304c0474..087dc35b32c 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -76,6 +76,7 @@ library Cardano.Wallet.Deposit.IO.DB Cardano.Wallet.Deposit.IO.Network.Mock Cardano.Wallet.Deposit.IO.Network.Type + Cardano.Wallet.Deposit.IO.Resource Cardano.Wallet.Deposit.Pure Cardano.Wallet.Deposit.Pure.Balance Cardano.Wallet.Deposit.Pure.UTxO diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs new file mode 100644 index 00000000000..ca132829a20 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# HLINT ignore "Use void" #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- 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 + ) where + +import Prelude + +import Control.Concurrent + ( forkFinally + ) +import Control.Concurrent.Class.MonadMVar + ( MonadMVar (..) + , putMVar + , takeMVar + ) +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 a = Resource + { content :: TVar IO (ResourceStatus a) + , waitForEndOfLife :: IO () + -- ^ Wait until the 'Resource' is out of scope. + } + +-- | Possible status of the content of a 'Resource'. +data ResourceStatus a + = NotInitialized + | Initializing + | Initialized a + | Vanished SomeException + deriving (Show) + +instance Functor ResourceStatus where + fmap _ NotInitialized = NotInitialized + fmap _ Initializing = Initializing + fmap f (Initialized a) = Initialized (f a) + fmap _ (Vanished e) = Vanished e + +-- | Read the status of a 'Resource'. +readStatus :: Resource a -> IO (ResourceStatus ()) +readStatus resource = void <$> readTVarIO (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 a -> IO b) + -- ^ Action to perform on the 'Resource'. + -> IO b + -- ^ Result of the action. +withResource action = do + content <- newTVarIO NotInitialized + finished <- newEmptyMVar + let waitForEndOfLife = takeMVar finished + resource = Resource{content, waitForEndOfLife} + action resource `finally` putMVar finished () + +-- | Error condition for 'onResource'. +data ErrResourceMissing + = -- | The 'Resource' has not been initialized yet. + ErrNotInitialized + | -- | The 'Resource' is currently being initialized. + ErrStillInitializing + | -- | The 'Resource' has not been initialized yet. + ErrVanished SomeException + deriving (Show) + +-- | Perform an action on a 'Resource' if it is initialized. +onResource + :: (a -> IO b) + -- ^ Action to perform on the initialized 'Resource'. + -> Resource a + -- ^ The 'Resource' to act on. + -> IO (Either ErrResourceMissing b) +onResource action resource = do + eContent <- readTVarIO $ content resource + case eContent of + NotInitialized -> pure $ Left ErrNotInitialized + Initializing -> pure $ Left ErrStillInitializing + Initialized a -> Right <$> action a + Vanished e -> pure $ Left $ ErrVanished e + +-- | Error condition for 'putResource'. +data ErrResourceExists a + = -- | The 'Resource' is currently being initialized. + ErrAlreadyInitializing + | -- | The 'Resource' has already been initialized. + ErrAlreadyInitialized a + | -- | The 'Resource has vanished because of an exception. + ErrAlreadyVanished SomeException + 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. +putResource + :: (forall b. (a -> IO b) -> IO b) + -- ^ Function to run a continuation on the initialized 'Resource'. + -> Resource a + -- ^ The 'Resource' to initialize. + -> IO (Either (ErrResourceExists a) ()) +putResource start resource = do + forking <- atomically $ do + ca :: ResourceStatus a <- readTVar (content resource) + case ca of + Vanished e -> pure $ Left $ ErrAlreadyVanished e + Initializing -> pure $ Left ErrAlreadyInitializing + Initialized a -> pure $ Left $ ErrAlreadyInitialized a + NotInitialized -> do + writeTVar (content resource) Initializing + pure $ Right forkInitialization + case forking of + Left e -> pure $ Left e + Right action -> Right <$> action + where + forkInitialization = void $ forkFinally (start run) vanish + + run a = do + atomically $ writeTVar (content resource) (Initialized a) + waitForEndOfLife resource + + vanish (Left e) = + atomically $ writeTVar (content resource) (Vanished e) + vanish (Right _) = + pure () -- waitForEndOfLife has succeeded From 8a1873a10b8e78a627df2664af74b5020f2c9f61 Mon Sep 17 00:00:00 2001 From: paolino Date: Fri, 6 Sep 2024 07:44:14 +0000 Subject: [PATCH 2/4] Add boot env datatype --- .../src/Cardano/Wallet/Deposit/IO.hs | 71 +++++++++++++------ .../test/scenario/Test/Scenario/Blockchain.hs | 11 +-- 2 files changed, 57 insertions(+), 25 deletions(-) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs index 388864cfb78..a2bf305f295 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs @@ -5,6 +5,7 @@ module Cardano.Wallet.Deposit.IO ( -- * Types WalletEnv (..) + , WalletBootEnv (..) , WalletInstance -- * Operations @@ -27,6 +28,7 @@ module Cardano.Wallet.Deposit.IO , createPayment , getBIP32PathsForOwnedInputs , signTxBody + , WalletStore ) where import Prelude @@ -72,12 +74,28 @@ import qualified Data.Store as Store {----------------------------------------------------------------------------- Types ------------------------------------------------------------------------------} -data WalletEnv m = - WalletEnv + +-- | 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.Block - , database :: Store.UpdateStore IO Wallet.DeltaWalletState + -- ^ 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 @@ -108,6 +126,7 @@ readWalletState WalletInstance{walletState} = Operations Initialization ------------------------------------------------------------------------------} + -- | Initialize a new wallet in the given environment. withWalletInit :: WalletEnv IO @@ -115,10 +134,18 @@ withWalletInit -> Word31 -> (WalletInstance -> IO a) -> IO a -withWalletInit env@WalletEnv{..} xpub knownCustomerCount action = do - walletState <- DBVar.initDBVar database - $ Wallet.fromXPubAndGenesis xpub knownCustomerCount genesisData - withWalletDBVar env walletState action +withWalletInit + env@WalletEnv + { bootEnv = WalletBootEnv{genesisData} + , .. + } + xpub + knownCustomerCount + action = do + walletState <- + DBVar.initDBVar store + $ Wallet.fromXPubAndGenesis xpub knownCustomerCount genesisData + withWalletDBVar env walletState action -- | Load an existing wallet from the given environment. withWalletLoad @@ -126,7 +153,7 @@ withWalletLoad -> (WalletInstance -> IO a) -> IO a withWalletLoad env@WalletEnv{..} action = do - walletState <- DBVar.loadDBVar database + walletState <- DBVar.loadDBVar store withWalletDBVar env walletState action withWalletDBVar @@ -134,18 +161,22 @@ withWalletDBVar -> DBVar.DBVar IO Wallet.DeltaWalletState -> (WalletInstance -> IO a) -> IO a -withWalletDBVar env@WalletEnv{..} 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 = undefined - , readChainPoints = undefined - , rollForward = rollForward w - , rollBackward = rollBackward w - } +withWalletDBVar + 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 = undefined + , readChainPoints = undefined + , rollForward = rollForward w + , rollBackward = rollBackward w + } {----------------------------------------------------------------------------- Operations diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs index 2b215fe0189..d126d3be4fe 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs @@ -91,11 +91,12 @@ withWalletEnvMock withWalletEnvMock ScenarioEnv{..} action = do database <- newStore let walletEnv = Wallet.WalletEnv - { Wallet.logger = nullTracer - , Wallet.genesisData = genesisData - , Wallet.networkEnv = networkEnv - , Wallet.database = database - } + Wallet.WalletBootEnv + { Wallet.logger = nullTracer + , Wallet.genesisData = genesisData + , Wallet.networkEnv = networkEnv + } + database action walletEnv {----------------------------------------------------------------------------- From 6283116470c00c3a547c3a60ef7d1923d6edaf9f Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Wed, 4 Sep 2024 16:58:46 +0200 Subject: [PATCH 3/4] Add `Cardano.Wallet.Deposit.REST` module --- .../src/Cryptography/Hash/Blake.hs | 4 + .../customer-deposit-wallet.cabal | 58 +-- .../src/Cardano/Wallet/Deposit/REST.hs | 338 ++++++++++++++++++ 3 files changed, 375 insertions(+), 25 deletions(-) create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/REST.hs diff --git a/lib/crypto-primitives/src/Cryptography/Hash/Blake.hs b/lib/crypto-primitives/src/Cryptography/Hash/Blake.hs index a428a0176d6..7f77d163913 100644 --- a/lib/crypto-primitives/src/Cryptography/Hash/Blake.hs +++ b/lib/crypto-primitives/src/Cryptography/Hash/Blake.hs @@ -6,6 +6,7 @@ module Cryptography.Hash.Blake , Blake2b_224 , Blake2b_256 + , blake2b160 , blake2b256 , blake2b224 , hashSizeBlake2b224 @@ -41,5 +42,8 @@ blake2b256 = BA.convert . hash @_ @Blake2b_256 blake2b224 :: ByteArrayAccess a => a -> ByteString blake2b224 = BA.convert . hash @_ @Blake2b_224 +blake2b160 :: ByteArrayAccess a => a -> ByteString +blake2b160 = BA.convert . hash @_ @Blake2b_160 + hashSizeBlake2b224 :: Int hashSizeBlake2b224 = hashDigestSize Blake2b_224 diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 087dc35b32c..725852b2a67 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -12,24 +12,21 @@ maintainer: hal@cardanofoundation.org copyright: 2023 Cardano Foundation category: Web data-files: data/swagger.json - extra-source-files: spec/**/*.lagda.md spec/**/*.lhs.md spec/**/*.openapi.yaml common language - default-language: - Haskell2010 + default-language: Haskell2010 default-extensions: NoImplicitPrelude OverloadedStrings common opts-lib ghc-options: - -Wall -Wcompat - -Wredundant-constraints - -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wall -Wcompat -Wredundant-constraints -Wincomplete-uni-patterns + -Wincomplete-record-updates if flag(release) ghc-options: -O2 -Werror @@ -50,27 +47,36 @@ library , async , base , bytestring + , cardano-addresses + , cardano-binary , cardano-crypto - , cardano-wallet:cardano-wallet - , cardano-wallet-network-layer - , cardano-wallet-read == 0.2024.8.27 + , cardano-ledger-api + , cardano-ledger-binary , cardano-ledger-byron + , cardano-strict-containers + , cardano-wallet + , cardano-wallet-network-layer + , cardano-wallet-read ==0.2024.8.27 , containers , contra-tracer + , crypto-primitives , customer-deposit-wallet-pure , delta-store , delta-table , delta-types + , directory + , filepath , io-classes , iohk-monitoring-extra + , memory + , microlens , OddWord , sqlite-simple + , serialise , text - , transformers , time - , cardano-ledger-api - , cardano-strict-containers - , microlens + , transformers + exposed-modules: Cardano.Wallet.Deposit.IO Cardano.Wallet.Deposit.IO.DB @@ -79,10 +85,11 @@ library Cardano.Wallet.Deposit.IO.Resource Cardano.Wallet.Deposit.Pure Cardano.Wallet.Deposit.Pure.Balance + Cardano.Wallet.Deposit.Pure.Submissions Cardano.Wallet.Deposit.Pure.UTxO Cardano.Wallet.Deposit.Pure.UTxOHistory - Cardano.Wallet.Deposit.Pure.Submissions Cardano.Wallet.Deposit.Read + Cardano.Wallet.Deposit.REST Cardano.Wallet.Deposit.Write test-suite scenario @@ -90,10 +97,8 @@ test-suite scenario 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-tool-depends: markdown-unlit:markdown-unlit + ghc-options: -pgmL markdown-unlit build-depends: , base , bytestring @@ -103,7 +108,8 @@ test-suite scenario , contra-tracer , customer-deposit-wallet , delta-store - , hspec >=2.8.2 + , hspec >=2.8.2 + other-modules: Test.Scenario.Blockchain Test.Scenario.Wallet.Deposit.Exchanges @@ -129,6 +135,7 @@ library customer-deposit-wallet-http , text , text-class , warp + exposed-modules: Cardano.Wallet.Deposit.HTTP Cardano.Wallet.Deposit.HTTP.Endpoints @@ -150,13 +157,16 @@ test-suite unit , bytestring , cardano-crypto , cardano-wallet-test-utils - , customer-deposit-wallet:{customer-deposit-wallet, customer-deposit-wallet-http} + , customer-deposit-wallet + , customer-deposit-wallet:customer-deposit-wallet-http , directory - , hspec >=2.8.2 + , hspec , hspec-golden , openapi3 , QuickCheck + , temporary , with-utf8 + build-tool-depends: hspec-discover:hspec-discover other-modules: Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec @@ -167,7 +177,5 @@ test-suite unit executable customer-deposit-wallet import: language, opts-exe hs-source-dirs: exe - build-depends: - , base - main-is: - customer-deposit-wallet.hs + build-depends: base + main-is: customer-deposit-wallet.hs diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/REST.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/REST.hs new file mode 100644 index 00000000000..6926b6b5079 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/REST.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- 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 + , runWalletResourceM + + -- * Operations + + -- ** Initialization + , initXPubWallet + , loadWallet + + -- ** Mapping between customers and addresses + , listCustomers + , createAddress + + -- ** Reading from the blockchain + , getWalletTip + , availableBalance + , getCustomerHistory + , getCustomerHistories + + -- ** Writing to the blockchain + , createPayment + , getBIP32PathsForOwnedInputs + , signTxBody + ) where + +import Prelude + +import Cardano.Address.Derivation + ( xpubFromBytes + , xpubToBytes + ) +import Cardano.Crypto.Wallet + ( XPub (..) + ) +import Cardano.Wallet.Address.BIP32 + ( BIP32Path + ) +import Cardano.Wallet.Deposit.IO.Resource + ( ErrResourceExists (ErrAlreadyInitialized, ErrAlreadyInitializing, ErrAlreadyVanished) + , ErrResourceMissing (..) + ) +import Cardano.Wallet.Deposit.Pure + ( Customer + , Word31 + , fromXPubAndGenesis + ) +import Cardano.Wallet.Deposit.Read + ( Address + ) +import Codec.Serialise + ( deserialise + , serialise + ) +import Control.Exception + ( Exception + , throwIO + ) +import Control.Monad.Trans.Class + ( lift + ) +import Control.Monad.Trans.Except + ( ExceptT (..) + , runExceptT + ) +import Control.Monad.Trans.Reader + ( ReaderT (..) + , ask + ) +import Cryptography.Hash.Blake + ( blake2b160 + ) +import Data.Bifunctor + ( first + ) +import Data.ByteArray.Encoding + ( Base (..) + , convertToBase + ) +import Data.List + ( isPrefixOf + ) +import Data.Store + ( Store (..) + , newStore + ) +import System.Directory + ( listDirectory + ) +import System.FilePath + ( () + ) + +import qualified Cardano.Wallet.Deposit.IO as WalletIO +import qualified Cardano.Wallet.Deposit.IO.Resource as Resource +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 Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as Map + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} + +-- | Mutable resource that may hold a 'WalletInstance'. +type WalletResource = Resource.Resource WalletIO.WalletInstance + +-- | Error indicating that the 'WalletResource' does not hold a wallet. +data ErrWalletResource + = ErrNoWallet Resource.ErrResourceMissing + | ErrYesWallet (Resource.ErrResourceExists 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' + ErrYesWallet e -> case e of + ErrAlreadyInitializing -> "Wallet is already initializing" + ErrAlreadyInitialized _ -> "Wallet is already initialized" + ErrAlreadyVanished e' -> "Wallet vanished: " <> show e' + +-- | Monad for acting on a 'WalletResource'. +type WalletResourceM = ReaderT WalletResource (ExceptT ErrWalletResource IO) + +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. +depostiPrefix :: String +depostiPrefix = "deposit-" + +-- | Scan a directory for deposit wallets. +scanDirectoryForDepositPrefix :: FilePath -> IO [FilePath] +scanDirectoryForDepositPrefix fp = do + files <- listDirectory fp + pure $ filter (depostiPrefix `isPrefixOf`) files + +data ErrLoadingDatabase + = ErrDatabaseNotFound FilePath + | ErrDatabaseCorrupted FilePath + | ErrMultipleDatabases [FilePath] + deriving (Show) + +-- | Try to open an existing wallet +findTheDepositWalletOnDisk + :: FilePath + -- ^ Path to the wallet database directory + -> (Either ErrLoadingDatabase WalletIO.WalletStore -> IO a) + -- ^ Action to run if the wallet is found + -> IO a +findTheDepositWalletOnDisk fp action = do + ds <- scanDirectoryForDepositPrefix fp + case ds of + [d] -> do + (xpub, users) <- deserialise <$> BL.readFile (fp d) + case xpubFromBytes xpub of + Nothing -> action $ Left $ ErrDatabaseCorrupted (fp d) + Just identity -> do + let state = + fromXPubAndGenesis + identity + (fromIntegral @Int users) + (error "FIXME") + store <- newStore + writeS store state + action $ Right store + [] -> action $ Left $ ErrDatabaseNotFound fp + ds' -> action $ Left $ ErrMultipleDatabases ((fp ) <$> ds') + +-- | Try to create a new wallet +createTheDepositWalletOnDisk + :: FilePath + -- ^ Path to the wallet database directory + -> XPub + -- ^ Id of the wallet + -> Word31 + -- ^ Max number of users ? + -> (Maybe WalletIO.WalletStore -> IO a) + -- ^ Action to run if the wallet is created + -> IO a +createTheDepositWalletOnDisk fp identity users action = do + ds <- scanDirectoryForDepositPrefix fp + case ds of + [] -> do + BL.writeFile (fp depostiPrefix <> hashWalletId identity) + $ serialise (xpubToBytes identity, fromIntegral users :: Int) + store <- newStore + action $ Just store + _ -> do + action Nothing + where + hashWalletId :: XPub -> String + hashWalletId = + B8.unpack + . convertToBase Base64 + . blake2b160 + . xpubPublicKey + +-- | Exception thrown when a wallet database is not found. +newtype ExceptionLoadingDatabase = ExceptionLoadingDatabase ErrLoadingDatabase + deriving (Show) + +instance Exception ExceptionLoadingDatabase + +-- | Load an existing wallet from disk. +loadWallet + :: WalletIO.WalletBootEnv IO + -- ^ Environment for the wallet + -> FilePath + -- ^ Path to the wallet database directory + -> WalletResourceM () +loadWallet bootEnv fp = do + let action :: (WalletIO.WalletInstance -> IO b) -> IO b + action f = findTheDepositWalletOnDisk fp $ \case + Right wallet -> do + WalletIO.withWalletLoad + (WalletIO.WalletEnv bootEnv wallet) + f + Left e -> throwIO $ ExceptionLoadingDatabase e + resource <- ask + lift $ ExceptT $ first ErrYesWallet <$> Resource.putResource action resource + +-- | Exception thrown when a wallet database already exists. +newtype ExceptionDatabaseAlreadyExists = ExceptionDatabaseAlreadyExists FilePath + deriving (Show) + +instance Exception ExceptionDatabaseAlreadyExists + +-- | Initialize a new wallet from an 'XPub'. +initXPubWallet + :: WalletIO.WalletBootEnv IO + -- ^ Environment for the wallet + -> FilePath + -- ^ Path to the wallet database directory + -> XPub + -- ^ Id of the wallet + -> Word31 + -- ^ Max number of users ? + -> WalletResourceM () +initXPubWallet bootEnv fp xpub users = do + let action :: (WalletIO.WalletInstance -> IO b) -> IO b + action f = createTheDepositWalletOnDisk fp xpub users $ \case + Just wallet -> + WalletIO.withWalletInit + (WalletIO.WalletEnv bootEnv wallet) + xpub + users + f + Nothing -> throwIO $ ExceptionDatabaseAlreadyExists fp + resource <- ask + lift $ ExceptT $ first ErrYesWallet <$> Resource.putResource action resource + +{----------------------------------------------------------------------------- + Operations +------------------------------------------------------------------------------} +listCustomers + :: WalletResourceM [(Customer, Address)] +listCustomers = onWalletInstance WalletIO.listCustomers + +createAddress + :: Customer + -> WalletResourceM Address +createAddress = onWalletInstance . WalletIO.createAddress + +{----------------------------------------------------------------------------- + Operations + Reading from the blockchain +------------------------------------------------------------------------------} +getWalletTip :: WalletResourceM Read.ChainPoint +getWalletTip = onWalletInstance WalletIO.getWalletTip + +availableBalance :: WalletResourceM Read.Value +availableBalance = onWalletInstance WalletIO.availableBalance + +getCustomerHistory + :: Customer + -> WalletResourceM [Wallet.TxSummary] +getCustomerHistory = onWalletInstance . WalletIO.getCustomerHistory + +getCustomerHistories + :: (Read.ChainPoint, Read.ChainPoint) + -> WalletResourceM (Map.Map Customer Wallet.ValueTransfer) +getCustomerHistories = onWalletInstance . WalletIO.getCustomerHistories + +{----------------------------------------------------------------------------- + Operations + Writing to blockchain +------------------------------------------------------------------------------} + +createPayment + :: [(Address, Read.Value)] + -> WalletResourceM (Maybe Write.TxBody) +createPayment = onWalletInstance . WalletIO.createPayment + +getBIP32PathsForOwnedInputs + :: Write.TxBody + -> WalletResourceM [BIP32Path] +getBIP32PathsForOwnedInputs = + onWalletInstance . WalletIO.getBIP32PathsForOwnedInputs + +signTxBody + :: Write.TxBody + -> WalletResourceM (Maybe Write.Tx) +signTxBody = onWalletInstance . WalletIO.signTxBody From 33aec0f246fab774be2b2831e111f0d766435bac Mon Sep 17 00:00:00 2001 From: paolino Date: Fri, 6 Sep 2024 14:16:06 +0000 Subject: [PATCH 4/4] Test deposit REST module --- .../customer-deposit-wallet.cabal | 1 + .../unit/Cardano/Wallet/Deposit/RESTSpec.hs | 112 ++++++++++++++++++ 2 files changed, 113 insertions(+) create mode 100644 lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 725852b2a67..e0f2ddf1380 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -171,6 +171,7 @@ test-suite unit other-modules: Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec Cardano.Wallet.Deposit.HTTP.OpenAPISpec + Cardano.Wallet.Deposit.RESTSpec Paths_customer_deposit_wallet Spec diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs new file mode 100644 index 00000000000..0af62f002b6 --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs @@ -0,0 +1,112 @@ +module Cardano.Wallet.Deposit.RESTSpec + ( spec + ) +where + +import Prelude + +import Cardano.Crypto.Wallet + ( XPub + , generate + , toXPub + ) +import Cardano.Wallet.Deposit.IO + ( WalletBootEnv (WalletBootEnv) + ) +import Cardano.Wallet.Deposit.IO.Resource + ( withResource + ) +import Cardano.Wallet.Deposit.REST + ( WalletResourceM + , availableBalance + , initXPubWallet + , loadWallet + , runWalletResourceM + ) +import Control.Concurrent + ( threadDelay + ) +import Control.Monad.IO.Class + ( MonadIO (..) + ) +import System.IO.Temp + ( withSystemTempDirectory + ) +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + ) + +import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Data.ByteString.Char8 as B8 + +fakeBootEnv :: WalletBootEnv IO +fakeBootEnv = WalletBootEnv undefined undefined undefined + +xpub :: XPub +xpub = + toXPub + $ generate (B8.pack "random seed for a testing xpub lala") B8.empty + +waitAndGetBalance :: WalletResourceM Read.Value +waitAndGetBalance = do + liftIO $ threadDelay 100000 + availableBalance + +spec :: Spec +spec = do + describe "REST Deposit interface" $ do + it "can initialize a wallet" + $ withSystemTempDirectory "deposit-rest" + $ \dir -> do + r <- + withResource + $ runWalletResourceM + $ do + initXPubWallet fakeBootEnv dir xpub 0 + waitAndGetBalance + case r of + Left e -> fail $ show e + Right cs -> cs `shouldBe` mempty + it "can load an existing wallet" + $ withSystemTempDirectory "deposit-rest" + $ \dir -> do + r <- + withResource + $ runWalletResourceM + $ do + initXPubWallet fakeBootEnv dir xpub 0 + waitAndGetBalance + case r of + Left e -> fail $ show e + Right _ -> do + r' <- + withResource + $ runWalletResourceM + $ do + loadWallet fakeBootEnv dir + waitAndGetBalance + case r' of + Left e -> fail $ show e + Right cs -> cs `shouldBe` mempty + it "cannot re-initialize a wallet" + $ withSystemTempDirectory "deposit-rest" + $ \dir -> do + r <- + withResource + $ runWalletResourceM + $ initXPubWallet fakeBootEnv dir xpub 0 + case r of + Left e -> fail $ show e + Right _ -> do + r' <- + withResource + $ runWalletResourceM + $ do + initXPubWallet fakeBootEnv dir xpub 0 + waitAndGetBalance + case r' of + Left _ -> return () + Right _ -> fail "Should have failed"