Exclude Shared Keys at the type level

lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs

@@ -17,6 +17,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 {-# HLINT ignore "Use record patterns" #-}
 
@@ -427,7 +428,7 @@ import Cardano.Wallet.Compat
 import Cardano.Wallet.DB
     ( DBFactory (..), DBFresh, DBLayer, loadDBLayer )
 import Cardano.Wallet.Flavor
-    ( KeyOf, WalletFlavor (..), WalletFlavorS (ShelleyWallet) )
+    ( Excluding, KeyOf, WalletFlavor (..), WalletFlavorS (..) )
 import Cardano.Wallet.Network
     ( NetworkLayer (..), fetchRewardAccountBalances, timeInterpreter )
 import Cardano.Wallet.Pools
@@ -1754,9 +1755,10 @@ getWalletUtxoSnapshot ctx (ApiT wid) = do
 -------------------------------------------------------------------------------}
 
 selectCoins
-    :: forall s n k .
+    :: forall s n k.
         ( IsOurs s Address
         , WalletFlavor s
+        , Excluding '[SharedKey] k
         , s ~ SeqState n k
         , AddressBookIso s
         , GenChange s
@@ -1816,6 +1818,7 @@ selectCoinsForJoin
     :: forall s n k.
         ( s ~ SeqState n k
         , WalletFlavor s
+        , Excluding '[SharedKey] k
         , AddressBookIso s
         , Seq.SupportsDiscovery n k
         , DelegationAddress k 'CredFromKeyK
@@ -1883,6 +1886,7 @@ selectCoinsForQuit
     :: forall s n k.
         ( s ~ SeqState n k
         , WalletFlavor s
+        , Excluding '[SharedKey] k
         , AddressBookIso s
         , Seq.SupportsDiscovery n k
         , DelegationAddress k 'CredFromKeyK
@@ -2156,6 +2160,7 @@ postTransactionOld
         , AddressBookIso s
         , HasDelegation s
         , WalletFlavor s
+        , Excluding '[SharedKey] k
         , IsOurs s RewardAccount
         , k ~ KeyOf s
         )
@@ -2335,6 +2340,7 @@ mkApiTransactionFromInfo ti wrk deposit info metadataSchema = do
 postTransactionFeeOld
     :: forall s n k
      . ( WalletFlavor s
+       , Excluding '[SharedKey] k
        , AddressBookIso s
        , TxWitnessTagFor k
        , k ~ KeyOf s
@@ -2407,10 +2413,13 @@ postTransactionFeeOld ctx@ApiLayer{..} (ApiT walletId) body = do
     padding = Quantity 20
 
 constructTransaction
-    :: forall n
-     . HasSNetworkId n
-    => ApiLayer (SeqState n ShelleyKey) 'CredFromKeyK
-    -> ArgGenChange (SeqState n ShelleyKey)
+    :: forall n s k.
+        ( HasSNetworkId n
+        , s ~ SeqState n k
+        , k ~ ShelleyKey
+        )
+    => ApiLayer s 'CredFromKeyK
+    -> ArgGenChange s
     -> IO (Set PoolId)
     -> (PoolId -> IO PoolLifeCycleStatus)
     -> ApiT WalletId
@@ -3497,6 +3506,7 @@ joinStakePool
     :: forall s n k.
         ( s ~ SeqState n k
         , WalletFlavor s
+        , Excluding '[SharedKey] k
         , AddressIndexDerivationType k ~ 'Soft
         , GenChange s
         , IsOwned s k 'CredFromKeyK

lib/wallet/src/Cardano/Wallet.hs

@@ -23,6 +23,8 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- suppress false warning
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 -- |
 -- Copyright: © 2018-2020 IOHK
@@ -336,7 +338,13 @@ import Cardano.Wallet.DB.WalletState
     , getSlot
     )
 import Cardano.Wallet.Flavor
-    ( KeyOf, WalletFlavor (..), WalletFlavorS (..), keyFlavor )
+    ( Excluding
+    , KeyFlavorS (..)
+    , KeyOf
+    , WalletFlavor (..)
+    , WalletFlavorS (..)
+    , keyFlavor
+    )
 import Cardano.Wallet.Logging
     ( BracketLog
     , BracketLog' (..)
@@ -1840,16 +1848,17 @@ type MakeRewardAccountBuilder k =
 --
 -- Requires the encryption passphrase in order to decrypt the root private key.
 buildSignSubmitTransaction
-    :: forall s k
-     . ( WalletKey k
-       , HardDerivation k
-       , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k))
-       , IsOwned s k 'CredFromKeyK
-       , IsOurs s RewardAccount
-       , AddressBookIso s
-       , WalletFlavor s
-       , k ~ KeyOf s
-       )
+    :: forall s k.
+        ( WalletKey k
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k))
+        , IsOwned s k 'CredFromKeyK
+        , IsOurs s RewardAccount
+        , AddressBookIso s
+        , WalletFlavor s
+        , Excluding '[SharedKey] k
+        , k ~ KeyOf s
+        )
     => DBLayer IO s
     -> NetworkLayer IO Read.Block
     -> TransactionLayer k 'CredFromKeyK SealedTx
@@ -1932,15 +1941,16 @@ buildSignSubmitTransaction db@DBLayer{..} netLayer txLayer pwd walletId
     wrapBalanceConstructError = either ExceptionBalanceTx ExceptionConstructTx
 
 buildAndSignTransactionPure
-    :: forall k s
-     . ( WalletKey k
-       , HardDerivation k
-       , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k))
-       , IsOwned s k 'CredFromKeyK
-       , IsOurs s RewardAccount
-       , WalletFlavor s
-       , k ~ KeyOf s
-       )
+    :: forall k s.
+        ( WalletKey k
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k))
+        , IsOwned s k 'CredFromKeyK
+        , IsOurs s RewardAccount
+        , WalletFlavor s
+        , Excluding '[SharedKey] k
+        , k ~ KeyOf s
+        )
     => TimeTranslation
     -> UTxO
     -> k 'RootK XPrv
