Apply further review suggestions

Author: Julian Ospald

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -16,7 +16,8 @@ module Test.Integration.Scenario.API.Shelley.StakePools
 import Prelude
 
 import Cardano.Wallet.Api.Types
-    ( ApiStakePool
+    ( ApiCertificate (JoinPool, QuitPool, RegisterRewardAccount)
+    , ApiStakePool
     , ApiT (..)
     , ApiTransaction
     , ApiWallet
@@ -53,6 +54,8 @@ import Data.IORef
     ( readIORef )
 import Data.List
     ( find, sortOn )
+import Data.List.NonEmpty
+    ( NonEmpty (..) )
 import Data.Maybe
     ( fromMaybe, isJust, isNothing, listToMaybe, mapMaybe )
 import Data.Ord
@@ -576,14 +579,17 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     . find (isNothing . getRetirementEpoch)
                     $ nonRetiredPools
 
+            let isValidCerts (Just (RegisterRewardAccount{}:|[JoinPool{}])) = True
+                isValidCerts _ = False
+
             -- Join Pool
             w <- fixtureWallet ctx
             joinStakePoolUnsigned @n @'Shelley ctx w nonRetiringPoolId >>= \o -> do
                 verify o
                     [ expectResponseCode HTTP.status200
                     , expectField #inputs (`shouldSatisfy` (not . null))
                     , expectField #outputs (`shouldSatisfy` (not . null))
-                    , expectField #certificates (`shouldSatisfy` (not . null))
+                    , expectField #certificates (`shouldSatisfy` isValidCerts)
                     ]
 
     describe "STAKE_POOLS_JOIN_UNSIGNED_02"
@@ -668,13 +674,17 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     [ expectField #delegation (`shouldBe` delegating pool [])
                     ]
 
+            let isValidCerts (Just (QuitPool{}:|[])) = True
+                isValidCerts _ = False
+
             -- Quit Pool
             quitStakePoolUnsigned @n @'Shelley ctx w >>= \o -> do
                 verify o
                     [ expectResponseCode HTTP.status200
                     , expectField #inputs (`shouldSatisfy` (not . null))
                     , expectField #outputs (`shouldSatisfy` (not . null))
-                    , expectField #certificates (`shouldSatisfy` (not . null))
+                    , expectField #certificates (`shouldSatisfy` ((==1) . length))
+                    , expectField #certificates (`shouldSatisfy` isValidCerts)
                     ]
 
     describe "STAKE_POOLS_QUIT_UNSIGNED_02"

lib/core/src/Cardano/Wallet.hs

@@ -230,7 +230,7 @@ import Cardano.Wallet.Primitive.AddressDerivation
     , encryptPassphrase
     , liftIndex
     , preparePassphrase
-    , stakePath
+    , stakeDerivationPath
     )
 import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( ByronKey, unsafeMkByronKeyFromMasterKey )
@@ -2029,7 +2029,7 @@ joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid =
 
         let s = getState wal
             dprefix = Seq.derivationPrefix s
-            sPath = stakePath dprefix
+            sPath = stakeDerivationPath dprefix
 
         pure (cs, action, sPath)
 
@@ -2146,7 +2146,7 @@ quitStakePoolUnsigned' ctx wid = db & \DBLayer{..} -> do
         $ readCheckpoint (PrimaryKey wid)
     let s = getState cp
         dprefix = Seq.derivationPrefix s
-        sPath = stakePath dprefix
+        sPath = stakeDerivationPath dprefix
 
     pure (cs, action, sPath)
   where

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

@@ -1838,14 +1838,21 @@ mkApiCoinSelection mcerts (UnsignedTx inputs outputs) =
         -> NonEmpty DerivationIndex
         -> NonEmpty Api.ApiCertificate
     mkCertificates action xs =
-        let apiStakePath = ApiT <$> xs
-        in case action of
-            Join pid -> Api.JoinPool apiStakePath (ApiT pid) :| []
-            RegisterKeyAndJoin pid ->
-                Api.RegisterRewardAccount apiStakePath :|
-                    [Api.JoinPool apiStakePath (ApiT pid)]
-            Quit-> Api.QuitPool apiStakePath :| []
+        case action of
+            Join pid -> NE.fromList
+                [ Api.JoinPool apiStakePath (ApiT pid)
+                ]
+
+            RegisterKeyAndJoin pid -> NE.fromList
+                [ Api.RegisterRewardAccount apiStakePath
+                , Api.JoinPool apiStakePath (ApiT pid)
+                ]
 
+            Quit -> NE.fromList
+                [ Api.QuitPool apiStakePath
+                ]
+      where
+        apiStakePath = ApiT <$> xs
     mkAddressAmount :: TxOut -> AddressAmount (ApiT Address, Proxy n)
     mkAddressAmount (TxOut addr (Coin c)) =
         AddressAmount (ApiT addr, Proxy @n) (Quantity $ fromIntegral c)
@@ -2199,12 +2206,12 @@ instance Buildable e => LiftHandler (ErrSelectCoinsExternal e) where
         ErrSelectCoinsExternalUnableToMakeSelection e ->
             handler e
         ErrSelectCoinsExternalUnableToAssignInputs e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign inputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign inputs from coin selection: "
                 , pretty e]
         ErrSelectCoinsExternalUnableToAssignOutputs e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign outputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign outputs from coin selection: "
                 , pretty e]
 
 instance Buildable e => LiftHandler (ErrCoinSelection e) where
