Allow to generate reward account addresses

command-line/cardano-addresses-cli.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 3737cc69d18f00a50e3c375be8e4be7728f2315689dc3bc92200f54e3c79c5b6
+-- hash: 137f6ee00d870a85ba847ab7061528566b677fe8338c0b737f3f8f1e193dcb6c
 
 name:           cardano-addresses-cli
 version:        1.0.0
@@ -38,6 +38,7 @@ library
       Command.Address.Inspect
       Command.Address.Payment
       Command.Address.Pointer
+      Command.Address.Reward
       Command.Key
       Command.Key.Child
       Command.Key.FromRecoveryPhrase
@@ -69,6 +70,7 @@ library
     , cardano-crypto
     , code-page
     , extra
+    , fmt
     , optparse-applicative
     , safe
     , text
@@ -102,6 +104,7 @@ test-suite unit
       Command.Address.InspectSpec
       Command.Address.PaymentSpec
       Command.Address.PointerSpec
+      Command.Address.RewardSpec
       Command.Key.ChildSpec
       Command.Key.FromRecoveryPhraseSpec
       Command.Key.InspectSpec

command-line/lib/Command/Address.hs

@@ -29,6 +29,7 @@ import qualified Command.Address.Delegation as Delegation
 import qualified Command.Address.Inspect as Inspect
 import qualified Command.Address.Payment as Payment
 import qualified Command.Address.Pointer as Pointer
+import qualified Command.Address.Reward as Reward
 
 
 data Cmd
@@ -37,6 +38,7 @@ data Cmd
     | Delegation Delegation.Cmd
     | Pointer Pointer.Cmd
     | Inspect Inspect.Cmd
+    | Reward Reward.Cmd
     deriving (Show)
 
 mod :: (Cmd -> parent) -> Mod CommandFields parent
@@ -57,6 +59,7 @@ mod liftCmd = command "address" $
         , Delegation.mod Delegation
         , Pointer.mod Pointer
         , Inspect.mod Inspect
+        , Reward.mod Reward
         ]
 
 run :: Cmd -> IO ()
@@ -66,3 +69,4 @@ run = \case
     Delegation sub -> Delegation.run sub
     Pointer sub -> Pointer.run sub
     Inspect sub -> Inspect.run sub
+    Reward sub -> Reward.run sub

command-line/lib/Command/Address/Reward.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+module Command.Address.Reward
+    ( Cmd
+    , mod
+    , run
+    ) where
+
+import Prelude hiding
+    ( mod )
+
+import Cardano.Address
+    ( NetworkTag (..), bech32 )
+import Cardano.Address.Style.Shelley
+    ( mkNetworkDiscriminant )
+import Fmt
+    ( build, fmt )
+import Options.Applicative
+    ( CommandFields, Mod, command, footerDoc, header, helper, info, progDesc )
+import Options.Applicative.Discrimination
+    ( networkTagOpt )
+import Options.Applicative.Help.Pretty
+    ( bold, indent, string, vsep )
+import Options.Applicative.Style
+    ( Style (..) )
+import System.Exit
+    ( die )
+import System.IO
+    ( stdin, stdout )
+import System.IO.Extra
+    ( hGetXPub, progName )
+
+import qualified Cardano.Address.Style.Shelley as Shelley
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Text.Encoding as T
+
+
+newtype Cmd = Cmd
+    { networkTag :: NetworkTag
+    } deriving (Show)
+
+mod :: (Cmd -> parent) -> Mod CommandFields parent
+mod liftCmd = command "stake" $
+    info (helper <*> fmap liftCmd parser) $ mempty
+        <> progDesc "Create a stake address"
+        <> header "Create a stake address \
+            \that references a staking key (1-1)."
+        <> footerDoc (Just $ vsep
+            [ string "The public key is read from stdin."
+            , string ""
+            , string "Example:"
+            , indent 2 $ bold $ string $ "$ "<>progName<>" recovery-phrase generate --size 15 \\"
+            , indent 4 $ bold $ string $ "| "<>progName<>" key from-recovery-phrase Shelley > root.prv"
+            , indent 2 $ string ""
+            , indent 2 $ bold $ string "$ cat root.prv \\"
+            , indent 4 $ bold $ string $ "| "<>progName<>" key child 1852H/1815H/0H/2/0 > stake.prv"
+            , indent 2 $ string ""
+            , indent 2 $ bold $ string "$ cat stake.prv \\"
+            , indent 4 $ bold $ string $ "| "<>progName<>" key public \\"
+            , indent 4 $ bold $ string $ "| "<>progName<>" address stake --network-tag 0"
+            , indent 2 $ string "addr1uqly0fjvrgguywze067gwhsexggtj8rrdnxczgp5vexe8zgxqns3g"
+            ])
+  where
+    parser = Cmd
+        <$> networkTagOpt Shelley
+
+run :: Cmd -> IO ()
+run Cmd{networkTag} = do
+    xpub <- hGetXPub stdin
+    case (mkNetworkDiscriminant . fromIntegral . unNetworkTag) networkTag of
+        Left e -> die (fmt $ build e)
+        Right discriminant -> do
+            let addr = Shelley.stakeAddress discriminant (Shelley.liftXPub xpub)
+            B8.hPutStr stdout $ T.encodeUtf8 $ bech32 addr
+
+