@@ -2033,11 +2043,12 @@ buildAndSignTransactionPure
     anyCardanoEra = Write.fromAnyRecentEra era
 
 buildTransaction
-    :: forall s era
-    . ( WalletFlavor s
-      , Write.IsRecentEra era
-      , AddressBookIso s
-      )
+    :: forall s era.
+        ( WalletFlavor s
+        , Write.IsRecentEra era
+        , AddressBookIso s
+        , Excluding '[SharedKey] (KeyOf s)
+        )
     => DBLayer IO s
     -> TransactionLayer (KeyOf s) 'CredFromKeyK SealedTx
     -> TimeTranslation
@@ -2074,10 +2085,11 @@ buildTransaction DBLayer{..} txLayer timeTranslation changeAddrGen
                 & either (liftIO . throwIO) pure
 
 buildTransactionPure
-    :: forall s era
-     . ( Write.IsRecentEra era
-       , WalletFlavor s
-       )
+    :: forall s era.
+        ( Write.IsRecentEra era
+        , WalletFlavor s
+        , Excluding '[SharedKey] (KeyOf s)
+        )
     => Wallet s
     -> TimeTranslation
     -> UTxO
@@ -2100,16 +2112,11 @@ buildTransactionPure
                 txCtx
                 (Left preSelection)
 
-    let utxoAssumptions :: UTxOAssumptions =
-            case walletFlavor @s of
-                ShelleyWallet -> AllKeyPaymentCredentials
-                IcarusWallet -> AllByronKeyPaymentCredentials
-                ByronWallet -> AllByronKeyPaymentCredentials
-                SharedWallet -> AllScriptPaymentCredentialsFrom
-                    (error "buildTransactionPure.scriptTemplate")
-                    (error "buildTransactionPure.scriptLookup")
-                BenchByronWallet -> AllByronKeyPaymentCredentials
-                BenchShelleyWallet -> AllKeyPaymentCredentials
+    let utxoAssumptions =
+            case keyFlavor @s of
+                ByronKeyS -> AllByronKeyPaymentCredentials
+                IcarusKeyS -> AllByronKeyPaymentCredentials
+                ShelleyKeyS -> AllKeyPaymentCredentials
 
     withExceptT Left $
         balanceTransaction @_ @_ @s
@@ -2710,6 +2717,7 @@ delegationFee
     :: forall s
      . ( AddressBookIso s
        , WalletFlavor s
+       , Excluding '[SharedKey] (KeyOf s)
        )
     => DBLayer IO s
     -> NetworkLayer IO Read.Block
@@ -2743,6 +2751,7 @@ transactionFee
      . ( AddressBookIso s
        , Write.IsRecentEra era
        , WalletFlavor s
+       , Excluding '[SharedKey] (KeyOf s)
        )
     => DBLayer IO s
     -> Write.ProtocolParameters era
@@ -2784,11 +2793,18 @@ transactionFee DBLayer{atomically, walletState} protocolParams txLayer
                 , inputs = Cardano.UTxO mempty
                 , redeemers = []
                 }
+
+        let utxoAssumptions =
+                case keyFlavor @s of
+                    ByronKeyS -> AllByronKeyPaymentCredentials
+                    IcarusKeyS -> AllByronKeyPaymentCredentials
+                    ShelleyKeyS -> AllKeyPaymentCredentials
+
         wrapErrSelectAssets $ calculateFeePercentiles $ do
             res <- runExceptT $
                     balanceTransaction @_ @_ @s
                         nullTracer
-                        AllKeyPaymentCredentials
+                        utxoAssumptions
                         protocolParams
                         timeTranslation
                         utxoIndex

lib/wallet/src/Cardano/Wallet/Flavor.hs

@@ -6,9 +6,11 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Wallet.Flavor
     ( WalletFlavorS (..)
@@ -17,6 +19,9 @@ module Cardano.Wallet.Flavor
     , TestState (..)
     , KeyFlavorS (..)
     , keyFlavor
+    , keyOfWallet
+    , Including
+    , Excluding
     )
 where
 
@@ -114,3 +119,23 @@ keyOfWallet TestStateS = ShelleyKeyS
 -- > keyFlavor @s
 keyFlavor :: forall s. WalletFlavor s => KeyFlavorS (KeyOf s)
 keyFlavor = keyOfWallet (walletFlavor @s)
+
+-- | A type family to check if a type is included in a list of types.
+-- This type family exists as a way to refine types in functions.
+-- Ideally we wouldn't need it, as we want our types to describe the domain
+-- precisely enough not to need a refinement.
+-- However, in practice, we need to temporary refine types in functions,
+-- as we're refactoring the codebase.
+type family Exclude xs x where
+    Exclude '[] _ = 'True
+    Exclude (x ': xs) x = 'False
+    Exclude (x ': xs) y = Exclude xs y
+
+type family Include xs x where
+    Include '[] _ = 'False
+    Include (x ': xs) x = 'True
+    Include (x ': xs) y = Include xs y
+
+type Excluding (xs :: [k]) (x :: k) = Exclude xs x ~ 'True
+
+type Including xs x = Include xs x ~ 'True

lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs

@@ -121,8 +121,6 @@ import Cardano.Wallet.Address.Derivation
     , paymentAddress
     , publicKey
     )
-import Cardano.Wallet.Address.Derivation.Byron
-    ( ByronKey )
 import Cardano.Wallet.Address.Derivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Address.Discovery.Random