Merge #2257

2257: API data-types & specifications for arbitrary metadata signing. r=rvl a=KtorZ

# Issue Number

<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->

ADP-481 > ADP-508

# Overview

<!-- Detail in a few bullet points the work accomplished in this PR -->

- 209781b
  📍 **define ToText/FromText instances for 'DerivationIndex'**
    I had to also move it in '...Primitive.AddressDerivation' because of otherwise circular dependencies (since this module is using the Bounded instances of 'Index', relying on the 'DerivationType' as type parameter. This is mostly extracting the text parsing that was already done in the JSON instance, and moving it as a ToText/FromText instances (and re-using it to build the JSON instances). I've however added a quick sanity text roundtrip property test in the meantime.

- c965936
  📍 **rename UTxO*ternal -> Utxo*ternal**
    We use the data-type constructor in order to generate text instances.
  However, our automatic casing function is doing pretty bad with the
  mixed cases and we end up with something like:

    - u_tx_o_external
    - u_tx_o_internal
    - mutable_account

  Instead of fixing the instance itself to work around this, I found it
  easier to just fix the type (which isn't used in many places).

- c4cbafe
  📍 **do not output back invalid input when parsing text values.**
    This is a rather bad practice; if a value failed to parse, then we have very little idea about _what_ it is and what's it's shape. It may not be even readable / printable. Instead, the error message should show valid expected options.

- fb5ab0d
  📍 **extend API and specifications to include the 'signMetadata' operation**

# Comments

<!-- Additional comments or screenshots to attach if any -->

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: KtorZ <matthias.benkort@gmail.com>
Co-authored-by: Rodney Lorrimar <rodney.lorrimar@iohk.io>

lib/core-integration/src/Test/Integration/Faucet.hs

@@ -1903,7 +1903,7 @@ genIcarusFaucets = genFaucet encodeAddress genAddresses
             accXPrv =
                 deriveAccountPrivateKey pwd rootXPrv minBound
             addrXPrv =
-                deriveAddressPrivateKey pwd accXPrv UTxOExternal
+                deriveAddressPrivateKey pwd accXPrv UtxoExternal
         in
             [ paymentAddress @'Mainnet $ publicKey $ addrXPrv ix
             | ix <- [minBound..maxBound]
@@ -1929,7 +1929,7 @@ genShelleyAddresses mw =
         accXPrv =
             deriveAccountPrivateKey pwd rootXPrv minBound
         addrXPrv =
-            deriveAddressPrivateKey pwd accXPrv UTxOExternal
+            deriveAddressPrivateKey pwd accXPrv UtxoExternal
     in
         [ paymentAddress @'Mainnet $ publicKey $ addrXPrv ix
         | ix <- [minBound..maxBound]

lib/core-integration/src/Test/Integration/Framework/DSL.hs

@@ -1360,7 +1360,7 @@ icarusAddresses mw =
         accXPrv =
             deriveAccountPrivateKey pwd rootXPrv minBound
         addrXPrv =
-            deriveAddressPrivateKey pwd accXPrv UTxOExternal
+            deriveAddressPrivateKey pwd accXPrv UtxoExternal
     in
         [ paymentAddress @n (publicKey $ addrXPrv ix)
         | ix <- [minBound..maxBound]
@@ -1385,7 +1385,7 @@ shelleyAddresses mw =
         accXPrv =
             deriveAccountPrivateKey pwd rootXPrv minBound
         addrXPrv =
-            deriveAddressPrivateKey pwd accXPrv UTxOExternal
+            deriveAddressPrivateKey pwd accXPrv UtxoExternal
     in
         [ paymentAddress @n (publicKey $ addrXPrv ix)
         | ix <- [minBound..maxBound]

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

@@ -156,7 +156,7 @@ spec = describe "SHELLEY_ADDRESSES" $ do
                 [ expectResponseCode @IO HTTP.status400
                 , expectErrorMessage $
                     "Error parsing query parameter state failed: Unable to\
-                    \ decode the given value: '" <> fil <> "'. Please specify\
+                    \ decode the given text value. Please specify\
                     \ one of the following values: used, unused."
                 ]
 

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

@@ -35,7 +35,8 @@ import Cardano.Wallet.Api.Types
     , WalletStyle (..)
     )
 import Cardano.Wallet.Primitive.AddressDerivation
-    ( DerivationType (..)
+    ( DerivationIndex (..)
+    , DerivationType (..)
     , Index (..)
     , PassphraseMaxLength (..)
     , PassphraseMinLength (..)
@@ -52,7 +53,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress (..) )
 import Cardano.Wallet.Primitive.Types
-    ( DerivationIndex (..), walletNameMaxLength, walletNameMinLength )
+    ( walletNameMaxLength, walletNameMinLength )
 import Control.Monad
     ( forM_ )
 import Data.Generics.Internal.VL.Lens

lib/core-integration/src/Test/Integration/Scenario/CLI/Shelley/Addresses.hs

@@ -151,7 +151,7 @@ spec = describe "SHELLEY_CLI_ADDRESSES" $ do
             walId <- emptyWallet' ctx
             (Exit c, Stdout o, Stderr e)
                 <- listAddressesViaCLI @t ctx ["--state", fil, walId]
-            let err = "Unable to decode the given value: \"" <> fil <> "\". Please\
+            let err = "Unable to decode the given text value. Please\
                     \ specify one of the following values: used, unused."
             e `shouldContain` err
             c `shouldBe` ExitFailure 1

lib/core/src/Cardano/Wallet.hs

@@ -212,6 +212,7 @@ import Cardano.Wallet.Network
 import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
     , Depth (..)
+    , DerivationIndex
     , DerivationType (..)
     , ErrWrongPassphrase (..)
     , HardDerivation (..)
@@ -293,7 +294,6 @@ import Cardano.Wallet.Primitive.Types
     , ChimericAccount (..)
     , Coin (..)
     , DelegationCertificate (..)
-    , DerivationIndex
     , Direction (..)
     , FeePolicy (LinearFee)
     , GenesisParameters (..)

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

@@ -28,6 +28,7 @@ module Cardano.Wallet.Api
         , PutWallet
         , PutWalletPassphrase
         , GetUTxOsStatistics
+        , SignMetadata
 
     , Addresses
         , ListAddresses
@@ -132,6 +133,7 @@ import Cardano.Wallet.Api.Types
     , ApiWalletMigrationInfo
     , ApiWalletMigrationPostDataT
     , ApiWalletPassphrase
+    , ApiWalletSignData
     , ByronWalletPutPassphraseData
     , Iso8601Time
     , MinWithdrawal
@@ -149,7 +151,7 @@ import Cardano.Wallet.DB
 import Cardano.Wallet.Network
     ( NetworkLayer )
 import Cardano.Wallet.Primitive.AddressDerivation
-    ( Depth )
+    ( AccountingStyle, Depth, DerivationIndex )
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncTolerance )
 import Cardano.Wallet.Primitive.Types
@@ -166,6 +168,8 @@ import Cardano.Wallet.Transaction
     ( TransactionLayer )
 import Control.Tracer
     ( Tracer, contramap )
+import Data.ByteString
+    ( ByteString )
 import Data.Generics.Internal.VL.Lens
     ( Lens' )
 import Data.Generics.Labels
@@ -233,6 +237,7 @@ type Wallets =
     :<|> PutWallet
     :<|> PutWalletPassphrase
     :<|> GetUTxOsStatistics
+    :<|> SignMetadata
 
 -- | https://input-output-hk.github.io/cardano-wallet/api/#operation/deleteWallet
 type DeleteWallet = "wallets"
@@ -273,6 +278,15 @@ type GetUTxOsStatistics = "wallets"
     :> "utxos"
     :> Get '[JSON] ApiUtxoStatistics
 
+-- | https://input-output-hk.github.io/cardano-wallet/api/#operation/signMetadata
+type SignMetadata = "wallets"
+    :> Capture "walletId" (ApiT WalletId)
+    :> Capture "role" (ApiT AccountingStyle)
+    :> Capture "index" (ApiT DerivationIndex)
+    :> "signatures"
+    :> ReqBody '[JSON] ApiWalletSignData
+    :> Post '[OctetStream] ByteString
+
 {-------------------------------------------------------------------------------
                                   Addresses
 

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

@@ -223,6 +223,7 @@ walletClient =
             :<|> _putWallet
             :<|> _putWalletPassphrase
             :<|> _getWalletUtxoStatistics
+            :<|> _signMetadata
             = client (Proxy @("v2" :> Wallets))
     in
         WalletClient

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

@@ -227,6 +227,7 @@ import Cardano.Wallet.Primitive.AddressDerivation
     ( ChimericAccount (..)
     , DelegationAddress (..)
     , Depth (..)
+    , DerivationIndex (..)
     , DerivationType (..)
     , HardDerivation (..)
     , Index (..)
@@ -286,7 +287,6 @@ import Cardano.Wallet.Primitive.Types
     , Block
     , BlockHeader (..)
     , Coin (..)
-    , DerivationIndex (..)
     , Hash (..)
     , NetworkParameters (..)
     , PassphraseScheme (..)
@@ -352,7 +352,7 @@ import Data.Generics.Internal.VL.Lens
 import Data.Generics.Labels
     ()
 import Data.List
-    ( isInfixOf, isSubsequenceOf, sortOn )
+    ( isInfixOf, isPrefixOf, isSubsequenceOf, isSuffixOf, sortOn )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Map.Strict
@@ -2693,14 +2693,22 @@ instance LiftHandler (Request, ServerError) where
             , "endpoint and the method: one of them is likely to be incorrect "
             , "(for example: POST instead of PUT, or GET instead of POST...)."
             ]
-        406 -> apiError err' NotAcceptable $ mconcat
-            [ "It seems as though you don't accept 'application/json', but "
-            , "unfortunately I only speak 'application/json'! Please "
+        406 ->
+            let cType =
+                    -- FIXME: Ugly and not really scalable nor maintainable.
+                    if ["wallets"] `isPrefixOf` pathInfo req
+                    && ["signatures"] `isSuffixOf` pathInfo req
+                    then "application/octet-stream"
+                    else "application/json"
+            in apiError err' NotAcceptable $ mconcat
+            [ "It seems as though you don't accept '", cType,"', but "
+            , "unfortunately I only speak '", cType,"'! Please "
             , "double-check your 'Accept' request header and make sure it's "
-            , "set to 'application/json'."
+            , "set to '", cType,"'."
             ]
         415 ->
             let cType =
+                    -- FIXME: Ugly and not really scalable nor maintainable.
                     if ["proxy", "transactions"] `isSubsequenceOf` pathInfo req
                         then "application/octet-stream"
                         else "application/json"

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

@@ -93,6 +93,7 @@ module Cardano.Wallet.Api.Types
     , ApiWalletMigrationPostData (..)
     , ApiWalletMigrationInfo (..)
     , ApiWithdrawal (..)
+    , ApiWalletSignData (..)
 
     -- * API Types (Byron)
     , ApiByronWallet (..)
@@ -150,7 +151,7 @@ import Cardano.Mnemonic
     )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..)
-    , DerivationType (..)
+    , DerivationIndex (..)
     , Index (..)
     , NetworkDiscriminant (..)
     , Passphrase (..)
@@ -174,7 +175,6 @@ import Cardano.Wallet.Primitive.Types
     , ChimericAccount (..)
     , Coin (..)
     , DecentralizationLevel (..)
-    , DerivationIndex (..)
     , Direction (..)
     , EpochLength (..)
     , EpochNo (..)
@@ -251,8 +251,6 @@ import Data.Proxy
     ( Proxy (..) )
 import Data.Quantity
     ( Percentage, Quantity (..) )
-import Data.Scientific
-    ( Scientific, toBoundedInteger )
 import Data.String
     ( IsString )
 import Data.Text
@@ -281,8 +279,6 @@ import GHC.TypeLits
     ( Nat, Symbol )
 import Numeric.Natural
     ( Natural )
-import Safe
-    ( readMay )
 import Servant.API
     ( MimeRender (..), MimeUnrender (..), OctetStream )
 import Web.HttpApiData
@@ -740,6 +736,11 @@ data ApiWalletMigrationInfo = ApiWalletMigrationInfo
 newtype ApiWithdrawRewards = ApiWithdrawRewards Bool
     deriving (Eq, Generic, Show)
 
+data ApiWalletSignData = ApiWalletSignData
+    { metadata :: ApiT TxMetadata
+    , passphrase :: ApiT (Passphrase "lenient")
+    } deriving (Eq, Generic, Show)
+
 -- | Error codes returned by the API, in the form of snake_cased strings
 data ApiErrorCode
     = NoSuchWallet
@@ -976,45 +977,10 @@ instance EncodeAddress n => ToJSON (ApiAddress n) where
     toJSON = genericToJSON defaultRecordTypeOptions
 
 instance ToJSON (ApiT DerivationIndex) where
-    toJSON (ApiT (DerivationIndex ix))
-        | ix >= firstHardened = toJSON (show (ix - firstHardened) <> "H")
-        | otherwise = toJSON (show ix)
-      where
-        firstHardened = getIndex @'Hardened minBound
-
+    toJSON = toJSON . toText . getApiT
 instance FromJSON (ApiT DerivationIndex) where
-    parseJSON value = ApiT <$> (parseJSON value >>= parseAsText)
-      where
-        firstHardened = getIndex @'Hardened minBound
-
-        parseAsText :: Text -> Aeson.Parser DerivationIndex
-        parseAsText txt =
-            if "H" `T.isSuffixOf` txt then do
-                DerivationIndex ix <- castNumber (T.init txt) >>= parseAsScientific
-                pure $ DerivationIndex $ ix + firstHardened
-            else
-                castNumber txt >>= parseAsScientific
-
-        parseAsScientific :: Scientific -> Aeson.Parser DerivationIndex
-        parseAsScientific x =
-            case toBoundedInteger x of
-                Just ix | ix < firstHardened -> pure $ DerivationIndex ix
-                _ -> fail $ mconcat
-                    [ "A derivation index must be a natural number between "
-                    , show (getIndex @'Soft minBound)
-                    , " and "
-                    , show (getIndex @'Soft maxBound)
-                    , "."
-                    ]
-
-        castNumber :: Text -> Aeson.Parser Scientific
-        castNumber txt =
-            case readMay (T.unpack txt) of
-                Nothing ->
-                    fail "expected a number as string with an optional 'H' \
-                         \suffix (e.g. \"1815H\" or \"44\""
-                Just s ->
-                    pure s
+    parseJSON = parseJSON
+        >=> fmap ApiT . eitherToParser . first ShowFmt . fromText
 
 instance FromJSON ApiEpochInfo where
     parseJSON = genericParseJSON defaultRecordTypeOptions
@@ -1578,6 +1544,11 @@ instance FromJSON ApiNetworkParameters where
 instance ToJSON ApiNetworkParameters where
     toJSON = genericToJSON defaultRecordTypeOptions
 
+instance FromJSON ApiWalletSignData where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON ApiWalletSignData where
+    toJSON = genericToJSON defaultRecordTypeOptions
+
 instance DecodeStakeAddress n => FromJSON (ApiWithdrawal n) where
     parseJSON = genericParseJSON defaultRecordTypeOptions
 instance EncodeStakeAddress n => ToJSON (ApiWithdrawal n) where

lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -430,7 +431,28 @@ instance PersistFieldSql AddressPoolGap where
 
 instance PersistField AccountingStyle where
     toPersistValue = toPersistValue . toText
-    fromPersistValue = fromPersistValueFromText
+    fromPersistValue value =
+        backwardCompatible . fromPersistValueFromText $ value
+      where
+        -- The 'AccountingStyle' constructors used to be respectively:
+        --
+        --   - UTxOInternal
+        --   - UTxOExternal
+        --
+        -- (notice the mixed case here) and were serialized to text as:
+        --
+        --   - u_tx_o_internal
+        --   - u_tx_o_external
+        --
+        -- which is pretty lame. This was changed later on, but already
+        -- serialized data may subsist on for quite a while. Hence this little
+        -- pirouette here.
+        backwardCompatible = \case
+            success@Right{} -> success
+            failure@Left{}  -> fromPersistValue @Text value >>= \case
+                t | t == "u_tx_o_internal" -> pure UtxoInternal
+                t | t == "u_tx_o_external" -> pure UtxoExternal
+                _ -> failure
 
 instance PersistFieldSql AccountingStyle where
     sqlType _ = sqlType (Proxy @Text)