command-line/package.yaml

@@ -43,6 +43,7 @@ library:
   - cardano-crypto
   - code-page
   - extra
+  - fmt
   - optparse-applicative
   - safe
   - text

command-line/test/Command/Address/RewardSpec.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Command.Address.RewardSpec
+    ( spec
+    ) where
+
+import Prelude
+
+import Test.Hspec
+    ( Spec, SpecWith, it, shouldBe, shouldContain )
+import Test.Utils
+    ( cli, describeCmd )
+
+spec :: Spec
+spec = describeCmd [ "address", "reward" ] $ do
+    specShelley defaultPhrase "1852H/1815H/0H/2/0" 0
+        "addr1ura3dk68y6echdmfmnvm8mej8u5truwv8ufmv830w5a45tc3fm70z"
+
+    specShelley defaultPhrase "1852H/1815H/0H/2/0" 3
+        "addr1u0a3dk68y6echdmfmnvm8mej8u5truwv8ufmv830w5a45tc3kzy0t"
+
+    specMalformedNetwork "💩"
+
+    specInvalidNetwork "42"
+
+specShelley :: [String] -> String -> Int -> String -> SpecWith ()
+specShelley phrase path networkTag want = it ("golden shelley (payment) " <> path) $ do
+    out <- cli [ "key", "from-recovery-phrase", "shelley" ] (unwords phrase)
+       >>= cli [ "key", "child", path ]
+       >>= cli [ "key", "public" ]
+       >>= cli [ "address", "reward", "--network-tag", show networkTag ]
+    out `shouldBe` want
+
+specMalformedNetwork :: String -> SpecWith ()
+specMalformedNetwork networkTag = it ("malformed network " <> networkTag) $ do
+    (out, err) <- cli [ "key", "from-recovery-phrase", "shelley" ] (unwords defaultPhrase)
+        >>= cli [ "key", "public" ]
+        >>= cli [ "address", "reward", "--network-tag", networkTag ]
+    out `shouldBe` ""
+    err `shouldContain` "Invalid network tag"
+    err `shouldContain` "Usage"
+
+specInvalidNetwork :: String -> SpecWith ()
+specInvalidNetwork networkTag = it ("invalid network " <> networkTag) $ do
+    (out, err) <- cli [ "key", "from-recovery-phrase", "shelley" ] (unwords defaultPhrase)
+        >>= cli [ "key", "public" ]
+        >>= cli [ "address", "reward", "--network-tag", networkTag ]
+    out `shouldBe` ""
+    err `shouldContain` "Invalid network tag"
+
+defaultPhrase :: [String]
+defaultPhrase =
+    [ "pole", "pulse", "wolf", "blame", "chronic"
+    , "ship", "vivid", "tree", "small", "onion"
+    , "host", "accident", "burden", "lazy", "swarm"
+    ]
+

