Add Signing module with mkStdTx

Not tested yet. For the time being we hard-code the testnet protocol
magic in the signing.

cardano-wallet.cabal

@@ -53,12 +53,13 @@ library
     , http-types
     , memory
     , servant
-    , servant-server
     , servant-client
     , servant-client-core
+    , servant-server
     , text
     , time
     , transformers
+    , vector
   hs-source-dirs:
       src
   exposed-modules:
@@ -81,6 +82,7 @@ library
       Cardano.Wallet.Primitive.Mnemonic
       Cardano.Wallet.Primitive.Model
       Cardano.Wallet.Primitive.Types
+      Cardano.Wallet.Primitive.Signing
       Data.Text.Class
       Data.Quantity
       Servant.Extra.ContentTypes

src/Cardano/Wallet.hs

@@ -38,6 +38,8 @@ import Cardano.Wallet.Binary
     ( encodeSignedTx, toByteString )
 import Cardano.Wallet.CoinSelection
     ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions )
+import Cardano.Wallet.CoinSelection
+    ( shuffle )
 import Cardano.Wallet.DB
     ( DBLayer
     , ErrNoSuchWallet (..)
@@ -61,6 +63,8 @@ import Cardano.Wallet.Primitive.AddressDiscovery
     ( AddressPoolGap, SeqState (..), mkAddressPool )
 import Cardano.Wallet.Primitive.Model
     ( Wallet, applyBlocks, availableUTxO, currentTip, getState, initWallet )
+import Cardano.Wallet.Primitive.Signing
+    ( SignTxError, mkStdTx )
 import Cardano.Wallet.Primitive.Types
     ( Block (..)
     , BlockHeader (..)
@@ -180,7 +184,7 @@ data ErrCreateUnsignedTx
 -- | Errors occuring when signing a transaction
 data ErrSignTx
     = ErrSignTxNoSuchWallet ErrNoSuchWallet
-    | ErrSignTx
+    | ErrSignTx SignTxError
 
 -- | Errors occuring when submitting a signed transaction to the network
 data ErrSubmitTx = forall a. NetworkError a
@@ -251,12 +255,14 @@ mkWalletLayer db network = WalletLayer
         let signed = SignedTx $ toByteString $ encodeSignedTx (tx, witnesses)
         withExceptT NetworkError $ postTx network signed
 
-    , signTx = \wid rootXPrv password (CoinSelection ins outs chgs) -> do
+    , signTx = \wid rootXPrv password (CoinSelection ins outs _chgs) -> do
+        -- TODO: This is untested
         (w, _) <- withExceptT ErrSignTxNoSuchWallet $ _readWallet wid
-        maybe
-            (throwE ErrSignTx)
-            return
-            (mkStdTx (getState w) rootXPrv password ins outs chgs)
+
+        shuffledOuts <- liftIO $ shuffle outs
+        case mkStdTx (getState w) (rootXPrv, password) ins shuffledOuts of
+            Right a -> return a
+            Left e -> throwE $ ErrSignTx e
     }
   where
     _readWallet
@@ -337,8 +343,6 @@ mkWalletLayer db network = WalletLayer
             DB.putTxHistory db (PrimaryKey wid) txs
             DB.putWalletMeta db (PrimaryKey wid) meta'
 
-    mkStdTx = error "TODO: mkStdTx not implemented yet"
-
 {-------------------------------------------------------------------------------
                                  Helpers
 -------------------------------------------------------------------------------}

src/Cardano/Wallet/CoinSelection.hs

@@ -26,6 +26,7 @@ module Cardano.Wallet.CoinSelection
     , FeeOptions (..)
     , FeeError(..)
     , adjustForFees
+    , shuffle
     ) where
 
 import Prelude
@@ -41,16 +42,22 @@ import Cardano.Wallet.Primitive.Types
     , isValidCoin
     , pickRandom
     )
+import Control.Monad
+    ( forM_ )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT (..), throwE )
 import Control.Monad.Trans.State
     ( StateT (..), evalStateT )
+import Crypto.Number.Generate
+    ( generateBetween )
 import Crypto.Random.Types
     ( MonadRandom )
 import Data.Bifunctor
     ( bimap )
+import Data.Vector.Mutable
+    ( IOVector )
 import Data.Word
     ( Word64 )
 import Fmt
@@ -64,6 +71,9 @@ import qualified Data.List as L
                                 Coin Selection
 -------------------------------------------------------------------------------}
 