@@ -2507,12 +2514,12 @@ instance LiftHandler ErrJoinStakePool where
                     , toText pid
                     ]
         ErrJoinStakePoolUnableToAssignInputs e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign inputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign inputs from coin selection: "
                 , pretty e]
         ErrJoinStakePoolUnableToAssignOutputs  e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign outputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign outputs from coin selection: "
                 , pretty e]
 
 instance LiftHandler ErrFetchRewards where
@@ -2551,12 +2558,12 @@ instance LiftHandler ErrQuitStakePool where
                     , " lovelace first."
                     ]
         ErrQuitStakePoolUnableToAssignInputs e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign inputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign inputs from coin selection: "
                 , pretty e]
         ErrQuitStakePoolUnableToAssignOutputs e ->
-            apiError err403 UnableToAssignInputOutput $ mconcat
-                [ "Unable to assign outputs from coin selection: "
+            apiError err500 UnableToAssignInputOutput $ mconcat
+                [ "I'm unable to assign outputs from coin selection: "
                 , pretty e]
 
 instance LiftHandler ErrCreateRandomAddress where

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

@@ -1041,7 +1041,7 @@ instance DecodeAddress n => FromJSON (ApiSelectCoinsData n) where
                 pure $ ApiSelectForDelegation $ ApiSelectCoinsAction v
             (Just v, Nothing) ->
                 pure $ ApiSelectForPayment $ ApiSelectCoinsPayments v
-            _ -> fail "No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+            _ -> fail "No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
 instance EncodeAddress n => ToJSON (ApiSelectCoinsData n) where
     toJSON (ApiSelectForPayment v) = toJSON v
     toJSON (ApiSelectForDelegation v) = toJSON v
@@ -1060,7 +1060,7 @@ apiCertificateOptions = Aeson.defaultOptions
       , sumEncoding = TaggedObject
           {
             tagFieldName = "certificate_type"
-          , contentsFieldName = "details"
+          , contentsFieldName = "details" -- this isn't actually used
           }
       }
 
@@ -1080,7 +1080,8 @@ instance FromJSON (ApiT DelegationAction) where
             val -> fail ("Unexpeced action value \"" <> T.unpack val <> "\". Valid values are: \"quit\" and \"join\".")
 
 instance ToJSON (ApiT DelegationAction) where
-    toJSON (ApiT (RegisterKeyAndJoin _)) = error "RegisterKeyAndJoin not valid"
+    toJSON (ApiT (RegisterKeyAndJoin pid)) = object
+        [ "action" .= String "register_key_and_join", "pool" .= (ApiT pid) ]
     toJSON (ApiT (Join pid)) = object [ "action" .= String "join", "pool" .= (ApiT pid) ]
     toJSON (ApiT Quit) = object [ "action" .= String "quit" ]
 

lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs

@@ -39,7 +39,7 @@ module Cardano.Wallet.Primitive.AddressDerivation
     , utxoInternal
     , mutableAccount
     , zeroAccount
-    , stakePath
+    , stakeDerivationPath
     , DerivationType (..)
     , HardDerivation (..)
     , SoftDerivation (..)
@@ -217,16 +217,16 @@ zeroAccount :: Index 'Soft 'AddressK
 zeroAccount = minBound
 
 -- | Full path to the stake key. There's only one.
-stakePath :: DerivationPrefix -> NonEmpty DerivationIndex
-stakePath (DerivationPrefix (purpose, coin, acc)) =
+stakeDerivationPath :: DerivationPrefix -> NonEmpty DerivationIndex
+stakeDerivationPath (DerivationPrefix (purpose, coin, acc)) =
     (fromIndex purpose) :| [
       fromIndex coin
     , fromIndex acc
     , fromIndex mutableAccount
     , fromIndex zeroAccount]
   where
     fromIndex :: Index t l -> DerivationIndex
-    fromIndex (Index ix) = DerivationIndex ix
+    fromIndex = DerivationIndex . getIndex
 
 -- | A derivation index, with phantom-types to disambiguate derivation type.
 --

lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs

