From 20478d375ee54e74b3d03f7ccacd317cb96bcd35 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 25 Apr 2019 15:47:14 +0200 Subject: [PATCH] compute, store and return transaction metadata upon submission --- src/Cardano/Wallet.hs | 61 +++++++++++++++++++-------- src/Cardano/Wallet/Api/Server.hs | 28 ++++++++++-- src/Cardano/Wallet/Api/Types.hs | 2 +- src/Cardano/Wallet/CoinSelection.hs | 2 +- src/Cardano/Wallet/Primitive/Model.hs | 8 ++++ 5 files changed, 78 insertions(+), 23 deletions(-) diff --git a/src/Cardano/Wallet.hs b/src/Cardano/Wallet.hs index 5ebd21e32ca..f8825706d2a 100644 --- a/src/Cardano/Wallet.hs +++ b/src/Cardano/Wallet.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} -- | @@ -38,7 +39,7 @@ module Cardano.Wallet import Prelude import Cardano.Wallet.Binary - ( encodeSignedTx, toByteString ) + ( encodeSignedTx, toByteString, txId ) import Cardano.Wallet.CoinSelection ( CoinSelection (..) , CoinSelectionError (..) @@ -52,7 +53,7 @@ import Cardano.Wallet.DB , PrimaryKey (..) ) import Cardano.Wallet.Network - ( NetworkLayer (..) ) + ( ErrPostTx (..), NetworkLayer (..) ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (RootK) , ErrWrongPassphrase (..) @@ -80,17 +81,21 @@ import Cardano.Wallet.Primitive.Model , currentTip , getState , initWallet + , newPending , updateState ) import Cardano.Wallet.Primitive.Signing ( SignTxError, mkStdTx ) import Cardano.Wallet.Primitive.Types ( Block (..) - , BlockHeader (..) + , Coin (..) + , Direction (..) , SignedTx (..) , SlotId (..) - , Tx (..) + , Tx + , TxMeta (..) , TxOut (..) + , TxStatus (..) , TxWitness , WalletDelegation (..) , WalletId (..) @@ -118,8 +123,14 @@ import Control.Monad.Trans.State ( runState, state ) import Data.Functor ( ($>) ) +import Data.Generics.Internal.VL.Lens + ( view, (^.) ) +import Data.Generics.Labels + () import Data.List.NonEmpty ( NonEmpty ) +import Data.Quantity + ( Quantity (..) ) import Data.Time.Clock ( getCurrentTime ) import Fmt @@ -129,6 +140,7 @@ import GHC.Generics import qualified Cardano.Wallet.CoinSelection.Policy.Random as CoinSelection import qualified Cardano.Wallet.DB as DB +import qualified Data.Map.Strict as Map import qualified Data.Text.IO as TIO {------------------------------------------------------------------------------- @@ -189,8 +201,9 @@ data WalletLayer s = WalletLayer -- 'submitTx'. , submitTx - :: (Tx, [TxWitness]) - -> ExceptT ErrSubmitTx IO () + :: WalletId + -> (Tx, [TxWitness]) + -> ExceptT ErrSubmitTx IO (Tx, TxMeta) -- ^ Broadcast a (signed) transaction to the network. } @@ -219,7 +232,9 @@ data ErrSignTx | ErrSignTxWrongPassphrase ErrWrongPassphrase -- | Errors occuring when submitting a signed transaction to the network -data ErrSubmitTx = forall a. NetworkError a +data ErrSubmitTx + = ErrSubmitTxNetwork ErrPostTx + | ErrSubmitTxNoSuchWallet ErrNoSuchWallet {------------------------------------------------------------------------------- Construction @@ -277,7 +292,7 @@ mkWalletLayer db network = WalletLayer TIO.putStrLn $ "[ERROR] restoreSleep: " +|| e ||+ "" restoreSleep wid (currentTip w) Right (_, tip) -> do - restoreStep wid (currentTip w, slotId tip) + restoreStep wid (currentTip w, tip ^. #slotId) {--------------------------------------------------------------------------- Transactions @@ -290,19 +305,29 @@ mkWalletLayer db network = WalletLayer withExceptT ErrCreateUnsignedTxCoinSelection $ CoinSelection.random opts utxo recipients - , submitTx = \(tx, witnesses) -> do + , submitTx = \wid (tx, witnesses) -> do let signed = SignedTx $ toByteString $ encodeSignedTx (tx, witnesses) - withExceptT NetworkError $ postTx network signed + withExceptT ErrSubmitTxNetwork $ postTx network signed + let amt = fromIntegral $ sum (getCoin . coin <$> tx ^. #outputs) + DB.withLock db $ withExceptT ErrSubmitTxNoSuchWallet $ do + (w, _) <- _readWallet wid + let meta = TxMeta + { status = Pending + , direction = Outgoing + , slotId = currentTip w + , amount = Quantity amt + } + let history = Map.fromList [(txId tx, (tx, meta))] + DB.putCheckpoint db (PrimaryKey wid) (newPending tx w) + DB.putTxHistory db (PrimaryKey wid) history + return (tx, meta) , signTx = \wid pwd (CoinSelection ins outs chgs) -> DB.withLock db $ do (w, _) <- withExceptT ErrSignTxNoSuchWallet $ _readWallet wid - let (changeOuts, s') = flip runState (getState w) $ forM chgs $ \c -> do addr <- state nextChangeAddress return $ TxOut addr c - allShuffledOuts <- liftIO $ shuffle (outs ++ changeOuts) - withRootKey wid pwd ErrSignTxWrongPassphrase $ \xprv -> do case mkStdTx (getState w) (xprv, pwd) ins allShuffledOuts of Right a -> do @@ -353,7 +378,7 @@ mkWalletLayer db network = WalletLayer Right [] -> do restoreSleep wid slot Right blocks -> do - let next = slotId . header . last $ blocks + let next = view #slotId . header . last $ blocks runExceptT (restoreBlocks wid blocks tip) >>= \case Left (ErrNoSuchWallet _) -> do TIO.putStrLn $ "[ERROR] restoreStep: wallet " +| wid |+ "is gone!" @@ -371,7 +396,7 @@ mkWalletLayer db network = WalletLayer TIO.putStrLn $ "[ERROR] restoreSleep: " +|| e ||+ "" restoreSleep wid slot Right (_, tip) -> - restoreStep wid (slot, slotId tip) + restoreStep wid (slot, tip ^. #slotId) -- | Apply the given blocks to the wallet and update the wallet state, -- transaction history and corresponding metadata. @@ -382,8 +407,8 @@ mkWalletLayer db network = WalletLayer -> ExceptT ErrNoSuchWallet IO () restoreBlocks wid blocks tip = do let (inf, sup) = - ( slotId . header . head $ blocks - , slotId . header . last $ blocks + ( view #slotId . header . head $ blocks + , view #slotId . header . last $ blocks ) liftIO $ TIO.putStrLn $ "[INFO] Applying blocks ["+| inf |+" ... "+| sup |+"]" @@ -398,7 +423,7 @@ mkWalletLayer db network = WalletLayer let (txs, cp') = applyBlocks (h ++ q) cp let progress = slotRatio sup tip let status' = if progress == maxBound then Ready else Restoring progress - let meta' = meta { status = status' } + let meta' = meta { status = status' } :: WalletMetadata -- NOTE -- Not as good as a transaction, but, with the lock, nothing can make diff --git a/src/Cardano/Wallet/Api/Server.hs b/src/Cardano/Wallet/Api/Server.hs index 255988f5df2..2ac07334db7 100644 --- a/src/Cardano/Wallet/Api/Server.hs +++ b/src/Cardano/Wallet/Api/Server.hs @@ -28,9 +28,10 @@ import Cardano.Wallet.Api ( Addresses, Api, Transactions, Wallets ) import Cardano.Wallet.Api.Types ( ApiAddress (..) + , ApiBlockData (..) , ApiCoins (..) , ApiT (..) - , ApiTransaction + , ApiTransaction (..) , ApiWallet (..) , PostTransactionData , WalletBalance (..) @@ -39,6 +40,8 @@ import Cardano.Wallet.Api.Types , WalletPutPassphraseData (..) , getApiMnemonicT ) +import Cardano.Wallet.Binary + ( txId ) import Cardano.Wallet.CoinSelection ( CoinSelectionOptions (..) ) import Cardano.Wallet.Primitive.AddressDiscovery @@ -59,6 +62,8 @@ import Data.Generics.Labels () import Data.Quantity ( Quantity (..) ) +import Data.Time.Clock + ( getCurrentTime ) import Servant ( (:<|>) (..) , NoContent (..) @@ -74,6 +79,7 @@ import Servant.Server ( Handler (..), ServantErr (..) ) import qualified Cardano.Wallet as W +import qualified Data.List.NonEmpty as NE -- | A Servant server for our wallet API @@ -206,12 +212,28 @@ createTransaction w (ApiT wid) body = do let pwd = getApiT $ body ^. #passphrase selection <- liftHandler $ W.createUnsignedTx w wid opts outs signedTx <- liftHandler $ W.signTx w wid pwd selection - liftHandler $ W.submitTx w signedTx - return undefined + (tx, meta) <- liftHandler $ W.submitTx w wid signedTx + now <- liftIO getCurrentTime + return ApiTransaction + { id = ApiT (txId tx) + , amount = meta ^. #amount + , insertedAt = ApiBlockData + { time = now -- FIXME Compute this deterministally from the slot + , block = ApiT (meta ^. #slotId) + } + , depth = Quantity 0 + , direction = ApiT (meta ^. #direction) + , inputs = NE.fromList (coerceTxOut . snd <$> selection ^. #inputs) + , outputs = NE.fromList (coerceTxOut <$> tx ^. #outputs) + , status = ApiT (meta ^. #status) + } where coerceCoin :: ApiCoins -> TxOut coerceCoin (ApiCoins (ApiT addr) (Quantity c)) = TxOut addr (Coin $ fromIntegral c) + coerceTxOut :: TxOut -> ApiCoins + coerceTxOut (TxOut addr (Coin c)) = + ApiCoins (ApiT addr) (Quantity $ fromIntegral c) {------------------------------------------------------------------------------- Error Handling diff --git a/src/Cardano/Wallet/Api/Types.hs b/src/Cardano/Wallet/Api/Types.hs index 3e06b479e95..9c1848f5ac0 100644 --- a/src/Cardano/Wallet/Api/Types.hs +++ b/src/Cardano/Wallet/Api/Types.hs @@ -152,7 +152,7 @@ data PostTransactionData = PostTransactionData , passphrase :: !(ApiT (Passphrase "encryption")) } deriving (Eq, Generic, Show) -data ApiTransaction = Transaction +data ApiTransaction = ApiTransaction { id :: !(ApiT (Hash "Tx")) , amount :: !(Quantity "lovelace" Natural) , insertedAt :: !ApiBlockData diff --git a/src/Cardano/Wallet/CoinSelection.hs b/src/Cardano/Wallet/CoinSelection.hs index ba6dbe1c08d..2319cc767ac 100644 --- a/src/Cardano/Wallet/CoinSelection.hs +++ b/src/Cardano/Wallet/CoinSelection.hs @@ -73,7 +73,7 @@ data CoinSelection = CoinSelection -- ^ Picked outputs , change :: [Coin] -- ^ Resulting changes - } deriving (Show, Eq) + } deriving (Generic, Show, Eq) -- NOTE -- We don't check for duplicates when combining selections because we assume diff --git a/src/Cardano/Wallet/Primitive/Model.hs b/src/Cardano/Wallet/Primitive/Model.hs index 17881e8d188..28279876290 100644 --- a/src/Cardano/Wallet/Primitive/Model.hs +++ b/src/Cardano/Wallet/Primitive/Model.hs @@ -35,6 +35,7 @@ module Cardano.Wallet.Primitive.Model , updateState , applyBlock , applyBlocks + , newPending -- * Accessors , currentTip @@ -182,6 +183,13 @@ applyBlocks blocks cp0 = applyBlock' (txs, cp) b = let (txs', cp') = applyBlock b cp in (txs <> txs', cp') +newPending + :: Tx + -> Wallet s + -> Wallet s +newPending !tx (Wallet !utxo !pending !history !tip !s) = + Wallet utxo (Set.insert tx pending) history tip s + {------------------------------------------------------------------------------- Accessors -------------------------------------------------------------------------------}