From e3b9d6f7de22f672f306a5c51e0a418905ca2a11 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 9 Oct 2020 17:39:52 +0200 Subject: [PATCH 01/25] Unsigned delegation --- lib/core/src/Cardano/Wallet.hs | 268 +++++++++++++----- lib/core/src/Cardano/Wallet/Api/Server.hs | 98 +++++-- lib/core/src/Cardano/Wallet/Api/Types.hs | 99 ++++++- .../Wallet/Primitive/AddressDerivation.hs | 62 +++- .../Primitive/AddressDiscovery/Sequential.hs | 39 +-- lib/core/src/Cardano/Wallet/Transaction.hs | 5 +- .../test/unit/Cardano/Wallet/Api/Malformed.hs | 25 +- .../test/unit/Cardano/Wallet/Api/TypesSpec.hs | 45 ++- .../Cardano/Wallet/Jormungandr/Api/Server.hs | 20 +- .../src/Cardano/Wallet/Shelley/Api/Server.hs | 36 ++- .../src/Cardano/Wallet/Shelley/Transaction.hs | 62 +++- lib/text-class/src/Data/Text/Class.hs | 32 ++- lib/text-class/text-class.cabal | 1 + nix/.stack.nix/cardano-wallet-cli.nix | 2 +- nix/.stack.nix/cardano-wallet.nix | 2 +- nix/.stack.nix/text-class.nix | 1 + specifications/api/swagger.yaml | 55 +++- 17 files changed, 685 insertions(+), 167 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 2ab2a0834a4..24d2e1af0a9 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -125,7 +125,9 @@ module Cardano.Wallet -- ** Delegation , PoolRetirementEpochInfo (..) , joinStakePool + , joinStakePoolUnsigned , quitStakePool + , quitStakePoolUnsigned , selectCoinsForDelegation , estimateFeeForDelegation , signDelegation @@ -181,7 +183,7 @@ import Prelude hiding ( log ) import Cardano.Address.Derivation - ( XPrv ) + ( XPrv, XPub ) import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer @@ -220,6 +222,7 @@ import Cardano.Wallet.Primitive.AddressDerivation , NetworkDiscriminant (..) , Passphrase , PaymentAddress (..) + , SoftDerivation , ToChimericAccount (..) , WalletKey (..) , checkPassphrase @@ -227,6 +230,7 @@ import Cardano.Wallet.Primitive.AddressDerivation , encryptPassphrase , liftIndex , preparePassphrase + , stakePath ) import Cardano.Wallet.Primitive.AddressDerivation.Byron ( ByronKey, unsafeMkByronKeyFromMasterKey ) @@ -1688,47 +1692,18 @@ selectCoinsExternal ctx wid argGenChange payments withdrawal md = do putCheckpoint (PrimaryKey wid) (updateState s' cp) pure (cs', s') UnsignedTx - <$> (fullyQualifiedInputs s' cs' >>= flip ensureNonEmpty - ErrSelectCoinsExternalUnableToAssignInputs) + <$> (fullyQualifiedInputs s' cs' + (ErrSelectCoinsExternalUnableToAssignInputs $ ErrNoSuchWallet wid)) <*> ensureNonEmpty (outputs cs') - ErrSelectCoinsExternalUnableToAssignOutputs + (ErrSelectCoinsExternalUnableToAssignOutputs $ ErrNoSuchWallet wid) where db = ctx ^. dbLayer @s @k - fullyQualifiedInputs - :: s - -> CoinSelection - -> ExceptT - (ErrSelectCoinsExternal e) - IO - [(TxIn, TxOut, NonEmpty DerivationIndex)] - fullyQualifiedInputs s cs = - traverse withDerivationPath (inputs cs) - where - withDerivationPath - :: (TxIn, TxOut) - -> ExceptT - (ErrSelectCoinsExternal e) - IO - (TxIn, TxOut, NonEmpty DerivationIndex) - withDerivationPath (txin, txout) = do - case fst $ isOurs (address txout) s of - Nothing -> throwE $ ErrSelectCoinsExternalUnableToAssignInputs wid - Just path -> pure (txin, txout, path) - - ensureNonEmpty - :: forall a. [a] - -> (WalletId -> ErrSelectCoinsExternal e) - -> ExceptT (ErrSelectCoinsExternal e) IO (NonEmpty a) - ensureNonEmpty mxs err = case NE.nonEmpty mxs of - Nothing -> throwE $ err wid - Just xs -> pure xs - data ErrSelectCoinsExternal e = ErrSelectCoinsExternalNoSuchWallet ErrNoSuchWallet | ErrSelectCoinsExternalUnableToMakeSelection (ErrSelectForPayment e) - | ErrSelectCoinsExternalUnableToAssignInputs WalletId - | ErrSelectCoinsExternalUnableToAssignOutputs WalletId + | ErrSelectCoinsExternalUnableToAssignInputs ErrNoSuchWallet + | ErrSelectCoinsExternalUnableToAssignOutputs ErrNoSuchWallet deriving (Eq, Show) signDelegation @@ -1972,19 +1947,17 @@ getTransaction ctx wid tid = db & \DBLayer{..} -> do Delegation -------------------------------------------------------------------------------} --- | Helper function to factor necessary logic for joining a stake pool. -joinStakePool - :: forall ctx s t k. +-- | Get the coin selection and certificate info for joining a stake pool. +-- Don't create a signed transaction. +joinStakePoolUnsigned + :: forall ctx s t k n. ( HasDBLayer s k ctx , HasLogger WalletLog ctx - , HasNetworkLayer t ctx , HasTransactionLayer t k ctx - , IsOwned s k - , IsOurs s ChimericAccount - , GenChange s - , HardDerivation k - , AddressIndexDerivationType k ~ 'Soft - , WalletKey k + , SoftDerivation k + , s ~ SeqState n k + , MkKeyFingerprint k Address + , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) ) => ctx -> W.EpochNo @@ -1992,12 +1965,40 @@ joinStakePool -> PoolId -> PoolLifeCycleStatus -> WalletId - -> ArgGenChange s - -> Passphrase "raw" - -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime) -joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd = + -> ExceptT ErrJoinStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, [DerivationIndex]) +joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid = db & \DBLayer{..} -> do + (wal, _, _) <- withExceptT + ErrJoinStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) + (cs, action, sPath) <- + joinStakePoolUnsigned' @ctx @s @t @k @n + ctx currentEpoch knownPools pid poolStatus wid + + utx <- UnsignedTx + <$> (fullyQualifiedInputs (getState wal) cs + (ErrJoinStakePoolUnableToAssignInputs $ ErrNoSuchWallet wid)) + <*> ensureNonEmpty (outputs cs) + (ErrJoinStakePoolUnableToAssignOutputs $ ErrNoSuchWallet wid) + pure (utx, action, sPath) + where + db = ctx ^. dbLayer @s @k +joinStakePoolUnsigned' + :: forall ctx s t k n. + ( HasDBLayer s k ctx + , HasLogger WalletLog ctx + , HasTransactionLayer t k ctx + , s ~ SeqState n k + ) + => ctx + -> W.EpochNo + -> Set PoolId + -> PoolId + -> PoolLifeCycleStatus + -> WalletId + -> ExceptT ErrJoinStakePool IO (CoinSelection, DelegationAction, [DerivationIndex]) +joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = + db & \DBLayer{..} -> do (isKeyReg, walMeta) <- mapExceptT atomically $ withExceptT ErrJoinStakePoolNoSuchWallet $ (,) <$> isStakeKeyRegistered (PrimaryKey wid) @@ -2014,9 +2015,52 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd = let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg - selection <- withExceptT ErrJoinStakePoolSelectCoin $ + cs <- withExceptT ErrJoinStakePoolSelectCoin $ selectCoinsForDelegation @ctx @s @t @k ctx wid action + cp <- mapExceptT atomically + $ withExceptT ErrJoinStakePoolNoSuchWallet + $ withNoSuchWallet wid + $ readCheckpoint (PrimaryKey wid) + let s = getState cp + dprefix = Seq.derivationPrefix s + sPath = stakePath dprefix + + pure (cs, action, sPath) + + where + db = ctx ^. dbLayer @s @k + tr = ctx ^. logger + +-- | Helper function to factor necessary logic for joining a stake pool. +joinStakePool + :: forall ctx s t k n. + ( HasDBLayer s k ctx + , HasLogger WalletLog ctx + , HasTransactionLayer t k ctx + , IsOwned s k + , IsOurs s ChimericAccount + , GenChange s + , AddressIndexDerivationType k ~ 'Soft + , WalletKey k + , s ~ SeqState n k + , SoftDerivation k + , HasNetworkLayer t ctx + ) + => ctx + -> W.EpochNo + -> Set PoolId + -> PoolId + -> PoolLifeCycleStatus + -> WalletId + -> ArgGenChange s + -> Passphrase "raw" + -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime) +joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd = + db & \DBLayer{..} -> do + (selection, action, _) <- joinStakePoolUnsigned' @ctx @s @t @k + ctx currentEpoch knownPools pid poolStatus wid + (tx, txMeta, txTime, sealedTx) <- withExceptT ErrJoinStakePoolSignDelegation $ signDelegation @@ -2028,11 +2072,76 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd = pure (tx, txMeta, txTime) where db = ctx ^. dbLayer @s @k - tr = ctx ^. logger + +-- | Quit stake pool and return the coin selection and certificates. +-- Don't create a signed transaction. +quitStakePoolUnsigned + :: forall ctx s t k n. + ( HasDBLayer s k ctx + , HasLogger WalletLog ctx + , HasTransactionLayer t k ctx + , SoftDerivation k + , s ~ SeqState n k + , MkKeyFingerprint k Address + , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) + ) + => ctx + -> WalletId + -> ExceptT ErrQuitStakePool IO + (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), + DelegationAction, [DerivationIndex]) +quitStakePoolUnsigned ctx wid = db & \DBLayer{..} -> do + (wal, _, _) <- withExceptT + ErrQuitStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) + (cs, action, sPath) <- quitStakePoolUnsigned' @ctx @s @t @k @n ctx wid + + utx <- UnsignedTx + <$> (fullyQualifiedInputs (getState wal) cs + (ErrQuitStakePoolUnableToAssignInputs $ ErrNoSuchWallet wid)) + <*> ensureNonEmpty (outputs cs) + (ErrQuitStakePoolUnableToAssignOutputs $ ErrNoSuchWallet wid) + pure (utx, action, sPath) + where + db = ctx ^. dbLayer @s @k + +quitStakePoolUnsigned' + :: forall ctx s t k n. + ( HasDBLayer s k ctx + , HasLogger WalletLog ctx + , HasTransactionLayer t k ctx + , s ~ SeqState n k + ) + => ctx + -> WalletId + -> ExceptT ErrQuitStakePool IO (CoinSelection, DelegationAction, [DerivationIndex]) +quitStakePoolUnsigned' ctx wid = db & \DBLayer{..} -> do + walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $ + withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) + + rewards <- liftIO $ fetchRewardBalance @ctx @s @k ctx wid + withExceptT ErrQuitStakePoolCannotQuit $ except $ + guardQuit (walMeta ^. #delegation) rewards + + let action = Quit + + cs <- withExceptT ErrQuitStakePoolSelectCoin $ + selectCoinsForDelegation @ctx @s @t @k ctx wid action + + cp <- mapExceptT atomically + $ withExceptT ErrQuitStakePoolNoSuchWallet + $ withNoSuchWallet wid + $ readCheckpoint (PrimaryKey wid) + let s = getState cp + dprefix = Seq.derivationPrefix s + sPath = stakePath dprefix + + pure (cs, action, sPath) + where + db = ctx ^. dbLayer @s @k -- | Helper function to factor necessary logic for quitting a stake pool. quitStakePool - :: forall ctx s t k. + :: forall ctx s t k n. ( HasDBLayer s k ctx , HasLogger WalletLog ctx , HasNetworkLayer t ctx @@ -2040,9 +2149,10 @@ quitStakePool , IsOwned s k , IsOurs s ChimericAccount , GenChange s - , HardDerivation k , AddressIndexDerivationType k ~ 'Soft , WalletKey k + , s ~ SeqState n k + , SoftDerivation k ) => ctx -> WalletId @@ -2050,17 +2160,8 @@ quitStakePool -> Passphrase "raw" -> ExceptT ErrQuitStakePool IO (Tx, TxMeta, UTCTime) quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do - walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $ - withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) - - rewards <- liftIO $ fetchRewardBalance @ctx @s @k ctx wid - withExceptT ErrQuitStakePoolCannotQuit $ except $ - guardQuit (walMeta ^. #delegation) rewards - - let action = Quit - - selection <- withExceptT ErrQuitStakePoolSelectCoin $ - selectCoinsForDelegation @ctx @s @t @k ctx wid action + (selection, action, _) <- quitStakePoolUnsigned' @ctx @s @t @k + ctx wid (tx, txMeta, txTime, sealedTx) <- withExceptT ErrQuitStakePoolSignDelegation $ signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection action @@ -2331,6 +2432,8 @@ data ErrStartTimeLaterThanEndTime = ErrStartTimeLaterThanEndTime data ErrSelectForDelegation = ErrSelectForDelegationNoSuchWallet ErrNoSuchWallet | ErrSelectForDelegationFee ErrAdjustForFee + | ErrSelectForDelegationUnableToAssignInputs ErrNoSuchWallet + | ErrSelectForDelegationUnableToAssignOutputs ErrNoSuchWallet deriving (Show, Eq) -- | Errors that can occur when signing a delegation certificate. @@ -2347,6 +2450,8 @@ data ErrJoinStakePool | ErrJoinStakePoolSignDelegation ErrSignDelegation | ErrJoinStakePoolSubmitTx ErrSubmitTx | ErrJoinStakePoolCannotJoin ErrCannotJoin + | ErrJoinStakePoolUnableToAssignInputs ErrNoSuchWallet + | ErrJoinStakePoolUnableToAssignOutputs ErrNoSuchWallet deriving (Generic, Eq, Show) data ErrQuitStakePool @@ -2355,6 +2460,8 @@ data ErrQuitStakePool | ErrQuitStakePoolSignDelegation ErrSignDelegation | ErrQuitStakePoolSubmitTx ErrSubmitTx | ErrQuitStakePoolCannotQuit ErrCannotQuit + | ErrQuitStakePoolUnableToAssignInputs ErrNoSuchWallet + | ErrQuitStakePoolUnableToAssignOutputs ErrNoSuchWallet deriving (Generic, Eq, Show) -- | Errors that can occur when fetching the reward balance of a wallet @@ -2494,6 +2601,39 @@ guardCoinSelection minUtxoValue cs@CoinSelection{outputs, change} = do unless (L.null invalidTxOuts) $ Left (ErrUTxOTooSmall (getCoin minUtxoValue) (getCoin <$> invalidTxOuts)) +fullyQualifiedInputs + :: forall s e. + (IsOurs s Address) + => s + -> CoinSelection + -> e + -> ExceptT + e + IO + (NonEmpty (TxIn, TxOut, NonEmpty DerivationIndex)) +fullyQualifiedInputs s cs e = + traverse withDerivationPath (inputs cs) >>= flip ensureNonEmpty e + where + withDerivationPath + :: (TxIn, TxOut) + -> ExceptT + e + IO + (TxIn, TxOut, NonEmpty DerivationIndex) + withDerivationPath (txin, txout) = do + case fst $ isOurs (address txout) s of + Nothing -> throwE e + Just path -> pure (txin, txout, path) + +ensureNonEmpty + :: forall a e. + [a] + -> e + -> ExceptT e IO (NonEmpty a) +ensureNonEmpty mxs err = case NE.nonEmpty mxs of + Nothing -> throwE err + Just xs -> pure xs + {------------------------------------------------------------------------------- Logging -------------------------------------------------------------------------------} diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 47fdaf605fd..9a590ed64d9 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -49,6 +49,8 @@ module Cardano.Wallet.Api.Server , getUTxOsStatistics , getWallet , joinStakePool + , selectCoinsJoinStakePool + , selectCoinsQuitStakePool , listAddresses , listTransactions , getTransaction @@ -176,7 +178,7 @@ import Cardano.Wallet.Api.Types , ApiPoolId (..) , ApiPostRandomAddressData (..) , ApiPutAddressesData (..) - , ApiSelectCoinsData (..) + , ApiSelectCoinsPayments , ApiSlotId (..) , ApiSlotReference (..) , ApiT (..) @@ -310,7 +312,7 @@ import Cardano.Wallet.Registry , workerResource ) import Cardano.Wallet.Transaction - ( TransactionLayer ) + ( DelegationAction (..), TransactionLayer ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) import Control.Arrow @@ -352,7 +354,7 @@ import Data.Generics.Labels import Data.List ( isInfixOf, isSubsequenceOf, sortOn ) import Data.List.NonEmpty - ( NonEmpty ) + ( NonEmpty (..) ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -1116,10 +1118,10 @@ selectCoins => ctx -> ArgGenChange s -> ApiT WalletId - -> ApiSelectCoinsData n + -> ApiSelectCoinsPayments n -> Handler (ApiCoinSelection n) selectCoins ctx gen (ApiT wid) body = - fmap mkApiCoinSelection + fmap (mkApiCoinSelection Nothing) $ withWorkerCtx ctx wid liftE liftE $ \wrk -> do -- TODO: @@ -1128,6 +1130,50 @@ selectCoins ctx gen (ApiT wid) body = let outs = coerceCoin <$> body ^. #payments liftHandler $ W.selectCoinsExternal @_ @s @t @k wrk wid gen outs withdrawal Nothing +selectCoinsJoinStakePool + :: forall ctx s t n k. + ( s ~ SeqState n k + , ctx ~ ApiLayer s t k + , SoftDerivation k + , MkKeyFingerprint k Address + , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) + ) + => ctx + -> IO (Set PoolId) + -- ^ Known pools + -- We could maybe replace this with a @IO (PoolId -> Bool)@ + -> (PoolId -> IO PoolLifeCycleStatus) + -> PoolId + -> WalletId + -> Handler (Api.ApiCoinSelection n) +selectCoinsJoinStakePool ctx knownPools getPoolStatus pid wid = do + poolStatus <- liftIO (getPoolStatus pid) + pools <- liftIO knownPools + curEpoch <- getCurrentEpoch ctx + + (utx, action, spath) <- withWorkerCtx ctx wid liftE liftE $ + \wrk -> liftHandler $ + W.joinStakePoolUnsigned + @_ @s @t @k wrk + curEpoch pools pid poolStatus wid + pure $ mkApiCoinSelection (Just (action, spath)) utx + +selectCoinsQuitStakePool + :: forall ctx s t n k. + ( s ~ SeqState n k + , ctx ~ ApiLayer s t k + , SoftDerivation k + , MkKeyFingerprint k Address + , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) + ) + => ctx + -> ApiT WalletId + -> Handler (Api.ApiCoinSelection n) +selectCoinsQuitStakePool ctx (ApiT wid) = do + (utx, action, spath) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ + W.quitStakePoolUnsigned @_ @s @t @k wrk wid + pure $ mkApiCoinSelection (Just (action, spath)) utx + {------------------------------------------------------------------------------- Addresses -------------------------------------------------------------------------------} @@ -1393,7 +1439,7 @@ joinStakePool , IsOurs s ChimericAccount , IsOwned s k , GenChange s - , HardDerivation k + , SoftDerivation k , AddressIndexDerivationType k ~ 'Soft , WalletKey k , ctx ~ ApiLayer s t k @@ -1458,9 +1504,9 @@ quitStakePool , IsOwned s k , GenChange s , HasNetworkLayer t ctx - , HardDerivation k , AddressIndexDerivationType k ~ 'Soft , WalletKey k + , SoftDerivation k , ctx ~ ApiLayer s t k ) => ctx @@ -1778,13 +1824,27 @@ rndStateChange ctx (ApiT wid) pwd = -- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'. mkApiCoinSelection :: forall n. () - => UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex) + => Maybe (DelegationAction, [DerivationIndex]) + -> UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex) -> ApiCoinSelection n -mkApiCoinSelection (UnsignedTx inputs outputs) = +mkApiCoinSelection mcerts (UnsignedTx inputs outputs) = ApiCoinSelection (mkApiCoinSelectionInput <$> inputs) (mkAddressAmount <$> outputs) + (fmap (uncurry mkCertificates) mcerts) where + mkCertificates :: DelegationAction -> [DerivationIndex] -> [Api.ApiCertificate] + mkCertificates action (s:sx) = + let apiStakePath = ApiT <$> (s:|sx) + 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] + mkCertificates _ _ = [] + mkAddressAmount :: TxOut -> AddressAmount (ApiT Address, Proxy n) mkAddressAmount (TxOut addr (Coin c)) = AddressAmount (ApiT addr, Proxy @n) (Quantity $ fromIntegral c) @@ -2137,18 +2197,8 @@ instance Buildable e => LiftHandler (ErrSelectCoinsExternal e) where handler e ErrSelectCoinsExternalUnableToMakeSelection e -> handler e - ErrSelectCoinsExternalUnableToAssignInputs wid -> - apiError err500 UnexpectedError $ mconcat - [ "I was unable to assign inputs while generating a coin " - , "selection for the specified wallet: " - , toText wid - ] - ErrSelectCoinsExternalUnableToAssignOutputs wid -> - apiError err500 UnexpectedError $ mconcat - [ "I was unable to assign outputs while generating a coin " - , "selection for the specified wallet: " - , toText wid - ] + ErrSelectCoinsExternalUnableToAssignInputs e -> handler e + ErrSelectCoinsExternalUnableToAssignOutputs e -> handler e instance Buildable e => LiftHandler (ErrCoinSelection e) where handler = \case @@ -2413,6 +2463,8 @@ instance LiftHandler ErrSelectForDelegation where [ "I'm unable to select enough coins to pay for a " , "delegation certificate. I need: ", showT cost, " Lovelace." ] + ErrSelectForDelegationUnableToAssignInputs e -> handler e + ErrSelectForDelegationUnableToAssignOutputs e -> handler e instance LiftHandler ErrSignDelegation where handler = \case @@ -2447,6 +2499,8 @@ instance LiftHandler ErrJoinStakePool where [ "I couldn't find any stake pool with the given id: " , toText pid ] + ErrJoinStakePoolUnableToAssignInputs e -> handler e + ErrJoinStakePoolUnableToAssignOutputs e -> handler e instance LiftHandler ErrFetchRewards where handler = \case @@ -2483,6 +2537,8 @@ instance LiftHandler ErrQuitStakePool where , "account! Make sure to withdraw your ", pretty rewards , " lovelace first." ] + ErrQuitStakePoolUnableToAssignInputs e -> handler e + ErrQuitStakePoolUnableToAssignOutputs e -> handler e instance LiftHandler ErrCreateRandomAddress where handler = \case diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 1f780f59e02..57f39fd543d 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -42,8 +42,12 @@ module Cardano.Wallet.Api.Types -- * API Types , ApiAddress (..) + , ApiRelativeDerivationIndex (..) + , ApiCertificate (..) , ApiEpochInfo (..) , ApiSelectCoinsData (..) + , ApiSelectCoinsPayments (..) + , ApiSelectCoinsAction (..) , ApiCoinSelection (..) , ApiCoinSelectionInput (..) , ApiStakePool (..) @@ -199,6 +203,8 @@ import Cardano.Wallet.Primitive.Types , txMetadataIsNull , unsafeEpochNo ) +import Cardano.Wallet.Transaction + ( DelegationAction (..) ) import Control.Applicative ( optional, (<|>) ) import Control.Arrow @@ -209,7 +215,7 @@ import Data.Aeson ( FromJSON (..) , SumEncoding (..) , ToJSON (..) - , Value (Object) + , Value (Object, String) , camelTo2 , constructorTagModifier , fieldLabelModifier @@ -372,18 +378,49 @@ data ApiAddress (n :: NetworkDiscriminant) = ApiAddress , state :: !(ApiT AddressState) } deriving (Eq, Generic, Show) +-- | Represents a relative address index. +-- +-- The range of this type is exactly half that of a 'Word32'. +-- +newtype ApiRelativeDerivationIndex = ApiRelativeDerivationIndex + { unApiRelativeDerivationIndex :: Word31 + } deriving (Bounded, Enum, Eq, Generic, Show) + data ApiEpochInfo = ApiEpochInfo { epochNumber :: !(ApiT EpochNo) , epochStartTime :: !UTCTime } deriving (Eq, Generic, Show) -newtype ApiSelectCoinsData (n :: NetworkDiscriminant) = ApiSelectCoinsData +data ApiSelectCoinsData (n :: NetworkDiscriminant) + = ApiSelectForPayment (ApiSelectCoinsPayments n) + | ApiSelectForAction ApiSelectCoinsAction + deriving (Eq, Generic, Show) + +newtype ApiSelectCoinsPayments (n :: NetworkDiscriminant) = ApiSelectCoinsPayments { payments :: NonEmpty (AddressAmount (ApiT Address, Proxy n)) } deriving (Eq, Generic, Show) +newtype ApiSelectCoinsAction = ApiSelectCoinsAction + { delegation_action :: ApiT DelegationAction + } deriving (Eq, Generic, Show) + +data ApiCertificate + = RegisterRewardAccount + { reward_account_path :: NonEmpty (ApiT DerivationIndex) + } + | JoinPool + { reward_account_path :: NonEmpty (ApiT DerivationIndex) + , pool :: ApiT PoolId + } + | QuitPool + { reward_account_path :: NonEmpty (ApiT DerivationIndex) + } + deriving (Eq, Generic, Show) + data ApiCoinSelection (n :: NetworkDiscriminant) = ApiCoinSelection { inputs :: !(NonEmpty (ApiCoinSelectionInput n)) , outputs :: !(NonEmpty (AddressAmount (ApiT Address, Proxy n))) + , certificates :: Maybe [ApiCertificate] } deriving (Eq, Generic, Show) data ApiCoinSelectionInput (n :: NetworkDiscriminant) = ApiCoinSelectionInput @@ -693,6 +730,7 @@ data ApiPostRandomAddressData = ApiPostRandomAddressData , addressIndex :: !(Maybe (ApiT (Index 'AD.Hardened 'AddressK))) } deriving (Eq, Generic, Show) + data ApiWalletMigrationPostData (n :: NetworkDiscriminant) (s :: Symbol) = ApiWalletMigrationPostData { passphrase :: !(ApiT (Passphrase s)) @@ -991,16 +1029,69 @@ instance FromJSON ApiEpochInfo where instance ToJSON ApiEpochInfo where toJSON = genericToJSON defaultRecordTypeOptions -instance DecodeAddress n => FromJSON (ApiSelectCoinsData n) where +instance FromJSON ApiSelectCoinsAction where parseJSON = genericParseJSON defaultRecordTypeOptions -instance EncodeAddress n => ToJSON (ApiSelectCoinsData n) where +instance ToJSON ApiSelectCoinsAction where toJSON = genericToJSON defaultRecordTypeOptions +instance DecodeAddress n => FromJSON (ApiSelectCoinsPayments n) where + parseJSON = genericParseJSON defaultRecordTypeOptions +instance EncodeAddress n => ToJSON (ApiSelectCoinsPayments n) where + toJSON = genericToJSON defaultRecordTypeOptions + +instance DecodeAddress n => FromJSON (ApiSelectCoinsData n) where + parseJSON = withObject "DelegationAction" $ \o -> do + p <- o .:? "payments" + a <- o .:? "delegation_action" + case (p, a) of + (Just _, Just _) -> fail "Specified both payments and action, pick one" + (Nothing, Just v) -> + pure $ ApiSelectForAction $ ApiSelectCoinsAction v + (Just v, Nothing) -> + pure $ ApiSelectForPayment $ ApiSelectCoinsPayments v + _ -> fail "No valid parse" +instance EncodeAddress n => ToJSON (ApiSelectCoinsData n) where + toJSON (ApiSelectForPayment v) = toJSON v + toJSON (ApiSelectForAction v) = toJSON v + instance DecodeAddress n => FromJSON (ApiCoinSelection n) where parseJSON = genericParseJSON defaultRecordTypeOptions instance EncodeAddress n => ToJSON (ApiCoinSelection n) where toJSON = genericToJSON defaultRecordTypeOptions +apiCertificateOptions :: Aeson.Options +apiCertificateOptions = Aeson.defaultOptions + { constructorTagModifier = camelTo2 '_' + , tagSingleConstructors = True + , fieldLabelModifier = camelTo2 '_' . dropWhile (== '_') + , omitNothingFields = True + , sumEncoding = TaggedObject + { + tagFieldName = "delegation_type" + , contentsFieldName = "contents" + } + } + +instance FromJSON ApiCertificate where + parseJSON = genericParseJSON apiCertificateOptions + +instance ToJSON ApiCertificate where + toJSON = genericToJSON apiCertificateOptions + +instance FromJSON (ApiT DelegationAction) where + parseJSON = withObject "DelegationAction" $ \o -> + o .: "action" >>= \case + "join" -> do + pid <- o .: "pool" + pure (ApiT $ Join (getApiT pid)) + "quit" -> pure $ ApiT Quit + val -> fail ("Unexpeced action value: " <> T.unpack val) + +instance ToJSON (ApiT DelegationAction) where + toJSON (ApiT (RegisterKeyAndJoin _)) = error "RegisterKeyAndJoin not valid" + toJSON (ApiT (Join pid)) = object [ "action" .= String "join", "pool" .= (ApiT pid) ] + toJSON (ApiT Quit) = object [ "action" .= String "quit" ] + instance DecodeAddress n => FromJSON (ApiCoinSelectionInput n) where parseJSON = genericParseJSON defaultRecordTypeOptions instance EncodeAddress n => ToJSON (ApiCoinSelectionInput n) where diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs index 701a791c73f..ad6baaaa6e5 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs @@ -38,9 +38,12 @@ module Cardano.Wallet.Primitive.AddressDerivation , utxoExternal , utxoInternal , mutableAccount + , zeroAccount + , stakePath , DerivationType (..) , HardDerivation (..) , SoftDerivation (..) + , DerivationPrefix (..) , liftIndex -- * Delegation @@ -85,7 +88,12 @@ import Cardano.Address.Derivation import Cardano.Mnemonic ( SomeMnemonic ) import Cardano.Wallet.Primitive.Types - ( Address (..), ChimericAccount (..), Hash (..), PassphraseScheme (..) ) + ( Address (..) + , ChimericAccount (..) + , DerivationIndex (..) + , Hash (..) + , PassphraseScheme (..) + ) import Control.DeepSeq ( NFData ) import Control.Monad @@ -203,6 +211,21 @@ utxoInternal = toEnum $ fromEnum UTxOInternal mutableAccount :: Index 'Soft 'RoleK mutableAccount = toEnum $ fromEnum MutableAccount +zeroAccount :: Index 'Soft 'AddressK +zeroAccount = toEnum 0 + +-- | Full path to the stake key. There's only one. +stakePath :: DerivationPrefix -> [DerivationIndex] +stakePath (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 + -- | A derivation index, with phantom-types to disambiguate derivation type. -- -- @ @@ -277,6 +300,43 @@ instance LiftIndex 'Hardened where instance LiftIndex 'Soft where liftIndex (Index ix) = Index ix +-- | Each 'SeqState' is like a bucket of addresses associated with an 'account'. +-- An 'account' corresponds to a subset of an HD tree as defined in BIP-0039. +-- +-- cardano-wallet implements two similar HD schemes on top of BIP-0039 that are: +-- +-- - BIP-0044 (for so-called Icarus wallets) +-- - CIP-1815 (for so-called Shelley and Jormungandr wallets) +-- +-- Both scheme works by considering 5 levels of derivation from an initial root +-- key (see also 'Depth' from Cardano.Wallet.Primitive.AddressDerivation). A +-- SeqState keeps track of indexes from the two last levels of a derivation +-- branch. The 'DerivationPrefix' defines the first three indexes chosen for +-- this particular 'SeqState'. +newtype DerivationPrefix = DerivationPrefix + ( Index 'Hardened 'PurposeK + , Index 'Hardened 'CoinTypeK + , Index 'Hardened 'AccountK + ) deriving (Show, Generic, Eq, Ord) + +instance NFData DerivationPrefix + +instance ToText DerivationPrefix where + toText (DerivationPrefix (purpose, coinType, account)) + = T.intercalate "/" + $ map toText + [getIndex purpose, getIndex coinType, getIndex account] + +instance FromText DerivationPrefix where + fromText txt = + DerivationPrefix <$> case T.splitOn "/" txt of + [purposeT, coinTypeT, accountT] -> (,,) + <$> fromText purposeT + <*> fromText coinTypeT + <*> fromText accountT + _ -> + Left $ TextDecodingError "expected exactly 3 derivation paths" + -- | Type of derivation that should be used with the given indexes. -- -- In theory, we should only consider two derivation types: soft and hard. diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Sequential.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Sequential.hs index c48ae17d8ef..89f73055bd7 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Sequential.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Sequential.hs @@ -74,6 +74,7 @@ import Cardano.Crypto.Wallet import Cardano.Wallet.Primitive.AddressDerivation ( AccountingStyle (..) , Depth (..) + , DerivationPrefix (..) , DerivationType (..) , HardDerivation (..) , Index (..) @@ -590,44 +591,6 @@ instance PersistPublicKey (k 'AccountK) => Buildable (SeqState n k) where where chgsF = blockListF' "-" build (pendingIxsToList chgs) --- | Each 'SeqState' is like a bucket of addresses associated with an 'account'. --- An 'account' corresponds to a subset of an HD tree as defined in BIP-0039. --- --- cardano-wallet implements two similar HD schemes on top of BIP-0039 that are: --- --- - BIP-0044 (for so-called Icarus wallets) --- - CIP-1815 (for so-called Shelley and Jormungandr wallets) --- --- Both scheme works by considering 5 levels of derivation from an initial root --- key (see also 'Depth' from Cardano.Wallet.Primitive.AddressDerivation). A --- SeqState keeps track of indexes from the two last levels of a derivation --- branch. The 'DerivationPrefix' defines the first three indexes chosen for --- this particular 'SeqState'. -newtype DerivationPrefix = DerivationPrefix - ( Index 'Hardened 'PurposeK - , Index 'Hardened 'CoinTypeK - , Index 'Hardened 'AccountK - ) deriving (Show, Generic, Eq, Ord) - -instance NFData DerivationPrefix - -instance ToText DerivationPrefix where - toText (DerivationPrefix (purpose, coinType, account)) - = T.intercalate "/" - $ map (T.pack . show) - [getIndex purpose, getIndex coinType, getIndex account] - -instance FromText DerivationPrefix where - fromText txt = - DerivationPrefix <$> case T.splitOn "/" txt of - [purposeT, coinTypeT, accountT] -> (,,) - <$> fromText purposeT - <*> fromText coinTypeT - <*> fromText accountT - _ -> - Left $ TextDecodingError "expected exactly 3 derivation paths" - - -- | Purpose is a constant set to 44' (or 0x8000002C) following the original -- BIP-44 specification. -- diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs index 943719e7fd7..4b2f7bc17a7 100644 --- a/lib/core/src/Cardano/Wallet/Transaction.hs +++ b/lib/core/src/Cardano/Wallet/Transaction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,6 +47,8 @@ import Data.Text import Data.Word ( Word16, Word8 ) +import GHC.Generics + data TransactionLayer t k = TransactionLayer { mkStdTx :: (XPrv, Passphrase "encryption") @@ -158,7 +161,7 @@ data TransactionLayer t k = TransactionLayer -- | Whether the user is attempting any particular delegation action. data DelegationAction = RegisterKeyAndJoin PoolId | Join PoolId | Quit - deriving (Show) + deriving (Show, Eq, Generic) -- | A type family for validations that are specific to a particular backend -- type. This demands an instantiation of the family for a particular backend: diff --git a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs index adf23d296b7..b9d2ae37774 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs +++ b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs @@ -847,12 +847,31 @@ instance Malformed (BodyParam (ApiSelectCoinsData ('Testnet pm))) where malformed = jsonValid ++ jsonInvalid where jsonInvalid = first BodyParam <$> - [ ("1020344", "Error in $: parsing Cardano.Wallet.Api.Types.ApiSelectCoinsData(ApiSelectCoinsData) failed, expected Object, but encountered Number") - , ("\"1020344\"", "Error in $: parsing Cardano.Wallet.Api.Types.ApiSelectCoinsData(ApiSelectCoinsData) failed, expected Object, but encountered String") + [ ("1020344", "Error in $: parsing DelegationAction failed, expected Object, but encountered Number") + , ("\"1020344\"", "Error in $: parsing DelegationAction failed, expected Object, but encountered String") , ("\"slot_number : \"random\"}", "trailing junk after valid JSON: endOfInput") , ("{\"payments : [], \"random\"}", msgJsonInvalid) + , ("join", "I couldn't understand the content of your message. If your message is intended to be in JSON format, please check that the JSON is valid.") + , ("quit", msgJsonInvalid) + ] + jsonValid = (first (BodyParam . Aeson.encode) <$> paymentCases) <> jsonValidAction + jsonValidAction = first (BodyParam . Aeson.encode) <$> + [ ( [aesonQQ| { "action": "join" }|] + , "Error in $: No valid parse" + ) + , ( [aesonQQ| { "action": "" }|] + , "Error in $: No valid parse" + ) + , ( [aesonQQ| { "action": "join", "pool": "" }|] + , "Error in $: No valid parse" + ) + , ( [aesonQQ| { "action": "join", "pool": "1" }|] + , "Error in $: No valid parse" + ) + , ( [aesonQQ| { "pool": "pool1wqaz0q0zhtxlgn0ewssevn2mrtm30fgh2g7hr7z9rj5856457mm" }|] + , "Error in $: No valid parse" + ) ] - jsonValid = first (BodyParam . Aeson.encode) <$> paymentCases instance Malformed (BodyParam (PostTransactionData ('Testnet pm))) where malformed = jsonValid ++ jsonInvalid diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 12a9e39c603..3a013dd92f3 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -48,6 +48,7 @@ import Cardano.Wallet.Api.Types , ApiBlockReference (..) , ApiByronWallet (..) , ApiByronWalletBalance (..) + , ApiCertificate (..) , ApiCoinSelection (..) , ApiCoinSelectionInput (..) , ApiEpochInfo (..) @@ -59,7 +60,9 @@ import Cardano.Wallet.Api.Types , ApiNtpStatus (..) , ApiPostRandomAddressData , ApiPutAddressesData (..) + , ApiSelectCoinsAction (..) , ApiSelectCoinsData (..) + , ApiSelectCoinsPayments (..) , ApiSlotId (..) , ApiSlotReference (..) , ApiStakePool (..) @@ -167,6 +170,8 @@ import Cardano.Wallet.Primitive.Types , walletNameMaxLength , walletNameMinLength ) +import Cardano.Wallet.Transaction + ( DelegationAction (..) ) import Cardano.Wallet.Unsafe ( unsafeFromText, unsafeXPrv ) import Control.Lens @@ -602,8 +607,8 @@ spec = do x' === x .&&. show x' === show x it "ApiSelectCoinsData" $ property $ \x -> let - x' = ApiSelectCoinsData - { payments = payments (x :: ApiSelectCoinsData ('Testnet 0)) + x' = ApiSelectCoinsPayments + { payments = payments (x :: ApiSelectCoinsPayments ('Testnet 0)) } in x' === x .&&. show x' === show x @@ -612,6 +617,7 @@ spec = do x' = ApiCoinSelection { inputs = inputs (x :: ApiCoinSelection ('Testnet 0)) , outputs = outputs (x :: ApiCoinSelection ('Testnet 0)) + , certificates = certificates (x :: ApiCoinSelection ('Testnet 0)) } in x' === x .&&. show x' === show x @@ -911,12 +917,28 @@ instance Arbitrary ApiEpochInfo where arbitrary = ApiEpochInfo <$> arbitrary <*> genUniformTime shrink _ = [] +instance Arbitrary (ApiSelectCoinsPayments n) where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ApiSelectCoinsAction where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary (ApiSelectCoinsData n) where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary DelegationAction where + arbitrary = oneof [Join <$> arbitrary, pure Quit] + shrink _ = [] + +instance Arbitrary ApiCertificate where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary (ApiCoinSelection n) where - arbitrary = applyArbitrary2 ApiCoinSelection + arbitrary = ApiCoinSelection <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary (ApiCoinSelectionInput n) where @@ -1559,7 +1581,22 @@ instance ToSchema (ApiPutAddressesData t) where declareNamedSchema _ = declareSchemaForDefinition "ApiPutAddressesData" instance ToSchema (ApiSelectCoinsData n) where - declareNamedSchema _ = declareSchemaForDefinition "ApiSelectCoinsData" + declareNamedSchema _ = do + NamedSchema _ paymentData <- declareNamedSchema (Proxy @(ApiSelectCoinsPayments n)) + NamedSchema _ actionData <- declareNamedSchema (Proxy @ApiSelectCoinsAction) + pure $ NamedSchema Nothing $ mempty + & type_ .~ Just SwaggerObject + & required .~ [] + & properties .~ mconcat + [ paymentData ^. properties + , actionData ^. properties + ] + +instance ToSchema (ApiSelectCoinsPayments n) where + declareNamedSchema _ = declareSchemaForDefinition "ApiSelectCoinsPayments" + +instance ToSchema ApiSelectCoinsAction where + declareNamedSchema _ = declareSchemaForDefinition "ApiSelectCoinsAction" instance ToSchema (ApiCoinSelection n) where declareNamedSchema _ = declareSchemaForDefinition "ApiCoinSelection" diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs index aaab8710589..ef8c6b20b23 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- | -- Copyright: © 2018-2020 IOHK @@ -37,6 +38,7 @@ import Cardano.Wallet.Api , Api , ApiLayer (..) , ByronAddresses + , ByronCoinSelections , ByronMigrations , ByronTransactions , ByronWallets @@ -89,7 +91,11 @@ import Cardano.Wallet.Api.Server , withLegacyLayer' ) import Cardano.Wallet.Api.Types - ( ApiErrorCode (..), ApiT (..), SomeByronWalletPostData (..) ) + ( ApiErrorCode (..) + , ApiSelectCoinsData (..) + , ApiT (..) + , SomeByronWalletPostData (..) + ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..), NetworkDiscriminant (..), PaymentAddress ) import Cardano.Wallet.Primitive.AddressDerivation.Byron @@ -169,8 +175,16 @@ server byron icarus jormungandr spl ntp = addresses = listAddresses jormungandr (normalizeDelegationAddress @_ @JormungandrKey @n) :<|> (\_ -> throwError err501) + -- Hlint doesn't seem to care about inlining properties: + -- https://github.com/quchen/articles/blob/master/fbut.md#f-x---is-not-f--x--- + {-# HLINT ignore "Redundant lambda" #-} coinSelections :: Server (CoinSelections n) - coinSelections = selectCoins jormungandr (delegationAddress @n) + coinSelections = + \wid ascd -> case ascd of + (ApiSelectForPayment ascp) -> + selectCoins jormungandr (delegationAddress @n) wid ascp + (ApiSelectForAction _) -> + throwError err501 transactions :: Server (Transactions n) transactions = @@ -242,7 +256,7 @@ server byron icarus jormungandr spl ntp = :<|> (\_ _ -> throwError err501) :<|> (\_ _ -> throwError err501) - byronCoinSelections :: Server (CoinSelections n) + byronCoinSelections :: Server (ByronCoinSelections n) byronCoinSelections _ _ = throwError err501 byronTransactions :: Server (ByronTransactions n) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index a2341f1dc0b..35c9f875e14 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs @@ -6,6 +6,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + -- | -- Copyright: © 2018-2020 IOHK -- License: Apache-2.0 @@ -32,6 +34,7 @@ import Cardano.Wallet.Api , Api , ApiLayer (..) , ByronAddresses + , ByronCoinSelections , ByronMigrations , ByronTransactions , ByronWallets @@ -85,6 +88,8 @@ import Cardano.Wallet.Api.Server , quitStakePool , rndStateChange , selectCoins + , selectCoinsJoinStakePool + , selectCoinsQuitStakePool , withLegacyLayer , withLegacyLayer' ) @@ -92,6 +97,8 @@ import Cardano.Wallet.Api.Types ( ApiAddressInspect (..) , ApiAddressInspectData (..) , ApiErrorCode (..) + , ApiSelectCoinsAction (..) + , ApiSelectCoinsData (..) , ApiStakePool , ApiT (..) , SettingsPutData (..) @@ -113,6 +120,8 @@ import Cardano.Wallet.Shelley.Compatibility ( inspectAddress ) import Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) ) +import Cardano.Wallet.Transaction + ( DelegationAction (..) ) import Control.Applicative ( liftA2 ) import Control.Monad.IO.Class @@ -134,7 +143,7 @@ import Fmt import Network.Ntp ( NtpClient ) import Servant - ( (:<|>) (..), Handler (..), NoContent (..), Server, err400 ) + ( (:<|>) (..), Handler (..), NoContent (..), Server, err400, throwError ) import Servant.Server ( ServerError (..) ) import Type.Reflection @@ -192,8 +201,21 @@ server byron icarus shelley spl ntp = handler transform = Handler . withExceptT toServerError . except . fmap transform + -- Hlint doesn't seem to care about inlining properties: + -- https://github.com/quchen/articles/blob/master/fbut.md#f-x---is-not-f--x--- + {-# HLINT ignore "Redundant lambda" #-} coinSelections :: Server (CoinSelections n) - coinSelections = selectCoins shelley (delegationAddress @n) + coinSelections = (\wid ascd -> case ascd of + (ApiSelectForPayment ascp) -> selectCoins shelley (delegationAddress @n) wid ascp + (ApiSelectForAction (ApiSelectCoinsAction (ApiT action))) -> case action of + Join pid -> selectCoinsJoinStakePool + shelley + (knownPools spl) + (getPoolLifeCycleStatus spl) + pid + (getApiT wid) + RegisterKeyAndJoin _ -> throwError err400 + Quit -> selectCoinsQuitStakePool shelley wid) transactions :: Server (Transactions n) transactions = @@ -285,10 +307,12 @@ server byron icarus shelley spl ntp = (icarus, listAddresses icarus (const pure) wid s) ) - byronCoinSelections :: Server (CoinSelections n) - byronCoinSelections wid x = withLegacyLayer wid - (byron, liftHandler $ throwE ErrNotASequentialWallet) - (icarus, selectCoins icarus (const $ paymentAddress @n) wid x) + byronCoinSelections :: Server (ByronCoinSelections n) + byronCoinSelections wid (ApiSelectForPayment x) = + withLegacyLayer wid + (byron, liftHandler $ throwE ErrNotASequentialWallet) + (icarus, selectCoins icarus (const $ paymentAddress @n) wid x) + byronCoinSelections _ _ = throwError err400 byronTransactions :: Server (ByronTransactions n) byronTransactions = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index a6856bf2859..e9d472f39d4 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -109,6 +109,8 @@ 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 @@ -172,25 +174,40 @@ instance TxWitnessTagFor IcarusKey where 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 - -- ^ Tip of chain, for calculating TTL + -- ^ Time to Live -> (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 = mkUnsignedTx timeToLive cs md wdrls certs + let (unsigned, wdrls) = mkTxUnsigned networkId certs md timeToLive rewardAcnt cs wits <- case (txWitnessTagFor @k) of TxWitnessShelleyUTxO -> do @@ -265,19 +282,17 @@ newTransactionLayer networkId = TransactionLayer _mkDelegationJoinTx poolId acc@(accXPrv, pwd') keyFrom tip cs = do let accXPub = toXPub accXPrv let certs = - if deposit cs > 0 then - [ toStakeKeyRegCert accXPub - , toStakePoolDlgCert accXPub poolId - ] - else - [ toStakePoolDlgCert accXPub poolId ] + if deposit cs > 0 + then mkDelegationCertificates (RegisterKeyAndJoin poolId) accXPub + else mkDelegationCertificates (Join poolId) accXPub let mkWits unsigned = [ mkShelleyWitness unsigned (accXPrv, pwd') ] let payload = TxPayload Nothing certs mkWits - mkTx networkId payload tip acc keyFrom cs + let ttl = defaultTTL tip + mkTx networkId payload ttl acc keyFrom cs _mkDelegationQuitTx :: (XPrv, Passphrase "encryption") @@ -298,7 +313,24 @@ newTransactionLayer networkId = TransactionLayer ] let payload = TxPayload Nothing certs mkWits - mkTx networkId payload tip acc keyFrom cs + let ttl = defaultTTL tip + mkTx networkId payload ttl acc keyFrom cs + +mkDelegationCertificates + :: DelegationAction + -- Pool Id to which we're planning to delegate + -> XPub + -- Reward account public key + -> [Cardano.Certificate] +mkDelegationCertificates da accXPub = + case da of + Join poolId -> + [ toStakePoolDlgCert accXPub poolId ] + RegisterKeyAndJoin poolId -> + [ toStakeKeyRegCert accXPub + , toStakePoolDlgCert accXPub poolId + ] + Quit -> [toStakeKeyDeregCert accXPub] _estimateMaxNumberOfInputs :: forall k. TxWitnessTagFor k diff --git a/lib/text-class/src/Data/Text/Class.hs b/lib/text-class/src/Data/Text/Class.hs index cda90df20fb..c7b86a743b2 100644 --- a/lib/text-class/src/Data/Text/Class.hs +++ b/lib/text-class/src/Data/Text/Class.hs @@ -48,6 +48,10 @@ import Data.Text ( Text ) import Data.Text.Read ( decimal, signed ) +import Data.Word + ( Word32, Word64 ) +import Data.Word.Odd + ( Word31 ) import Fmt ( Buildable ) import GHC.Generics @@ -59,6 +63,11 @@ import Text.Read import qualified Data.Char as C import qualified Data.Text as T +import qualified Data.Text.Lazy as T + ( toStrict ) +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.Int as B +import qualified Data.Text.Lazy.Builder.RealFloat as B import qualified Text.Casing as Casing -- | Defines a textual encoding for a type. @@ -103,7 +112,7 @@ instance FromText Int where <> "." instance ToText Int where - toText = T.pack . show + toText = intToText instance FromText Natural where fromText t = do @@ -114,7 +123,7 @@ instance FromText Natural where err = TextDecodingError "Expecting natural number" instance ToText Natural where - toText = T.pack . show + toText = intToText instance FromText Integer where fromText t = do @@ -125,7 +134,7 @@ instance FromText Integer where err = TextDecodingError "Expecting integer" instance ToText Integer where - toText = T.pack . show + toText = intToText instance FromText Double where fromText = first (const err) . readEither . T.unpack @@ -133,7 +142,22 @@ instance FromText Double where err = TextDecodingError "Expecting floating number" instance ToText Double where - toText = T.pack . show + toText = realFloatToText + +instance ToText Word64 where + toText = intToText + +instance ToText Word32 where + toText = intToText + +instance ToText Word31 where + toText = intToText + +realFloatToText :: RealFloat a => a -> T.Text +realFloatToText = T.toStrict . B.toLazyText . B.realFloat + +intToText :: Integral a => a -> T.Text +intToText = T.toStrict . B.toLazyText . B.decimal -- | Decode the specified text with a 'Maybe' result type. fromTextMaybe :: FromText a => Text -> Maybe a diff --git a/lib/text-class/text-class.cabal b/lib/text-class/text-class.cabal index 5c45ea435e0..7be9cf87213 100644 --- a/lib/text-class/text-class.cabal +++ b/lib/text-class/text-class.cabal @@ -34,6 +34,7 @@ library , fmt , text , hspec + , OddWord , QuickCheck hs-source-dirs: src diff --git a/nix/.stack.nix/cardano-wallet-cli.nix b/nix/.stack.nix/cardano-wallet-cli.nix index 38bbd412983..2059354cf09 100644 --- a/nix/.stack.nix/cardano-wallet-cli.nix +++ b/nix/.stack.nix/cardano-wallet-cli.nix @@ -70,4 +70,4 @@ }; }; }; - } // rec { src = (pkgs.lib).mkDefault ../.././lib/cli; } + } // rec { src = (pkgs.lib).mkDefault ../.././lib/cli; } \ No newline at end of file diff --git a/nix/.stack.nix/cardano-wallet.nix b/nix/.stack.nix/cardano-wallet.nix index 2d4a6940926..5c4057edbe2 100644 --- a/nix/.stack.nix/cardano-wallet.nix +++ b/nix/.stack.nix/cardano-wallet.nix @@ -227,4 +227,4 @@ }; }; }; - } // rec { src = (pkgs.lib).mkDefault ../.././lib/shelley; } + } // rec { src = (pkgs.lib).mkDefault ../.././lib/shelley; } \ No newline at end of file diff --git a/nix/.stack.nix/text-class.nix b/nix/.stack.nix/text-class.nix index c5808c85f9c..265e7da47cd 100644 --- a/nix/.stack.nix/text-class.nix +++ b/nix/.stack.nix/text-class.nix @@ -32,6 +32,7 @@ (hsPkgs."fmt" or (errorHandler.buildDepError "fmt")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."hspec" or (errorHandler.buildDepError "hspec")) + (hsPkgs."OddWord" or (errorHandler.buildDepError "OddWord")) (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) ]; buildable = true; diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index 69784dddefc..331fc2c41e2 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -530,6 +530,41 @@ x-transactionOutputs: &transactionOutputs address: *addressId amount: *transactionAmount +x-delegationAction: &delegationAction + description: A delegation action + type: object + required: + - action + properties: + action: + type: string + enum: ["quit", "join"] + pool: *stakePoolId + +x-rewardAccountPath: &rewardAccountPath + type: array + minItems: 1 + items: + type: string + +x-certificate: &certificate + description: | + A delegation certificate + + Only for 'join_pool' the 'pool' property is required. + type: object + required: + - delegation_type + - reward_account_path + properties: + delegation_type: + type: string + enum: ["join_pool", "quit_pool", "register_reward_account"] + pool: + <<: *stakePoolId + reward_account_path: + <<: *rewardAccountPath + x-transactionRedemptionRequest: &transactionRedemptionRequest <<: *walletMnemonicSentence description: | @@ -1085,13 +1120,27 @@ components: minimum_utxo_value: *amount hardfork_at: *epochInfo - ApiSelectCoinsData: &ApiSelectCoinsData + + ApiSelectCoinsPayments: &ApiSelectCoinsPayments type: object required: - payments properties: payments: *transactionOutputs + ApiSelectCoinsAction: &ApiSelectCoinsAction + type: object + required: + - delegation_action + properties: + delegation_action: *delegationAction + + ApiSelectCoinsData: &ApiSelectCoinsData + type: object + oneOf: + - <<: *ApiSelectCoinsPayments + - <<: *ApiSelectCoinsAction + ApiCoinSelection: &ApiCoinSelection type: object required: @@ -1100,6 +1149,9 @@ components: properties: inputs: *transactionResolvedInputs outputs: *transactionOutputs + certificates: + type: array + items: *certificate ApiStakePool: &ApiStakePool type: object @@ -3021,3 +3073,4 @@ paths: Return the current settings. responses: *responsesGetSettings + From a9e42c8d1698638981e5f3ffc892bc743541b008 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 13 Oct 2020 15:58:12 +0200 Subject: [PATCH 02/25] Fix review suggestions --- lib/core/src/Cardano/Wallet.hs | 42 +++++++-------- lib/core/src/Cardano/Wallet/Api/Server.hs | 51 +++++++++++++------ lib/core/src/Cardano/Wallet/Api/Types.hs | 34 +++++-------- .../Wallet/Primitive/AddressDerivation.hs | 10 ++-- lib/core/src/Cardano/Wallet/Transaction.hs | 2 +- .../test/unit/Cardano/Wallet/Api/Malformed.hs | 10 ++-- .../Cardano/Wallet/Jormungandr/Api/Server.hs | 2 +- .../src/Cardano/Wallet/Shelley/Api/Server.hs | 2 +- specifications/api/swagger.yaml | 9 ++-- 9 files changed, 86 insertions(+), 76 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 24d2e1af0a9..7e667953ef2 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1693,17 +1693,17 @@ selectCoinsExternal ctx wid argGenChange payments withdrawal md = do pure (cs', s') UnsignedTx <$> (fullyQualifiedInputs s' cs' - (ErrSelectCoinsExternalUnableToAssignInputs $ ErrNoSuchWallet wid)) + (ErrSelectCoinsExternalUnableToAssignInputs cs')) <*> ensureNonEmpty (outputs cs') - (ErrSelectCoinsExternalUnableToAssignOutputs $ ErrNoSuchWallet wid) + (ErrSelectCoinsExternalUnableToAssignOutputs cs') where db = ctx ^. dbLayer @s @k data ErrSelectCoinsExternal e = ErrSelectCoinsExternalNoSuchWallet ErrNoSuchWallet | ErrSelectCoinsExternalUnableToMakeSelection (ErrSelectForPayment e) - | ErrSelectCoinsExternalUnableToAssignInputs ErrNoSuchWallet - | ErrSelectCoinsExternalUnableToAssignOutputs ErrNoSuchWallet + | ErrSelectCoinsExternalUnableToAssignInputs CoinSelection + | ErrSelectCoinsExternalUnableToAssignOutputs CoinSelection deriving (Eq, Show) signDelegation @@ -1965,7 +1965,7 @@ joinStakePoolUnsigned -> PoolId -> PoolLifeCycleStatus -> WalletId - -> ExceptT ErrJoinStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, [DerivationIndex]) + -> ExceptT ErrJoinStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, NonEmpty DerivationIndex) joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid = db & \DBLayer{..} -> do (wal, _, _) <- withExceptT @@ -1976,9 +1976,9 @@ joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid = utx <- UnsignedTx <$> (fullyQualifiedInputs (getState wal) cs - (ErrJoinStakePoolUnableToAssignInputs $ ErrNoSuchWallet wid)) + (ErrJoinStakePoolUnableToAssignInputs cs)) <*> ensureNonEmpty (outputs cs) - (ErrJoinStakePoolUnableToAssignOutputs $ ErrNoSuchWallet wid) + (ErrJoinStakePoolUnableToAssignOutputs cs) pure (utx, action, sPath) where db = ctx ^. dbLayer @s @k @@ -1996,7 +1996,7 @@ joinStakePoolUnsigned' -> PoolId -> PoolLifeCycleStatus -> WalletId - -> ExceptT ErrJoinStakePool IO (CoinSelection, DelegationAction, [DerivationIndex]) + -> ExceptT ErrJoinStakePool IO (CoinSelection, DelegationAction, NonEmpty DerivationIndex) joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = db & \DBLayer{..} -> do (isKeyReg, walMeta) <- mapExceptT atomically @@ -2089,7 +2089,7 @@ quitStakePoolUnsigned -> WalletId -> ExceptT ErrQuitStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), - DelegationAction, [DerivationIndex]) + DelegationAction, NonEmpty DerivationIndex) quitStakePoolUnsigned ctx wid = db & \DBLayer{..} -> do (wal, _, _) <- withExceptT ErrQuitStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) @@ -2097,9 +2097,9 @@ quitStakePoolUnsigned ctx wid = db & \DBLayer{..} -> do utx <- UnsignedTx <$> (fullyQualifiedInputs (getState wal) cs - (ErrQuitStakePoolUnableToAssignInputs $ ErrNoSuchWallet wid)) + (ErrQuitStakePoolUnableToAssignInputs cs)) <*> ensureNonEmpty (outputs cs) - (ErrQuitStakePoolUnableToAssignOutputs $ ErrNoSuchWallet wid) + (ErrQuitStakePoolUnableToAssignOutputs cs) pure (utx, action, sPath) where db = ctx ^. dbLayer @s @k @@ -2113,7 +2113,7 @@ quitStakePoolUnsigned' ) => ctx -> WalletId - -> ExceptT ErrQuitStakePool IO (CoinSelection, DelegationAction, [DerivationIndex]) + -> ExceptT ErrQuitStakePool IO (CoinSelection, DelegationAction, NonEmpty DerivationIndex) quitStakePoolUnsigned' ctx wid = db & \DBLayer{..} -> do walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $ withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) @@ -2450,8 +2450,8 @@ data ErrJoinStakePool | ErrJoinStakePoolSignDelegation ErrSignDelegation | ErrJoinStakePoolSubmitTx ErrSubmitTx | ErrJoinStakePoolCannotJoin ErrCannotJoin - | ErrJoinStakePoolUnableToAssignInputs ErrNoSuchWallet - | ErrJoinStakePoolUnableToAssignOutputs ErrNoSuchWallet + | ErrJoinStakePoolUnableToAssignInputs CoinSelection + | ErrJoinStakePoolUnableToAssignOutputs CoinSelection deriving (Generic, Eq, Show) data ErrQuitStakePool @@ -2460,8 +2460,8 @@ data ErrQuitStakePool | ErrQuitStakePoolSignDelegation ErrSignDelegation | ErrQuitStakePoolSubmitTx ErrSubmitTx | ErrQuitStakePoolCannotQuit ErrCannotQuit - | ErrQuitStakePoolUnableToAssignInputs ErrNoSuchWallet - | ErrQuitStakePoolUnableToAssignOutputs ErrNoSuchWallet + | ErrQuitStakePoolUnableToAssignInputs CoinSelection + | ErrQuitStakePoolUnableToAssignOutputs CoinSelection deriving (Generic, Eq, Show) -- | Errors that can occur when fetching the reward balance of a wallet @@ -2607,19 +2607,13 @@ fullyQualifiedInputs => s -> CoinSelection -> e - -> ExceptT - e - IO - (NonEmpty (TxIn, TxOut, NonEmpty DerivationIndex)) + -> ExceptT e IO (NonEmpty (TxIn, TxOut, NonEmpty DerivationIndex)) fullyQualifiedInputs s cs e = traverse withDerivationPath (inputs cs) >>= flip ensureNonEmpty e where withDerivationPath :: (TxIn, TxOut) - -> ExceptT - e - IO - (TxIn, TxOut, NonEmpty DerivationIndex) + -> ExceptT e IO (TxIn, TxOut, NonEmpty DerivationIndex) withDerivationPath (txin, txout) = do case fst $ isOurs (address txout) s of Nothing -> throwE e diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 9a590ed64d9..e22c6634dfc 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1824,7 +1824,7 @@ rndStateChange ctx (ApiT wid) pwd = -- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'. mkApiCoinSelection :: forall n. () - => Maybe (DelegationAction, [DerivationIndex]) + => Maybe (DelegationAction, NonEmpty DerivationIndex) -> UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex) -> ApiCoinSelection n mkApiCoinSelection mcerts (UnsignedTx inputs outputs) = @@ -1833,17 +1833,18 @@ mkApiCoinSelection mcerts (UnsignedTx inputs outputs) = (mkAddressAmount <$> outputs) (fmap (uncurry mkCertificates) mcerts) where - mkCertificates :: DelegationAction -> [DerivationIndex] -> [Api.ApiCertificate] - mkCertificates action (s:sx) = - let apiStakePath = ApiT <$> (s:|sx) + mkCertificates + :: DelegationAction + -> NonEmpty DerivationIndex + -> NonEmpty Api.ApiCertificate + mkCertificates action xs = + let apiStakePath = ApiT <$> xs in case action of - Join pid -> [Api.JoinPool apiStakePath (ApiT pid)] + Join pid -> Api.JoinPool apiStakePath (ApiT pid) :| [] RegisterKeyAndJoin pid -> - [ Api.RegisterRewardAccount apiStakePath - , Api.JoinPool apiStakePath (ApiT pid) - ] - Quit-> [Api.QuitPool apiStakePath] - mkCertificates _ _ = [] + Api.RegisterRewardAccount apiStakePath :| + [Api.JoinPool apiStakePath (ApiT pid)] + Quit-> Api.QuitPool apiStakePath :| [] mkAddressAmount :: TxOut -> AddressAmount (ApiT Address, Proxy n) mkAddressAmount (TxOut addr (Coin c)) = @@ -2197,8 +2198,14 @@ instance Buildable e => LiftHandler (ErrSelectCoinsExternal e) where handler e ErrSelectCoinsExternalUnableToMakeSelection e -> handler e - ErrSelectCoinsExternalUnableToAssignInputs e -> handler e - ErrSelectCoinsExternalUnableToAssignOutputs e -> handler e + ErrSelectCoinsExternalUnableToAssignInputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign inputs from coin selection: " + , pretty e] + ErrSelectCoinsExternalUnableToAssignOutputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign outputs from coin selection: " + , pretty e] instance Buildable e => LiftHandler (ErrCoinSelection e) where handler = \case @@ -2499,8 +2506,14 @@ instance LiftHandler ErrJoinStakePool where [ "I couldn't find any stake pool with the given id: " , toText pid ] - ErrJoinStakePoolUnableToAssignInputs e -> handler e - ErrJoinStakePoolUnableToAssignOutputs e -> handler e + ErrJoinStakePoolUnableToAssignInputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign inputs from coin selection: " + , pretty e] + ErrJoinStakePoolUnableToAssignOutputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign outputs from coin selection: " + , pretty e] instance LiftHandler ErrFetchRewards where handler = \case @@ -2537,8 +2550,14 @@ instance LiftHandler ErrQuitStakePool where , "account! Make sure to withdraw your ", pretty rewards , " lovelace first." ] - ErrQuitStakePoolUnableToAssignInputs e -> handler e - ErrQuitStakePoolUnableToAssignOutputs e -> handler e + ErrQuitStakePoolUnableToAssignInputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign inputs from coin selection: " + , pretty e] + ErrQuitStakePoolUnableToAssignOutputs e -> + apiError err403 UnableToAssignInputOutput $ mconcat + [ "Unable to assign outputs from coin selection: " + , pretty e] instance LiftHandler ErrCreateRandomAddress where handler = \case diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 57f39fd543d..0b5a916acb9 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -42,7 +42,6 @@ module Cardano.Wallet.Api.Types -- * API Types , ApiAddress (..) - , ApiRelativeDerivationIndex (..) , ApiCertificate (..) , ApiEpochInfo (..) , ApiSelectCoinsData (..) @@ -378,14 +377,6 @@ data ApiAddress (n :: NetworkDiscriminant) = ApiAddress , state :: !(ApiT AddressState) } deriving (Eq, Generic, Show) --- | Represents a relative address index. --- --- The range of this type is exactly half that of a 'Word32'. --- -newtype ApiRelativeDerivationIndex = ApiRelativeDerivationIndex - { unApiRelativeDerivationIndex :: Word31 - } deriving (Bounded, Enum, Eq, Generic, Show) - data ApiEpochInfo = ApiEpochInfo { epochNumber :: !(ApiT EpochNo) , epochStartTime :: !UTCTime @@ -393,7 +384,7 @@ data ApiEpochInfo = ApiEpochInfo data ApiSelectCoinsData (n :: NetworkDiscriminant) = ApiSelectForPayment (ApiSelectCoinsPayments n) - | ApiSelectForAction ApiSelectCoinsAction + | ApiSelectForDelegation ApiSelectCoinsAction deriving (Eq, Generic, Show) newtype ApiSelectCoinsPayments (n :: NetworkDiscriminant) = ApiSelectCoinsPayments @@ -401,26 +392,26 @@ newtype ApiSelectCoinsPayments (n :: NetworkDiscriminant) = ApiSelectCoinsPaymen } deriving (Eq, Generic, Show) newtype ApiSelectCoinsAction = ApiSelectCoinsAction - { delegation_action :: ApiT DelegationAction + { delegationAction :: ApiT DelegationAction } deriving (Eq, Generic, Show) data ApiCertificate = RegisterRewardAccount - { reward_account_path :: NonEmpty (ApiT DerivationIndex) + { rewardAccountPath :: NonEmpty (ApiT DerivationIndex) } | JoinPool - { reward_account_path :: NonEmpty (ApiT DerivationIndex) + { rewardAccountPath :: NonEmpty (ApiT DerivationIndex) , pool :: ApiT PoolId } | QuitPool - { reward_account_path :: NonEmpty (ApiT DerivationIndex) + { rewardAccountPath :: NonEmpty (ApiT DerivationIndex) } deriving (Eq, Generic, Show) data ApiCoinSelection (n :: NetworkDiscriminant) = ApiCoinSelection { inputs :: !(NonEmpty (ApiCoinSelectionInput n)) , outputs :: !(NonEmpty (AddressAmount (ApiT Address, Proxy n))) - , certificates :: Maybe [ApiCertificate] + , certificates :: Maybe (NonEmpty ApiCertificate) } deriving (Eq, Generic, Show) data ApiCoinSelectionInput (n :: NetworkDiscriminant) = ApiCoinSelectionInput @@ -797,6 +788,7 @@ data ApiErrorCode | AlreadyWithdrawing | WithdrawalNotWorth | PastHorizon + | UnableToAssignInputOutput deriving (Eq, Generic, Show) -- | Defines a point in time that can be formatted as and parsed from an @@ -1046,13 +1038,13 @@ instance DecodeAddress n => FromJSON (ApiSelectCoinsData n) where case (p, a) of (Just _, Just _) -> fail "Specified both payments and action, pick one" (Nothing, Just v) -> - pure $ ApiSelectForAction $ ApiSelectCoinsAction v + pure $ ApiSelectForDelegation $ ApiSelectCoinsAction v (Just v, Nothing) -> pure $ ApiSelectForPayment $ ApiSelectCoinsPayments v - _ -> fail "No valid parse" + _ -> fail "No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" instance EncodeAddress n => ToJSON (ApiSelectCoinsData n) where toJSON (ApiSelectForPayment v) = toJSON v - toJSON (ApiSelectForAction v) = toJSON v + toJSON (ApiSelectForDelegation v) = toJSON v instance DecodeAddress n => FromJSON (ApiCoinSelection n) where parseJSON = genericParseJSON defaultRecordTypeOptions @@ -1067,8 +1059,8 @@ apiCertificateOptions = Aeson.defaultOptions , omitNothingFields = True , sumEncoding = TaggedObject { - tagFieldName = "delegation_type" - , contentsFieldName = "contents" + tagFieldName = "certificate_type" + , contentsFieldName = "details" } } @@ -1085,7 +1077,7 @@ instance FromJSON (ApiT DelegationAction) where pid <- o .: "pool" pure (ApiT $ Join (getApiT pid)) "quit" -> pure $ ApiT Quit - val -> fail ("Unexpeced action value: " <> T.unpack val) + 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" diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs index ad6baaaa6e5..9ab120a43ea 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs @@ -146,6 +146,8 @@ import qualified Codec.CBOR.Write as CBOR import qualified Crypto.Scrypt as Scrypt import qualified Data.ByteArray as BA import qualified Data.ByteString as BS +import Data.List.NonEmpty + ( NonEmpty (..) ) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -212,13 +214,13 @@ mutableAccount :: Index 'Soft 'RoleK mutableAccount = toEnum $ fromEnum MutableAccount zeroAccount :: Index 'Soft 'AddressK -zeroAccount = toEnum 0 +zeroAccount = minBound -- | Full path to the stake key. There's only one. -stakePath :: DerivationPrefix -> [DerivationIndex] +stakePath :: DerivationPrefix -> NonEmpty DerivationIndex stakePath (DerivationPrefix (purpose, coin, acc)) = - [fromIndex purpose - , fromIndex coin + (fromIndex purpose) :| [ + fromIndex coin , fromIndex acc , fromIndex mutableAccount , fromIndex zeroAccount] diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs index 4b2f7bc17a7..c0a695872f1 100644 --- a/lib/core/src/Cardano/Wallet/Transaction.hs +++ b/lib/core/src/Cardano/Wallet/Transaction.hs @@ -46,8 +46,8 @@ import Data.Text ( Text ) import Data.Word ( Word16, Word8 ) - import GHC.Generics + ( Generic ) data TransactionLayer t k = TransactionLayer { mkStdTx diff --git a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs index b9d2ae37774..d37f21f712d 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs +++ b/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" + , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" ) , ( [aesonQQ| { "action": "" }|] - , "Error in $: No valid parse" + , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" ) , ( [aesonQQ| { "action": "join", "pool": "" }|] - , "Error in $: No valid parse" + , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" ) , ( [aesonQQ| { "action": "join", "pool": "1" }|] - , "Error in $: No valid parse" + , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" ) , ( [aesonQQ| { "pool": "pool1wqaz0q0zhtxlgn0ewssevn2mrtm30fgh2g7hr7z9rj5856457mm" }|] - , "Error in $: No valid parse" + , "Error in $: No valid parse for ApiSelectCoinsAction or ApiSelectCoinsAction" ) ] diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs index ef8c6b20b23..5f1a9ae3b7b 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs @@ -183,7 +183,7 @@ server byron icarus jormungandr spl ntp = \wid ascd -> case ascd of (ApiSelectForPayment ascp) -> selectCoins jormungandr (delegationAddress @n) wid ascp - (ApiSelectForAction _) -> + (ApiSelectForDelegation _) -> throwError err501 transactions :: Server (Transactions n) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index 35c9f875e14..e7a0f512bcb 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs @@ -207,7 +207,7 @@ server byron icarus shelley spl ntp = coinSelections :: Server (CoinSelections n) coinSelections = (\wid ascd -> case ascd of (ApiSelectForPayment ascp) -> selectCoins shelley (delegationAddress @n) wid ascp - (ApiSelectForAction (ApiSelectCoinsAction (ApiT action))) -> case action of + (ApiSelectForDelegation (ApiSelectCoinsAction (ApiT action))) -> case action of Join pid -> selectCoinsJoinStakePool shelley (knownPools spl) diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index 331fc2c41e2..96933c0288d 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -554,10 +554,10 @@ x-certificate: &certificate Only for 'join_pool' the 'pool' property is required. type: object required: - - delegation_type + - certificate_type - reward_account_path properties: - delegation_type: + certificate_type: type: string enum: ["join_pool", "quit_pool", "register_reward_account"] pool: @@ -1141,6 +1141,9 @@ components: - <<: *ApiSelectCoinsPayments - <<: *ApiSelectCoinsAction + ApiByronSelectCoinsData: &ApiByronSelectCoinsData + <<: *ApiSelectCoinsPayments + ApiCoinSelection: &ApiCoinSelection type: object required: @@ -2944,7 +2947,7 @@ paths: required: true content: application/json: - schema: *ApiSelectCoinsData + schema: *ApiByronSelectCoinsData responses: *responsesSelectCoins /byron-wallets/{walletId}/migrations: From 0506f1471fc8aa1d62b6f177dc6fbdd818eeb5e6 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 13 Oct 2020 17:28:27 +0200 Subject: [PATCH 03/25] Assign change addresses in `joinStakePoolUnsigned` --- lib/core/src/Cardano/Wallet.hs | 18 +++++++++++++----- lib/core/src/Cardano/Wallet/Api/Server.hs | 4 ++-- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 7e667953ef2..c32b84a7cb3 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1965,8 +1965,9 @@ joinStakePoolUnsigned -> PoolId -> PoolLifeCycleStatus -> WalletId + -> ArgGenChange s -> ExceptT ErrJoinStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, NonEmpty DerivationIndex) -joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid = +joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid argGenChange = db & \DBLayer{..} -> do (wal, _, _) <- withExceptT ErrJoinStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) @@ -1974,11 +1975,18 @@ joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid = joinStakePoolUnsigned' @ctx @s @t @k @n ctx currentEpoch knownPools pid poolStatus wid + coinSel' <- mapExceptT atomically $ do + (coinSel', s') <- assignChangeAddresses argGenChange cs (getState wal) + + withExceptT ErrJoinStakePoolNoSuchWallet $ + putCheckpoint (PrimaryKey wid) (updateState s' wal) + pure coinSel' + utx <- UnsignedTx - <$> (fullyQualifiedInputs (getState wal) cs - (ErrJoinStakePoolUnableToAssignInputs cs)) - <*> ensureNonEmpty (outputs cs) - (ErrJoinStakePoolUnableToAssignOutputs cs) + <$> (fullyQualifiedInputs (getState wal) coinSel' + (ErrJoinStakePoolUnableToAssignInputs coinSel')) + <*> ensureNonEmpty (outputs coinSel') + (ErrJoinStakePoolUnableToAssignOutputs coinSel') pure (utx, action, sPath) where db = ctx ^. dbLayer @s @k diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index e22c6634dfc..9a05fff31da 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1135,7 +1135,7 @@ selectCoinsJoinStakePool ( s ~ SeqState n k , ctx ~ ApiLayer s t k , SoftDerivation k - , MkKeyFingerprint k Address + , DelegationAddress n k , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) ) => ctx @@ -1155,7 +1155,7 @@ selectCoinsJoinStakePool ctx knownPools getPoolStatus pid wid = do \wrk -> liftHandler $ W.joinStakePoolUnsigned @_ @s @t @k wrk - curEpoch pools pid poolStatus wid + curEpoch pools pid poolStatus wid (delegationAddress @n) pure $ mkApiCoinSelection (Just (action, spath)) utx selectCoinsQuitStakePool From bed33889650288dce649a8a358cd0ead8b9abea7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 13 Oct 2020 17:29:17 +0200 Subject: [PATCH 04/25] Avoid capturing checkpoint multiple times --- lib/core/src/Cardano/Wallet.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index c32b84a7cb3..93bf597befd 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -2007,10 +2007,11 @@ joinStakePoolUnsigned' -> ExceptT ErrJoinStakePool IO (CoinSelection, DelegationAction, NonEmpty DerivationIndex) joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = db & \DBLayer{..} -> do - (isKeyReg, walMeta) <- mapExceptT atomically + (wal, walMeta, _) <- withExceptT + ErrJoinStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) + isKeyReg <- mapExceptT atomically $ withExceptT ErrJoinStakePoolNoSuchWallet - $ (,) <$> isStakeKeyRegistered (PrimaryKey wid) - <*> withNoSuchWallet wid (readWalletMeta (PrimaryKey wid)) + $ isStakeKeyRegistered (PrimaryKey wid) let mRetirementEpoch = view #retirementEpoch <$> W.getPoolRetirementCertificate poolStatus @@ -2026,11 +2027,7 @@ joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = cs <- withExceptT ErrJoinStakePoolSelectCoin $ selectCoinsForDelegation @ctx @s @t @k ctx wid action - cp <- mapExceptT atomically - $ withExceptT ErrJoinStakePoolNoSuchWallet - $ withNoSuchWallet wid - $ readCheckpoint (PrimaryKey wid) - let s = getState cp + let s = getState wal dprefix = Seq.derivationPrefix s sPath = stakePath dprefix From 7616b5c9415f1f82f52caa84f1cb2363bfb266be Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 14 Oct 2020 15:02:45 +0200 Subject: [PATCH 05/25] Assign change addresses in `quitStakePoolUnsigned` --- lib/core/src/Cardano/Wallet.hs | 18 +++++++++++++----- lib/core/src/Cardano/Wallet/Api/Server.hs | 4 ++-- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 93bf597befd..44c33d3cf5d 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -2092,19 +2092,27 @@ quitStakePoolUnsigned ) => ctx -> WalletId + -> ArgGenChange s -> ExceptT ErrQuitStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, NonEmpty DerivationIndex) -quitStakePoolUnsigned ctx wid = db & \DBLayer{..} -> do +quitStakePoolUnsigned ctx wid argGenChange = db & \DBLayer{..} -> do (wal, _, _) <- withExceptT ErrQuitStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) (cs, action, sPath) <- quitStakePoolUnsigned' @ctx @s @t @k @n ctx wid + coinSel' <- mapExceptT atomically $ do + (coinSel', s') <- assignChangeAddresses argGenChange cs (getState wal) + + withExceptT ErrQuitStakePoolNoSuchWallet $ + putCheckpoint (PrimaryKey wid) (updateState s' wal) + pure coinSel' + utx <- UnsignedTx - <$> (fullyQualifiedInputs (getState wal) cs - (ErrQuitStakePoolUnableToAssignInputs cs)) - <*> ensureNonEmpty (outputs cs) - (ErrQuitStakePoolUnableToAssignOutputs cs) + <$> (fullyQualifiedInputs (getState wal) coinSel' + (ErrQuitStakePoolUnableToAssignInputs coinSel')) + <*> ensureNonEmpty (outputs coinSel') + (ErrQuitStakePoolUnableToAssignOutputs coinSel') pure (utx, action, sPath) where db = ctx ^. dbLayer @s @k diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 9a05fff31da..62ad7359ea6 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1163,7 +1163,7 @@ selectCoinsQuitStakePool ( s ~ SeqState n k , ctx ~ ApiLayer s t k , SoftDerivation k - , MkKeyFingerprint k Address + , DelegationAddress n k , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) ) => ctx @@ -1171,7 +1171,7 @@ selectCoinsQuitStakePool -> Handler (Api.ApiCoinSelection n) selectCoinsQuitStakePool ctx (ApiT wid) = do (utx, action, spath) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ - W.quitStakePoolUnsigned @_ @s @t @k wrk wid + W.quitStakePoolUnsigned @_ @s @t @k wrk wid (delegationAddress @n) pure $ mkApiCoinSelection (Just (action, spath)) utx {------------------------------------------------------------------------------- From 1fc3ac47e358ba3b2d3c7f999892addb5424c4c0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 14 Oct 2020 15:08:52 +0200 Subject: [PATCH 06/25] Add integration tests --- .../src/Test/Integration/Framework/DSL.hs | 45 ++++++ .../Scenario/API/Shelley/StakePools.hs | 146 ++++++++++++++++-- 2 files changed, 182 insertions(+), 9 deletions(-) diff --git a/lib/core-integration/src/Test/Integration/Framework/DSL.hs b/lib/core-integration/src/Test/Integration/Framework/DSL.hs index b3c820e85ed..cc6eb2ca5f0 100644 --- a/lib/core-integration/src/Test/Integration/Framework/DSL.hs +++ b/lib/core-integration/src/Test/Integration/Framework/DSL.hs @@ -73,8 +73,10 @@ module Test.Integration.Framework.DSL , getFromResponseList , json , joinStakePool + , joinStakePoolUnsigned , delegationFee , quitStakePool + , quitStakePoolUnsigned , selectCoins , listAddresses , listTransactions @@ -143,6 +145,9 @@ module Test.Integration.Framework.DSL , postExternalTransactionViaCLI , deleteTransactionViaCLI , getTransactionViaCLI + + -- utilites + , getRetirementEpoch ) where import Cardano.CLI @@ -170,6 +175,7 @@ import Cardano.Wallet.Api.Types , ApiFee , ApiNetworkInformation , ApiNetworkParameters (..) + , ApiStakePool , ApiT (..) , ApiTransaction , ApiTxId (ApiTxId) @@ -1221,6 +1227,24 @@ joinStakePool ctx p (w, pass) = do request @(ApiTransaction n) ctx (Link.joinStakePool (Identity p) w) Default payload +joinStakePoolUnsigned + :: forall n style t w. + ( HasType (ApiT WalletId) w + , DecodeAddress n + , EncodeAddress n + , Link.Discriminate style + ) + => Context t + -> w + -> ApiT PoolId + -> IO (HTTP.Status, Either RequestException (ApiCoinSelection n)) +joinStakePoolUnsigned ctx w pid = do + let payload = Json [aesonQQ| { + "delegation_action": { "action": "join", "pool": #{pid} } + } |] + request @(ApiCoinSelection n) ctx + (Link.selectCoins @style w) Default payload + quitStakePool :: forall n t w. ( HasType (ApiT WalletId) w @@ -1237,6 +1261,23 @@ quitStakePool ctx (w, pass) = do request @(ApiTransaction n) ctx (Link.quitStakePool w) Default payload +quitStakePoolUnsigned + :: forall n style t w. + ( HasType (ApiT WalletId) w + , DecodeAddress n + , EncodeAddress n + , Link.Discriminate style + ) + => Context t + -> w + -> IO (HTTP.Status, Either RequestException (ApiCoinSelection n)) +quitStakePoolUnsigned ctx w = do + let payload = Json [aesonQQ| { + "delegation_action": { "action": "quit" } + } |] + request @(ApiCoinSelection n) ctx + (Link.selectCoins @style w) Default payload + selectCoins :: forall n style t w. ( HasType (ApiT WalletId) w @@ -1854,3 +1895,7 @@ delegating delegating pidActive nexts = (notDelegating nexts) { active = ApiWalletDelegationNext Delegating (Just pidActive) Nothing } + + +getRetirementEpoch :: ApiStakePool -> Maybe EpochNo +getRetirementEpoch = fmap (view (#epochNumber . #getApiT)) . view #retirement diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs index e2690ea71fd..fbd236ae01c 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -35,11 +35,11 @@ import Cardano.Wallet.Primitive.Fee import Cardano.Wallet.Primitive.Types ( Coin (..) , Direction (..) - , EpochNo (..) , PoolId (..) , StakePoolMetadata (..) , StakePoolTicker (..) , TxStatus (..) + , decodePoolIdBech32 ) import Cardano.Wallet.Unsafe ( unsafeFromHex, unsafeMkPercentage ) @@ -52,9 +52,9 @@ import Data.Generics.Internal.VL.Lens import Data.IORef ( readIORef ) import Data.List - ( sortOn ) + ( find, sortOn ) import Data.Maybe - ( fromMaybe, listToMaybe, mapMaybe ) + ( fromMaybe, isJust, isNothing, listToMaybe, mapMaybe ) import Data.Ord ( Down (..) ) import Data.Quantity @@ -89,13 +89,16 @@ import Test.Integration.Framework.DSL , fixtureWallet , fixtureWalletWith , getFromResponse + , getRetirementEpoch , getSlotParams , joinStakePool + , joinStakePoolUnsigned , json , listAddresses , minUTxOValue , notDelegating , quitStakePool + , quitStakePoolUnsigned , request , unsafeRequest , verify @@ -552,6 +555,137 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do , expectField (#direction . #getApiT) (`shouldBe` Outgoing) ] + describe "STAKE_POOLS_JOIN_UNSIGNED_01" $ do + it "Can join a pool that's not retiring" $ \ctx -> do + nonRetiredPools <- eventually "One of the pools should retire." $ do + response <- listPools ctx arbitraryStake + + verify response [ expectListSize 3 ] + + pure $ getFromResponse Prelude.id response + + let reportError = error $ unlines + [ "Unable to find a non-retiring pool ID." + , "Test cluster pools:" + , unlines (showT <$> Set.toList testClusterPoolIds) + , "Non-retired pools:" + , unlines (show <$> nonRetiredPools) + ] + + let nonRetiringPoolId = (view #id) . fromMaybe reportError + . find (isNothing . getRetirementEpoch) + $ nonRetiredPools + + -- 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)) + ] + + describe "STAKE_POOLS_JOIN_UNSIGNED_02" + $ it "Can join a pool that's retiring" $ \ctx -> do + nonRetiredPools <- eventually "One of the pools should retire." $ do + response <- listPools ctx arbitraryStake + + verify response [ expectListSize 3 ] + + pure $ getFromResponse Prelude.id response + let reportError = error $ unlines + [ "Unable to find a retiring pool ID." + , "Test cluster pools:" + , unlines (showT <$> Set.toList testClusterPoolIds) + , "Non-retired pools:" + , unlines (show <$> nonRetiredPools) + ] + + let retiringPoolId = (view #id) . fromMaybe reportError + . find (isJust . getRetirementEpoch) + $ nonRetiredPools + -- Join Pool + w <- fixtureWallet ctx + joinStakePoolUnsigned @n @'Shelley ctx w retiringPoolId >>= \o -> do + verify o + [ expectResponseCode HTTP.status200 + , expectField #inputs (`shouldSatisfy` (not . null)) + , expectField #outputs (`shouldSatisfy` (not . null)) + , expectField #certificates (`shouldSatisfy` (not . null)) + ] + + describe "STAKE_POOLS_JOIN_UNSIGNED_03" + $ it "Cannot join a pool that's retired" $ \ctx -> do + nonRetiredPoolIds <- eventually "One of the pools should retire." $ do + response <- listPools ctx arbitraryStake + verify response [ expectListSize 3 ] + getFromResponse Prelude.id response + & fmap (view (#id . #getApiT)) + & Set.fromList + & pure + let reportError = error $ unlines + [ "Unable to find a retired pool ID." + , "Test cluster pools:" + , unlines (showT <$> Set.toList testClusterPoolIds) + , "Non-retired pools:" + , unlines (showT <$> Set.toList nonRetiredPoolIds) + ] + let retiredPoolIds = + testClusterPoolIds `Set.difference` nonRetiredPoolIds + let retiredPoolId = + fromMaybe reportError $ listToMaybe $ Set.toList retiredPoolIds + w <- fixtureWallet ctx + r <- joinStakePoolUnsigned @n @'Shelley ctx w (ApiT retiredPoolId) + expectResponseCode HTTP.status404 r + expectErrorMessage (errMsg404NoSuchPool (toText retiredPoolId)) r + + describe "STAKE_POOLS_JOIN_UNSIGNED_04" + $ it "Cannot join a pool that's never existed" $ \ctx -> do + (Right non_existing_pool_id) <- pure $ decodePoolIdBech32 + "pool1y25deq9kldy9y9gfvrpw8zt05zsrfx84zjhugaxrx9ftvwdpua2" + w <- fixtureWallet ctx + r <- joinStakePoolUnsigned @n @'Shelley ctx w (ApiT non_existing_pool_id) + expectResponseCode HTTP.status404 r + expectErrorMessage (errMsg404NoSuchPool (toText non_existing_pool_id)) r + + describe "STAKE_POOLS_QUIT_UNSIGNED_01" + $ it "Can quit a joined pool" $ \ctx -> do + w <- fixtureWallet ctx + + pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool] + ctx (Link.listStakePools arbitraryStake) Empty + + joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify + [ expectResponseCode HTTP.status202 + , expectField (#status . #getApiT) (`shouldBe` Pending) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + ] + + eventually "Wallet is delegating to p1" $ do + request @ApiWallet ctx (Link.getWallet @'Shelley w) + Default Empty >>= flip verify + [ expectField #delegation (`shouldBe` delegating pool []) + ] + + -- 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)) + ] + + describe "STAKE_POOLS_QUIT_UNSIGNED_02" + $ it "Cannot quit if not delegating" $ \ctx -> do + w <- fixtureWallet ctx + + quitStakePoolUnsigned @n @'Shelley ctx w >>= \r -> do + expectResponseCode HTTP.status403 r + expectErrorMessage "It seems that you're trying to retire from delegation although you're not even delegating, nor won't be in an immediate future" r + + describe "STAKE_POOLS_JOIN_01x - Fee boundary values" $ do it "STAKE_POOLS_JOIN_01x - \ \I can join if I have just the right amount" $ \ctx -> do @@ -688,12 +822,6 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do response <- listPools ctx arbitraryStake expectResponseCode HTTP.status200 response - let getRetirementEpoch :: ApiStakePool -> Maybe EpochNo - getRetirementEpoch = - fmap (view (#epochNumber . #getApiT)) - . - view #retirement - let actualRetirementEpochs = getFromResponse Prelude.id response & fmap getRetirementEpoch From 9b379d2d70ae09717b1450142361b83e7467537a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Oct 2020 19:25:27 +0200 Subject: [PATCH 07/25] Apply further review suggestions --- .../Scenario/API/Shelley/StakePools.hs | 16 +++++-- lib/core/src/Cardano/Wallet.hs | 6 +-- lib/core/src/Cardano/Wallet/Api/Server.hs | 45 +++++++++++-------- lib/core/src/Cardano/Wallet/Api/Types.hs | 7 +-- .../Wallet/Primitive/AddressDerivation.hs | 8 ++-- .../test/unit/Cardano/Wallet/Api/Malformed.hs | 10 ++--- .../src/Cardano/Wallet/Shelley/Api/Server.hs | 3 +- .../src/Cardano/Wallet/Shelley/Transaction.hs | 32 ++++--------- specifications/api/swagger.yaml | 8 +++- 9 files changed, 72 insertions(+), 63 deletions(-) diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs index fbd236ae01c..7bd2c35f8b0 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/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,6 +579,9 @@ 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 @@ -583,7 +589,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do [ 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" diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 44c33d3cf5d..53e3d2bec89 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 62ad7359ea6..af813b900f8 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 0b5a916acb9..bb6f82aa78f 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/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" ] diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs index 9ab120a43ea..8c03e92d50e 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs +++ b/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,8 +217,8 @@ 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 @@ -226,7 +226,7 @@ stakePath (DerivationPrefix (purpose, coin, acc)) = , 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. -- diff --git a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs index d37f21f712d..7e179700035 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs +++ b/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" ) ] diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index e7a0f512bcb..f5854c967bd 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/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 = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index e9d472f39d4..4f9bf5231fb 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/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 diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index 96933c0288d..54af9fc9d28 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -531,7 +531,10 @@ x-transactionOutputs: &transactionOutputs amount: *transactionAmount x-delegationAction: &delegationAction - description: A delegation action + description: | + A delegation action. + + Pool id is only required for "join". type: object required: - action @@ -543,7 +546,8 @@ x-delegationAction: &delegationAction x-rewardAccountPath: &rewardAccountPath type: array - minItems: 1 + minItems: 5 + maxItems: 5 items: type: string From 16451e5d91de21913f12a49eda6d874c66e37d5f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 16 Oct 2020 11:08:03 +0200 Subject: [PATCH 08/25] Fix 'Arbitrary ApiCertificate' --- lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 3a013dd92f3..d363845a480 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -275,6 +275,7 @@ import Test.QuickCheck , scale , shrinkIntegral , vector + , vectorOf , (.&&.) , (===) ) @@ -298,6 +299,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -934,7 +936,14 @@ instance Arbitrary DelegationAction where shrink _ = [] instance Arbitrary ApiCertificate where - arbitrary = genericArbitrary + arbitrary = + oneof [ JoinPool <$> arbitraryRewardAccountPath <*> arbitrary + , QuitPool <$> arbitraryRewardAccountPath + , RegisterRewardAccount <$> arbitraryRewardAccountPath + ] + where + arbitraryRewardAccountPath :: Gen (NonEmpty (ApiT DerivationIndex)) + arbitraryRewardAccountPath = NE.fromList <$> vectorOf 5 arbitrary shrink = genericShrink instance Arbitrary (ApiCoinSelection n) where From 16a5f0cda96867b4bc0eaa37a125c4824e6d2a25 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 16 Oct 2020 15:23:18 +0200 Subject: [PATCH 09/25] remove duplicated logic with regards to selections for join/quit The code was becoming quite convoluted here with function names that were screaming for refactoring (when we start adding `'` to functions, it's usually a good sign that something can be simplified). The main change is actually in 'selectCoinsExternal' which is now parameterized over the selection to run. This way, the steps of assigning change addresses are factored out in this function and a lot of the duplication goes away. Another important change is that I've moved the signing and submission of join/quit outside of the body of the function. So that each step can be ran independently. This avoid the need for weird intermediate product types aggregating more and more information. Now, both functions are returning a 'DelegationAction' and merely checking that a join or quit is possible. --- lib/core/src/Cardano/Wallet.hs | 273 +++--------------- lib/core/src/Cardano/Wallet/Api/Server.hs | 123 ++++++-- .../src/Cardano/Wallet/Shelley/Api/Server.hs | 9 +- 3 files changed, 145 insertions(+), 260 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 53e3d2bec89..ee57c72aa60 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -125,9 +125,7 @@ module Cardano.Wallet -- ** Delegation , PoolRetirementEpochInfo (..) , joinStakePool - , joinStakePoolUnsigned , quitStakePool - , quitStakePoolUnsigned , selectCoinsForDelegation , estimateFeeForDelegation , signDelegation @@ -183,7 +181,7 @@ import Prelude hiding ( log ) import Cardano.Address.Derivation - ( XPrv, XPub ) + ( XPrv ) import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer @@ -222,7 +220,6 @@ import Cardano.Wallet.Primitive.AddressDerivation , NetworkDiscriminant (..) , Passphrase , PaymentAddress (..) - , SoftDerivation , ToChimericAccount (..) , WalletKey (..) , checkPassphrase @@ -997,18 +994,20 @@ readChimericAccount ) => ctx -> WalletId - -> ExceptT ErrReadChimericAccount IO ChimericAccount + -> ExceptT ErrReadChimericAccount IO (ChimericAccount, NonEmpty DerivationIndex) readChimericAccount ctx wid = db & \DBLayer{..} -> do cp <- withExceptT ErrReadChimericAccountNoSuchWallet $ mapExceptT atomically $ withNoSuchWallet wid $ readCheckpoint (PrimaryKey wid) case testEquality (typeRep @s) (typeRep @shelley) of - Nothing -> throwE ErrReadChimericAccountNotAShelleyWallet - Just Refl -> pure - $ toChimericAccount - $ Seq.rewardAccountKey - $ getState cp + Nothing -> + throwE ErrReadChimericAccountNotAShelleyWallet + Just Refl -> do + let s = getState cp + let acct = toChimericAccount $ Seq.rewardAccountKey s + let path = stakeDerivationPath $ Seq.derivationPrefix s + pure (acct, path) where db = ctx ^. dbLayer @s @k @@ -1051,7 +1050,7 @@ manageRewardBalance _ ctx wid = db & \DBLayer{..} -> do watchNodeTip $ \bh -> do traceWith tr $ MsgRewardBalanceQuery bh query <- runExceptT $ do - acct <- withExceptT ErrFetchRewardsReadChimericAccount $ + (acct, _) <- withExceptT ErrFetchRewardsReadChimericAccount $ readChimericAccount @ctx @s @k @n ctx wid queryRewardBalance @ctx @t ctx acct traceWith tr $ MsgRewardBalanceResult query @@ -1663,27 +1662,20 @@ signTx ctx wid pwd md (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do -- | Makes a fully-resolved coin selection for the given set of payments. selectCoinsExternal - :: forall ctx s t k e. + :: forall ctx s k e resolvedInput. ( GenChange s , HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx - , e ~ ErrValidateSelection t , IsOurs s Address + , resolvedInput ~ (TxIn, TxOut, NonEmpty DerivationIndex) ) => ctx -> WalletId -> ArgGenChange s - -> NonEmpty TxOut - -> Quantity "lovelace" Word64 - -> Maybe TxMetadata - -> ExceptT - (ErrSelectCoinsExternal e) - IO - (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex)) -selectCoinsExternal ctx wid argGenChange payments withdrawal md = do - cs <- withExceptT ErrSelectCoinsExternalUnableToMakeSelection $ - selectCoinsForPayment @ctx @s @t @k @e ctx wid payments withdrawal md + -> ExceptT (ErrSelectCoinsExternal e) IO CoinSelection + -> ExceptT (ErrSelectCoinsExternal e) IO (UnsignedTx resolvedInput) +selectCoinsExternal ctx wid argGenChange selectCoins = do + cs <- selectCoins + (cs', s') <- db & \DBLayer{..} -> withExceptT ErrSelectCoinsExternalNoSuchWallet $ mapExceptT atomically $ do @@ -1691,6 +1683,7 @@ selectCoinsExternal ctx wid argGenChange payments withdrawal md = do (cs', s') <- assignChangeAddresses argGenChange cs (getState cp) putCheckpoint (PrimaryKey wid) (updateState s' cp) pure (cs', s') + UnsignedTx <$> (fullyQualifiedInputs s' cs' (ErrSelectCoinsExternalUnableToAssignInputs cs')) @@ -1701,7 +1694,8 @@ selectCoinsExternal ctx wid argGenChange payments withdrawal md = do data ErrSelectCoinsExternal e = ErrSelectCoinsExternalNoSuchWallet ErrNoSuchWallet - | ErrSelectCoinsExternalUnableToMakeSelection (ErrSelectForPayment e) + | ErrSelectCoinsExternalForPayment (ErrSelectForPayment e) + | ErrSelectCoinsExternalForDelegation ErrSelectForDelegation | ErrSelectCoinsExternalUnableToAssignInputs CoinSelection | ErrSelectCoinsExternalUnableToAssignOutputs CoinSelection deriving (Eq, Show) @@ -1947,55 +1941,10 @@ getTransaction ctx wid tid = db & \DBLayer{..} -> do Delegation -------------------------------------------------------------------------------} --- | Get the coin selection and certificate info for joining a stake pool. --- Don't create a signed transaction. -joinStakePoolUnsigned - :: forall ctx s t k n. - ( HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx - , SoftDerivation k - , s ~ SeqState n k - , MkKeyFingerprint k Address - , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) - ) - => ctx - -> W.EpochNo - -> Set PoolId - -> PoolId - -> PoolLifeCycleStatus - -> WalletId - -> ArgGenChange s - -> ExceptT ErrJoinStakePool IO (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), DelegationAction, NonEmpty DerivationIndex) -joinStakePoolUnsigned ctx currentEpoch knownPools pid poolStatus wid argGenChange = - db & \DBLayer{..} -> do - (wal, _, _) <- withExceptT - ErrJoinStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) - (cs, action, sPath) <- - joinStakePoolUnsigned' @ctx @s @t @k @n - ctx currentEpoch knownPools pid poolStatus wid - - coinSel' <- mapExceptT atomically $ do - (coinSel', s') <- assignChangeAddresses argGenChange cs (getState wal) - - withExceptT ErrJoinStakePoolNoSuchWallet $ - putCheckpoint (PrimaryKey wid) (updateState s' wal) - pure coinSel' - - utx <- UnsignedTx - <$> (fullyQualifiedInputs (getState wal) coinSel' - (ErrJoinStakePoolUnableToAssignInputs coinSel')) - <*> ensureNonEmpty (outputs coinSel') - (ErrJoinStakePoolUnableToAssignOutputs coinSel') - pure (utx, action, sPath) - where - db = ctx ^. dbLayer @s @k - -joinStakePoolUnsigned' - :: forall ctx s t k n. +joinStakePool + :: forall ctx s k n. ( HasDBLayer s k ctx , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx , s ~ SeqState n k ) => ctx @@ -2004,14 +1953,16 @@ joinStakePoolUnsigned' -> PoolId -> PoolLifeCycleStatus -> WalletId - -> ExceptT ErrJoinStakePool IO (CoinSelection, DelegationAction, NonEmpty DerivationIndex) -joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = + -> ExceptT ErrJoinStakePool IO DelegationAction +joinStakePool ctx currentEpoch knownPools pid poolStatus wid = db & \DBLayer{..} -> do - (wal, walMeta, _) <- withExceptT - ErrJoinStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) - isKeyReg <- mapExceptT atomically - $ withExceptT ErrJoinStakePoolNoSuchWallet - $ isStakeKeyRegistered (PrimaryKey wid) + (walMeta, isKeyReg) <- mapExceptT atomically $ do + walMeta <- withExceptT ErrJoinStakePoolNoSuchWallet + $ withNoSuchWallet wid + $ readWalletMeta (PrimaryKey wid) + isKeyReg <- withExceptT ErrJoinStakePoolNoSuchWallet + $ isStakeKeyRegistered (PrimaryKey wid) + pure (walMeta, isKeyReg) let mRetirementEpoch = view #retirementEpoch <$> W.getPoolRetirementCertificate poolStatus @@ -2021,172 +1972,40 @@ joinStakePoolUnsigned' ctx currentEpoch knownPools pid poolStatus wid = withExceptT ErrJoinStakePoolCannotJoin $ except $ guardJoin knownPools (walMeta ^. #delegation) pid retirementInfo - let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg - cs <- withExceptT ErrJoinStakePoolSelectCoin $ - selectCoinsForDelegation @ctx @s @t @k ctx wid action - - let s = getState wal - dprefix = Seq.derivationPrefix s - sPath = stakeDerivationPath dprefix - - pure (cs, action, sPath) - + return $ if isKeyReg + then Join pid + else RegisterKeyAndJoin pid where db = ctx ^. dbLayer @s @k tr = ctx ^. logger --- | Helper function to factor necessary logic for joining a stake pool. -joinStakePool - :: forall ctx s t k n. - ( HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx - , IsOwned s k - , IsOurs s ChimericAccount - , GenChange s - , AddressIndexDerivationType k ~ 'Soft - , WalletKey k - , s ~ SeqState n k - , SoftDerivation k - , HasNetworkLayer t ctx - ) - => ctx - -> W.EpochNo - -> Set PoolId - -> PoolId - -> PoolLifeCycleStatus - -> WalletId - -> ArgGenChange s - -> Passphrase "raw" - -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime) -joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd = - db & \DBLayer{..} -> do - (selection, action, _) <- joinStakePoolUnsigned' @ctx @s @t @k - ctx currentEpoch knownPools pid poolStatus wid - - (tx, txMeta, txTime, sealedTx) <- - withExceptT ErrJoinStakePoolSignDelegation $ - signDelegation - @ctx @s @t @k ctx wid argGenChange pwd selection action - - withExceptT ErrJoinStakePoolSubmitTx $ - submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx) - - pure (tx, txMeta, txTime) - where - db = ctx ^. dbLayer @s @k - --- | Quit stake pool and return the coin selection and certificates. --- Don't create a signed transaction. -quitStakePoolUnsigned - :: forall ctx s t k n. - ( HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx - , SoftDerivation k - , s ~ SeqState n k - , MkKeyFingerprint k Address - , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) - ) - => ctx - -> WalletId - -> ArgGenChange s - -> ExceptT ErrQuitStakePool IO - (UnsignedTx (TxIn, TxOut, NonEmpty DerivationIndex), - DelegationAction, NonEmpty DerivationIndex) -quitStakePoolUnsigned ctx wid argGenChange = db & \DBLayer{..} -> do - (wal, _, _) <- withExceptT - ErrQuitStakePoolNoSuchWallet (readWallet @ctx @s @k ctx wid) - (cs, action, sPath) <- quitStakePoolUnsigned' @ctx @s @t @k @n ctx wid - - coinSel' <- mapExceptT atomically $ do - (coinSel', s') <- assignChangeAddresses argGenChange cs (getState wal) - - withExceptT ErrQuitStakePoolNoSuchWallet $ - putCheckpoint (PrimaryKey wid) (updateState s' wal) - pure coinSel' - - utx <- UnsignedTx - <$> (fullyQualifiedInputs (getState wal) coinSel' - (ErrQuitStakePoolUnableToAssignInputs coinSel')) - <*> ensureNonEmpty (outputs coinSel') - (ErrQuitStakePoolUnableToAssignOutputs coinSel') - pure (utx, action, sPath) - where - db = ctx ^. dbLayer @s @k - -quitStakePoolUnsigned' - :: forall ctx s t k n. - ( HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasTransactionLayer t k ctx - , s ~ SeqState n k - ) - => ctx - -> WalletId - -> ExceptT ErrQuitStakePool IO (CoinSelection, DelegationAction, NonEmpty DerivationIndex) -quitStakePoolUnsigned' ctx wid = db & \DBLayer{..} -> do - walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $ - withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid) - - rewards <- liftIO $ fetchRewardBalance @ctx @s @k ctx wid - withExceptT ErrQuitStakePoolCannotQuit $ except $ - guardQuit (walMeta ^. #delegation) rewards - - let action = Quit - - cs <- withExceptT ErrQuitStakePoolSelectCoin $ - selectCoinsForDelegation @ctx @s @t @k ctx wid action - - cp <- mapExceptT atomically - $ withExceptT ErrQuitStakePoolNoSuchWallet - $ withNoSuchWallet wid - $ readCheckpoint (PrimaryKey wid) - let s = getState cp - dprefix = Seq.derivationPrefix s - sPath = stakeDerivationPath dprefix - - pure (cs, action, sPath) - where - db = ctx ^. dbLayer @s @k - -- | Helper function to factor necessary logic for quitting a stake pool. quitStakePool - :: forall ctx s t k n. + :: forall ctx s k n. ( HasDBLayer s k ctx - , HasLogger WalletLog ctx - , HasNetworkLayer t ctx - , HasTransactionLayer t k ctx - , IsOwned s k - , IsOurs s ChimericAccount - , GenChange s - , AddressIndexDerivationType k ~ 'Soft - , WalletKey k , s ~ SeqState n k - , SoftDerivation k ) => ctx -> WalletId - -> ArgGenChange s - -> Passphrase "raw" - -> ExceptT ErrQuitStakePool IO (Tx, TxMeta, UTCTime) -quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do - (selection, action, _) <- quitStakePoolUnsigned' @ctx @s @t @k - ctx wid + -> ExceptT ErrQuitStakePool IO DelegationAction +quitStakePool ctx wid = db & \DBLayer{..} -> do + walMeta <- mapExceptT atomically + $ withExceptT ErrQuitStakePoolNoSuchWallet + $ withNoSuchWallet wid + $ readWalletMeta (PrimaryKey wid) - (tx, txMeta, txTime, sealedTx) <- withExceptT ErrQuitStakePoolSignDelegation $ - signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection action + rewards <- liftIO + $ fetchRewardBalance @ctx @s @k ctx wid - withExceptT ErrQuitStakePoolSubmitTx $ - submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx) + withExceptT ErrQuitStakePoolCannotQuit $ except $ + guardQuit (walMeta ^. #delegation) rewards - pure (tx, txMeta, txTime) + pure Quit where db = ctx ^. dbLayer @s @k - {------------------------------------------------------------------------------- Fee Estimation -------------------------------------------------------------------------------} diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index af813b900f8..a1b9913f17e 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -49,8 +49,6 @@ module Cardano.Wallet.Api.Server , getUTxOsStatistics , getWallet , joinStakePool - , selectCoinsJoinStakePool - , selectCoinsQuitStakePool , listAddresses , listTransactions , getTransaction @@ -75,6 +73,8 @@ module Cardano.Wallet.Api.Server , putWalletPassphrase , quitStakePool , selectCoins + , selectCoinsForJoin + , selectCoinsForQuit -- * Internals , LiftHandler(..) @@ -1120,7 +1120,7 @@ selectCoins -> ApiT WalletId -> ApiSelectCoinsPayments n -> Handler (ApiCoinSelection n) -selectCoins ctx gen (ApiT wid) body = +selectCoins ctx genChange (ApiT wid) body = fmap (mkApiCoinSelection Nothing) $ withWorkerCtx ctx wid liftE liftE $ \wrk -> do @@ -1128,15 +1128,21 @@ selectCoins ctx gen (ApiT wid) body = -- Allow representing withdrawals as part of external coin selections. let withdrawal = Quantity 0 let outs = coerceCoin <$> body ^. #payments - liftHandler $ W.selectCoinsExternal @_ @s @t @k wrk wid gen outs withdrawal Nothing + liftHandler + $ W.selectCoinsExternal @_ @s @k wrk wid genChange + $ withExceptT ErrSelectCoinsExternalForPayment + $ W.selectCoinsForPayment @_ @s @t @k wrk wid outs withdrawal Nothing -selectCoinsJoinStakePool - :: forall ctx s t n k. +selectCoinsForJoin + :: forall ctx e s t n k. ( s ~ SeqState n k , ctx ~ ApiLayer s t k + , Buildable e , SoftDerivation k , DelegationAddress n k , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) + , Typeable s + , Typeable n ) => ctx -> IO (Set PoolId) @@ -1146,33 +1152,61 @@ selectCoinsJoinStakePool -> PoolId -> WalletId -> Handler (Api.ApiCoinSelection n) -selectCoinsJoinStakePool ctx knownPools getPoolStatus pid wid = do +selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do poolStatus <- liftIO (getPoolStatus pid) pools <- liftIO knownPools curEpoch <- getCurrentEpoch ctx - (utx, action, spath) <- withWorkerCtx ctx wid liftE liftE $ - \wrk -> liftHandler $ - W.joinStakePoolUnsigned - @_ @s @t @k wrk - curEpoch pools pid poolStatus wid (delegationAddress @n) - pure $ mkApiCoinSelection (Just (action, spath)) utx + (utx, action, path) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do + action <- liftHandler + $ W.joinStakePool @_ @s @k @n wrk curEpoch pools pid poolStatus wid -selectCoinsQuitStakePool - :: forall ctx s t n k. + utx <- liftHandler + $ W.selectCoinsExternal @_ @s @k @e wrk wid genChange + $ withExceptT ErrSelectCoinsExternalForDelegation + $ W.selectCoinsForDelegation @_ @s @t @k wrk wid action + + (_, path) <- liftHandler + $ W.readChimericAccount @_ @s @k @n wrk wid + + pure (utx, action, path) + + pure $ mkApiCoinSelection (Just (action, path)) utx + where + genChange = delegationAddress @n + +selectCoinsForQuit + :: forall ctx e s t n k. ( s ~ SeqState n k , ctx ~ ApiLayer s t k + , Buildable e , SoftDerivation k , DelegationAddress n k , MkKeyFingerprint k (Proxy n, k 'AddressK XPub) + , Typeable s + , Typeable n ) => ctx -> ApiT WalletId -> Handler (Api.ApiCoinSelection n) -selectCoinsQuitStakePool ctx (ApiT wid) = do - (utx, action, spath) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ - W.quitStakePoolUnsigned @_ @s @t @k wrk wid (delegationAddress @n) - pure $ mkApiCoinSelection (Just (action, spath)) utx +selectCoinsForQuit ctx (ApiT wid) = do + (utx, action, path) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do + action <- liftHandler + $ W.quitStakePool @_ @s @k @n wrk wid + + utx <- liftHandler + $ W.selectCoinsExternal @_ @s @k @e wrk wid genChange + $ withExceptT ErrSelectCoinsExternalForDelegation + $ W.selectCoinsForDelegation @_ @s @t @k wrk wid action + + (_, path) <- liftHandler + $ W.readChimericAccount @_ @s @k @n wrk wid + + pure (utx, action, path) + + pure $ mkApiCoinSelection (Just (action, path)) utx + where + genChange = delegationAddress @n {------------------------------------------------------------------------------- Addresses @@ -1289,7 +1323,7 @@ postTransaction ctx genChange (ApiT wid) body = do pure (Quantity 0, selfRewardCredentials) Just SelfWithdrawal -> do - acct <- liftHandler $ W.readChimericAccount @_ @s @k @n wrk wid + (acct, _) <- liftHandler $ W.readChimericAccount @_ @s @k @n wrk wid wdrl <- liftHandler $ W.queryRewardBalance @_ @t wrk acct (, selfRewardCredentials) <$> liftIO (W.readNextWithdrawal @_ @s @t @k wrk wid wdrl) @@ -1420,7 +1454,7 @@ postTransactionFee ctx (ApiT wid) body = do pure (Quantity 0) Just SelfWithdrawal -> do - acct <- liftHandler $ W.readChimericAccount @_ @s @k @n wrk wid + (acct, _) <- liftHandler $ W.readChimericAccount @_ @s @k @n wrk wid wdrl <- liftHandler $ W.queryRewardBalance @_ @t wrk acct liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid wdrl @@ -1464,11 +1498,21 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do pools <- liftIO knownPools curEpoch <- getCurrentEpoch ctx - (tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ - \wrk -> liftHandler $ - W.joinStakePool - @_ @s @t @k wrk - curEpoch pools pid poolStatus wid (delegationAddress @n) pwd + (tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do + action <- liftHandler + $ W.joinStakePool @_ @s @k @n wrk curEpoch pools pid poolStatus wid + + cs <- liftHandler + $ W.selectCoinsForDelegation @_ @s @t @k wrk wid action + + (tx, txMeta, txTime, sealedTx) <- liftHandler + $ W.signDelegation @_ @s @t @k wrk wid genChange pwd cs action + + liftHandler + $ W.submitTx @_ @s @t @k wrk + wid (tx, txMeta, sealedTx) + + pure (tx, txMeta, txTime) liftIO $ mkApiTransaction ti @@ -1480,10 +1524,13 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do Nothing #pendingSince where + genChange = delegationAddress @n + -- Not forecasting into the future. Should be safe. ti :: TimeInterpreter IO ti = timeInterpreter (ctx ^. networkLayer @t) + delegationFee :: forall ctx s t n k. ( s ~ SeqState n k @@ -1516,8 +1563,22 @@ quitStakePool quitStakePool ctx (ApiT wid) body = do let pwd = coerce $ getApiT $ body ^. #passphrase - (tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ - W.quitStakePool @_ @s @t @k wrk wid (delegationAddress @n) pwd + (tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do + action <- liftHandler + $ W.quitStakePool @_ @s @k @n wrk wid + + cs <- liftHandler + $ W.selectCoinsForDelegation @_ @s @t @k wrk wid action + + (tx, txMeta, txTime, sealedTx) <- liftHandler + $ W.signDelegation @_ @s @t @k wrk wid genChange pwd cs action + + liftHandler + $ W.submitTx @_ @s @t @k wrk + wid (tx, txMeta, sealedTx) + + pure (tx, txMeta, txTime) + liftIO $ mkApiTransaction ti @@ -1529,6 +1590,8 @@ quitStakePool ctx (ApiT wid) body = do Nothing #pendingSince where + genChange = delegationAddress @n + -- Not forecasting into the future. Should be safe. ti :: TimeInterpreter IO ti = timeInterpreter (ctx ^. networkLayer @t) @@ -2203,7 +2266,9 @@ instance Buildable e => LiftHandler (ErrSelectCoinsExternal e) where handler = \case ErrSelectCoinsExternalNoSuchWallet e -> handler e - ErrSelectCoinsExternalUnableToMakeSelection e -> + ErrSelectCoinsExternalForPayment e -> + handler e + ErrSelectCoinsExternalForDelegation e -> handler e ErrSelectCoinsExternalUnableToAssignInputs e -> apiError err500 UnableToAssignInputOutput $ mconcat diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index f5854c967bd..da877a83ee6 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs @@ -88,8 +88,8 @@ import Cardano.Wallet.Api.Server , quitStakePool , rndStateChange , selectCoins - , selectCoinsJoinStakePool - , selectCoinsQuitStakePool + , selectCoinsForJoin + , selectCoinsForQuit , withLegacyLayer , withLegacyLayer' ) @@ -208,14 +208,15 @@ server byron icarus shelley spl ntp = coinSelections = (\wid ascd -> case ascd of (ApiSelectForPayment ascp) -> selectCoins shelley (delegationAddress @n) wid ascp (ApiSelectForDelegation (ApiSelectCoinsAction (ApiT action))) -> case action of - Join pid -> selectCoinsJoinStakePool + Join pid -> selectCoinsForJoin @_ @() shelley (knownPools spl) (getPoolLifeCycleStatus spl) pid (getApiT wid) RegisterKeyAndJoin _ -> throwError err400 - Quit -> selectCoinsQuitStakePool shelley wid) + Quit -> selectCoinsForQuit @_ @() shelley wid + ) transactions :: Server (Transactions n) transactions = From 4a5f4d96ea74f89bf0920b2ebed3a57c3bee1ca2 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 16 Oct 2020 15:46:09 +0200 Subject: [PATCH 10/25] return structured error for invalid wallets, instead of plain string --- lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index da877a83ee6..5646d63c665 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs @@ -313,8 +313,10 @@ server byron icarus shelley spl ntp = withLegacyLayer wid (byron, liftHandler $ throwE ErrNotASequentialWallet) (icarus, selectCoins icarus (const $ paymentAddress @n) wid x) - byronCoinSelections _ _ = throwError - $ err400 { errBody = "Byron wallets don't have delegation capabilities." } + byronCoinSelections _ _ = Handler + $ throwE + $ apiError err400 InvalidWalletType + "Byron wallets don't have delegation capabilities." byronTransactions :: Server (ByronTransactions n) byronTransactions = From ad67e13aab5781067e54089810068f5b3e9b2484 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Tue, 8 Sep 2020 14:36:15 +1000 Subject: [PATCH 11/25] nix: Add shell with profiled haskell packages --- default.nix | 89 ++++++++++++++++++++++++++++------------------------- release.nix | 20 ++++++++++-- shell.nix | 17 +++++++++- 3 files changed, 80 insertions(+), 46 deletions(-) diff --git a/default.nix b/default.nix index 45be24c3f51..e1f8f545ad4 100644 --- a/default.nix +++ b/default.nix @@ -72,6 +72,51 @@ let getPackageChecks = mapAttrs (_: package: package.checks); + # Creates a development environment for Cabal builds or ghci + # sessions, with various build tools included. + mkShell = name: hsPkgs: hsPkgs.shellFor { + inherit name; + packages = ps: attrValues (selectProjectPackages ps); + buildInputs = (with self; [ + jormungandr + jormungandr-cli + cardano-node + cardano-cli + cardano-address + cardano-tx + bech32 + ]) ++ (with pkgs; [ + niv + pkgconfig + python3Packages.openapi-spec-validator + ruby + sqlite-interactive + yq + ]); + tools = { + cabal = "3.2.0.0"; + ghcid = "0.8.7"; + ghcide = "0.2.0"; + hlint = "3.1.6"; + lentil = "1.3.2.0"; + stylish-haskell = "0.11.0.0"; + weeder = "1.0.9"; + }; + CARDANO_NODE_CONFIGS = cardano-node.deployments; + meta.platforms = lib.platforms.unix; + shellHook = '' + setup_completion() { + local p + for p in $buildInputs; do + if [ -d "$p/share/bash-completion" ]; then + addToSearchPath XDG_DATA_DIRS "$p/share" + fi + done + } + setup_completion + ''; + }; + self = { inherit pkgs commonLib src haskellPackages profiledHaskellPackages; # Jormungandr @@ -114,48 +159,8 @@ let shelley = self.cardano-wallet; }); - shell = haskellPackages.shellFor { - name = "cardano-wallet-shell"; - packages = ps: attrValues (selectProjectPackages ps); - buildInputs = (with self; [ - jormungandr - jormungandr-cli - cardano-node - cardano-cli - cardano-address - cardano-tx - bech32 - ]) ++ (with pkgs; [ - niv - pkgconfig - python3Packages.openapi-spec-validator - ruby - sqlite-interactive - yq - ]); - tools = { - cabal = "3.2.0.0"; - ghcid = "0.8.7"; - ghcide = "0.2.0"; - hlint = "3.1.6"; - lentil = "1.3.2.0"; - stylish-haskell = "0.11.0.0"; - weeder = "1.0.9"; - }; - CARDANO_NODE_CONFIGS = cardano-node.deployments; - meta.platforms = lib.platforms.unix; - shellHook = '' - setup_completion() { - local p - for p in $buildInputs; do - if [ -d "$p/share/bash-completion" ]; then - addToSearchPath XDG_DATA_DIRS "$p/share" - fi - done - } - setup_completion - ''; - }; + shell = mkShell "cardano-wallet-shell" haskellPackages; + shell-prof = mkShell "cardano-wallet-shell-profiled" profiledHaskellPackages; cabalShell = import ./nix/cabal-shell.nix { inherit pkgs; walletPackages = self; }; stackShell = import ./nix/stack-shell.nix { inherit pkgs; walletPackages = self; }; diff --git a/release.nix b/release.nix index 2dc53a179e6..90d6b0b7092 100644 --- a/release.nix +++ b/release.nix @@ -90,7 +90,7 @@ let inherit (systems.examples) mingwW64 musl64; mappedJobs = optionalAttrs buildNative { - native = mapTestOn (filterJobsNative (packagePlatformsOrig project)); + native = mapTestOn (filterMappedNative (packagePlatformsOrig (filterJobsNative project))); } // optionalAttrs buildWindows { "${mingwW64.config}" = mapTestOnCross mingwW64 (packagePlatformsCross (filterJobsWindows project)); @@ -116,7 +116,14 @@ let ) ds); # Remove build jobs for which cross compiling does not make sense. - filterJobsCross = filterAttrs (n: _: !(elem n ["dockerImage" "shell" "stackShell" "cabalShell" "stackNixRegenerate"])); + filterJobsCross = filterAttrs (n: _: !(elem n [ + "dockerImage" + "shell" + "shell-prof" + "stackShell" + "cabalShell" + "stackNixRegenerate" + ])); # Remove cardano-node integration tests for Windows because # ouroboros-network doesn't work under wine. @@ -128,13 +135,20 @@ let js: mapAttrsRecursive f (filterJobsCross js); # Don't run tests on linux native, because they are also run for linux musl. - filterJobsNative = let + filterMappedNative = let removeLinuxNativeChecks = path: value: if (head path == "checks" && builtins.typeOf value == "list") then remove "x86_64-linux" value else value; in mapAttrsRecursive removeLinuxNativeChecks; + # Build profiled packages for the master branch, so that they are cached. + # But don't make profiled builds for PRs because this is a waste of time. + filterJobsNative = let + removeProfiledBuildForPRs = if (pr == null) + then id + else filterAttrs (n: _: n != "shell-prof"); + in removeProfiledBuildForPRs; ############################################################################ # This aggregate job is what IOHK Hydra uses to update the CI status diff --git a/shell.nix b/shell.nix index 82fb296083f..98e9cb38a96 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,16 @@ -(import ./default.nix {}).shell +# This file is used by nix-shell. +# It just plucks the "shell" attribute from default.nix. +# See that file for more info. +# +# If you want Haskell dependencies built with profiling, then use: +# nix-shell --arg profiling true +{ profiling ? false +, sourcesOverride ? {} # see sourcesOverride in nix/default.nix +}: + +let + cardanoWallet = import ./default.nix { inherit sourcesOverride; }; +in + if profiling + then cardanoWallet.shell-prof + else cardanoWallet.shell From 57672a0d11cc75b45a5e4bcd3fdf637839acbc60 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 2 Oct 2020 12:52:48 +1000 Subject: [PATCH 12/25] release.nix: Fix sourcesOverride --- release.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/release.nix b/release.nix index 90d6b0b7092..70e8c0809d7 100644 --- a/release.nix +++ b/release.nix @@ -41,7 +41,7 @@ , projectArgs ? { config = { allowUnfree = false; inHydra = true; }; gitrev = cardano-wallet.rev; - inherit pr; + inherit pr sourcesOverride; } # The systems that the jobset will be built for. From 5e41f7e264632b8879d302aa6008baa25bfaf061 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 23 Sep 2020 14:03:54 +1000 Subject: [PATCH 13/25] Bump iohk-nix to latest master --- nix/sources.json | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index a0f51016d94..e572227a276 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -29,10 +29,10 @@ "homepage": null, "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "b22d8da9dd38c971ad40d9ad2d1a60cce53995fb", - "sha256": "0r6x6gnbb63c70h14l8fmv34cql2kzvsdabgm8bixvinlghpm1w1", + "rev": "f4790863d0d4e3f9018f012ec6575432c7952a48", + "sha256": "0jds3j5fqcwbgpmbddrp9cxia5mxz8kw7sqsw6jcq9bq5mv1x00d", "type": "tarball", - "url": "https://github.com/input-output-hk/iohk-nix/archive/b22d8da9dd38c971ad40d9ad2d1a60cce53995fb.tar.gz", + "url": "https://github.com/input-output-hk/iohk-nix/archive/f4790863d0d4e3f9018f012ec6575432c7952a48.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "niv": { From 97f09769c1ced23a2303d1bcdf46b12d597c2da7 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 1 Oct 2020 12:40:00 +1000 Subject: [PATCH 14/25] Update iohk-nix cardano deployments --- nix/pkgs.nix | 1 - 1 file changed, 1 deletion(-) diff --git a/nix/pkgs.nix b/nix/pkgs.nix index d9d344e246e..6060eb24507 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -17,7 +17,6 @@ in pkgs: super: with pkgs; { environments = { inherit (pkgs.commonLib.cardanoLib.environments) mainnet - mainnet_candidate_4 staging testnet shelley_qa From 87666d56d4072cbaa01f869ea97221e468e1ffd9 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Tue, 8 Sep 2020 16:12:07 +1000 Subject: [PATCH 15/25] Bump haskell.nix to latest master Includes Samuel's coverage PR. https://github.com/input-output-hk/haskell.nix/pull/762 --- nix/sources.json | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index e572227a276..46b09222de2 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -17,10 +17,10 @@ "homepage": "https://input-output-hk.github.io/haskell.nix", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "e4dab4d33ce8fb2b8f375ca7e064731733e44cbd", - "sha256": "19r7283878x62l5bn3j4xq001wlmprmw0pxg9ghv21lgjy54cvz1", + "rev": "b12905981daa8f398e0847e148904955986404b8", + "sha256": "0n2im8v5szmbmjrgxrd0aid6hciscj517dk8nd5gsidfx0ys98ai", "type": "tarball", - "url": "https://github.com/input-output-hk/haskell.nix/archive/e4dab4d33ce8fb2b8f375ca7e064731733e44cbd.tar.gz", + "url": "https://github.com/input-output-hk/haskell.nix/archive/b12905981daa8f398e0847e148904955986404b8.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "iohk-nix": { @@ -58,5 +58,18 @@ "type": "tarball", "url": "https://github.com/NixOS/nixpkgs/archive/a8f81dc037a5977414a356dd068f2621b3c89b60.tar.gz", "url_template": "https://github.com///archive/.tar.gz" + }, + "sphinxcontrib-haddock": { + "branch": "master", + "builtin": false, + "description": "Tools for using Haddock with Sphinx", + "homepage": null, + "owner": "michaelpj", + "repo": "sphinxcontrib-haddock", + "rev": "f3956b3256962b2d27d5a4e96edb7951acf5de34", + "sha256": "0mlxa5zzgdka0c6sj7pp4cfvc8rcrd8g2z2113vp614l43g17miv", + "type": "tarball", + "url": "https://github.com/michaelpj/sphinxcontrib-haddock/archive/f3956b3256962b2d27d5a4e96edb7951acf5de34.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" } } From f7766855406aa99bc123ada8839feb6257881f65 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Tue, 8 Sep 2020 16:11:52 +1000 Subject: [PATCH 16/25] Build tests with Haskell Program Coverage enabled --- default.nix | 13 ++++++++++--- nix/haskell.nix | 19 +++++++++++++++++++ 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index e1f8f545ad4..e1da3b7f89d 100644 --- a/default.nix +++ b/default.nix @@ -69,6 +69,7 @@ let } // args); haskellPackages = buildHaskellPackages {}; profiledHaskellPackages = buildHaskellPackages { profiling = true; }; + coveredHaskellPackages = buildHaskellPackages { coverage = true; }; getPackageChecks = mapAttrs (_: package: package.checks); @@ -118,7 +119,7 @@ let }; self = { - inherit pkgs commonLib src haskellPackages profiledHaskellPackages; + inherit pkgs commonLib src haskellPackages profiledHaskellPackages coveredHaskellPackages; # Jormungandr inherit (jmPkgs) jormungandr jormungandr-cli; # expose cardano-node, so daedalus can ship it without needing to pin cardano-node @@ -146,9 +147,15 @@ let }; # `tests` are the test suites which have been built. - tests = collectComponents "tests" isProjectPackage haskellPackages; + tests = collectComponents "tests" isProjectPackage coveredHaskellPackages; # `checks` are the result of executing the tests. - checks = pkgs.recurseIntoAttrs (getPackageChecks (selectProjectPackages haskellPackages)); + checks = pkgs.recurseIntoAttrs (getPackageChecks (selectProjectPackages coveredHaskellPackages)); + # Combined coverage report + # fixme: haskell.nix needs to support using `checks` attrset from + # above, otherwise we will be running unnecessary test suites. + # testCoverageReport = pkgs.haskell-nix.haskellLib.projectCoverageReport { + # packages = selectProjectPackages coveredHaskellPackages; + # }; # `benchmarks` are only built, not run. benchmarks = collectComponents "benchmarks" isProjectPackage haskellPackages; diff --git a/nix/haskell.nix b/nix/haskell.nix index 8946b969211..45c25d83705 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -9,6 +9,8 @@ , config ? {} # Enable profiling , profiling ? config.haskellNix.profiling or false +# Enable Haskell Program Coverage for cardano-wallet libraries and test suites. +, coverage ? config.haskellNix.coverage or false # Project top-level source tree , src # GitHub PR number (when building on Hydra) @@ -61,6 +63,23 @@ let packages.text-class.flags.release = true; } + (lib.optionalAttrs coverage { + # Enable Haskell Program Coverage for all local libraries and test suites. + packages.cardano-wallet.components.library.doCoverage = true; + packages.cardano-wallet.components.tests.unit.doCoverage = true; + packages.cardano-wallet.components.tests.integration.doCoverage = true; + packages.cardano-wallet-cli.components.library.doCoverage = true; + packages.cardano-wallet-core-integration.components.library.doCoverage = true; + packages.cardano-wallet-core.components.library.doCoverage = true; + packages.cardano-wallet-core.components.tests.unit.doCoverage = true; + packages.cardano-wallet-jormungandr.components.library.doCoverage = true; + packages.cardano-wallet-jormungandr.components.tests.unit.doCoverage = true; + packages.cardano-wallet-jormungandr.components.tests.jormungandr-integration.doCoverage = true; + packages.cardano-wallet-launcher.components.library.doCoverage = true; + packages.cardano-wallet-test-utils.components.library.doCoverage = true; + packages.text-class.components.library.doCoverage = true; + }) + # Provide configuration and dependencies to cardano-wallet components { packages.cardano-wallet.components.tests = { From 51951bdd43bace07052c910ae59689a0963ccc52 Mon Sep 17 00:00:00 2001 From: Samuel Evans-Powell Date: Wed, 23 Sep 2020 11:13:44 +0800 Subject: [PATCH 17/25] Add stock coverage reports --- nix/haskell.nix | 12 ++++++------ nix/stack-shell.nix | 2 ++ 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/nix/haskell.nix b/nix/haskell.nix index 45c25d83705..e6bbcf46591 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -66,8 +66,6 @@ let (lib.optionalAttrs coverage { # Enable Haskell Program Coverage for all local libraries and test suites. packages.cardano-wallet.components.library.doCoverage = true; - packages.cardano-wallet.components.tests.unit.doCoverage = true; - packages.cardano-wallet.components.tests.integration.doCoverage = true; packages.cardano-wallet-cli.components.library.doCoverage = true; packages.cardano-wallet-core-integration.components.library.doCoverage = true; packages.cardano-wallet-core.components.library.doCoverage = true; @@ -325,7 +323,9 @@ let }; in - pkgSet.config.hsPkgs // { - _config = pkgSet.config; - _roots = haskell.roots pkgSet.config.ghc; - } +haskell.addProjectAndPackageAttrs { + pkg-set = pkgSet; + inherit (pkgSet.config) hsPkgs; + _config = pkgSet.config; + _roots = haskell.roots pkgSet.config.ghc; +} diff --git a/nix/stack-shell.nix b/nix/stack-shell.nix index 32ac71fe42d..49bd852e5b0 100644 --- a/nix/stack-shell.nix +++ b/nix/stack-shell.nix @@ -12,6 +12,8 @@ in cabalShell.overrideAttrs (old: { name = "cardano-wallet-stack-env"; + buildInputs = old.buildInputs ++ [ pkgs.stack ]; + # Build environment setup copied from # GIT_SSL_CAINFO = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; From a853fe85d1ddd662fb8bce186589791c233b9b5b Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 25 Sep 2020 16:36:49 +1000 Subject: [PATCH 18/25] nix: Update ghcide, hlint, stylish-haskell versions --- default.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index e1da3b7f89d..b4870a41b6d 100644 --- a/default.nix +++ b/default.nix @@ -97,10 +97,10 @@ let tools = { cabal = "3.2.0.0"; ghcid = "0.8.7"; - ghcide = "0.2.0"; - hlint = "3.1.6"; + ghcide = "0.4.0"; + hlint = "3.2"; lentil = "1.3.2.0"; - stylish-haskell = "0.11.0.0"; + stylish-haskell = "0.11.0.3"; weeder = "1.0.9"; }; CARDANO_NODE_CONFIGS = cardano-node.deployments; From c70a7db2455b0469a0e637a2b2445581ad5915f2 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 1 Oct 2020 12:11:40 +1000 Subject: [PATCH 19/25] release.nix: Filter test coverage report to be musl linux only --- release.nix | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/release.nix b/release.nix index 70e8c0809d7..063f68ed1f9 100644 --- a/release.nix +++ b/release.nix @@ -129,12 +129,13 @@ let # ouroboros-network doesn't work under wine. filterJobsWindows = let f = path: value: if (isCardanoNodeIntegration path) then {} else value; - isCardanoNodeIntegration = path: elem path - (map (x: ["checks" "cardano-wallet-${x}" "integration"]) ["shelley"]); + isCardanoNodeIntegration = path: + path == ["checks" "cardano-wallet" "integration"]; in js: mapAttrsRecursive f (filterJobsCross js); - # Don't run tests on linux native, because they are also run for linux musl. + # Filters jobs for non-cross builds after platform mapping. + # 1. Don't run tests on linux native, because they are also run for linux musl. filterMappedNative = let removeLinuxNativeChecks = path: value: if (head path == "checks" && builtins.typeOf value == "list") @@ -142,13 +143,17 @@ let else value; in mapAttrsRecursive removeLinuxNativeChecks; - # Build profiled packages for the master branch, so that they are cached. - # But don't make profiled builds for PRs because this is a waste of time. + # Filters the derivations from default.nix for non-cross builds. + # 1. Build profiled packages for the master branch, so that they are cached. + # But don't make profiled builds for PRs because this is a waste of time. + # 2. Remove the test coverage report - only generate that for Linux musl. filterJobsNative = let removeProfiledBuildForPRs = if (pr == null) then id else filterAttrs (n: _: n != "shell-prof"); - in removeProfiledBuildForPRs; + removeCoverageReport = filterAttrs (n: _: n != "testCoverageReport"); + in + drvs: removeCoverageReport (removeProfiledBuildForPRs drvs); ############################################################################ # This aggregate job is what IOHK Hydra uses to update the CI status From 30eb486ac908ab6c33139f5c1f5fd9e7a63455a9 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 30 Sep 2020 18:12:04 +1000 Subject: [PATCH 20/25] Fix up Haskell.nix usage and add Hydra job for coverage --- default.nix | 10 +++------- nix/haskell.nix | 24 +++++++++++++++++------- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/default.nix b/default.nix index b4870a41b6d..22494c6321e 100644 --- a/default.nix +++ b/default.nix @@ -75,7 +75,7 @@ let # Creates a development environment for Cabal builds or ghci # sessions, with various build tools included. - mkShell = name: hsPkgs: hsPkgs.shellFor { + mkShell = name: hp: hp.shellFor { inherit name; packages = ps: attrValues (selectProjectPackages ps); buildInputs = (with self; [ @@ -150,12 +150,8 @@ let tests = collectComponents "tests" isProjectPackage coveredHaskellPackages; # `checks` are the result of executing the tests. checks = pkgs.recurseIntoAttrs (getPackageChecks (selectProjectPackages coveredHaskellPackages)); - # Combined coverage report - # fixme: haskell.nix needs to support using `checks` attrset from - # above, otherwise we will be running unnecessary test suites. - # testCoverageReport = pkgs.haskell-nix.haskellLib.projectCoverageReport { - # packages = selectProjectPackages coveredHaskellPackages; - # }; + # Combined project coverage report + inherit (coveredHaskellPackages) testCoverageReport; # `benchmarks` are only built, not run. benchmarks = collectComponents "benchmarks" isProjectPackage haskellPackages; diff --git a/nix/haskell.nix b/nix/haskell.nix index e6bbcf46591..e6558568f99 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -31,7 +31,7 @@ let filterSubDir = subDir: haskell.haskellLib.cleanSourceWith { inherit src subDir; }; - pkgSet = haskell.mkStackPkgSet { + pkg-set = haskell.mkStackPkgSet { inherit stack-pkgs; modules = [ # Add source filtering to local packages @@ -322,10 +322,20 @@ let ''; }; + proj = haskell.addProjectAndPackageAttrs { + inherit pkg-set; + inherit (pkg-set.config) hsPkgs; + }; + in -haskell.addProjectAndPackageAttrs { - pkg-set = pkgSet; - inherit (pkgSet.config) hsPkgs; - _config = pkgSet.config; - _roots = haskell.roots pkgSet.config.ghc; -} + proj.hsPkgs // { + _config = proj.pkg-set.config; + #_roots = haskell.roots proj.pkg-set.config.ghc; + testCoverageReport = proj.projectCoverageReport.overrideAttrs (old: { + buildCommand = old.buildCommand + '' + mkdir -p $out/nix-support + echo "report coverage $out/share/hpc/vanilla/html/all/hpc_index.html" >> $out/nix-support/hydra-build-products + echo "report coverage-per-package $out/share/hpc/vanilla/html/index.html" >> $out/nix-support/hydra-build-products + ''; + }); + } From 1aa25859817da5bb1c3560b7038318e6c93d35af Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 1 Oct 2020 15:54:18 +1000 Subject: [PATCH 21/25] Remove old script --- nix/update-iohk-nix.sh | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100755 nix/update-iohk-nix.sh diff --git a/nix/update-iohk-nix.sh b/nix/update-iohk-nix.sh deleted file mode 100755 index adebaeb7a67..00000000000 --- a/nix/update-iohk-nix.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/env nix-shell -#!nix-shell -i bash -p nix-prefetch-git coreutils - -set -euo pipefail - -nix_dir=$(dirname $0) -json="$nix_dir/iohk-nix-src.json" - -nix-prefetch-git --quiet --url https://github.com/input-output-hk/iohk-nix | tee "$json" -echo "Updated $json" From f560971f5f693f1e3031e6c6789c0e33761f59de Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 2 Oct 2020 12:10:45 +1000 Subject: [PATCH 22/25] nix: Remove upstreamed code --- nix/haskell.nix | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/nix/haskell.nix b/nix/haskell.nix index e6558568f99..260c7a6f6a1 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -331,11 +331,5 @@ in proj.hsPkgs // { _config = proj.pkg-set.config; #_roots = haskell.roots proj.pkg-set.config.ghc; - testCoverageReport = proj.projectCoverageReport.overrideAttrs (old: { - buildCommand = old.buildCommand + '' - mkdir -p $out/nix-support - echo "report coverage $out/share/hpc/vanilla/html/all/hpc_index.html" >> $out/nix-support/hydra-build-products - echo "report coverage-per-package $out/share/hpc/vanilla/html/index.html" >> $out/nix-support/hydra-build-products - ''; - }); + testCoverageReport = proj.projectCoverageReport; } From 95c37bcee9be7e1670cefcdef19fa8573cb23add Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 2 Oct 2020 13:30:19 +1000 Subject: [PATCH 23/25] Fix new HLint errors --- lib/shelley/src/Cardano/Wallet/Shelley/Network.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index f0496d98e81..76d4f17db2a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -264,6 +264,8 @@ import qualified Shelley.Spec.Ledger.Keys as SL import qualified Shelley.Spec.Ledger.LedgerState as SL {- HLINT ignore "Use readTVarIO" -} +{- HLINT ignore "Use newTVarIO" -} +{- HLINT ignore "Use newEmptyTMVarIO" -} -- | Network layer cursor for Shelley. Mostly useless since the protocol itself is -- stateful and the node's keep track of the associated connection's cursor. From 23e9257dfb19132ea7983998cab21bfb60bcfe79 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 2 Oct 2020 13:38:31 +1000 Subject: [PATCH 24/25] Use shorter cross-compiler friendly HLint annotations --- lib/core/src/Cardano/Byron/Codec/Cbor.hs | 7 ++----- lib/core/src/Cardano/DB/Sqlite.hs | 3 +-- lib/core/src/Cardano/Pool/DB/Model.hs | 2 +- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 3 +-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 3 +-- lib/core/test/unit/Cardano/Byron/Codec/CborSpec.hs | 2 +- lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs | 4 ++-- .../unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs | 2 +- lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs | 2 +- .../integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs | 2 +- .../test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs | 3 +-- lib/launcher/test/unit/Cardano/LauncherSpec.hs | 3 ++- lib/shelley/bench/Restore.hs | 2 +- 13 files changed, 16 insertions(+), 22 deletions(-) diff --git a/lib/core/src/Cardano/Byron/Codec/Cbor.hs b/lib/core/src/Cardano/Byron/Codec/Cbor.hs index 717c4060a45..8752391e1dc 100644 --- a/lib/core/src/Cardano/Byron/Codec/Cbor.hs +++ b/lib/core/src/Cardano/Byron/Codec/Cbor.hs @@ -1,6 +1,3 @@ --- need this for {-# HLINT ... #-}; see https://github.com/ndmitchell/hlint#ignoring-hints -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -281,7 +278,7 @@ decodeTx = do _ <- decodeEmptyAttributes return (ins, outs) -{-# HLINT ignore decodeTxIn "Use <$>" #-} +{- HLINT ignore decodeTxIn "Use <$>" -} decodeTxIn :: CBOR.Decoder s TxIn decodeTxIn = do _ <- CBOR.decodeListLenCanonicalOf 2 @@ -301,7 +298,7 @@ decodeTxIn = do tx <- Hash <$> CBOR.decodeBytes TxIn tx <$> CBOR.decodeWord32 -{-# HLINT ignore decodeTxOut "Use <$>" #-} +{- HLINT ignore decodeTxOut "Use <$>" -} decodeTxOut :: CBOR.Decoder s TxOut decodeTxOut = do _ <- CBOR.decodeListLenCanonicalOf 2 diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 432d4193ce0..d0516d9ed12 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -13,8 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant flip" #-} +{- HLINT ignore "Redundant flip" -} -- | -- Copyright: © 2018-2020 IOHK diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 5837716455c..032699a5e88 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -451,7 +451,7 @@ mReadSettings = get #settings -- `const` isn't more readable than lambdas. Our language is based on -- lambda calculus and we shouldn't feel ashamed to use them. They also -- have different strictness properties. -{-# HLINT ignore mPutSettings "Use const" #-} +{- HLINT ignore mPutSettings "Use const" -} mPutSettings :: Settings -> ModelOp () diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 83fb60632cf..b1245150a9b 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -14,8 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant flip" #-} +{- HLINT ignore "Redundant flip" -} -- | -- Copyright: © 2018-2020 IOHK diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 9626013500a..91c91f7324b 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -12,8 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant flip" #-} +{- HLINT ignore "Redundant flip" -} -- | -- Copyright: © 2018-2020 IOHK diff --git a/lib/core/test/unit/Cardano/Byron/Codec/CborSpec.hs b/lib/core/test/unit/Cardano/Byron/Codec/CborSpec.hs index eed7d9f5428..b257a9c9a89 100644 --- a/lib/core/test/unit/Cardano/Byron/Codec/CborSpec.hs +++ b/lib/core/test/unit/Cardano/Byron/Codec/CborSpec.hs @@ -58,7 +58,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -{-# ANN spec ("HLint: ignore Use head" :: String) #-} +{- HLINT ignore spec "Use head" -} spec :: Spec spec = do diff --git a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs index 8713a32ee06..b706f3f0f66 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs @@ -229,7 +229,7 @@ import qualified Test.QuickCheck as QC import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 -{-# ANN module ("HLint: ignore Unused LANGUAGE pragma" :: String) #-} +{- HLINT ignore "Unused LANGUAGE pragma" -} {------------------------------------------------------------------------------- Mock implementation @@ -569,7 +569,7 @@ lockstep m@(Model _ ws) c (At resp) = Event Generator -------------------------------------------------------------------------------} -{-# ANN generator ("HLint: ignore Use ++" :: String) #-} +{- HLINT ignore generator "Use ++" -} generator :: forall s. (Arbitrary (Wallet s), GenState s) => Model s Symbolic diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs index fe0145806bb..68e45d39dd4 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs @@ -84,7 +84,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Test.QuickCheck.Monadic as QC -{-# ANN module ("HLint: ignore Use <$>" :: String) #-} +{- HLINT ignore "Use <$>" -} spec :: Spec spec = do diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs index c23afc1657f..f3ce660693e 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs @@ -197,7 +197,7 @@ maxNumberOfOutputs = 254 -------------------------------------------------------------------------------} -- Do-notation is favoured over applicative syntax for readability: -{-# ANN module ("HLint: ignore Use <$>" :: String) #-} +{- HLINT ignore "Use <$>" -} data BlockHeader = BlockHeader { version :: Word16 diff --git a/lib/jormungandr/test/integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs b/lib/jormungandr/test/integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs index f7af1dfabd4..e7345b68371 100644 --- a/lib/jormungandr/test/integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs +++ b/lib/jormungandr/test/integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs @@ -129,7 +129,7 @@ import qualified Cardano.Wallet.Jormungandr.Api.Client as Jormungandr import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -{-# ANN spec ("HLint: ignore Use head" :: String) #-} +{- HLINT ignore spec "Use head" -} spec :: Spec spec = do diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 5bc2be6240f..6f122864814 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -8,7 +8,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module Cardano.Pool.Jormungandr.MetricsSpec ( spec @@ -177,7 +176,7 @@ prop_combineIsLeftBiased mStake_ mProd_ mPerf_ = mStake = Map.mapKeys getLowEntropy mStake_ mProd = Map.mapKeys getLowEntropy mProd_ mPerf = Map.mapKeys getLowEntropy mPerf_ -{-# HLINT ignore prop_combineIsLeftBiased "Use ||" #-} +{- HLINT ignore prop_combineIsLeftBiased "Use ||" -} -- | A list of chunks of blocks to be served up by the mock network layer. newtype RegistrationsTest = RegistrationsTest diff --git a/lib/launcher/test/unit/Cardano/LauncherSpec.hs b/lib/launcher/test/unit/Cardano/LauncherSpec.hs index 79380c5da78..4297a2521a0 100644 --- a/lib/launcher/test/unit/Cardano/LauncherSpec.hs +++ b/lib/launcher/test/unit/Cardano/LauncherSpec.hs @@ -81,7 +81,8 @@ import Test.Hspec import Test.Utils.Windows ( isWindows, pendingOnWine ) -{-# ANN spec ("HLint: ignore Use head" :: String) #-} +{- HLINT ignore spec "Use head" -} + spec :: Spec spec = beforeAll setupMockCommands $ do it "Buildable Command" $ \MockCommands{..} -> do diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index 82b4c9ec0f2..1a3ba285d08 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -528,7 +528,7 @@ benchmarksSeq _ w wid wname restoreTime = do , walletOverview } -{-# ANN bench_restoration ("HLint: ignore Use camelCase" :: String) #-} +{- HLINT ignore bench_restoration "Use camelCase" -} bench_restoration :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *) s t results. ( IsOurs s Address From e2c02b01bdfe0d16ee69a5e508af142daa760ac5 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 7 Oct 2020 12:52:57 +1000 Subject: [PATCH 25/25] nix-shell: Replace ghcide-0.4.0 with haskell-language-server-0.5.0 --- default.nix | 8 ++++++-- nix/hls.nix | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+), 2 deletions(-) create mode 100644 nix/hls.nix diff --git a/default.nix b/default.nix index 22494c6321e..a121b72e7f9 100644 --- a/default.nix +++ b/default.nix @@ -93,11 +93,10 @@ let ruby sqlite-interactive yq - ]); + ]) ++ attrValues hls; tools = { cabal = "3.2.0.0"; ghcid = "0.8.7"; - ghcide = "0.4.0"; hlint = "3.2"; lentil = "1.3.2.0"; stylish-haskell = "0.11.0.3"; @@ -118,6 +117,11 @@ let ''; }; + # Build latest release of haskell-language-server from github + hls = pkgs.callPackages ./nix/hls.nix { + compiler-nix-name = haskellPackages._config.compiler.nix-name; + }; + self = { inherit pkgs commonLib src haskellPackages profiledHaskellPackages coveredHaskellPackages; # Jormungandr diff --git a/nix/hls.nix b/nix/hls.nix new file mode 100644 index 00000000000..12910f257a7 --- /dev/null +++ b/nix/hls.nix @@ -0,0 +1,32 @@ +{ haskell-nix, fetchFromGitHub, compiler-nix-name }: + +let + hlsPkgs = haskell-nix.cabalProject { + src = fetchFromGitHub { + name = "haskell-language-server"; + owner = "haskell"; + repo = "haskell-language-server"; + rev = "0.5.0"; + sha256 = "0vkh5ff6l5wr4450xmbki3cfhlwf041fjaalnwmj7zskd72s9p7p"; + fetchSubmodules = true; + }; + + # Fix source info of brittany dep + lookupSha256 = { location, tag, ... } : { + "https://github.com/bubba/brittany.git"."c59655f10d5ad295c2481537fc8abf0a297d9d1c" = "1rkk09f8750qykrmkqfqbh44dbx1p8aq1caznxxlw8zqfvx39cxl"; + }."${location}"."${tag}"; + + # Use same GHC as the project + inherit compiler-nix-name; + + # # Materialization voodoo (disabled for now). + # inherit index-state checkMaterialization; + # Invalidate and update if you change the version + # plan-sha256 = "144p19wpydc6c56f0zw5b7c17151n0cghimr9wd8rlhifymmky2h"; + }; + +in + { + inherit (hlsPkgs.haskell-language-server.components.exes) haskell-language-server; + inherit (hlsPkgs.hie-bios.components.exes) hie-bios; + }