@@ -857,19 +857,19 @@ instance Malformed (BodyParam (ApiSelectCoinsData ('Testnet pm))) where
          jsonValid = (first (BodyParam . Aeson.encode) <$> paymentCases) <> jsonValidAction
          jsonValidAction = first (BodyParam . Aeson.encode) <$>
             [ ( [aesonQQ| { "action": "join" }|]
-              , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+              , "Error in $: No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
               )
             , ( [aesonQQ| { "action": "" }|]
-              , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+              , "Error in $: No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
               )
             , ( [aesonQQ| { "action": "join", "pool": "" }|]
-              , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+              , "Error in $: No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
               )
             , ( [aesonQQ| { "action": "join", "pool": "1" }|]
-              , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+              , "Error in $: No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
               )
             , ( [aesonQQ| { "pool": "pool1wqaz0q0zhtxlgn0ewssevn2mrtm30fgh2g7hr7z9rj5856457mm" }|]
-              , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction"
+              , "Error in $: No valid parse for ApiSelectCoinsPayments or ApiSelectCoinsAction"
               )
             ]
 

lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs

@@ -312,7 +312,8 @@ server byron icarus shelley spl ntp =
         withLegacyLayer wid
             (byron, liftHandler $ throwE ErrNotASequentialWallet)
             (icarus, selectCoins icarus (const $ paymentAddress @n) wid x)
-    byronCoinSelections _ _ = throwError err400
+    byronCoinSelections _ _ = throwError
+        $ err400 { errBody = "Byron wallets don't have delegation capabilities." }
 
     byronTransactions :: Server (ByronTransactions n)
     byronTransactions =

lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs

@@ -45,6 +45,8 @@ import Cardano.Binary
     ( serialize' )
 import Cardano.Crypto.DSIGN
     ( DSIGNAlgorithm (..), SignedDSIGN (..) )
+import Cardano.Crypto.Wallet
+    ( XPub )
 import Cardano.Ledger.Crypto
     ( Crypto (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -109,8 +111,6 @@ import qualified Cardano.Api.Typed as Cardano
 import qualified Cardano.Chain.Common as Byron
 import qualified Cardano.Crypto as CC
 import qualified Cardano.Crypto.Hash.Class as Crypto
-import Cardano.Crypto.Wallet
-    ( XPub )
 import qualified Cardano.Crypto.Wallet as Crypto.HD
 import qualified Cardano.Wallet.Primitive.CoinSelection as CS
 import qualified Data.ByteArray as BA
@@ -175,39 +175,25 @@ instance TxWitnessTagFor ByronKey where
     txWitnessTagFor = TxWitnessByronUTxO Byron
 
 
--- | Returns a tuple of unsigned transactions and withdrawals.
-mkTxUnsigned
-    :: Cardano.NetworkId
-    -> [Cardano.Certificate]
-    -> Maybe Cardano.TxMetadata
-    -> SlotNo
-    -- ^ Time to Live
-    -> XPrv
-    -- ^ Reward account
-    -> CoinSelection
-    -> (Cardano.TxBody Cardano.Shelley, [(Cardano.StakeAddress, Cardano.Lovelace)])
-mkTxUnsigned networkId certs md timeToLive rewardAcnt cs =
-    let wdrls = mkWithdrawals
-            networkId
-            (toChimericAccountRaw . toXPub $ rewardAcnt)
-            (withdrawal cs)
-        unsigned = mkUnsignedTx timeToLive cs md wdrls certs
-    in (unsigned, wdrls)
-
 mkTx
     :: forall k. (TxWitnessTagFor k, WalletKey k)
     => Cardano.NetworkId
     -> TxPayload Cardano.Shelley
     -> SlotNo
-    -- ^ Time to Live
+    -- ^ Tip of chain, for calculating TTL
     -> (XPrv, Passphrase "encryption")
     -- ^ Reward account
     -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
     -> CoinSelection
     -> Either ErrMkTx (Tx, SealedTx, SlotNo)
 mkTx networkId (TxPayload md certs mkExtraWits) tip (rewardAcnt, pwdAcnt) keyFrom cs = do
+    let wdrls = mkWithdrawals
+            networkId
+            (toChimericAccountRaw . toXPub $ rewardAcnt)
+            (withdrawal cs)
+
     let timeToLive = defaultTTL tip
-    let (unsigned, wdrls) = mkTxUnsigned networkId certs md timeToLive rewardAcnt cs
+    let unsigned = mkUnsignedTx timeToLive cs md wdrls certs
 
     wits <- case (txWitnessTagFor @k) of
         TxWitnessShelleyUTxO -> do

specifications/api/swagger.yaml

@@ -531,19 +531,23 @@ x-transactionOutputs: &transactionOutputs
       amount: *transactionAmount
 
 x-delegationAction: &delegationAction
-  description: A delegation action
+  description: |
+    A delegation action.
+
+    Pool id is only required for "join" and "register_key_and_join".
   type: object
   required:
     - action
   properties:
     action:
       type: string
-      enum: ["quit", "join"]
+      enum: ["quit", "join", "register_key_and_join"]
     pool: *stakePoolId
 
 x-rewardAccountPath: &rewardAccountPath
   type: array
-  minItems: 1
+  minItems: 5
+  maxItems: 5
   items:
     type: string