Rework JSON -> UTxO conversion with Write.Tx module

lib/wallet/cardano-wallet.cabal

@@ -394,6 +394,7 @@ library
     Cardano.Wallet.Util
     Cardano.Wallet.Version
     Cardano.Wallet.Version.TH
+    Cardano.Wallet.Write.Tx
     Control.Concurrent.Concierge
     Control.Monad.Exception.Unchecked
     Control.Monad.Random.Extra

lib/wallet/src/Cardano/Wallet.hs

@@ -456,6 +456,8 @@ import Cardano.Wallet.Primitive.Types.UTxOSelection
     ( UTxOSelection )
 import Cardano.Wallet.Read.Tx.CBOR
     ( TxCBOR (..) )
+import Cardano.Wallet.Shelley.Compatibility
+    ( toCardanoUTxO )
 import Cardano.Wallet.Transaction
     ( DelegationAction (..)
     , ErrAssignRedeemers (..)
@@ -1902,8 +1904,9 @@ balanceTransactionWithSelectionStrategy
          -- UTxO set. (Whether or not this is a sane thing for the user to do,
          -- is another question.)
          [ unUTxO inputUTxO
-         , unUTxO $ toCardanoUTxO tl walletUTxO []
+         , unUTxO $ toCardanoUTxO Cardano.shelleyBasedEra walletUTxO
          ]
+
       where
          unUTxO (Cardano.UTxO u) = u
 

lib/wallet/src/Cardano/Wallet/Api/Server.hs

@@ -137,12 +137,12 @@ import Cardano.Address.Script
     )
 import Cardano.Api
     ( NetworkId, SerialiseAsCBOR (..), toNetworkMagic, unNetworkMagic )
-import Cardano.Api.Extra
-    ( asAnyShelleyBasedEra, inAnyCardanoEra, withShelleyBasedTx )
 import Cardano.BM.Tracing
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Ledger.Alonzo.TxInfo
     ( TranslationError (..) )
+import Cardano.Ledger.BaseTypes
+    ( StrictMaybe (..) )
 import Cardano.Mnemonic
     ( SomeMnemonic )
 import Cardano.Wallet
@@ -523,6 +523,8 @@ import Cardano.Wallet.Registry
     , defaultWorkerAfter
     , workerResource
     )
+import Cardano.Wallet.Shelley.Compatibility.Ledger
+    ( toLedger )
 import Cardano.Wallet.TokenMetadata
     ( TokenMetadataClient, fillMetadata )
 import Cardano.Wallet.Transaction
@@ -546,7 +548,7 @@ import Control.DeepSeq
 import Control.Error.Util
     ( failWith )
 import Control.Monad
-    ( forM, forever, join, void, when, (>=>) )
+    ( forM, forever, join, void, when, (<=<), (>=>) )
 import Control.Monad.IO.Class
     ( MonadIO, liftIO )
 import Control.Monad.Trans.Except
@@ -669,6 +671,8 @@ import UnliftIO.Exception
     ( IOException, bracket, throwIO, tryAnyDeep, tryJust )
 
 import qualified Cardano.Api as Cardano
+import Cardano.Api.Extra
+    ( inAnyCardanoEra )
 import qualified Cardano.Wallet as W
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Cardano.Wallet.DB as W
@@ -686,6 +690,7 @@ import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
 import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
 import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection
 import qualified Cardano.Wallet.Registry as Registry
+import qualified Cardano.Wallet.Write.Tx as WriteTx
 import qualified Control.Concurrent.Concierge as Concierge
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
@@ -2797,15 +2802,45 @@ balanceTransaction ctx genChange (ApiT wid) body = do
         ti <- liftIO $ snapshot $ timeInterpreter $ ctx ^. networkLayer
 
         let mkPartialTx
-                :: forall era. Cardano.IsShelleyBasedEra era => Cardano.Tx era
-                -> W.PartialTx era
-            mkPartialTx tx = W.PartialTx
+                :: forall era. WriteTx.IsRecentEra era => Cardano.Tx era
+                -> Handler (W.PartialTx era)
+            mkPartialTx tx = do
+                utxo <- fmap WriteTx.toCardanoUTxO $ mkLedgerUTxO $ body ^. #inputs
+                pure $ W.PartialTx
                     tx