core/lib/Cardano/Address.hs

@@ -14,6 +14,7 @@ module Cardano.Address
     ( -- * Address
       Address
     , PaymentAddress (..)
+    , StakeAddress (..)
     , DelegationAddress (..)
     , PointerAddress (..)
     , ChainPointer (..)
@@ -121,6 +122,16 @@ fromBech32 :: Text -> Maybe Address
 fromBech32 =
     eitherToMaybe . fmap unsafeMkAddress. E.fromBech32 (const id) . T.encodeUtf8
 
+-- | Encoding of addresses for certain key types and backend targets.
+--
+-- @since 1.0.0
+class HasNetworkDiscriminant key => StakeAddress key where
+    -- | Convert a staking key to a stake 'Address' (aka: reward account address)
+    -- valid for the given network discrimination.
+    --
+    -- @since 1.0.0
+    stakeAddress :: NetworkDiscriminant key -> key 'StakingK XPub -> Address
+
 -- | Encoding of addresses for certain key types and backend targets.
 --
 -- @since 1.0.0

core/lib/Cardano/Address/Style/Shelley.hs

@@ -39,6 +39,7 @@ module Cardano.Address.Style.Shelley
     , paymentAddress
     , delegationAddress
     , pointerAddress
+    , stakeAddress
     , extendAddress
     , ErrExtendAddress (..)
 
@@ -128,6 +129,8 @@ import Data.Word
     ( Word32 )
 import Data.Word7
     ( getVariableLengthNat, putVariableLengthNat )
+import Fmt
+    ( Buildable, build, (+|), (|+) )
 import GHC.Generics
     ( Generic )
 
@@ -375,6 +378,19 @@ deriveStakingPrivateKey =
 -- > bech32 $ pointerAddress tag (toXPub <$> addrK) ptr
 -- > "addr1gxpfffuj3zkp5g7ct6h4va89caxx9ayq2gvkyfvww48sdnmmqypqfcp5um"
 
+instance Internal.StakeAddress Shelley where
+    stakeAddress discrimination k = unsafeMkAddress $
+        invariantSize expectedLength $ BL.toStrict $ runPut $ do
+            putWord8 firstByte
+            putByteString (blake2b224 k)
+      where
+          -- First 4 bits are `1110` for keyhash28 reward account address.
+          -- Next 4 bits are network discriminator.
+          -- `1110 0000` is 224 in decimal.
+          firstByte =
+              224 + invariantNetworkTag 16 (networkTag @Shelley discrimination)
+          expectedLength = 1 + pubkeyHashSize
+
 instance Internal.PaymentAddress Shelley where
     paymentAddress discrimination k = unsafeMkAddress $
         invariantSize expectedLength $ BL.toStrict $ runPut $ do
@@ -634,6 +650,20 @@ pointerAddress
 pointerAddress =
     Internal.pointerAddress
 
+-- Re-export from 'Cardano.Address' to have it documented specialized in Haddock.
+--
+-- | Convert a staking key to a stake Address (aka reward account address)
+-- for the given network discrimination.
+--
+-- @since 2.0.0
+stakeAddress
+    :: NetworkDiscriminant Shelley
+    -> Shelley 'StakingK XPub
+    -> Address
+stakeAddress =
+    Internal.stakeAddress
+
+
 --
 -- Network Discriminant
 --
@@ -651,6 +681,9 @@ newtype MkNetworkDiscriminantError
       -- ^ Wrong network tag.
     deriving (Eq, Show)
 
+instance Buildable MkNetworkDiscriminantError where
+  build (ErrWrongNetworkTag i) = "Invalid network tag "+|i|+". Must be between [0, 15]"
+
 -- | Construct 'NetworkDiscriminant' for Cardano 'Shelley' from a number.
 -- If the number is invalid, ie., not between 0 and 15, then
 -- 'MkNetworkDiscriminantError' is thrown.