compute, store and return transaction metadata upon submission

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

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

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

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

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
 -------------------------------------------------------------------------------}