-                    (convertToCardano $ fromExternalInput <$> body ^. #inputs)
+                    utxo
                     (fromApiRedeemer <$> body ^. #redeemers)
               where
-                convertToCardano xs =
-                    toCardanoUTxO (wrk ^. W.transactionLayer @k @'CredFromKeyK) mempty xs
+
+                recentEra :: WriteTx.RecentEra era
+                recentEra = case Cardano.cardanoEra @era of
+                    Cardano.BabbageEra -> WriteTx.RecentEraBabbage
+                    Cardano.AlonzoEra -> WriteTx.RecentEraAlonzo
+                    _ -> error "todo: old era"
+
+                -- NOTE: There are a couple of spread-out pieces of logic
+                -- dealing with the choice of era, most prominantly: tx, utxo,
+                -- pparams / current node era. It /might/ be neater to have a
+                -- single function dedicated to this choice instead; something
+                -- like
+                -- @@
+                --      chooseEra
+                --          :: InRecentEra Tx
+                --          -> InRecentEra UTxO
+                --          -> InRecentEra PParams
+                --          -> (IsRecentEra era
+                --              => Tx era
+                --              -> UTxO era
+                --              -> PParams era
+                --              -> res)
+                --          -> res
+                -- @@
+
+                mkLedgerUTxO = liftHandler
+                    . ExceptT
+                    . pure
+                    . WriteTx.utxoFromTxOutsInRecentEra recentEra
+                    . map fromExternalInput
 
         let balanceTx
                 :: forall era. Cardano.IsShelleyBasedEra era
@@ -2820,13 +2855,13 @@ balanceTransaction ctx genChange (ApiT wid) body = do
                     wallet
                     partialTx
 
-        anyShelleyTx <- maybeToHandler ErrByronTxNotSupported
-            . asAnyShelleyBasedEra
+        anyRecentTx <- maybeToHandler ErrByronTxNotSupported -- FIXME more eras
+            . WriteTx.asAnyRecentEra
             . cardanoTxIdeallyNoLaterThan era
             . getApiT $ body ^. #transaction
 
-        res <- withShelleyBasedTx anyShelleyTx
-            (fmap inAnyCardanoEra . balanceTx . mkPartialTx)
+        res <- WriteTx.withRecentEra anyRecentTx
+            (fmap inAnyCardanoEra . balanceTx <=< mkPartialTx)
 
         case body ^. #encoding of
             Just HexEncoded ->
@@ -4369,7 +4404,7 @@ getWalletTip
     -> m ApiBlockReference
 getWalletTip ti = makeApiBlockReferenceFromHeader ti . currentTip
 
-fromExternalInput :: ApiExternalInput n -> (TxIn, TxOut, Maybe (Hash "Datum"))
+fromExternalInput :: ApiExternalInput n -> (WriteTx.TxIn, WriteTx.TxOutInRecentEra)
 fromExternalInput ApiExternalInput
     { id = ApiT tid
     , index = ix
@@ -4379,10 +4414,16 @@ fromExternalInput ApiExternalInput
     , datum
     }
   =
-    ( TxIn tid ix
-    , TxOut addr (TokenBundle (Coin $ fromIntegral amt) assets)
-    , getApiT <$> datum
-    )
+    let
+        inp = toLedger $ TxIn tid ix
+        script = SNothing
+        addr' = toLedger addr
+        val = toLedger $ TokenBundle (Coin.fromNatural amt) assets
+        datum' = maybe WriteTx.NoDatum WriteTx.DatumHash (getApiT <$> datum)
+        out = WriteTx.wrapTxOutInRecentEra
+            $ WriteTx.TxOut addr' val datum' script
+    in
+        (inp, out)
 
 fromApiRedeemer :: ApiRedeemer n -> Redeemer
 fromApiRedeemer = \case
@@ -4845,6 +4886,20 @@ instance IsServerError ErrDecodeTx where
             , errReasonPhrase = errReasonPhrase err404
             }
 
+-- FIXME: Define as part of wrapper, not alone
+instance IsServerError WriteTx.ErrInvalidTxOutInEra where
+    toServerError = \case
+        WriteTx.ErrInlineDatumNotSupportedInAlonzo ->
+            apiError err403 fixme $ mconcat
+                [ "Inline datums are not supported in the Alonzo era."
+                ]
+        WriteTx.ErrInlineScriptNotSupportedInAlonzo ->
+            apiError err403 fixme $ mconcat
+                [ "Inline scripts are not supported in the Alonzo era."
+                ]
+      where
+        fixme = BalanceTxByronNotSupported -- FIXME proper tag
+
 instance IsServerError ErrBalanceTx where
     toServerError = \case
         ErrByronTxNotSupported ->

lib/wallet/src/Cardano/Wallet/Api/Types.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -416,7 +417,7 @@ import Data.Aeson.Types
     , Parser
     , SumEncoding (..)
     , ToJSON (..)
-    , Value (Object, String)
+    , Value (Null, Object, String)
     , camelTo2
     , constructorTagModifier
     , fieldLabelModifier
@@ -513,6 +514,7 @@ import qualified Cardano.Wallet.Primitive.Types.TokenBundle as W
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as W
 import qualified Cardano.Wallet.Primitive.Types.TokenPolicy as W
+import qualified Cardano.Wallet.Write.Tx as WriteTx
 import qualified Codec.Binary.Bech32 as Bech32
 import qualified Codec.Binary.Bech32.TH as Bech32
 import qualified Data.Aeson as Aeson
@@ -1099,9 +1101,24 @@ data ApiExternalInput (n :: NetworkDiscriminant) = ApiExternalInput
     , address :: !(ApiT Address, Proxy n)
     , amount :: !(Quantity "lovelace" Natural)
     , assets :: !(ApiT W.TokenMap)
-    , datum :: !(Maybe (ApiT (Hash "Datum")))
+    , datum :: !(Maybe (ApiT WriteTx.DatumHash))
     } deriving (Eq, Generic, Show, Typeable)
-      deriving anyclass NFData
+
+instance FromJSON (ApiT WriteTx.DatumHash) where
+    parseJSON = withText "DatumHash" $ \hex -> maybeToParser $ do
+            bytes <- parseHex hex
+            ApiT <$> WriteTx.datumHashFromBytes bytes
+      where
+        maybeToParser = maybe failWithHelp pure
+        failWithHelp = fail $ mconcat
+            [ "expected <hex of valid datum hash>"
+            ]
+
+        parseHex :: Text -> Maybe ByteString
+        parseHex = eitherToMaybe . fromHexText
+
+instance ToJSON (ApiT WriteTx.DatumHash) where
+    toJSON (ApiT dh) = String $ hexText $ WriteTx.datumHashToBytes dh
 
 data ApiBalanceTransactionPostData (n :: NetworkDiscriminant) = ApiBalanceTransactionPostData
     { transaction :: !(ApiT SealedTx)

lib/wallet/src/Cardano/Wallet/Shelley/Compatibility/Ledger.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE LambdaCase #-}
@@ -63,7 +64,7 @@ import Cardano.Wallet.Primitive.Types.TokenPolicy
 import Cardano.Wallet.Primitive.Types.TokenQuantity
     ( TokenQuantity (..) )
 import Cardano.Wallet.Primitive.Types.Tx
-    ( TxOut (..) )
+    ( TxIn (..), TxOut (..) )
 import Data.ByteString.Short
     ( fromShort, toShort )
 import Data.Foldable
@@ -100,6 +101,7 @@ import qualified Cardano.Ledger.Babbage.TxBody as Babbage
 import qualified Cardano.Ledger.Crypto as Ledger
 import qualified Cardano.Ledger.Keys as Ledger
 import qualified Cardano.Ledger.Mary.Value as Ledger
+import qualified Cardano.Ledger.SafeHash as SafeHash
 import qualified Cardano.Ledger.Shelley.API as Ledger
 import qualified Cardano.Ledger.Shelley.TxBody as Shelley
 import qualified Cardano.Ledger.ShelleyMA.Timelocks as MA
@@ -247,6 +249,23 @@ toWalletTokenQuantity q
             , pretty q
             ]
 
+--------------------------------------------------------------------------------
+-- Conversions for 'TxIn'
+--------------------------------------------------------------------------------
+
+instance Convert TxIn (Ledger.TxIn StandardCrypto) where
+    toLedger (TxIn tid ix) =
+        Ledger.TxIn (toLedgerHash tid) (toEnum $ intCast ix)
+      where
+        toLedgerHash (Hash h) =
+            Ledger.TxId
+                $ SafeHash.unsafeMakeSafeHash
+                $ Crypto.UnsafeHash
+                $ toShort h
+
+    toWallet = error "todo"--Address . Ledger.serialiseAddr
+
+
 --------------------------------------------------------------------------------
 -- Conversions for 'Address'
 --------------------------------------------------------------------------------