+import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as MV
+
 newtype CoinSelectionOptions = CoinSelectionOptions
     { maximumNumberOfInputs
         :: Word64
@@ -399,3 +409,25 @@ computeFee (CoinSelection inps outs chgs) =
     -- by definition, impossible; unless we messed up real hard.
     collapse [] _ =
         invariant "outputs are bigger than inputs" (undefined) (const False)
+
+
+-- | Shuffles a list. Meant to be used on @CoinSelection@ outputs.
+shuffle :: [a] -> IO [a]
+shuffle = modifyInPlace $ \v -> do
+    let (lo, hi) = (0, MV.length v - 1)
+    forM_ [lo .. hi] $ \i -> do
+      j <- fromInteger <$> generateBetween (fromIntegral lo) (fromIntegral hi)
+      swapElems v i j
+  where
+    swapElems :: IOVector a -> Int -> Int -> IO ()
+    swapElems v i j = do
+        x <- MV.read v i
+        y <- MV.read v j
+        MV.write v i y
+        MV.write v j x
+
+modifyInPlace :: forall a. (IOVector a -> IO ()) -> [a] -> IO [a]
+modifyInPlace f xs = do
+    v' <- V.thaw $ V.fromList xs
+    f v'
+    V.toList <$> V.freeze v'

src/Cardano/Wallet/Primitive/AddressDerivation.hs

@@ -25,6 +25,7 @@ module Cardano.Wallet.Primitive.AddressDerivation
     -- * Polymorphic / General Purpose Types
     -- $use
       Key
+    , getKey
     , Depth (..)
     , Index
     , getIndex
@@ -120,7 +121,7 @@ import qualified Data.Text.Encoding as T
 -- let accountPubKey = Key 'AccountK XPub
 -- let addressPubKey = Key 'AddressK XPub
 -- @
-newtype Key (level :: Depth) key = Key key
+newtype Key (level :: Depth) key = Key { getKey :: key }
     deriving stock (Generic, Show, Eq)
 
 instance (NFData key) => NFData (Key level key)

src/Cardano/Wallet/Primitive/AddressDiscovery.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -15,10 +16,11 @@
 -- compatibility with random address scheme from the legacy Cardano wallets.
 
 module Cardano.Wallet.Primitive.AddressDiscovery
-    ( -- * Sequential Derivation
+    ( AddressScheme (..)
+    -- * Sequential Derivation
 
     -- ** Address Pool Gap
-      AddressPoolGap
+    , AddressPoolGap
     , MkAddressPoolGapError (..)
     , defaultAddressPoolGap
     , getAddressPoolGap
@@ -40,13 +42,16 @@ module Cardano.Wallet.Primitive.AddressDiscovery
 import Prelude
 
 import Cardano.Crypto.Wallet
-    ( XPub )
+    ( XPrv, XPub )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( ChangeChain (..)
     , Depth (..)
     , DerivationType (..)
     , Index
     , Key
+    , Passphrase
+    , deriveAccountPrivateKey
+    , deriveAddressPrivateKey
     , deriveAddressPublicKey
     , keyToAddress
     )
@@ -265,10 +270,51 @@ instance NFData SeqState
 -- that they are just created in sequence by the wallet software. Hence an
 -- address pool with a gap of 1 should be sufficient for the internal chain.
 instance IsOurs SeqState where
-    isOurs addr (SeqState !s1 !s2) =
+     isOurs addr (SeqState !s1 !s2) =
+         let
+             (res1, !s1') = lookupAddress addr s1
+             (res2, !s2') = lookupAddress addr s2
+             ours = isJust (res1 <|> res2)
+         in
+             (ours `deepseq` ours, SeqState s1' s2')
+
+-- TODO: We might want to move this abstraction / there is more work to be
+-- done here.
+--
+-- It would maybe be nice to derive IsOurs from AddressScheme automatically
+-- A /possible/ way to do that would be to return
+--     Maybe ((Key 'RootK XPrv, Passphrase "encryption") -> Key 'AddressK XPrv)
+-- instead, such that we can use @isJust@ without knowing the rootKey and pwd.
+class AddressScheme s where
+    keyFrom
+        :: Address
+        -> (Key 'RootK XPrv, Passphrase "encryption")
+        -> s
+        -> (Maybe (Key 'AddressK XPrv), s)
+
+instance AddressScheme SeqState where
+    keyFrom addr (rootPrv, pwd) (SeqState !s1 !s2) =
         let
-            (res1, !s1') = lookupAddress addr s1
-            (res2, !s2') = lookupAddress addr s2
-            ours = isJust (res1 <|> res2)
+            (xPrv1, !s1') = lookupAndDeriveXPrv s1 InternalChain
+            (xPrv2, !s2') = lookupAndDeriveXPrv s2 ExternalChain
+
+            xPrv = (xPrv1 <|> xPrv2)
+
         in
-            (ours `deepseq` ours, SeqState s1' s2')
+            (xPrv `deepseq` xPrv, SeqState s1' s2')
+
+      where
+        -- We are assuming there is only one account
+        account = minBound
+        accountPrv = deriveAccountPrivateKey pwd rootPrv account
+
+        lookupAndDeriveXPrv
+            :: AddressPool
+            -> ChangeChain
+            -> (Maybe (Key 'AddressK XPrv), AddressPool)
+        lookupAndDeriveXPrv pool chain =
+            let
+                (addrIx, pool') = lookupAddress addr pool
+            in
+                (deriveAddressPrivateKey pwd accountPrv chain <$> addrIx, pool')
+