From 36e6f5f41149ac5d860a0a14da8318fd96bbf0b9 Mon Sep 17 00:00:00 2001 From: Philippe Laprade Date: Tue, 31 Oct 2023 14:29:44 +0100 Subject: [PATCH] Use SQLite to store wallet state (#7) * Use an SQlite3 database to store accounts, addresses, transactions, coins and pending transactions locally * The database is synced with the blockchain using the syncacc command * Add a configuration file to specify a different API host, the gap value and batching values * Account and transaction import/export are in separate commands * Pending transactions now properly lock the coins they spend * Improved internal address management --- README.md | 29 +- app/Main.hs | 2 +- haskoin-wallet.cabal | 63 +- package.yaml | 9 +- src/Haskoin/Wallet.hs | 24 + src/{Network => }/Haskoin/Wallet/Amounts.hs | 29 +- src/Haskoin/Wallet/Commands.hs | 1132 ++++++++++++++ src/Haskoin/Wallet/Config.hs | 94 ++ src/Haskoin/Wallet/Database.hs | 1307 +++++++++++++++++ src/{Network => }/Haskoin/Wallet/Entropy.hs | 16 +- src/Haskoin/Wallet/FileIO.hs | 137 ++ src/Haskoin/Wallet/Main.hs | 19 + src/Haskoin/Wallet/Parser.hs | 985 +++++++++++++ src/Haskoin/Wallet/Signing.hs | 292 ++++ src/{Network => }/Haskoin/Wallet/TxInfo.hs | 109 +- src/{Network => }/Haskoin/Wallet/Util.hs | 12 +- src/Network/Haskoin/Wallet.hs | 28 - src/Network/Haskoin/Wallet/AccountStore.hs | 426 ------ src/Network/Haskoin/Wallet/Commands.hs | 984 ------------- src/Network/Haskoin/Wallet/FileIO.hs | 217 --- src/Network/Haskoin/Wallet/Parser.hs | 699 --------- src/Network/Haskoin/Wallet/Signing.hs | 346 ----- stack.yaml | 2 +- stack.yaml.lock | 8 +- .../Haskoin/Wallet/AmountsSpec.hs | 12 +- test/Haskoin/Wallet/CommandsSpec.hs | 768 ++++++++++ .../Haskoin/Wallet/EntropySpec.hs | 156 +- test/Haskoin/Wallet/SigningSpec.hs | 464 ++++++ test/Haskoin/Wallet/TestUtils.hs | 343 +++++ .../Haskoin/Wallet/AccountStoreSpec.hs | 207 --- test/Network/Haskoin/Wallet/SigningSpec.hs | 514 ------- test/Network/Haskoin/Wallet/TestUtils.hs | 15 - 32 files changed, 5809 insertions(+), 3639 deletions(-) create mode 100644 src/Haskoin/Wallet.hs rename src/{Network => }/Haskoin/Wallet/Amounts.hs (85%) create mode 100644 src/Haskoin/Wallet/Commands.hs create mode 100644 src/Haskoin/Wallet/Config.hs create mode 100644 src/Haskoin/Wallet/Database.hs rename src/{Network => }/Haskoin/Wallet/Entropy.hs (95%) create mode 100644 src/Haskoin/Wallet/FileIO.hs create mode 100644 src/Haskoin/Wallet/Main.hs create mode 100644 src/Haskoin/Wallet/Parser.hs create mode 100644 src/Haskoin/Wallet/Signing.hs rename src/{Network => }/Haskoin/Wallet/TxInfo.hs (88%) rename src/{Network => }/Haskoin/Wallet/Util.hs (91%) delete mode 100644 src/Network/Haskoin/Wallet.hs delete mode 100644 src/Network/Haskoin/Wallet/AccountStore.hs delete mode 100644 src/Network/Haskoin/Wallet/Commands.hs delete mode 100644 src/Network/Haskoin/Wallet/FileIO.hs delete mode 100644 src/Network/Haskoin/Wallet/Parser.hs delete mode 100644 src/Network/Haskoin/Wallet/Signing.hs rename test/{Network => }/Haskoin/Wallet/AmountsSpec.hs (93%) create mode 100644 test/Haskoin/Wallet/CommandsSpec.hs rename test/{Network => }/Haskoin/Wallet/EntropySpec.hs (62%) create mode 100644 test/Haskoin/Wallet/SigningSpec.hs create mode 100644 test/Haskoin/Wallet/TestUtils.hs delete mode 100644 test/Network/Haskoin/Wallet/AccountStoreSpec.hs delete mode 100644 test/Network/Haskoin/Wallet/SigningSpec.hs delete mode 100644 test/Network/Haskoin/Wallet/TestUtils.hs diff --git a/README.md b/README.md index 0e17392d..862daacd 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,16 @@ # Haskoin Wallet -Haskoin Wallet (`hw`) is a lightweight [BIP44] command line wallet for bitcoin and bitcoin-cash. It can be used to manage cold storage funds in an online/offline environment. It requires a haskoin-store server for querying addresses and transactions. It is currently not suitable for large wallets as the local database is a JSON file. +Haskoin Wallet (`hw`) is a lightweight [BIP44] command line wallet for bitcoin +and bitcoin-cash. It can be used to manage cold storage funds in an +online/offline environment. It requires a haskoin-store server for querying +addresses and transactions. It is suitable for small-ish wallets that are +managed by hand although work is being done to improve performance. + +## Dependencies + +```console +apt install libsecp256k1-dev +``` ## Build @@ -13,9 +23,10 @@ stack install ```console hw --help +hw COMMAND --help ``` -## Verify binaries +## Verify release binaries ### Get the GPG key @@ -39,7 +50,19 @@ sha256sum --check SHA256SUMS ## Critical Bugs -* Version 0.7.0 does not derive the correct account when using a --split mnemonic. Your funds are still secure and not lost but you should use the 0.7.0 binary to move your funds to a new wallet created with the latest release. +* Versions prior to 0.8.0 do not derive the correct accounts when using more + than one mnemonic (not the --split option, but different wallets). For + example, creating an account with mnemonic 1 yields account /44'/0'/0'. If you + then create an account using mnemonic 2, it yields the account /44'/0'/1'. As + it is a new mnemonic and thus a new wallet, it should yield account + /44'/0'/0'. Your funds are still secure and not lost but you should write down + the account derivation that you are using for reference if you need to recover + it. This bug is fixed in version 0.8.0. + +* Version 0.7.0 does not derive the correct account when using a --split + mnemonic. Your funds are still secure and not lost but you should use the + 0.7.0 binary to move your funds to a new wallet created with the latest + release. [BIP32]: https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki [BIP32]: https://github.com/bitcoin/bips/blob/master/bip-0039.mediawiki diff --git a/app/Main.hs b/app/Main.hs index 6c7681cc..e3b41482 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,4 @@ -import Network.Haskoin.Wallet +import Haskoin.Wallet.Main main :: IO () main = clientMain diff --git a/haskoin-wallet.cabal b/haskoin-wallet.cabal index 2a216bfa..57fe7a18 100644 --- a/haskoin-wallet.cabal +++ b/haskoin-wallet.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -- --- hash: 9428b61cc16c2222adae2f1931d2eb6ac71299ed2352c243d9c7f9e298c51bef +-- hash: 0e1826aa518f8c7890f529498b3362e18f28ddf992adaf9192167af089f6bd44 name: haskoin-wallet -version: 0.7.2 +version: 0.8.0 synopsis: Lightweight command-line wallet for Bitcoin and Bitcoin Cash description: haskoin-wallet (hw) is a lightweight Bitcoin wallet using BIP39 mnemonics and BIP44 account structure. It requires a full blockchain index such as @@ -42,38 +42,47 @@ library , base64-bytestring >=1.0.0.3 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 + , conduit >=1.3.5 , containers >=0.6.2.1 , data-default >=0.7.1.1 , directory >=1.3.6.0 , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 , haskeline >=0.7.5.0 , haskoin-core >=1.0.0 , haskoin-store-data >=1.0.0 , http-types >=0.12.3 , lens >=4.18.1 , lens-aeson >=1.1 + , monad-logger >=0.3.40 , mtl >=2.2.2 , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 , pretty >=1.1.3.6 , random >=1.1 + , raw-strings-qq >=1.1 , secp256k1-haskell >=1.0.0 , string-conversions >=0.4.0.1 , text >=1.2.4.0 + , time >=1.12.2 , tostring >=0.2.1.1 , transformers >=0.5.6.2 , unordered-containers >=0.2.10.0 , wreq >=0.5.3.2 exposed-modules: - Network.Haskoin.Wallet - Network.Haskoin.Wallet.AccountStore - Network.Haskoin.Wallet.Amounts - Network.Haskoin.Wallet.Commands - Network.Haskoin.Wallet.Entropy - Network.Haskoin.Wallet.FileIO - Network.Haskoin.Wallet.Parser - Network.Haskoin.Wallet.Signing - Network.Haskoin.Wallet.TxInfo - Network.Haskoin.Wallet.Util + Haskoin.Wallet + Haskoin.Wallet.Amounts + Haskoin.Wallet.Commands + Haskoin.Wallet.Config + Haskoin.Wallet.Database + Haskoin.Wallet.Entropy + Haskoin.Wallet.FileIO + Haskoin.Wallet.Main + Haskoin.Wallet.Parser + Haskoin.Wallet.Signing + Haskoin.Wallet.TxInfo + Haskoin.Wallet.Util other-modules: Paths_haskoin_wallet default-language: Haskell2010 @@ -93,24 +102,31 @@ executable hw , base64-bytestring >=1.0.0.3 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 + , conduit >=1.3.5 , containers >=0.6.2.1 , data-default >=0.7.1.1 , directory >=1.3.6.0 , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 , haskeline >=0.7.5.0 , haskoin-core >=1.0.0 , haskoin-store-data >=1.0.0 - , haskoin-wallet ==0.7.2 + , haskoin-wallet ==0.8.0 , http-types >=0.12.3 , lens >=4.18.1 , lens-aeson >=1.1 + , monad-logger >=0.3.40 , mtl >=2.2.2 , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 , pretty >=1.1.3.6 , random >=1.1 + , raw-strings-qq >=1.1 , secp256k1-haskell >=1.0.0 , string-conversions >=0.4.0.1 , text >=1.2.4.0 + , time >=1.12.2 , tostring >=0.2.1.1 , transformers >=0.5.6.2 , unordered-containers >=0.2.10.0 @@ -123,11 +139,11 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Network.Haskoin.Wallet.AccountStoreSpec - Network.Haskoin.Wallet.AmountsSpec - Network.Haskoin.Wallet.EntropySpec - Network.Haskoin.Wallet.SigningSpec - Network.Haskoin.Wallet.TestUtils + Haskoin.Wallet.AmountsSpec + Haskoin.Wallet.CommandsSpec + Haskoin.Wallet.EntropySpec + Haskoin.Wallet.SigningSpec + Haskoin.Wallet.TestUtils Paths_haskoin_wallet hs-source-dirs: test @@ -144,25 +160,32 @@ test-suite spec , base64-bytestring >=1.0.0.3 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 + , conduit >=1.3.5 , containers >=0.6.2.1 , data-default >=0.7.1.1 , directory >=1.3.6.0 , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 , haskeline >=0.7.5.0 , haskoin-core >=1.0.0 , haskoin-store-data >=1.0.0 - , haskoin-wallet ==0.7.2 + , haskoin-wallet ==0.8.0 , hspec >=2.7.1 , http-types >=0.12.3 , lens >=4.18.1 , lens-aeson >=1.1 + , monad-logger >=0.3.40 , mtl >=2.2.2 , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 , pretty >=1.1.3.6 , random >=1.1 + , raw-strings-qq >=1.1 , secp256k1-haskell >=1.0.0 , string-conversions >=0.4.0.1 , text >=1.2.4.0 + , time >=1.12.2 , tostring >=0.2.1.1 , transformers >=0.5.6.2 , unordered-containers >=0.2.10.0 diff --git a/package.yaml b/package.yaml index d927ec5a..4f57fee3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: haskoin-wallet -version: &version 0.7.2 +version: &version 0.8.0 synopsis: Lightweight command-line wallet for Bitcoin and Bitcoin Cash description: ! haskoin-wallet (hw) is a lightweight Bitcoin wallet using BIP39 mnemonics and @@ -30,24 +30,31 @@ dependencies: base64-bytestring: ">= 1.0.0.3" bytestring: ">= 0.10.10.0" cereal: ">= 0.5.8.1" + conduit: ">= 1.3.5" containers: ">= 0.6.2.1" data-default: ">= 0.7.1.1" directory: ">= 1.3.6.0" Decimal: ">= 0.5.1" entropy: ">= 0.4.1.6" + esqueleto: ">=3.5.10.1" haskeline: ">= 0.7.5.0" haskoin-core: ">= 1.0.0" haskoin-store-data: ">= 1.0.0" http-types: ">= 0.12.3" lens: ">= 4.18.1" lens-aeson: ">= 1.1" + monad-logger: ">= 0.3.40" mtl: ">= 2.2.2" optparse-applicative: ">= 0.15.1.0" + persistent: ">= 2.14.5.1" + persistent-sqlite: ">= 2.13.1.1" pretty: ">= 1.1.3.6" random: ">= 1.1" + raw-strings-qq: ">= 1.1" secp256k1-haskell: ">= 1.0.0" string-conversions: ">= 0.4.0.1" text: ">= 1.2.4.0" + time: ">= 1.12.2" tostring: ">= 0.2.1.1" transformers: ">= 0.5.6.2" unordered-containers: ">= 0.2.10.0" diff --git a/src/Haskoin/Wallet.hs b/src/Haskoin/Wallet.hs new file mode 100644 index 00000000..e20ba118 --- /dev/null +++ b/src/Haskoin/Wallet.hs @@ -0,0 +1,24 @@ +module Haskoin.Wallet + ( module Amounts, + module Commands, + module Config, + module Database, + module Entropy, + module FileIO, + module Parser, + module Signing, + module TxInfo, + module Util, + ) +where + +import Haskoin.Wallet.Amounts as Amounts +import Haskoin.Wallet.Commands as Commands +import Haskoin.Wallet.Config as Config +import Haskoin.Wallet.Database as Database +import Haskoin.Wallet.Entropy as Entropy +import Haskoin.Wallet.FileIO as FileIO +import Haskoin.Wallet.Parser as Parser +import Haskoin.Wallet.Signing as Signing +import Haskoin.Wallet.TxInfo as TxInfo +import Haskoin.Wallet.Util as Util diff --git a/src/Network/Haskoin/Wallet/Amounts.hs b/src/Haskoin/Wallet/Amounts.hs similarity index 85% rename from src/Network/Haskoin/Wallet/Amounts.hs rename to src/Haskoin/Wallet/Amounts.hs index 6e2b8dbb..bd38095e 100644 --- a/src/Network/Haskoin/Wallet/Amounts.hs +++ b/src/Haskoin/Wallet/Amounts.hs @@ -2,27 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -module Network.Haskoin.Wallet.Amounts where +module Haskoin.Wallet.Amounts where import Control.Arrow (second) import Control.Monad (guard) -import Data.Text as Text - ( Text, - breakOn, - drop, - filter, - intercalate, - length, - pack, - uncons, - ) -import Data.Text.Read as Read (decimal) -import Network.Haskoin.Wallet.Util - ( chunksOfEnd, - dropPatternEnd, - padEnd, - padStart, - ) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Read as Read +import Haskoin.Wallet.Util import Numeric.Natural (Natural) data AmountUnit @@ -58,7 +45,7 @@ showAmount unit amnt = where removeEnd = dropPatternEnd "0000" . dropPatternEnd "000000" addSep = Text.intercalate "'" . chunksOfEnd 3 - showT = pack . show + showT = Text.pack . show readAmount :: AmountUnit -> Text -> Maybe Natural readAmount unit amntStr = @@ -76,7 +63,7 @@ readAmount unit amntStr = UnitSatoshi -> readNatural str where str = dropAmountSep amntStr - (q, r) = second (Text.drop 1) $ breakOn "." str + (q, r) = second (Text.drop 1) $ Text.breakOn "." str readNatural :: Text -> Maybe Natural readNatural txt = @@ -96,6 +83,6 @@ showIntegerAmount unit i -- | Like 'readAmount' but can parse a negative amount readIntegerAmount :: AmountUnit -> Text -> Maybe Integer readIntegerAmount unit txt = - case uncons txt of + case Text.uncons txt of Just ('-', rest) -> negate . toInteger <$> readAmount unit rest _ -> toInteger <$> readAmount unit txt diff --git a/src/Haskoin/Wallet/Commands.hs b/src/Haskoin/Wallet/Commands.hs new file mode 100644 index 00000000..dac631cb --- /dev/null +++ b/src/Haskoin/Wallet/Commands.hs @@ -0,0 +1,1132 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.Commands where + +import Conduit (MonadUnliftIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..), MonadTrans (lift)) +import Data.Aeson (object, (.:), (.=)) +import qualified Data.Aeson as Json +import qualified Data.ByteString as BS +import Data.Default (def) +import Data.Foldable (for_) +import Data.List (nub, sort, (\\)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, isJust) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Database.Persist.Sqlite (runMigrationQuiet, runSqlite, transactionUndo) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.Amounts +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.Entropy +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Parser +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import qualified System.Console.Haskeline as Haskeline +import qualified System.Directory as D +import System.Random (initStdGen) + +data Response + = ResponseError + { responseError :: !Text + } + | ResponseMnemonic + { responseEntropySource :: !Text, + responseMnemonic :: ![Text], + responseSplitMnemonic :: ![[Text]] + } + | ResponseCreateAcc + { responseAccount :: !DBAccount + } + | ResponseTestAcc + { responseAccount :: !DBAccount, + responseResult :: !Bool, + responseText :: !Text + } + | ResponseImportAcc + { responseAccount :: !DBAccount + } + | ResponseExportAcc + { responseAccount :: !DBAccount, + responseAccountFile :: !FilePath + } + | ResponseRenameAcc + { responseAccount :: !DBAccount, + responseOldName :: !Text, + responseNewName :: !Text + } + | ResponseAccounts + { responseAccounts :: ![DBAccount] + } + | ResponseReceive + { responseAccount :: !DBAccount, + responseAddress :: !DBAddress + } + | ResponseAddresses + { responseAccount :: !DBAccount, + responseAddresses :: ![DBAddress] + } + | ResponseLabel + { responseAccount :: !DBAccount, + responseAddress :: !DBAddress + } + | ResponseTxs + { responseAccount :: !DBAccount, + responseTxs :: ![TxInfo] + } + | ResponsePrepareTx + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponsePendingTxs + { responseAccount :: !DBAccount, + responsePendingTxs :: ![NoSigTxInfo] + } + | ResponseReviewTx + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponseExportTx + { responseTxFile :: !FilePath + } + | ResponseImportTx + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponseDeleteTx + { responseFreedCoins :: !Natural, + responseFreedAddrs :: !Natural + } + | ResponseSignTx + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponseCoins + { responseAccount :: !DBAccount, + responseCoins :: ![JsonCoin] + } + | ResponseSendTx + { responseAccount :: !DBAccount, + responseTransaction :: !TxInfo, + responseNetworkTxId :: !TxHash + } + | ResponseSyncAcc + { responseAccount :: !DBAccount, + responseBestBlock :: !BlockHash, + responseBestHeight :: !Natural, + responseTxCount :: !Natural, + responseCoinCount :: !Natural + } + | ResponseDiscoverAcc + { responseAccount :: !DBAccount, + responseBestBlock :: !BlockHash, + responseBestHeight :: !Natural, + responseTxCount :: !Natural, + responseCoinCount :: !Natural + } + | ResponseVersion + {responseVersion :: !Text} + | ResponsePrepareSweep + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponseSignSweep + { responseAccount :: !DBAccount, + responsePendingTx :: !NoSigTxInfo + } + | ResponseRollDice + { responseRollDice :: ![Natural], + responseEntropySource :: !Text + } + deriving (Eq, Show) + +jsonError :: String -> Json.Value +jsonError err = object ["type" .= Json.String "error", "error" .= err] + +instance MarshalJSON Ctx Response where + marshalValue ctx = + \case + ResponseError err -> jsonError $ cs err + ResponseMnemonic e w ws -> + object + [ "type" .= Json.String "mnemonic", + "entropysource" .= e, + "mnemonic" .= w, + "splitmnemonic" .= ws + ] + ResponseCreateAcc a -> + object + [ "type" .= Json.String "createacc", + "account" .= a + ] + ResponseTestAcc a b t -> + object + [ "type" .= Json.String "testacc", + "account" .= a, + "result" .= b, + "text" .= t + ] + ResponseImportAcc a -> + object + [ "type" .= Json.String "importacc", + "account" .= a + ] + ResponseExportAcc a f -> + object + [ "type" .= Json.String "exportacc", + "account" .= a, + "accountfile" .= f + ] + ResponseRenameAcc o n a -> + object + [ "type" .= Json.String "renameacc", + "oldname" .= o, + "newname" .= n, + "account" .= a + ] + ResponseAccounts as -> + object + [ "type" .= Json.String "accounts", + "accounts" .= as + ] + ResponseReceive a addr -> + object + [ "type" .= Json.String "receive", + "account" .= a, + "address" .= addr + ] + ResponseAddresses a adrs -> + object + [ "type" .= Json.String "addresses", + "account" .= a, + "addresses" .= adrs + ] + ResponseLabel a adr -> + object + [ "type" .= Json.String "label", + "account" .= a, + "address" .= adr + ] + ResponseTxs a txs -> + object + [ "type" .= Json.String "txs", + "account" .= a, + "txs" .= (marshalValue (accountNetwork a, ctx) <$> txs) + ] + ResponsePrepareTx a t -> do + let net = accountNetwork a + object + [ "type" .= Json.String "preparetx", + "account" .= a, + "pendingtx" .= marshalValue (net, ctx) t + ] + ResponsePendingTxs a ts -> do + let net = accountNetwork a + object + [ "type" .= Json.String "pendingtxs", + "account" .= a, + "pendingtxs" .= (marshalValue (net, ctx) <$> ts) + ] + ResponseReviewTx a tx -> do + let net = accountNetwork a + object + [ "type" .= Json.String "reviewtx", + "account" .= a, + "pendingtx" .= marshalValue (net, ctx) tx + ] + ResponseExportTx f -> + object + [ "type" .= Json.String "exporttx", + "txfile" .= f + ] + ResponseImportTx a tx -> do + let net = accountNetwork a + object + [ "type" .= Json.String "importtx", + "account" .= a, + "pendingtx" .= marshalValue (net, ctx) tx + ] + ResponseDeleteTx c a -> + object + [ "type" .= Json.String "deletetx", + "freedcoins" .= c, + "freedaddrs" .= a + ] + ResponseSignTx a t -> do + let net = accountNetwork a + object + [ "type" .= Json.String "signtx", + "account" .= a, + "pendingtx" .= marshalValue (net, ctx) t + ] + ResponseCoins a coins -> do + let net = accountNetwork a + object + [ "type" .= Json.String "coins", + "account" .= a, + "coins" .= (marshalValue net <$> coins) + ] + ResponseSendTx a t h -> do + let net = accountNetwork a + object + [ "type" .= Json.String "sendtx", + "account" .= a, + "transaction" .= marshalValue (net, ctx) t, + "networktxid" .= h + ] + ResponseSyncAcc as bb bh tc cc -> + object + [ "type" .= Json.String "syncacc", + "account" .= as, + "bestblock" .= bb, + "bestheight" .= bh, + "txupdates" .= tc, + "coinupdates" .= cc + ] + ResponseDiscoverAcc as bb bh tc cc -> + object + [ "type" .= Json.String "discoveracc", + "account" .= as, + "bestblock" .= bb, + "bestheight" .= bh, + "txupdates" .= tc, + "coinupdates" .= cc + ] + ResponseVersion v -> + object ["type" .= Json.String "version", "version" .= v] + ResponsePrepareSweep a t -> do + let net = accountNetwork a + object + [ "type" .= Json.String "preparesweep", + "account" .= a, + "pendingtxs" .= marshalValue (net, ctx) t + ] + ResponseSignSweep a t -> do + let net = accountNetwork a + object + [ "type" .= Json.String "signsweep", + "account" .= a, + "pendingtx" .= marshalValue (net, ctx) t + ] + ResponseRollDice ns e -> + object + ["type" .= Json.String "rolldice", "entropysource" .= e, "dice" .= ns] + unmarshalValue ctx = + Json.withObject "response" $ \o -> do + Json.String resType <- o .: "type" + case resType of + "error" -> ResponseError <$> o .: "error" + "mnemonic" -> + ResponseMnemonic + <$> o .: "entropysource" + <*> o .: "mnemonic" + <*> o .: "splitmnemonic" + "createacc" -> + ResponseCreateAcc + <$> o .: "account" + "testacc" -> + ResponseTestAcc + <$> o .: "account" + <*> o .: "result" + <*> o .: "text" + "importacc" -> + ResponseImportAcc + <$> o .: "account" + "exportacc" -> + ResponseExportAcc + <$> o .: "account" + <*> o .: "accountfile" + "renameacc" -> + ResponseRenameAcc + <$> o .: "oldname" + <*> o .: "newname" + <*> o .: "account" + "accounts" -> + ResponseAccounts + <$> o .: "accounts" + "receive" -> + ResponseReceive + <$> o .: "account" + <*> o .: "address" + "addresses" -> + ResponseAddresses + <$> o .: "account" + <*> o .: "addresses" + "label" -> + ResponseLabel + <$> o .: "account" + <*> o .: "address" + "txs" -> do + a <- o .: "account" + let net = accountNetwork a + txs <- mapM (unmarshalValue (net, ctx)) =<< o .: "txs" + return $ ResponseTxs a txs + "preparetx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtx" + return $ ResponsePrepareTx a t + "pendingtxs" -> do + a <- o .: "account" + let net = accountNetwork a + ts <- mapM (unmarshalValue (net, ctx)) =<< o .: "pendingtxs" + return $ ResponsePendingTxs a ts + "reviewtx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtx" + return $ ResponseReviewTx a t + "exporttx" -> + ResponseExportTx + <$> o .: "txfile" + "importtx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtx" + return $ ResponseImportTx a t + "deletetx" -> + ResponseDeleteTx + <$> o .: "freedcoins" + <*> o .: "freedaddrs" + "signtx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtx" + return $ ResponseSignTx a t + "coins" -> do + a <- o .: "account" + xs <- o .: "coins" + coins <- mapM (unmarshalValue (accountNetwork a)) xs + return $ ResponseCoins a coins + "sendtx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "transaction" + i <- o .: "networktxid" + return $ ResponseSendTx a t i + "syncacc" -> + ResponseSyncAcc + <$> o .: "account" + <*> o .: "bestblock" + <*> o .: "bestheight" + <*> o .: "txupdates" + <*> o .: "coinupdates" + "discoveracc" -> + ResponseDiscoverAcc + <$> o .: "account" + <*> o .: "bestblock" + <*> o .: "bestheight" + <*> o .: "txupdates" + <*> o .: "coinupdates" + "version" -> + ResponseVersion + <$> o .: "version" + "preparesweep" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtxs" + return $ ResponsePrepareSweep a t + "signsweep" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "pendingtx" + return $ ResponseSignSweep a t + "rolldice" -> + ResponseRollDice + <$> o .: "dice" + <*> o .: "entropysource" + _ -> fail "Invalid JSON response type" + +runDB :: (MonadUnliftIO m) => ExceptT String (DB m) Response -> m Response +runDB action = do + dir <- liftIO hwDataDirectory + let dbFile = dir "accounts.sqlite" + runSqlite (cs dbFile) $ do + _ <- runMigrationQuiet migrateAll + resE <- runExceptT action + case resE of + Left err -> do + transactionUndo -- Roll back the current sqlite transaction + return $ ResponseError $ cs err + Right res -> return res + +catchResponseError :: (Monad m) => ExceptT String m Response -> m Response +catchResponseError m = do + resE <- runExceptT m + case resE of + Left err -> return $ ResponseError $ cs err + Right res -> return res + +commandResponse :: Ctx -> Config -> Command -> IO Response +commandResponse ctx cfg cmd = + case cmd of + -- Mnemonic and account management + CommandMnemonic e d s -> cmdMnemonic e d s + CommandCreateAcc t n dM s -> cmdCreateAcc ctx t n dM s + CommandTestAcc nameM s -> cmdTestAcc ctx nameM s + CommandRenameAcc old new -> cmdRenameAcc old new + CommandAccounts nameM -> cmdAccounts nameM + -- Address management + CommandReceive nameM labM -> cmdReceive ctx cfg nameM labM + CommandAddrs nameM p -> cmdAddrs nameM p + CommandLabel nameM i l -> cmdLabel nameM i l + -- Transaction management + CommandTxs nameM p -> cmdTxs ctx nameM p + CommandPrepareTx rcpts nameM unit fee dust rcptPay o -> + cmdPrepareTx ctx cfg rcpts nameM unit fee dust rcptPay o + CommandPendingTxs nameM p -> cmdPendingTxs ctx nameM p + CommandSignTx nameM h i o s -> cmdSignTx ctx nameM h i o s + CommandDeleteTx nameM h -> cmdDeleteTx ctx nameM h + CommandCoins nameM p -> cmdCoins nameM p + -- Import/export commands + CommandExportAcc nameM f -> cmdExportAcc ctx nameM f + CommandImportAcc f -> cmdImportAcc ctx f + CommandReviewTx nameM file -> cmdReviewTx ctx nameM file + CommandExportTx h f -> cmdExportTx h f + CommandImportTx nameM file -> cmdImportTx ctx nameM file + -- Online commands + CommandSendTx nameM h -> cmdSendTx ctx cfg nameM h + CommandSyncAcc nameM full -> cmdSyncAcc ctx cfg nameM full + CommandDiscoverAcc nameM -> cmdDiscoverAccount ctx cfg nameM + -- Utilities + CommandVersion -> cmdVersion + CommandPrepareSweep nameM sf fileM st outputM f d -> + prepareSweep ctx cfg nameM sf fileM st outputM f d + CommandSignSweep nameM h i o k -> signSweep ctx nameM h i o k + CommandRollDice n -> rollDice n + +-- runDB Monad Stack: +-- ExceptT String (ReaderT SqlBackend (NoLoggingT (ResourceT (IO)))) + +liftEitherIO :: (MonadIO m) => IO (Either String a) -> ExceptT String m a +liftEitherIO = liftEither <=< liftIO + +cmdMnemonic :: Natural -> Bool -> Natural -> IO Response +cmdMnemonic ent useDice splitMnemIn = + catchResponseError $ do + (orig, ms, splitMs) <- genMnemonic ent useDice splitMnemIn + return $ ResponseMnemonic orig (Text.words ms) (Text.words <$> splitMs) + +cmdCreateAcc :: + Ctx -> Text -> Network -> Maybe Natural -> Natural -> IO Response +cmdCreateAcc ctx name net derivM splitMnemIn = do + runDB $ do + mnem <- askMnemonicPass splitMnemIn + walletFP <- liftEither $ walletFingerprint net ctx mnem + d <- maybe (lift $ nextAccountDeriv walletFP net) return derivM + prvKey <- liftEither $ signingKey net ctx mnem d + let xpub = deriveXPubKey ctx prvKey + (_, acc) <- insertAccount net ctx walletFP name xpub + return $ ResponseCreateAcc acc + +cmdTestAcc :: Ctx -> Maybe Text -> Natural -> IO Response +cmdTestAcc ctx nameM splitMnemIn = + runDB $ do + (_, acc) <- getAccountByName nameM + let net = accountNetwork acc + xPubKey = accountXPubKey ctx acc + d = accountIndex acc + mnem <- askMnemonicPass splitMnemIn + xPrvKey <- liftEither $ signingKey net ctx mnem d + return $ + if deriveXPubKey ctx xPrvKey == xPubKey + then + ResponseTestAcc + { responseAccount = acc, + responseResult = True, + responseText = + "The mnemonic and passphrase matched the account" + } + else + ResponseTestAcc + { responseAccount = acc, + responseResult = False, + responseText = + "The mnemonic and passphrase did not match the account" + } + +cmdImportAcc :: Ctx -> FilePath -> IO Response +cmdImportAcc ctx fp = + runDB $ do + (PubKeyDoc xpub net name wallet) <- liftEitherIO $ readMarshalFile ctx fp + (_, acc) <- insertAccount net ctx wallet name xpub + return $ ResponseImportAcc acc + +cmdExportAcc :: Ctx -> Maybe Text -> FilePath -> IO Response +cmdExportAcc ctx nameM file = + runDB $ do + (_, acc) <- getAccountByName nameM + checkPathFree file + let xpub = accountXPubKey ctx acc + net = accountNetwork acc + name = dBAccountName acc + wallet = accountWallet acc + doc = PubKeyDoc xpub net name wallet + liftIO $ writeMarshalFile ctx file doc + return $ ResponseExportAcc acc file + +cmdRenameAcc :: Text -> Text -> IO Response +cmdRenameAcc oldName newName = + runDB $ do + acc <- renameAccount oldName newName + return $ ResponseRenameAcc acc oldName newName + +cmdAccounts :: Maybe Text -> IO Response +cmdAccounts nameM = + runDB $ do + case nameM of + Just _ -> do + (_, acc) <- getAccountByName nameM + return $ ResponseAccounts [acc] + _ -> do + accs <- lift getAccounts + return $ ResponseAccounts $ snd <$> accs + +cmdReceive :: Ctx -> Config -> Maybe Text -> Maybe Text -> IO Response +cmdReceive ctx cfg nameM labelM = + runDB $ do + (accId, acc) <- getAccountByName nameM + addr <- genExtAddress ctx cfg accId $ fromMaybe "" labelM + return $ ResponseReceive acc addr + +cmdAddrs :: Maybe Text -> Page -> IO Response +cmdAddrs nameM page = + runDB $ do + (accId, acc) <- getAccountByName nameM + as <- lift $ addressPage accId page + return $ ResponseAddresses acc as + +cmdLabel :: Maybe Text -> Natural -> Text -> IO Response +cmdLabel nameM idx lab = + runDB $ do + (accId, acc) <- getAccountByName nameM + adr <- setAddrLabel accId (fromIntegral idx) lab + return $ ResponseLabel acc adr + +cmdTxs :: Ctx -> Maybe Text -> Page -> IO Response +cmdTxs ctx nameM page = + runDB $ do + (accId, acc) <- getAccountByName nameM + txInfos <- txsPage ctx accId page + return $ ResponseTxs acc txInfos + +cmdPrepareTx :: + Ctx -> + Config -> + [(Text, Text)] -> + Maybe Text -> + AmountUnit -> + Natural -> + Natural -> + Bool -> + Maybe FilePath -> + IO Response +cmdPrepareTx ctx cfg rcpTxt nameM unit feeByte dust rcptPay fileM = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + rcpts <- liftEither $ mapM (toRecipient net) rcpTxt + gen <- liftIO initStdGen + signDat <- buildTxSignData net ctx cfg gen accId rcpts feeByte dust rcptPay + txInfoU <- liftEither $ parseTxSignData net ctx pub signDat + for_ fileM checkPathFree + nosigHash <- importPendingTx net ctx accId signDat + for_ fileM $ \file -> liftIO $ writeJsonFile file $ Json.toJSON signDat + newAcc <- getAccountById accId + return $ ResponsePrepareTx newAcc $ NoSigUnsigned nosigHash txInfoU + where + toRecipient net (a, v) = do + addr <- textToAddrE net a + val <- maybeToEither (cs $ badAmnt v) (readAmount unit v) + return (addr, val) + badAmnt v = + "Could not parse the amount " <> v <> " as " <> showUnit unit 1 + +cmdPendingTxs :: Ctx -> Maybe Text -> Page -> IO Response +cmdPendingTxs ctx nameM page = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsds <- pendingTxPage accId page + txs <- forM tsds $ \(nosigH, tsd@(TxSignData tx _ _ _ signed)) -> do + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + return $ + if signed + then NoSigSigned nosigH $ unsignedToTxInfo tx txInfoU + else NoSigUnsigned nosigH txInfoU + return $ ResponsePendingTxs acc txs + +cmdReviewTx :: Ctx -> Maybe Text -> FilePath -> IO Response +cmdReviewTx ctx nameM fp = + runDB $ do + (_, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsd@(TxSignData tx _ _ _ signed) <- liftEitherIO $ readJsonFile fp + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let txInfo = unsignedToTxInfo tx txInfoU + nosigHash = nosigTxHash tx + return $ + ResponseReviewTx acc $ + if signed + then NoSigSigned nosigHash txInfo + else NoSigUnsigned nosigHash txInfoU + +cmdExportTx :: TxHash -> FilePath -> IO Response +cmdExportTx nosigH fp = + runDB $ do + pendingTxM <- lift $ getPendingTx nosigH + case pendingTxM of + Just (tsd, _) -> do + checkPathFree fp + liftIO $ writeJsonFile fp $ Json.toJSON tsd + return $ ResponseExportTx fp + _ -> throwError "The pending transaction does not exist" + +cmdImportTx :: Ctx -> Maybe Text -> FilePath -> IO Response +cmdImportTx ctx nameM fp = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsd@(TxSignData tx _ _ _ signed) <- liftEitherIO $ readJsonFile fp + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let txInfo = unsignedToTxInfo tx txInfoU + nosigHash <- importPendingTx net ctx accId tsd + return $ + ResponseReviewTx acc $ + if signed + then NoSigSigned nosigHash txInfo + else NoSigUnsigned nosigHash txInfoU + +cmdDeleteTx :: Ctx -> Maybe Text -> TxHash -> IO Response +cmdDeleteTx ctx nameM nosigH = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + (coins, addrs) <- deletePendingTx net ctx accId nosigH + return $ ResponseDeleteTx coins addrs + +cmdSignTx :: + Ctx -> + Maybe Text -> + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + Natural -> + IO Response +cmdSignTx ctx nameM nosigHM inputM outputM splitMnemIn = + runDB $ do + (tsd, online) <- parseSignInput nosigHM inputM outputM + when online $ + throwError "The transaction is already online" + when (txSignDataSigned tsd) $ + throwError "The transaction is already signed" + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + idx = fromIntegral $ dBAccountIndex acc + accPub = accountXPubKey ctx acc + for_ outputM checkPathFree + mnem <- askMnemonicPass splitMnemIn + prvKey <- liftEither $ signingKey net ctx mnem idx + let xpub = deriveXPubKey ctx prvKey + unless (accPub == xpub) $ + throwError "The mnemonic did not match the provided account" + (newSignData, txInfo) <- liftEither $ signWalletTx net ctx tsd prvKey + let nosigH = nosigTxHash $ txSignDataTx newSignData + when (isJust nosigHM && Just nosigH /= nosigHM) $ + throwError "The nosigHash did not match" + when (isJust nosigHM) $ void $ importPendingTx net ctx accId newSignData + for_ outputM $ \o -> liftIO $ writeJsonFile o $ Json.toJSON newSignData + return $ ResponseSignTx acc (NoSigSigned nosigH txInfo) + +parseSignInput :: + (MonadUnliftIO m) => + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + ExceptT String (DB m) (TxSignData, Bool) +parseSignInput nosigHM inputM outputM = + case (nosigHM, inputM, outputM) of + (Nothing, Nothing, _) -> + throwError + "Provide either a TXHASH or both a --input file and a --output file" + (Just _, Just _, _) -> + throwError "Can not specify both a TXHASH and a --input file" + (_, Just _, Nothing) -> + throwError "When using a --input file, also provide a --output file" + (Just h, _, _) -> do + resM <- lift $ getPendingTx h + case resM of + Just res -> return res + _ -> throwError "The nosigHash does not exist in the wallet" + (_, Just i, _) -> do + exist <- liftIO $ D.doesFileExist i + unless exist $ throwError "Input file does not exist" + (,False) <$> liftEitherIO (readJsonFile i) + +cmdCoins :: Maybe Text -> Page -> IO Response +cmdCoins nameM page = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + coins <- coinPage net accId page + return $ ResponseCoins acc coins + +cmdSendTx :: Ctx -> Config -> Maybe Text -> TxHash -> IO Response +cmdSendTx ctx cfg nameM nosigH = + runDB $ do + (_, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsdM <- lift $ getPendingTx nosigH + case tsdM of + Just (tsd@(TxSignData signedTx _ _ _ signed), _) -> do + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let txInfo = unsignedToTxInfo signedTx txInfoU + verify = verifyTxInfo net ctx signedTx txInfo + unless (signed && verify) $ throwError "The transaction is not signed" + checkHealth ctx net cfg + let host = apiHost net cfg + Store.TxId netTxId <- liftExcept $ apiCall ctx host (PostTx signedTx) + _ <- lift $ setPendingTxOnline nosigH + return $ ResponseSendTx acc txInfo netTxId + _ -> throwError "The nosigHash does not exist in the wallet" + +cmdSyncAcc :: Ctx -> Config -> Maybe Text -> Bool -> IO Response +cmdSyncAcc ctx cfg nameM full = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + host = apiHost net cfg + -- Check API health + checkHealth ctx net cfg + -- Get the new best block before starting the sync + best <- liftExcept $ apiCall ctx host (GetBlockBest def) + -- Get the addresses from our local database + (addrPathMap, addrBalMap) <- allAddressesMap net accId + -- Fetch the address balances online + Store.SerialList storeBals <- + liftExcept . apiBatch ctx (configAddrBatch cfg) host $ + GetAddrsBalance (Map.keys addrBalMap) + -- Filter only those addresses whose balances have changed + balsToUpdate <- + if full + then return storeBals + else liftEither $ filterAddresses storeBals addrBalMap + let addrsToUpdate = (.address) <$> balsToUpdate + -- Update balances + updateAddressBalances net balsToUpdate + newAcc <- lift $ updateAccountBalances accId + -- Get a list of our confirmed txs in the local database + -- Use an empty list when doing a full sync + confirmedTxs <- if full then return [] else getConfirmedTxs accId True + -- Fetch the txids of the addresses to update + aTids <- searchAddrTxs net ctx cfg confirmedTxs addrsToUpdate + -- We also want to check if there is any change in unconfirmed txs + uTids <- getConfirmedTxs accId False + let tids = nub $ uTids <> aTids + -- Fetch the full transactions + Store.SerialList txs <- + liftExcept $ apiBatch ctx (configTxFullBatch cfg) host (GetTxs tids) + -- Convert them to TxInfo and store them in the local database + let txInfos = toTxInfo addrPathMap (fromIntegral best.height) <$> txs + resTxInfo <- lift $ forM txInfos $ repsertTxInfo net ctx accId + -- Fetch and update coins + Store.SerialList storeCoins <- + liftExcept . apiBatch ctx (configCoinBatch cfg) host $ + GetAddrsUnspent addrsToUpdate def + (coinCount, newCoins) <- refreshCoins net accId addrsToUpdate storeCoins + -- Get the dependent tranactions of the new coins + depTxsHash <- + if full + then return $ (.outpoint.hash) <$> storeCoins + else mapM (liftEither . coinToTxHash) newCoins + Store.RawResultList rawTxs <- + liftExcept + . apiBatch ctx (configTxFullBatch cfg) host + $ GetTxsRaw + $ nub depTxsHash + lift $ forM_ rawTxs insertRawTx + -- Remove pending transactions if they are online + pendingTids <- pendingTxHashes accId + let toRemove = filter ((`elem` tids) . fst) pendingTids + forM_ toRemove $ \(_, key) -> lift $ deletePendingTxOnline key + -- Update the best block for this network + lift $ updateBest net (headerHash best.header) best.height + return $ + ResponseSyncAcc + newAcc + (headerHash best.header) + (fromIntegral best.height) + (fromIntegral $ length $ filter id $ snd <$> resTxInfo) + (fromIntegral coinCount) + +coinToTxHash :: DBCoin -> Either String TxHash +coinToTxHash coin = + maybeToEither "coinToTxHash: Invalid outpoint" $ do + bs <- decodeHex $ dBCoinOutpoint coin + op <- eitherToMaybe (S.decode bs) :: Maybe OutPoint + return op.hash + +-- Filter addresses that need to be updated +filterAddresses :: + [Store.Balance] -> + Map Address AddressBalance -> + Either String [Store.Balance] +filterAddresses sBals aMap + | sort ((.address) <$> sBals) /= sort (Map.keys aMap) = + Left "Sync: addresses do not match" + | otherwise = + Right $ filter f sBals + where + f s = + let b = fromJust $ s.address `Map.lookup` aMap + in s.txs /= addrBalanceTxs b + || s.confirmed /= addrBalanceConfirmed b + || s.unconfirmed /= addrBalanceUnconfirmed b + || s.utxo /= addrBalanceCoins b + +searchAddrTxs :: + (MonadIO m) => + Network -> + Ctx -> + Config -> + [TxHash] -> + [Address] -> + ExceptT String m [TxHash] +searchAddrTxs _ _ _ _ [] = return [] +searchAddrTxs net ctx cfg confirmedTxs as + | length as > fromIntegral (configAddrBatch cfg) = + nub . concat <$> mapM (go Nothing 0) (chunksOf (configAddrBatch cfg) as) + | otherwise = + nub <$> go Nothing 0 as + where + go hashM offset xs = do + Store.SerialList txRefs <- + liftExcept $ + apiCall + ctx + (apiHost net cfg) + ( GetAddrsTxs + xs + def + { limit = Just $ fromIntegral (configTxBatch cfg), + start = StartParamHash <$> hashM, + offset = offset + } + ) + -- Remove txs that we already have + let tids = ((.txid) <$> txRefs) \\ confirmedTxs + -- Either we have reached the end of the stream, or we have hit some + -- txs in confirmedTxs. In both cases, we can stop the search. + if length tids < fromIntegral (configTxBatch cfg) + then return tids + else do + let lastId = (last tids).get + rest <- go (Just lastId) 1 xs + return $ tids <> rest + +cmdDiscoverAccount :: Ctx -> Config -> Maybe Text -> IO Response +cmdDiscoverAccount ctx cfg nameM = do + _ <- runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + checkHealth ctx net cfg + let recoveryGap = configRecoveryGap cfg + e <- go net pub extDeriv 0 (Page recoveryGap 0) + i <- go net pub intDeriv 0 (Page recoveryGap 0) + discoverAccGenAddrs ctx cfg accId AddrExternal e + discoverAccGenAddrs ctx cfg accId AddrInternal i + return $ ResponseDiscoverAcc acc "" 0 0 0 + -- Perform a full sync after discovery + ResponseSyncAcc a bb bh tc cc <- cmdSyncAcc ctx cfg nameM True + return $ ResponseDiscoverAcc a bb bh tc cc + where + go net pub path d page@(Page lim off) = do + let addrs = addrsDerivPage ctx path page pub + req = GetAddrsBalance $ fst <$> addrs + let host = apiHost net cfg + Store.SerialList bals <- liftExcept $ apiCall ctx host req + let vBals = filter ((/= 0) . (.txs)) bals + if null vBals + then return d + else do + let dMax = findMax addrs $ (.address) <$> vBals + go net pub path (dMax + 1) (Page lim (off + lim)) + -- Find the largest ID amongst the addresses that have a positive balance + findMax :: [(Address, SoftPath)] -> [Address] -> Int + findMax addrs balAddrs = + let fAddrs = filter ((`elem` balAddrs) . fst) addrs + in fromIntegral $ maximum $ last . pathToList . snd <$> fAddrs + +cmdVersion :: IO Response +cmdVersion = return $ ResponseVersion versionString + +prepareSweep :: + Ctx -> + Config -> + Maybe Text -> + [Text] -> + Maybe FilePath -> + [Text] -> + Maybe FilePath -> + Natural -> + Natural -> + IO Response +prepareSweep ctx cfg nameM sweepFromT sweepFromFileM sweepToT outputM feeByte dust = + runDB $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + sweepFromArg <- liftEither $ mapM (textToAddrE net) sweepFromT + sweepTo <- liftEither $ mapM (textToAddrE net) sweepToT + addrsFile <- + case sweepFromFileM of + Just file -> parseAddrsFile net <$> liftIO (readFileWords file) + _ -> return [] + let sweepFrom = sweepFromArg <> addrsFile + checkHealth ctx net cfg + tsd <- buildSweepSignData net ctx cfg accId sweepFrom sweepTo feeByte dust + info <- liftEither $ parseTxSignData net ctx pub tsd + for_ outputM checkPathFree + nosigHash <- importPendingTx net ctx accId tsd + for_ outputM $ \file -> liftIO $ writeJsonFile file $ Json.toJSON tsd + return $ ResponsePrepareSweep acc (NoSigUnsigned nosigHash info) + +signSweep :: + Ctx -> + Maybe Text -> + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + FilePath -> + IO Response +signSweep ctx nameM nosigHM inputM outputM keyFile = + runDB $ do + (tsd, online) <- parseSignInput nosigHM inputM outputM + when online $ + throwError "The transaction is already online" + when (txSignDataSigned tsd) $ + throwError "The transaction is already signed" + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + for_ outputM checkPathFree + -- Read the file containing the private keys + secKeys <- parseSecKeysFile net <$> liftIO (readFileWords keyFile) + when (null secKeys) $ throwError "No private keys to sign" + -- Sign the transactions + (newTsd, txInfo) <- liftEither $ signTxWithKeys net ctx tsd pub secKeys + let nosigH = nosigTxHash $ txSignDataTx newTsd + when (isJust nosigHM && Just nosigH /= nosigHM) $ + throwError "The nosigHash did not match" + when (isJust nosigHM) $ void $ importPendingTx net ctx accId newTsd + for_ outputM $ \o -> liftIO $ writeJsonFile o $ Json.toJSON newTsd + return $ ResponseSignSweep acc (NoSigSigned nosigH txInfo) + +rollDice :: Natural -> IO Response +rollDice n = do + (res, origEnt) <- go [] "" + return $ ResponseRollDice (take (fromIntegral n) res) origEnt + where + go acc orig + | length acc >= fromIntegral n = return (acc, orig) + | otherwise = do + (origEnt, sysEnt) <- systemEntropy 1 + go (word8ToBase6 (head $ BS.unpack sysEnt) <> acc) origEnt + +-- Utilities -- + +checkHealth :: + (MonadIO m) => + Ctx -> + Network -> + Config -> + ExceptT String (DB m) () +checkHealth ctx net cfg = do + let host = apiHost net cfg + health <- liftExcept $ apiCall ctx host GetHealth + unless (Store.isOK health) $ + throwError "The indexer health check has failed" + +-- Haskeline Helpers -- + +askInputLineHidden :: String -> IO String +askInputLineHidden message = do + inputM <- + Haskeline.runInputT Haskeline.defaultSettings $ + Haskeline.getPassword (Just '*') message + maybe + (error "No action due to EOF") + return + inputM + +askInputLine :: String -> IO String +askInputLine message = do + inputM <- + Haskeline.runInputT Haskeline.defaultSettings $ + Haskeline.getInputLine message + maybe + (error "No action due to EOF") + return + inputM + +askMnemonicWords :: String -> IO Mnemonic +askMnemonicWords txt = do + mnm <- askInputLineHidden txt + case fromMnemonic (cs mnm) of -- validate the mnemonic + Right _ -> return $ cs mnm + Left _ -> do + liftIO $ putStrLn "Invalid mnemonic" + askMnemonicWords txt + +askMnemonicPass :: (MonadError String m, MonadIO m) => Natural -> m MnemonicPass +askMnemonicPass splitMnemIn = do + mnm <- + if splitMnemIn == 1 + then liftIO $ askMnemonicWords "Enter your mnemonic words: " + else do + ms <- forM [1 .. splitMnemIn] $ \n -> + liftIO $ askMnemonicWords $ "Split mnemonic part #" <> show n <> ": " + liftEither $ mergeMnemonicParts ms + passStr <- liftIO askPassword + return + MnemonicPass + { mnemonicWords = mnm, + mnemonicPass = cs passStr + } + +askPassword :: IO String +askPassword = do + pass <- askInputLineHidden "Mnemonic passphrase or leave empty: " + if null pass + then return pass + else do + pass2 <- askInputLineHidden "Repeat your mnemonic passphrase: " + if pass == pass2 + then return pass + else do + putStrLn "The passphrases did not match" + askPassword diff --git a/src/Haskoin/Wallet/Config.hs b/src/Haskoin/Wallet/Config.hs new file mode 100644 index 00000000..135d924a --- /dev/null +++ b/src/Haskoin/Wallet/Config.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.Config where + +import Control.Monad (unless) +import Data.Aeson +import Data.Default +import Data.String (IsString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin.Network +import Haskoin.Store.WebClient +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import qualified System.Directory as D + +-- | Version of Haskoin Wallet package. +versionString :: (IsString a) => a +#ifdef CURRENT_PACKAGE_VERSION +versionString = CURRENT_PACKAGE_VERSION +#else +versionString = "Unavailable" +#endif + +hwDataDirectory :: IO FilePath +hwDataDirectory = do + dir <- D.getAppUserDataDirectory "hw" + D.createDirectoryIfMissing True dir + return dir + +data Config = Config + { configHost :: Text, + configGap :: Natural, + configRecoveryGap :: Natural, + configAddrBatch :: Natural, + configTxBatch :: Natural, + configCoinBatch :: Natural, + configTxFullBatch :: Natural + } + deriving (Eq, Show) + +instance FromJSON Config where + parseJSON = + withObject "config" $ \o -> + Config + <$> o .: "host" + <*> o .: "gap" + <*> o .: "recovery-gap" + <*> o .: "addr-batch" + <*> o .: "tx-batch" + <*> o .: "coin-batch" + <*> o .: "tx-full-batch" + +instance ToJSON Config where + toJSON cfg = + object + [ "host" .= configHost cfg, + "gap" .= configGap cfg, + "recovery-gap" .= configRecoveryGap cfg, + "addr-batch" .= configAddrBatch cfg, + "tx-batch" .= configTxBatch cfg, + "coin-batch" .= configCoinBatch cfg, + "tx-full-batch" .= configTxFullBatch cfg + ] + +instance Default Config where + def = + Config + { configHost = cs (def :: ApiConfig).host, + configGap = 20, + configRecoveryGap = 40, + configAddrBatch = 100, + configTxBatch = 100, + configCoinBatch = 100, + configTxFullBatch = 100 + } + +initConfig :: IO Config +initConfig = do + dir <- hwDataDirectory + let configFile = dir "config.json" + exists <- D.doesFileExist configFile + unless exists $ writeJsonFile configFile $ toJSON (def :: Config) + resE <- readJsonFile configFile + either (error "Could not read config.json") return resE + +apiHost :: Network -> Config -> ApiConfig +apiHost net = ApiConfig net . cs . configHost diff --git a/src/Haskoin/Wallet/Database.hs b/src/Haskoin/Wallet/Database.hs new file mode 100644 index 00000000..4c700f16 --- /dev/null +++ b/src/Haskoin/Wallet/Database.hs @@ -0,0 +1,1307 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.Database where + +import Conduit (MonadUnliftIO, ResourceT) +import Control.Arrow (Arrow (second)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (NoLoggingT) +import Control.Monad.Reader (MonadTrans (lift), ReaderT) +import Data.Aeson +import qualified Data.Aeson as Json +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Either (fromRight) +import Data.List (find, nub, partition) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time (UTCTime, getCurrentTime) +import Data.Word (Word64) +import Database.Esqueleto.Legacy as E +import qualified Database.Persist as P +import Database.Persist.TH +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.Config (Config (configGap)) +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util (Page (Page), textToAddrE) +import Numeric.Natural (Natural) + +{- SQL Table Definitions -} + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| + +DBWallet + fingerprint Text + Primary fingerprint + deriving Show + +DBAccount + name Text + wallet DBWalletId + index Int + network Text + derivation Text + external Int + internal Int + xPubKey Text + balanceConfirmed Word64 + balanceUnconfirmed Word64 + balanceCoins Word64 + created UTCTime default=CURRENT_TIME + Primary wallet derivation + UniqueName name + UniqueXPubKey xPubKey + UniqueNetworkId wallet network index + deriving Show + deriving Eq + +DBAddress + index Int + accountWallet DBWalletId + accountDerivation Text + derivation Text + address Text + label Text + balanceConfirmed Word64 + balanceUnconfirmed Word64 + balanceCoins Word64 + balanceTxs Word64 + balanceReceived Word64 + internal Bool + free Bool + created UTCTime default=CURRENT_TIME + Primary accountWallet accountDerivation derivation + UniqueAddress address + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBTxInfo + accountWallet DBWalletId + accountDerivation Text + txid Text + blockRef ByteString + confirmed Bool + blob ByteString + created UTCTime default=CURRENT_TIME + Primary accountWallet accountDerivation txid + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBCoin + accountWallet DBWalletId + accountDerivation Text + outpoint Text + address Text + value Word64 + blockRef ByteString + blob ByteString + confirmed Bool + locked Bool + created UTCTime default=CURRENT_TIME + Primary outpoint + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBRawTx + hash Text + blob ByteString + Primary hash + deriving Show + deriving Eq + +DBPendingTx + accountWallet DBWalletId + accountDerivation Text + nosigHash Text + blob ByteString + online Bool + created UTCTime default=CURRENT_TIME + Primary nosigHash + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBBest + network Text + bestBlock Text + bestHeight Int + Primary network + deriving Show +|] + +type DB m = ReaderT SqlBackend (NoLoggingT (ResourceT m)) + +{- Meta -} + +updateBest :: + (MonadUnliftIO m) => Network -> BlockHash -> BlockHeight -> DB m () +updateBest net hash height = do + let netT = cs net.name + key = DBBestKey netT + P.repsert key $ DBBest netT (blockHashToHex hash) (fromIntegral height) + +getBest :: + (MonadUnliftIO m) => Network -> DB m (Maybe (BlockHash, BlockHeight)) +getBest net = do + let netT = cs net.name + resM <- P.get $ DBBestKey netT + return $ do + DBBest _ a b <- resM + hash <- hexToBlockHash a + return (hash, fromIntegral b) + +{- Accounts -} + +instance ToJSON DBAccount where + toJSON acc = + object + [ "name" .= dBAccountName acc, + "wallet" .= dBAccountWallet acc, + "index" .= dBAccountIndex acc, + "network" .= dBAccountNetwork acc, + "derivation" .= dBAccountDerivation acc, + "external" .= dBAccountExternal acc, + "internal" .= dBAccountInternal acc, + "xPubKey" .= dBAccountXPubKey acc, + "balance" .= toJSON (AccountBalance confirm unconfirm coins), + "created" .= dBAccountCreated acc + ] + where + confirm = dBAccountBalanceConfirmed acc + unconfirm = dBAccountBalanceUnconfirmed acc + coins = dBAccountBalanceCoins acc + +instance FromJSON DBAccount where + parseJSON = + withObject "DBAccount" $ \o -> do + bal <- o .: "balance" + DBAccount + <$> o .: "name" + <*> o .: "wallet" + <*> o .: "index" + <*> o .: "network" + <*> o .: "derivation" + <*> o .: "external" + <*> o .: "internal" + <*> o .: "xPubKey" + <*> (bal .: "confirmed") + <*> (bal .: "unconfirmed") + <*> (bal .: "coins") + <*> o .: "created" + +data AccountBalance = AccountBalance + { -- | confirmed balance + accBalanceConfirmed :: !Word64, + -- | unconfirmed balance + accBalanceUnconfirmed :: !Word64, + -- | number of unspent outputs + accBalanceCoins :: !Word64 + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON AccountBalance where + toJSON b = + object + [ "confirmed" .= accBalanceConfirmed b, + "unconfirmed" .= accBalanceUnconfirmed b, + "coins" .= accBalanceCoins b + ] + +instance FromJSON AccountBalance where + parseJSON = + withObject "accountbalance" $ \o -> + AccountBalance + <$> o .: "confirmed" + <*> o .: "unconfirmed" + <*> o .: "coins" + +accountIndex :: DBAccount -> Natural +accountIndex = fromIntegral . dBAccountIndex + +accountNetwork :: DBAccount -> Network +accountNetwork = + fromMaybe (error "Invalid Network in database") + . netByName + . cs + . dBAccountNetwork + +accountWallet :: DBAccount -> Fingerprint +accountWallet acc = + let (DBWalletKey walletFP) = dBAccountWallet acc + in fromRight (error "Invalid WalletId in database") $ + textToFingerprint walletFP + +accountXPubKey :: Ctx -> DBAccount -> XPubKey +accountXPubKey ctx acc = + fromMaybe (error "Invalid XPubKey in database") $ + xPubImport (accountNetwork acc) ctx (dBAccountXPubKey acc) + +nextAccountDeriv :: (MonadUnliftIO m) => Fingerprint -> Network -> DB m Natural +nextAccountDeriv walletFP net = do + let walletId = DBWalletKey $ fingerprintToText walletFP + dM <- + selectOne . from $ \a -> do + where_ $ + a ^. DBAccountNetwork ==. val (cs net.name) + &&. a ^. DBAccountWallet ==. val walletId + return $ max_ $ a ^. DBAccountIndex + return $ joinMaybe 0 ((+ 1) . fromIntegral) dM + +existsAccount :: (MonadUnliftIO m) => Text -> DB m Bool +existsAccount name = P.existsBy $ UniqueName name + +existsXPubKey :: (MonadUnliftIO m) => Network -> Ctx -> XPubKey -> DB m Bool +existsXPubKey net ctx key = P.existsBy $ UniqueXPubKey $ xPubExport net ctx key + +getWalletOrCreate :: (MonadUnliftIO m) => Fingerprint -> DB m DBWalletId +getWalletOrCreate fp = do + let key = DBWalletKey $ fingerprintToText fp + walletM <- P.get key + case walletM of + Just _ -> return key + _ -> P.insert $ DBWallet $ fingerprintToText fp + +insertAccount :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Fingerprint -> + Text -> + XPubKey -> + ExceptT String (DB m) (DBAccountId, DBAccount) +insertAccount net ctx walletFP name xpub = do + existsName <- lift $ existsAccount name + if existsName + then throwError $ "Account " <> cs name <> " already exists" + else do + existsKey <- lift $ existsXPubKey net ctx xpub + if existsKey + then throwError "The XPubKey already exists" + else do + time <- liftIO getCurrentTime + walletId <- lift $ getWalletOrCreate walletFP + let path = bip44Deriv net $ fromIntegral $ xPubChild xpub + idx = fromIntegral $ xPubIndex xpub + account = + DBAccount + { dBAccountName = name, + dBAccountWallet = walletId, + dBAccountIndex = idx, + dBAccountNetwork = cs net.name, + dBAccountDerivation = cs $ pathToStr path, + dBAccountExternal = 0, + dBAccountInternal = 0, + dBAccountXPubKey = xPubExport net ctx xpub, + dBAccountBalanceConfirmed = 0, + dBAccountBalanceUnconfirmed = 0, + dBAccountBalanceCoins = 0, + dBAccountCreated = time + } + key <- lift $ P.insert account + return (key, account) + +-- When a name is provided, get that account or throw an error if it doesn't +-- exist. When no name is provided, return the account only if there is one +-- account. +getAccountByName :: + (MonadUnliftIO m) => + Maybe Text -> + ExceptT String (DB m) (DBAccountId, DBAccount) +getAccountByName (Just name) = do + aM <- lift $ P.getBy $ UniqueName name + case aM of + Just a -> return (entityKey a, entityVal a) + _ -> throwError $ "The account " <> cs name <> " does not exist" +getAccountByName Nothing = do + as <- lift getAccounts + case as of + [a] -> return a + [] -> throwError "There are no accounts in the wallet" + _ -> throwError "Specify which account to use" + +getAccountById :: + (MonadUnliftIO m) => DBAccountId -> ExceptT String (DB m) DBAccount +getAccountById accId = liftMaybe "Invalid account" =<< lift (P.get accId) + +getAccounts :: (MonadUnliftIO m) => DB m [(DBAccountId, DBAccount)] +getAccounts = + (go <$>) <$> P.selectList [] [P.Asc DBAccountCreated] + where + go a = (entityKey a, entityVal a) + +getAccountNames :: (MonadUnliftIO m) => DB m [Text] +getAccountNames = do + res <- select . from $ \a -> do + orderBy [asc $ a ^. DBAccountCreated] + return $ a ^. DBAccountName + return $ unValue <$> res + +renameAccount :: + (MonadUnliftIO m) => Text -> Text -> ExceptT String (DB m) DBAccount +renameAccount oldName newName + | oldName == newName = throwError "Old and new names are the same" + | otherwise = do + e <- lift $ existsAccount newName + if e + then throwError $ "The account " <> cs newName <> " already exists" + else do + c <- + lift . updateCount $ \a -> do + set a [DBAccountName =. val newName] + where_ $ a ^. DBAccountName ==. val oldName + if c == 0 + then throwError $ "The account " <> cs oldName <> " does not exist" + else snd <$> getAccountByName (Just newName) + +updateAccountBalances :: (MonadUnliftIO m) => DBAccountId -> DB m DBAccount +updateAccountBalances accId@(DBAccountKey wallet accDeriv) = do + confirm <- selectSum DBAddressBalanceConfirmed + unconfirm <- selectSum DBAddressBalanceUnconfirmed + coins <- selectSum DBAddressBalanceCoins + update $ \a -> do + set + a + [ DBAccountBalanceConfirmed =. val (unpack confirm), + DBAccountBalanceUnconfirmed =. val (unpack unconfirm), + DBAccountBalanceCoins =. val (unpack coins) + ] + where_ $ a ^. DBAccountId ==. val accId + fromJust <$> P.get accId + where + unpack m = fromMaybe 0 $ unValue $ fromMaybe (Value $ Just 0) m + selectSum field = + selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return $ sum_ $ a ^. field + +{- Addresses -} + +data AddrType = AddrInternal | AddrExternal + deriving (Eq, Show) + +isInternal :: AddrType -> Bool +isInternal AddrInternal = True +isInternal AddrExternal = False + +dBAccountCount :: AddrType -> DBAccount -> Int +dBAccountCount AddrInternal = dBAccountInternal +dBAccountCount AddrExternal = dBAccountExternal + +dBAccountField :: AddrType -> EntityField DBAccount Int +dBAccountField AddrInternal = DBAccountInternal +dBAccountField AddrExternal = DBAccountExternal + +addrDeriv :: AddrType -> SoftPath +addrDeriv AddrInternal = intDeriv +addrDeriv AddrExternal = extDeriv + +data AddrFree = AddrFree | AddrBusy + deriving (Eq, Show) + +isAddrFree :: AddrFree -> Bool +isAddrFree AddrFree = True +isAddrFree AddrBusy = False + +instance ToJSON DBAddress where + toJSON addr = + object + [ "index" .= dBAddressIndex addr, + "wallet" .= dBAddressAccountWallet addr, + "account" .= dBAddressAccountDerivation addr, + "derivation" .= dBAddressDerivation addr, + "address" .= dBAddressAddress addr, + "label" .= dBAddressLabel addr, + "balance" + .= AddressBalance + (dBAddressBalanceConfirmed addr) + (dBAddressBalanceUnconfirmed addr) + (dBAddressBalanceCoins addr) + (dBAddressBalanceTxs addr) + (dBAddressBalanceReceived addr), + "internal" .= dBAddressInternal addr, + "free" .= dBAddressFree addr, + "created" .= dBAddressCreated addr + ] + +instance FromJSON DBAddress where + parseJSON = + withObject "DBAddress" $ \o -> do + bal <- o .: "balance" + DBAddress + <$> o .: "index" + <*> o .: "wallet" + <*> o .: "account" + <*> o .: "derivation" + <*> o .: "address" + <*> o .: "label" + <*> bal .: "confirmed" + <*> bal .: "unconfirmed" + <*> bal .: "coins" + <*> bal .: "txs" + <*> bal .: "received" + <*> o .: "internal" + <*> o .: "free" + <*> o .: "created" + +data AddressBalance = AddressBalance + { -- | confirmed balance + addrBalanceConfirmed :: !Word64, + -- | unconfirmed balance + addrBalanceUnconfirmed :: !Word64, + -- | number of unspent outputs + addrBalanceCoins :: !Word64, + -- | number of transactions + addrBalanceTxs :: !Word64, + -- | total amount from all outputs in this address + addrBalanceReceived :: !Word64 + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON AddressBalance where + toJSON b = + object + [ "confirmed" .= addrBalanceConfirmed b, + "unconfirmed" .= addrBalanceUnconfirmed b, + "coins" .= addrBalanceCoins b, + "txs" .= addrBalanceTxs b, + "received" .= addrBalanceReceived b + ] + +instance FromJSON AddressBalance where + parseJSON = + withObject "accountbalance" $ \o -> + AddressBalance + <$> o .: "confirmed" + <*> o .: "unconfirmed" + <*> o .: "coins" + <*> o .: "txs" + <*> o .: "received" + +updateAddressBalances :: + (MonadUnliftIO m) => + Network -> + [Store.Balance] -> + ExceptT String (DB m) () +updateAddressBalances net storeBals = + forM_ storeBals $ \s -> do + addrT <- + liftEither $ maybeToEither "Invalid Address" (addrToText net s.address) + lift . update $ \a -> do + set + a + [ DBAddressBalanceConfirmed =. val s.confirmed, + DBAddressBalanceUnconfirmed =. val s.unconfirmed, + DBAddressBalanceCoins =. val s.utxo, + DBAddressBalanceTxs =. val s.txs, + DBAddressBalanceReceived =. val s.received + ] + where_ $ a ^. DBAddressAddress ==. val addrT + +insertAddress :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + SoftPath -> + Address -> + AddrFree -> + ExceptT String (DB m) DBAddress +insertAddress net (DBAccountKey wallet accDeriv) deriv addr free = do + time <- liftIO getCurrentTime + addrT <- liftEither $ maybeToEither "Invalid Address" (addrToText net addr) + let label = if isIntPath deriv then "Internal Address" else "" + derivS = cs $ pathToStr deriv + dbAddr = + DBAddress + (fromIntegral $ pathIndex deriv) + wallet + accDeriv + derivS + addrT + label + 0 + 0 + 0 + 0 + 0 + (isIntPath deriv) + (isAddrFree free) + time + lift $ P.insert_ dbAddr + return dbAddr + +-- This is an internal function +genNextAddress :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + AddrType -> + AddrFree -> + ExceptT String (DB m) DBAddress +genNextAddress ctx cfg accId addrType addrFree = do + acc <- getAccountById accId + let net = accountNetwork acc + pub = accountXPubKey ctx acc + nextIdx = dBAccountCount addrType acc + deriv = addrDeriv addrType + checkGap cfg accId nextIdx addrType + let (addr, _) = derivePathAddr ctx pub deriv (fromIntegral nextIdx) + dbAddr <- + insertAddress net accId (deriv :/ fromIntegral nextIdx) addr addrFree + lift $ P.update accId [dBAccountField addrType P.=. nextIdx + 1] + return dbAddr + +checkGap :: + (MonadUnliftIO m) => + Config -> + DBAccountId -> + Int -> + AddrType -> + ExceptT String (DB m) () +checkGap cfg accId addrIdx addrType = do + let gap = configGap cfg + usedIdxM <- lift $ bestAddrWithFunds accId addrType + let usedIdx = maybe 0 (+ 1) usedIdxM + when (addrIdx >= usedIdx + fromIntegral gap) $ + throwError $ + "Can not generate addresses beyond the gap of " <> show gap + +-- Highest address with a positive transaction count +bestAddrWithFunds :: + (MonadUnliftIO m) => DBAccountId -> AddrType -> DB m (Maybe Int) +bestAddrWithFunds (DBAccountKey wallet accDeriv) addrType = do + resM <- (flatMaybe <$>) . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val (isInternal addrType) + &&. a ^. DBAddressBalanceTxs >. val 0 + return $ max_ $ a ^. DBAddressIndex + return $ fromIntegral <$> resM + +-- Generate the discovered external and internal addresses +discoverAccGenAddrs :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + AddrType -> + Int -> + ExceptT String (DB m) () +discoverAccGenAddrs ctx cfg accId addrType newAddrCnt = do + acc <- getAccountById accId + let oldAddrCnt = dBAccountCount addrType acc + cnt = max 0 $ newAddrCnt - oldAddrCnt + replicateM_ cnt $ genNextAddress ctx cfg accId addrType AddrBusy + +genExtAddress :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + Text -> + ExceptT String (DB m) DBAddress +genExtAddress ctx cfg accId label = do + addr <- genNextAddress ctx cfg accId AddrExternal AddrBusy + setAddrLabel accId (dBAddressIndex addr) label + +setAddrLabel :: + (MonadUnliftIO m) => + DBAccountId -> + Int -> + Text -> + ExceptT String (DB m) DBAddress +setAddrLabel accId@(DBAccountKey wallet accDeriv) idx label = do + acc <- getAccountById accId + let path = cs $ pathToStr $ extDeriv :/ fromIntegral idx + aKey = DBAddressKey wallet accDeriv path + unless (fromIntegral idx < dBAccountExternal acc) $ + throwError $ + "Address " <> show idx <> " does not exist" + lift $ P.updateGet aKey [DBAddressLabel P.=. label] + +nextFreeIntAddr :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + ExceptT String (DB m) DBAddress +nextFreeIntAddr ctx cfg accId@(DBAccountKey wallet accDeriv) = do + resM <- lift . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val True + &&. a ^. DBAddressFree ==. val True + orderBy [asc $ a ^. DBAddressIndex] + limit 1 + return a + case resM of + Just (Entity _ a) -> return a + Nothing -> genNextAddress ctx cfg accId AddrInternal AddrFree + +fromDBAddr :: Network -> DBAddress -> Either String (Address, SoftPath) +fromDBAddr net addrDB = do + let addrT = dBAddressAddress addrDB + derivT = dBAddressDerivation addrDB + deriv <- maybeToEither "fromDBAddress deriv" $ parseSoft $ cs derivT + addr <- maybeToEither "fromDBAddress addr" $ textToAddr net addrT + return (addr, deriv) + +setAddrsFree :: (MonadUnliftIO m) => AddrFree -> [Text] -> DB m Natural +setAddrsFree free addrs = do + (fromIntegral <$>) . updateCount $ \a -> do + set a [DBAddressFree =. val (isAddrFree free)] + where_ $ a ^. DBAddressAddress `in_` valList addrs + +addressPage :: (MonadUnliftIO m) => DBAccountId -> Page -> DB m [DBAddress] +addressPage (DBAccountKey wallet accDeriv) (Page lim off) = do + as <- + select $ + from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val False + orderBy [desc (a ^. DBAddressIndex)] + limit $ fromIntegral lim + offset $ fromIntegral off + return a + return $ entityVal <$> as + +allAddressesMap :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + ExceptT String (DB m) (Map Address SoftPath, Map Address AddressBalance) +allAddressesMap net (DBAccountKey wallet accDeriv) = do + dbRes <- + lift . select $ + from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return a + res <- + forM dbRes $ \(Entity _ dbAddr) -> do + a <- liftEither $ textToAddrE net $ dBAddressAddress dbAddr + d <- + liftEither . maybeToEither "parsePath failed" $ + parseSoft . cs $ + dBAddressDerivation dbAddr + let b = + AddressBalance + (dBAddressBalanceConfirmed dbAddr) + (dBAddressBalanceUnconfirmed dbAddr) + (dBAddressBalanceCoins dbAddr) + (dBAddressBalanceTxs dbAddr) + (dBAddressBalanceReceived dbAddr) + return ((a, d), (a, b)) + return (Map.fromList $ fst <$> res, Map.fromList $ snd <$> res) + +getCoinDeriv :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Store.Unspent -> + DB m (Either String SoftPath) +getCoinDeriv net accId unspent = + runExceptT $ do + addr <- + liftEither . maybeToEither "getCoinDeriv: no address" $ unspent.address + liftEither <=< lift $ getAddrDeriv net accId addr + +getAddrDeriv :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Address -> + DB m (Either String SoftPath) +getAddrDeriv net (DBAccountKey wallet accDeriv) addr = + runExceptT $ do + addrT <- + liftEither . maybeToEither "getAddrDeriv: no address" $ addrToText net addr + derivM <- + lift . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAddress ==. val addrT + &&. a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return $ a ^. DBAddressDerivation + liftEither . maybeToEither "getAddrDeriv: no derivation" $ + parseSoft . cs . unValue =<< derivM + +{- Transactions -} + +getConfirmedTxs :: + (MonadUnliftIO m) => DBAccountId -> Bool -> ExceptT String (DB m) [TxHash] +getConfirmedTxs (DBAccountKey wallet accDeriv) confirm = do + ts <- + lift . select $ + from $ \t -> do + where_ $ + t ^. DBTxInfoAccountWallet ==. val wallet + &&. t ^. DBTxInfoAccountDerivation ==. val accDeriv + &&. t ^. DBTxInfoConfirmed ==. val confirm + orderBy [asc (t ^. DBTxInfoBlockRef)] + return $ t ^. DBTxInfoTxid + forM ts $ \(Value t) -> + liftEither $ maybeToEither "getConfirmedTxs invalid TxHash" $ hexToTxHash t + +-- Insert a new transaction or replace it, if it already exists +-- Returns True if there was a change or an insert +repsertTxInfo :: + (MonadUnliftIO m) => + Network -> + Ctx -> + DBAccountId -> + TxInfo -> + DB m (DBTxInfo, Bool) +repsertTxInfo net ctx accId tif = do + time <- liftIO getCurrentTime + let confirmed' = Store.confirmed $ txInfoBlockRef tif + tid = txHashToHex $ txInfoHash tif + bRef = S.encode $ txInfoBlockRef tif + -- Confirmations will get updated when retrieving them + blob = BS.toStrict $ marshalJSON (net, ctx) tif {txInfoConfirmations = 0} + (DBAccountKey wallet accDeriv) = accId + key = DBTxInfoKey wallet accDeriv tid + txInfo = + DBTxInfo + { dBTxInfoAccountWallet = wallet, + dBTxInfoAccountDerivation = accDeriv, + dBTxInfoTxid = tid, + dBTxInfoBlockRef = bRef, + dBTxInfoConfirmed = confirmed', + dBTxInfoBlob = blob, + dBTxInfoCreated = time + } + resM <- P.get key + case resM of + Just res -> do + let newTxInfo = + res + { dBTxInfoBlockRef = bRef, + dBTxInfoConfirmed = confirmed', + dBTxInfoBlob = blob + } + P.replace key newTxInfo + return (newTxInfo, res /= newTxInfo) + Nothing -> do + P.insert_ txInfo + return (txInfo, True) + +txsPage :: + (MonadUnliftIO m) => + Ctx -> + DBAccountId -> + Page -> + ExceptT String (DB m) [TxInfo] +txsPage ctx accId@(DBAccountKey wallet accDeriv) (Page lim off) = do + acc <- getAccountById accId + let net = accountNetwork acc + dbTxs <- + lift . select . from $ \t -> do + where_ $ + t ^. DBTxInfoAccountWallet ==. val wallet + &&. t ^. DBTxInfoAccountDerivation ==. val accDeriv + orderBy [asc (t ^. DBTxInfoBlockRef)] + limit $ fromIntegral lim + offset $ fromIntegral off + return $ t ^. DBTxInfoBlob + res <- + forM dbTxs $ \(Value dbTx) -> do + liftEither . maybeToEither "TxInfo unmarshalJSON Failed" $ + unmarshalJSON (net, ctx) $ + BS.fromStrict dbTx + bestM <- lift $ getBest net + return $ updateConfirmations (snd <$> bestM) <$> res + where + updateConfirmations bestM tif = + tif {txInfoConfirmations = getConfirmations bestM (txInfoBlockRef tif)} + +getConfirmations :: Maybe BlockHeight -> Store.BlockRef -> Natural +getConfirmations _ (Store.MemRef _) = 0 +getConfirmations Nothing (Store.BlockRef _ _) = 1 +getConfirmations (Just best) (Store.BlockRef height _) + | best < height = 1 + | otherwise = fromIntegral $ best - height + 1 + +{- Coins -} + +data JsonCoin = JsonCoin + { jsonCoinOutpoint :: !OutPoint, + jsonCoinAddress :: !Address, + jsonCoinValue :: !Word64, + jsonCoinBlock :: !Store.BlockRef, + jsonCoinConfirmations :: !Natural, + jsonCoinLocked :: !Bool + } + deriving (Eq, Show) + +instance MarshalJSON Network JsonCoin where + marshalValue net c = + object + [ "outpoint" .= jsonCoinOutpoint c, + "address" .= marshalValue net (jsonCoinAddress c), + "value" .= jsonCoinValue c, + "block" .= jsonCoinBlock c, + "confirmations" .= jsonCoinConfirmations c, + "locked" .= jsonCoinLocked c + ] + unmarshalValue net = + withObject "JsonCoin" $ \o -> + JsonCoin + <$> o .: "outpoint" + <*> (unmarshalValue net =<< o .: "address") + <*> o .: "value" + <*> o .: "block" + <*> o .: "confirmations" + <*> o .: "locked" + +toJsonCoin :: Network -> Maybe BlockHeight -> DBCoin -> Either String JsonCoin +toJsonCoin net bestM dbCoin = do + op <- textToOutpoint $ dBCoinOutpoint dbCoin + ad <- + maybeToEither "toJsonCoin: Invalid address" $ + textToAddr net $ + dBCoinAddress dbCoin + br <- S.decode $ dBCoinBlockRef dbCoin + let confirmations = getConfirmations bestM br + return $ + JsonCoin + { jsonCoinOutpoint = op, + jsonCoinAddress = ad, + jsonCoinValue = dBCoinValue dbCoin, + jsonCoinBlock = br, + jsonCoinConfirmations = confirmations, + jsonCoinLocked = dBCoinLocked dbCoin + } + +outpointText :: OutPoint -> Text +outpointText = encodeHex . S.encode + +textToOutpoint :: Text -> Either String OutPoint +textToOutpoint t = do + bs <- maybeToEither "textToOutpoint: invalid input" $ decodeHex t + S.decode bs + +-- Get all coins in an account, spendable or not +coinPage :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Page -> + ExceptT String (DB m) [JsonCoin] +coinPage net (DBAccountKey wallet accDeriv) (Page lim off) = do + coins <- + lift . select . from $ \c -> do + where_ $ do + c ^. DBCoinAccountWallet ==. val wallet + &&. c ^. DBCoinAccountDerivation ==. val accDeriv + orderBy [asc (c ^. DBCoinBlockRef), desc (c ^. DBCoinCreated)] + limit $ fromIntegral lim + offset $ fromIntegral off + return c + bestM <- lift $ getBest net + mapM (liftEither . toJsonCoin net (snd <$> bestM) . entityVal) coins + +-- Spendable coins must be confirmed and not locked +getSpendableCoins :: + (MonadUnliftIO m) => DBAccountId -> ExceptT String (DB m) [Store.Unspent] +getSpendableCoins (DBAccountKey wallet accDeriv) = do + coins <- lift . select . from $ \c -> do + where_ $ + c ^. DBCoinAccountWallet ==. val wallet + &&. c ^. DBCoinAccountDerivation ==. val accDeriv + &&. c ^. DBCoinConfirmed ==. val True + &&. c ^. DBCoinLocked ==. val False + return c + let bss = dBCoinBlob . entityVal <$> coins + mapM (liftEither . S.decode) bss + +insertCoin :: + (MonadUnliftIO m) => + DBAccountId -> + Text -> + Store.Unspent -> + DB m DBCoin +insertCoin (DBAccountKey wallet accDeriv) addr unspent = do + time <- liftIO getCurrentTime + let newCoin = + DBCoin + { dBCoinAccountWallet = wallet, + dBCoinAccountDerivation = accDeriv, + dBCoinOutpoint = outpointText unspent.outpoint, + dBCoinAddress = addr, + dBCoinValue = unspent.value, + dBCoinBlockRef = S.encode unspent.block, + dBCoinBlob = S.encode unspent, + dBCoinConfirmed = Store.confirmed unspent.block, + dBCoinLocked = False, + dBCoinCreated = time + } + P.insert_ newCoin + return newCoin + +updateCoin :: (MonadUnliftIO m) => Store.Unspent -> DB m () +updateCoin unspent = do + let key = DBCoinKey $ outpointText unspent.outpoint + P.update + key + [ DBCoinBlob P.=. S.encode unspent, + DBCoinConfirmed P.=. Store.confirmed unspent.block, + DBCoinBlockRef P.=. S.encode unspent.block + ] + +deleteCoin :: (MonadUnliftIO m) => DBCoin -> DB m () +deleteCoin coin = + delete . from $ \c -> + where_ $ + c ^. DBCoinOutpoint ==. val (dBCoinOutpoint coin) + +getCoinsByAddr :: (MonadUnliftIO m) => Text -> DB m [DBCoin] +getCoinsByAddr addr = do + coins <- select . from $ \c -> do + where_ $ c ^. DBCoinAddress ==. val addr + return c + return $ entityVal <$> coins + +-- This is the main coin function +-- Either insert, update or delete coins as required. Returns the number of +-- coins that have either been inserted, updated or deleted. +refreshCoins :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + [Address] -> + [Store.Unspent] -> + ExceptT String (DB m) (Int, [DBCoin]) +refreshCoins net accId addrsToUpdate allUnspent = do + let storeMap = groupCoins net allUnspent + addrsToUpdateE <- + mapM (liftEither . maybeToEither "Addr" . addrToText net) addrsToUpdate + res <- forM addrsToUpdateE $ \addr -> do + let storeCoins = fromMaybe [] $ Map.lookup addr storeMap + localCoins <- lift $ getCoinsByAddr addr + let storeOps = outpointText . (.outpoint) <$> storeCoins + localOps = dBCoinOutpoint <$> localCoins + toDelete = filter ((`notElem` storeOps) . dBCoinOutpoint) localCoins + toInsert = + filter ((`notElem` localOps) . outpointText . (.outpoint)) storeCoins + toUpdate = filter (f localCoins) storeCoins + lift $ forM_ toDelete deleteCoin + lift $ forM_ toUpdate updateCoin + newCoins <- lift $ forM toInsert $ insertCoin accId addr + return (length toDelete + length toUpdate + length toInsert, newCoins) + return (sum $ fst <$> res, concatMap snd res) + where + f localCoins s = + let cM = find ((== outpointText s.outpoint) . dBCoinOutpoint) localCoins + in case cM of + Just c -> dBCoinBlockRef c /= S.encode s.block + _ -> False + +groupCoins :: Network -> [Store.Unspent] -> Map Text [Store.Unspent] +groupCoins net = + Map.fromListWith (<>) . mapMaybe f + where + f x = + case x.address of + Just a -> (,[x]) <$> addrToText net a + _ -> Nothing + +setLockCoin :: (MonadUnliftIO m) => OutPoint -> Bool -> DB m Natural +setLockCoin op locked = do + cnt <- updateCount $ \c -> do + set c [DBCoinLocked =. val locked] + where_ $ + c ^. DBCoinOutpoint ==. val (outpointText op) + &&. c ^. DBCoinLocked ==. val (not locked) + return $ fromIntegral cnt + +{- Raw Transactions -} + +insertRawTx :: (MonadUnliftIO m) => Tx -> DB m () +insertRawTx tx = do + let hash = txHashToHex $ txHash tx + key = DBRawTxKey hash + P.repsert key $ DBRawTx hash (S.encode tx) + +getRawTx :: (MonadUnliftIO m) => TxHash -> ExceptT String (DB m) Tx +getRawTx hash = do + let key = DBRawTxKey $ txHashToHex hash + txM <- lift $ P.get key + case txM of + Just tx -> liftEither . S.decode $ dBRawTxBlob tx + Nothing -> throwError "getRawTx: missing transaction" + +{- Pending Transactions -} + +data TxOnline = TxOnline | TxOffline + deriving (Eq, Show) + +-- Returns (TxSignData, isOnline) +getPendingTx :: (MonadUnliftIO m) => TxHash -> DB m (Maybe (TxSignData, Bool)) +getPendingTx nosigHash = do + let hashT = txHashToHex nosigHash + key = DBPendingTxKey hashT + resM <- P.get key + case resM of + Just (DBPendingTx _ _ _ blob online _) -> do + let tsdM = Json.decode $ BS.fromStrict blob + return $ (,online) <$> tsdM + _ -> return Nothing + +pendingTxPage :: + (MonadUnliftIO m) => + DBAccountId -> + Page -> + ExceptT String (DB m) [(TxHash, TxSignData)] +pendingTxPage (DBAccountKey wallet accDeriv) (Page lim off) = do + tsds <- + lift . select . from $ \p -> do + where_ $ do + p ^. DBPendingTxAccountWallet ==. val wallet + &&. p ^. DBPendingTxAccountDerivation ==. val accDeriv + orderBy [desc (p ^. DBPendingTxCreated)] + limit $ fromIntegral lim + offset $ fromIntegral off + return p + forM tsds $ \(Entity _ res) -> do + tsd <- liftEither . Json.eitherDecode . BS.fromStrict $ dBPendingTxBlob res + nosigHash <- + liftEither $ + maybeToEither "TxHash" $ + hexToTxHash $ + dBPendingTxNosigHash res + return (nosigHash, tsd) + +-- Returns the TxHash and NoSigHash of pending transactions. They are compared +-- during a sync in order to delete pending transactions that are now online. +pendingTxHashes :: + (MonadUnliftIO m) => + DBAccountId -> + ExceptT String (DB m) [(TxHash, DBPendingTxId)] +pendingTxHashes (DBAccountKey wallet accDeriv) = do + blobs <- + lift . select . from $ \p -> do + where_ $ do + p ^. DBPendingTxAccountWallet ==. val wallet + &&. p ^. DBPendingTxAccountDerivation ==. val accDeriv + return (p ^. DBPendingTxBlob, p ^. DBPendingTxId) + res <- forM blobs $ \(Value blob, Value key) -> do + tsd <- liftEither . Json.eitherDecode $ BS.fromStrict blob + if txSignDataSigned tsd + then return [(txHash $ txSignDataTx tsd, key)] + else return [] + return $ concat res + +-- Imports a pending transaction, locks coins and locks internal addresses +importPendingTx :: + (MonadUnliftIO m) => + Network -> + Ctx -> + DBAccountId -> + TxSignData -> + ExceptT String (DB m) TxHash +importPendingTx net ctx accId tsd@(TxSignData tx _ _ _ signed) = do + acc <- getAccountById accId + let pub = accountXPubKey ctx acc + nosigHash = nosigTxHash $ txSignDataTx tsd + bs = BS.toStrict $ Json.encode tsd + prevM <- lift $ getPendingTx nosigHash + case prevM of + Just (TxSignData prevTx _ _ _ prevSigned, online) -> do + when online $ + throwError "The transaction is already online" + when (prevSigned && not signed) $ + throwError "Can not replace a signed transaction with an unsigned one" + when (prevTx == tx) $ + throwError "The transaction already exists" + when (not prevSigned && signed) $ do + let key = DBPendingTxKey $ txHashToHex nosigHash + lift $ P.update key [DBPendingTxBlob P.=. bs] + return nosigHash + Nothing -> do + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let (outpoints, outIntAddrs, restAddrs) = parseTxInfoU txInfoU + -- Verify coins and lock them + forM_ outpoints $ \outpoint -> do + coinM <- lift $ P.get $ DBCoinKey $ outpointText outpoint + case coinM of + Just coin -> do + when (dBCoinLocked coin) $ + throwError "A coin referenced by the transaction is locked" + lift $ setLockCoin outpoint True + _ -> throwError "A coin referenced by the transaction does not exist" + -- Verify addresses and set internal output addresses to busy + outIntAddrsT <- mapM (liftMaybe "Addrs" . addrToText net . fst) outIntAddrs + restAddrsT <- mapM (liftMaybe "Addrs" . addrToText net) restAddrs + outIntAddrsE <- lift . select . from $ \a -> do + where_ $ a ^. DBAddressAddress `in_` valList outIntAddrsT + return a + restAddrsE <- lift . select . from $ \a -> do + where_ $ a ^. DBAddressAddress `in_` valList restAddrsT + return a + when + ( length (outIntAddrsT <> restAddrsT) + /= length (outIntAddrsE <> restAddrsE) + ) + $ throwError "Some referenced addresses do not exist" + unless (all (dBAddressFree . entityVal) outIntAddrsE) $ + throwError "Some of the internal output addresses are not free" + -- Set the output internal addresses to not free + _ <- lift $ setAddrsFree AddrBusy outIntAddrsT + -- Insert the pending transaction + time <- liftIO getCurrentTime + let ptx = + DBPendingTx + (dBAccountWallet acc) + (dBAccountDerivation acc) + (txHashToHex nosigHash) + bs + False + time + lift $ P.insert_ ptx + return nosigHash + +-- (Outpoints, external addrs, internal addrs) +parseTxInfoU :: UnsignedTxInfo -> ([OutPoint], [(Address, KeyIndex)], [Address]) +parseTxInfoU (UnsignedTxInfo _ _ myOps _ myIps _ _ _ _) = + (outpoints, nub $ f <$> outIntAddrs, nub $ fst <$> restAddrs) + where + outpoints = (.outpoint) <$> concatMap myInputsSigInput (Map.elems myIps) + outAddrs = second myOutputsPath <$> Map.assocs myOps + inAddrs = second myInputsPath <$> Map.assocs myIps + (outIntAddrs, outExtAddrs) = partition (isIntPath . snd) outAddrs + restAddrs = outExtAddrs <> inAddrs + f (a, p) = + case pathToList p of + (_ : i : _) -> (a, i) + _ -> error "parseTxInfoU" + +-- Delete a pending transaction, unlocks coins and frees internal addresses +deletePendingTx :: + (MonadUnliftIO m) => + Network -> + Ctx -> + DBAccountId -> + TxHash -> + ExceptT String (DB m) (Natural, Natural) +deletePendingTx net ctx accId nosigHash = do + let key = DBPendingTxKey $ txHashToHex nosigHash + tsdM <- lift $ getPendingTx nosigHash + case tsdM of + Just (_, True) -> do + throwError + "This pending transaction has been sent to the network.\ + \ Run syncacc to refresh your database." + -- We only free coins and addresses if the transaction is offline + Just (tsd, False) -> do + acc <- getAccountById accId + let pub = accountXPubKey ctx acc + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let (outpoints, outIntAddrs, _) = parseTxInfoU txInfoU + outIntAddrsT <- + mapM (liftMaybe "Address" . addrToText net . fst) outIntAddrs + freedCoins <- forM outpoints $ \op -> lift $ setLockCoin op False + freedAddresses <- lift $ setAddrsFree AddrFree outIntAddrsT + lift $ P.delete key + return (sum freedCoins, fromIntegral freedAddresses) + _ -> throwError "The pending transaction does not exist" + +-- When the pending transaction is online, we just delete it +deletePendingTxOnline :: (MonadUnliftIO m) => DBPendingTxId -> DB m () +deletePendingTxOnline = P.delete + +setPendingTxOnline :: (MonadUnliftIO m) => TxHash -> DB m Natural +setPendingTxOnline nosigH = do + let nosigHT = txHashToHex nosigH + cnt <- updateCount $ \p -> do + set p [DBPendingTxOnline =. val True] + where_ $ p ^. DBPendingTxNosigHash ==. val nosigHT + return $ fromIntegral cnt + +{- Helpers -} + +extDeriv :: SoftPath +extDeriv = Deriv :/ 0 + +intDeriv :: SoftPath +intDeriv = Deriv :/ 1 + +isExtPath :: SoftPath -> Bool +isExtPath p = + case pathToList p of + [0, _] -> True + _ -> False + +isIntPath :: SoftPath -> Bool +isIntPath p = + case pathToList p of + [1, _] -> True + _ -> False + +pathIndex :: SoftPath -> KeyIndex +pathIndex p = + case pathToList p of + [_, i] -> i + _ -> error "Invalid pathIndex" + +bip44Deriv :: Network -> Natural -> HardPath +bip44Deriv net a = Deriv :| 44 :| net.bip44Coin :| fromIntegral a + +xPubIndex :: XPubKey -> Natural +xPubIndex = fromIntegral . xPubChild + +addrsDerivPage :: Ctx -> SoftPath -> Page -> XPubKey -> [(Address, SoftPath)] +addrsDerivPage ctx deriv (Page lim off) xpub = + fmap (\(a, _, i) -> (a, deriv :/ i)) addrs + where + addrs = + take (fromIntegral lim) $ + derivePathAddrs ctx xpub deriv (fromIntegral off) + +-- like `maybe` but for a maybe/value sandwich +joinMaybe :: b -> (a -> b) -> Maybe (E.Value (Maybe a)) -> b +joinMaybe d f m = + case m of + Just (Value m') -> maybe d f m' + Nothing -> d + +flatMaybe :: Maybe (E.Value (Maybe a)) -> Maybe a +flatMaybe = joinMaybe Nothing Just diff --git a/src/Network/Haskoin/Wallet/Entropy.hs b/src/Haskoin/Wallet/Entropy.hs similarity index 95% rename from src/Network/Haskoin/Wallet/Entropy.hs rename to src/Haskoin/Wallet/Entropy.hs index f7eb9cae..e6a6ddff 100644 --- a/src/Network/Haskoin/Wallet/Entropy.hs +++ b/src/Haskoin/Wallet/Entropy.hs @@ -2,24 +2,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module Network.Haskoin.Wallet.Entropy where +module Haskoin.Wallet.Entropy where +import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad (replicateM, unless, when) import Control.Monad.Except - ( ExceptT, - MonadError (throwError), - liftEither, - ) -import Control.Monad.IO.Class (liftIO) import Data.Bits (Bits (setBit, xor)) import qualified Data.ByteString as BS import Data.List (foldl', nub) import Data.Text (Text) -import qualified Data.Text as T import Data.Word (Word8) import Haskoin.Crypto (Mnemonic, toMnemonic, fromMnemonic) import Haskoin.Util (bsToInteger) -import Network.Haskoin.Wallet.Util (chunksOf) +import Haskoin.Wallet.Util (chunksOf) import Numeric (showIntAtBase) import Numeric.Natural (Natural) import qualified System.Console.Haskeline as Haskeline @@ -135,7 +130,7 @@ splitEntropy n secret splitEntropyWith :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString] splitEntropyWith secret ks = foldl' xorBytes secret ks : ks -mergeMnemonicParts :: [T.Text] -> Either String Mnemonic +mergeMnemonicParts :: [Text] -> Either String Mnemonic mergeMnemonicParts mnems | length mnems < 2 = Left "Only one mnemonic provided" | length (nub mnems) /= length mnems = Left "Two mnemonics are identical" @@ -183,10 +178,11 @@ getDiceEntropy ent = do -- Generate a mnemonic with optional dice entropy and key splitting genMnemonic :: + (MonadIO m) => Natural -> Bool -> Natural -> - ExceptT String IO (Text, Mnemonic, [Mnemonic]) + ExceptT String m (Text, Mnemonic, [Mnemonic]) genMnemonic reqEnt reqDice splitIn | splitIn == 0 = throwError "Invalid split option" | reqEnt `elem` [16, 20 .. 32] = do diff --git a/src/Haskoin/Wallet/FileIO.hs b/src/Haskoin/Wallet/FileIO.hs new file mode 100644 index 00000000..79dabeb5 --- /dev/null +++ b/src/Haskoin/Wallet/FileIO.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.FileIO where + +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..)) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Char8 as C8 +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Haskoin +import Haskoin.Wallet.Util +import qualified System.Directory as D +import qualified System.IO as IO + +data PubKeyDoc = PubKeyDoc + { documentPubKey :: !XPubKey, + documentNetwork :: !Network, + documentName :: !Text, + documentWallet :: !Fingerprint + } + deriving (Eq, Show) + +instance MarshalJSON Ctx PubKeyDoc where + unmarshalValue ctx = + withObject "pubkeydocument" $ \o -> do + net <- maybe mzero return . netByName =<< o .: "network" + PubKeyDoc + <$> (unmarshalValue (net, ctx) =<< o .: "xpubkey") + <*> return net + <*> (o .: "name") + <*> (o .: "wallet") + + marshalValue ctx (PubKeyDoc k net name wallet) = + object + [ "xpubkey" .= marshalValue (net, ctx) k, + "network" .= net.name, + "name" .= name, + "wallet" .= wallet + ] + +data TxSignData = TxSignData + { txSignDataTx :: !Tx, + txSignDataInputs :: ![Tx], + txSignDataInputPaths :: ![SoftPath], + txSignDataOutputPaths :: ![SoftPath], + txSignDataSigned :: !Bool + } + deriving (Eq, Show) + +instance FromJSON TxSignData where + parseJSON = + withObject "txsigndata" $ \o -> do + let f = eitherToMaybe . S.decode <=< decodeHex + t <- maybe mzero return . f =<< o .: "tx" + i <- maybe mzero return . mapM f =<< o .: "txinputs" + TxSignData t i + <$> o .: "inputpaths" + <*> o .: "outputpaths" + <*> o .: "signed" + +instance ToJSON TxSignData where + toJSON (TxSignData t i oi op s) = + object + [ "tx" .= encodeHex (S.encode t), + "txinputs" .= (encodeHex . S.encode <$> i), + "inputpaths" .= oi, + "outputpaths" .= op, + "signed" .= s + ] + +instance MarshalJSON Ctx TxSignData where + marshalValue _ = toJSON + unmarshalValue _ = parseJSON + +checkPathFree :: (MonadIO m) => FilePath -> ExceptT String m () +checkPathFree path = do + exist <- liftIO $ D.doesPathExist path + when exist $ throwError $ "Path '" <> path <> "' already exists" + +-- JSON IO Helpers-- + +writeJsonFile :: FilePath -> Value -> IO () +writeJsonFile filePath doc = C8.writeFile filePath $ encodeJsonPrettyLn doc + +readJsonFile :: (FromJSON a) => FilePath -> IO (Either String a) +readJsonFile = eitherDecodeFileStrict' + +writeMarshalFile :: (MarshalJSON s a) => s -> FilePath -> a -> IO () +writeMarshalFile s filePath a = writeJsonFile filePath $ marshalValue s a + +readMarshalFile :: (MarshalJSON s a) => s -> FilePath -> IO (Either String a) +readMarshalFile s filePath = do + vE <- readJsonFile filePath + return $ parseEither (unmarshalValue s) =<< vE + +-- Parse wallet dump files for sweeping -- + +readFileWords :: FilePath -> IO [[Text]] +readFileWords fp = do + strContents <- IO.readFile fp + return $ removeComments $ Text.words <$> Text.lines (cs strContents) + +parseAddrsFile :: Network -> [[Text]] -> [Address] +parseAddrsFile net = + withParser $ \w -> eitherToMaybe $ textToAddrE net $ strip "addr=" w + where + strip p w = fromMaybe w $ Text.stripPrefix p w + +parseSecKeysFile :: Network -> [[Text]] -> [SecKey] +parseSecKeysFile net = + withParser $ \w -> (.key) <$> (fromWif net w <|> fromMiniKey (cs w)) + +withParser :: (Text -> Maybe a) -> [[Text]] -> [a] +withParser parser = + mapMaybe go + where + go [] = Nothing + go (w : ws) = parser w <|> go ws + +removeComments :: [[Text]] -> [[Text]] +removeComments = + mapMaybe go + where + go [] = Nothing + go ws@(w : _) + | "#" `Text.isPrefixOf` w = Nothing + | otherwise = Just ws diff --git a/src/Haskoin/Wallet/Main.hs b/src/Haskoin/Wallet/Main.hs new file mode 100644 index 00000000..f71179e9 --- /dev/null +++ b/src/Haskoin/Wallet/Main.hs @@ -0,0 +1,19 @@ +module Haskoin.Wallet.Main where + +import qualified Data.ByteString.Char8 as C8 +import Haskoin (Ctx, MarshalJSON (..), withContext) +import Haskoin.Wallet.Commands (Response, commandResponse) +import Haskoin.Wallet.Config (initConfig) +import Haskoin.Wallet.Parser (parserMain) +import Haskoin.Wallet.Util (encodeJsonPretty) + +clientMain :: IO () +clientMain = + withContext $ \ctx -> do + cfg <- initConfig + cmd <- parserMain + res <- commandResponse ctx cfg cmd + jsonPrinter ctx res + +jsonPrinter :: Ctx -> Response -> IO () +jsonPrinter ctx = C8.putStrLn . encodeJsonPretty . marshalValue ctx diff --git a/src/Haskoin/Wallet/Parser.hs b/src/Haskoin/Wallet/Parser.hs new file mode 100644 index 00000000..a693bd05 --- /dev/null +++ b/src/Haskoin/Wallet/Parser.hs @@ -0,0 +1,985 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Haskoin.Wallet.Parser where + +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin +import Haskoin.Wallet.Amounts (AmountUnit (..), readNatural) +import Haskoin.Wallet.Util (Page (Page)) +import Numeric.Natural (Natural) +import Options.Applicative +import Options.Applicative.Help.Pretty +import Text.RawString.QQ (r) + +{- Command Parsers -} + +data Command + = CommandMnemonic + { commandEntropy :: !Natural, + commandUseDice :: !Bool, + commandSplitIn :: !Natural + } + | CommandCreateAcc + { commandName :: !Text, + commandNetwork :: !Network, + commandDerivation :: !(Maybe Natural), + commandSplitIn :: !Natural + } + | CommandTestAcc + { commandMaybeAcc :: !(Maybe Text), + commandSplitIn :: !Natural + } + | CommandImportAcc + { commandFilePath :: !FilePath + } + | CommandExportAcc + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandRenameAcc + { commandOldName :: !Text, + commandNewName :: !Text + } + | CommandAccounts + { commandMaybeAcc :: !(Maybe Text) + } + | CommandReceive + { commandMaybeAcc :: !(Maybe Text), + commandMaybeLabel :: !(Maybe Text) + } + | CommandAddrs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandLabel + { commandMaybeAcc :: !(Maybe Text), + commandAddrIndex :: !Natural, + commandLabel :: !Text + } + | CommandTxs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandPrepareTx + { commandRecipients :: ![(Text, Text)], + commandMaybeAcc :: !(Maybe Text), + commandUnit :: !AmountUnit, + commandFeeByte :: !Natural, + commandDust :: !Natural, + commandRcptPay :: !Bool, + commandOutputFileMaybe :: !(Maybe FilePath) + } + | CommandPendingTxs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandReviewTx + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandImportTx + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandExportTx + { commandNoSigHash :: !TxHash, + commandFilePath :: !FilePath + } + | CommandDeleteTx + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHash :: !TxHash + } + | CommandSignTx + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHashMaybe :: !(Maybe TxHash), + commandInputFileMaybe :: !(Maybe FilePath), + commandOutputFileMaybe :: !(Maybe FilePath), + commandSplitIn :: !Natural + } + | CommandCoins + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandSendTx + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHash :: !TxHash + } + | CommandSyncAcc + { commandMaybeAcc :: !(Maybe Text), + commandFull :: !Bool + } + | CommandDiscoverAcc + { commandMaybeAcc :: !(Maybe Text) + } + | CommandVersion + | CommandPrepareSweep + { commandMaybeAcc :: !(Maybe Text), + commandSweepFrom :: ![Text], + commandSweepFileMaybe :: !(Maybe FilePath), + commandSweepTo :: ![Text], + commandOutputFileMaybe :: !(Maybe FilePath), + commandFeeByte :: !Natural, + commandDust :: !Natural + } + | CommandSignSweep + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHashMaybe :: !(Maybe TxHash), + commandInputFileMaybe :: !(Maybe FilePath), + commandOutputFileMaybe :: !(Maybe FilePath), + commandSecKeyPath :: !FilePath + } + | CommandRollDice + { commandCount :: !Natural + } + deriving (Eq, Show) + +parserMain :: IO Command +parserMain = + customExecParser + (prefs $ showHelpOnEmpty <> helpIndent 25) + programParser + +programParser :: ParserInfo Command +programParser = do + let cmd = commandParser <**> helper + info cmd $ + fullDesc + <> progDesc + [r| +hw is a BIP-44 command-line wallet for bitcoin and bitcoin-cash. It allows +sensitive commands (!) to be run on a separate offline computer. For more +information on a command, type "hw COMMAND --help". +|] + +commandParser :: Parser Command +commandParser = + asum + [ hsubparser $ + mconcat + [ commandGroup "Mnemonic and account management", + command "mnemonic" mnemonicParser, + command "createacc" createAccParser, + command "testacc" testAccParser, + command "renameacc" renameAccParser, + command "accounts" accountsParser, + metavar "COMMAND", + style (const "COMMAND --help") + ], + hsubparser $ + mconcat + [ commandGroup "Address management", + command "receive" receiveParser, + command "addrs" addrsParser, + command "label" labelParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Transaction management", + command "txs" txsParser, + command "preparetx" prepareTxParser, + command "pendingtxs" pendingTxsParser, + command "signtx" signTxParser, + command "deletetx" deleteTxParser, + command "coins" coinsParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Import/export commands", + command "exportacc" exportAccParser, + command "importacc" importAccParser, + command "reviewtx" reviewTxParser, + command "exporttx" exportTxParser, + command "importtx" importTxParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Network commands", + command "sendtx" sendTxParser, + command "syncacc" syncAccParser, + command "discoveracc" discoverAccParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Utilities", + command "version" versionParser, + command "preparesweep" prepareSweepParser, + command "signsweep" signSweepParser, + command "rolldice" rollDiceParser, + hidden + ] + ] + +offline :: Doc -> Maybe Doc +offline s = Just $ annotate (color Red) "! " <> s + +{- Mnemonic Parser -} + +mnemonicParser :: ParserInfo Command +mnemonicParser = do + let cmd = + CommandMnemonic + <$> entropyOption + <*> diceOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Generate a mnemonic") + <> footer + [r| +Generate a mnemonic using the systems entropy pool. By default it should be +/dev/random on linux machines. If you use the --dice option, the additional dice +entropy will be mixed with the system entropy. You should ideally run this +command on an offline (air-gapped) computer. The mnemonic will NOT be stored on +disk. It will only be printed to the screen and you should write it down and +keep it in a secure location. Make multiple copies of your mnemonic. Do not +store your mnemonic on a digital medium. If you lose your mnemonic, you lose +your funds. If you choose to use the --split option, the mnemonic will be split +into different pieces such that ALL the pieces will be required for signing. +|] + +entropyOption :: Parser Natural +entropyOption = + option (maybeReader f) $ + short 'e' + <> long "entropy" + <> metavar "BYTES" + <> value 16 + <> showDefault + <> completeWith valid + <> help + [r| +Amount of entropy to use in bytes. Valid values are 16, 20, 24, 28 or 32. +|] + where + valid = ["16", "20", "24", "28", "32"] + f s + | s `elem` valid = fromIntegral <$> readNatural (cs s) + | otherwise = Nothing + +diceOption :: Parser Bool +diceOption = + switch $ + short 'd' + <> long "dice" + <> help + [r| +Provide additional entropy using 6-sided dice. The entropy will be mixed with +the system entropy. +|] + +splitInOption :: Parser Natural +splitInOption = + option (eitherReader $ f . cs) $ + short 's' + <> long "split" + <> metavar "INT" + <> value 1 + <> help + [r| +The mnemonic is split in different pieces and reconstructed using bitwise xor. +All the pieces are required for signing. The ordering of the pieces is not +important. +|] + where + f s = + case readNatural s of + Just n -> + if n >= 2 && n <= 12 + then Right n + else Left "The --split value has to be between 2 and 12" + Nothing -> Left "Could not parse the --split option" + +{- CreateAcc Parser -} + +createAccParser :: ParserInfo Command +createAccParser = do + let cmd = + CommandCreateAcc + <$> textArg "Name of the new account" + <*> networkOption + <*> derivationOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Create a new account") + <> footer + [r| +An account corresponds to the BIP-32 extended key derivation +m/44'/coin'/account'. For example, the bitcoin account 0 would be m/44'/0'/0'. +An account is tied to a private key and thus to a mnemonic. The derived account +m/44'/0'/0' would be different given two different mnemonics. To help manage +your accounts in hw, they are identified by a name. The command `createacc` will +ask for a mnemonic and save the derived public key M/44'/coin'/account' on disk. +The private keys are never stored anywhere while using hw. If you are using an +offline computer, you can then export your account and import it on an online +computer. +|] + +networkOption :: Parser Network +networkOption = + option (eitherReader (f . netByName)) $ + short 'n' + <> long "network" + <> metavar "TEXT" + <> value btc + <> showDefaultWith (.name) + <> completeWith ((.name) <$> allNets) + <> help ("Specify one of the following networks to use: " <> nets) + where + nets = intercalate ", " ((.name) <$> allNets) + f :: Maybe Network -> Either String Network + f Nothing = + Left $ "Invalid network name. Select one of the following: " <> nets + f (Just res) = Right res + +derivationOption :: Parser (Maybe Natural) +derivationOption = + optional . option (maybeReader $ readNatural . cs) $ + short 'd' + <> long "derivation" + <> metavar "INT" + <> help + [r| +Specify a different account derivation to use (the last part of +m/44'/coin'/account'). By default, account derivations are chosen sequentially +starting from 0. +|] + +{- TestAcc Parser -} + +testAccParser :: ParserInfo Command +testAccParser = do + let cmd = + CommandTestAcc + <$> accountOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Check the validity of your mnemonic/passphrase") + <> footer + [r| +`testacc` will prompt for your mnemonic/passphrase and check that the derived +public key M/44'/coin'/account' matches with the account stored on disk. +|] + +accountOption :: Parser (Maybe Text) +accountOption = + optional . strOption $ + short 'a' + <> long "account" + <> metavar "TEXT" + <> completer (mkCompleter accountCompleter) + <> help + [r| +Specify the account name if the wallet has more than one account. +|] + +{- ImportAcc Parser -} + +importAccParser :: ParserInfo Command +importAccParser = do + let cmd = + CommandImportAcc + <$> fileArgument "Path to the account file" + info cmd $ + progDesc "Import an account file" + <> footer importExportAccFooter + +importExportAccFooter :: String +importExportAccFooter = + [r| +When working in an online/offline environment, you can `importacc` a public key +file (on an online computer) that was exported with `exportacc` (on an offline +computer). This will allow the online computer to monitor transactions without +requiring access to the private keys. The file contains the public key +derivation M/44'/coin'/account' along with the account name, the network and a +wallet identifier. The wallet identifier is a fingerprint of the first public +account derivation M/44'/coin'/0'. +|] + +{- ExportAcc Parser -} + +exportAccParser :: ParserInfo Command +exportAccParser = do + let cmd = + CommandExportAcc + <$> accountOption + <*> fileArgument "File where the account data will be saved" + info cmd $ + progDesc "Export account data to a file" + <> footer importExportAccFooter + +{- RenameAcc Parser -} + +renameAccParser :: ParserInfo Command +renameAccParser = do + let cmd = + CommandRenameAcc + <$> accountArg "Old account name" + <*> textArg "New account name" + info cmd $ progDesc "Rename an account" + +accountArg :: String -> Parser Text +accountArg desc = + argument str $ + metavar "TEXT" + <> completer (mkCompleter accountCompleter) + <> help desc + +accountCompleter :: String -> IO [String] +accountCompleter _ = return [] + +{- TODO: Fix this +accountCompleter :: String -> IO [String] +accountCompleter pref = do + names <- runDB getAccountNames + return $ sort $ nub $ filter (pref `isPrefixOf`) (cs <$> names) +-} + +{- Accounts Parser -} + +accountsParser :: ParserInfo Command +accountsParser = do + let cmd = CommandAccounts <$> accountOption + info cmd $ progDesc "Display account information" + +{- Receive Parser -} + +receiveParser :: ParserInfo Command +receiveParser = do + let cmd = + CommandReceive <$> accountOption <*> labelOption + info cmd $ + progDesc "Get a new address for receiving a payment" + <> footer + [r| +There are two types of addresses in a BIP-44 wallet: internal and external addresses. +Internal addresses are not exposed to the user and are managed internally by the +wallet (mostly for producing change outputs in transactions). The `receive` command +produces external addresses that are meant for receiving payments. Internal addresses +are derived under the BIP-32 path M/44'/coin'/account'/1/address. External addresses +use the path M/44'/coin'/account'/0/address. +|] + +labelOption :: Parser (Maybe Text) +labelOption = + optional . strOption $ + short 'l' + <> long "label" + <> metavar "TEXT" + <> help "Specify a label for the address" + +{- Addrs Parser -} + +addrsParser :: ParserInfo Command +addrsParser = do + let cmd = + CommandAddrs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "List the receiving addresses of an account" + +offsetOption :: Parser Natural +offsetOption = + option (maybeReader $ readNatural . cs) $ + short 'o' + <> long "offset" + <> metavar "INT" + <> value 0 + <> showDefault + <> help "Offset the result set" + +limitOption :: Parser Natural +limitOption = + option (maybeReader $ readNatural . cs) $ + short 'l' + <> long "limit" + <> metavar "INT" + <> value 5 + <> showDefault + <> help + [r| +Limit the result set. If the result set is very large, you can specify the +--limit and --offset options to view the required data. For example, to skip the +first 20 values and then display the following 10, use --limit=10 and +--offset=20. +|] + +{- Label Parser-} + +labelParser :: ParserInfo Command +labelParser = do + let cmd = + CommandLabel + <$> accountOption + <*> addrIndexArg + <*> textArg "The new label for the address" + info cmd $ progDesc "Set the label of an address" + +addrIndexArg :: Parser Natural +addrIndexArg = + argument (maybeReader $ readNatural . cs) $ + metavar "INT" + <> help + [r| +The index of the external address to update. The first address has an index of +0. +|] + +{- Txs Parser -} + +txsParser :: ParserInfo Command +txsParser = do + let cmd = + CommandTxs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ progDesc "Display the transactions of an account" + +{- PrepareTx Parser -} + +prepareTxParser :: ParserInfo Command +prepareTxParser = do + let cmd = + CommandPrepareTx + <$> some recipientArg + <*> accountOption + <*> unitOption + <*> feeOption + <*> dustOption + <*> rcptPayOption + <*> outputFileMaybeOption + info cmd $ + progDesc "Prepare an unsigned transaction for making a payment" + <> footer + [r| +In hw, sending a transaction happens in separate steps. First, an unsigned +transaction is prepared using `preparetx`. No mnemonic or private keys are +required for this step and `preparetx` can be run on an online computer. The new +transaction will be stored in the local wallet database as a "pending" +transaction but it can also be exported as a file using the --output option. The +pending transactions can be inspected either with `reviewtx` or `pendingtxs`. +The new transaction is not signed. The next step will be to sign it. Any coins +spent by it will be locked to prevent spending them twice. If you change your +mind about sending this transaction, you can call `deletetx` to remove it and +free up the locked coins. All the pending transactions are referenced by their +noSigHash (a hash of the transaction without its signatures). +|] + +recipientArg :: Parser (Text, Text) +recipientArg = (,) <$> addressArg <*> amountArg + +addressArg :: Parser Text +addressArg = + strArgument $ + metavar "ADDRESS" + <> help + [r| +Recipient address. By can provide multiple "ADDRESS AMOUNT" pairs. +|] + +amountArg :: Parser Text +amountArg = + strArgument $ + metavar "AMOUNT" + <> help + [r| +Recipient amount. By default, amounts are parsed as bitcoins. You can also use the +--satoshi or --bit option to specify amounts in satoshis or bits. For example, +"0.00001" bitcoins is equivalent to "10.00" bits or "1000" satoshi. Bitcoins can +have up to 8 decimal places, bits up to 2 and satoshi are whole numbers. +|] + +feeOption :: Parser Natural +feeOption = + option (maybeReader $ readNatural . cs) $ + short 'f' + <> long "fee" + <> metavar "INT" + <> value 200 + <> showDefault + <> help "Fee to pay in satoshi/bytes" + +dustOption :: Parser Natural +dustOption = + option (maybeReader $ readNatural . cs) $ + short 'd' + <> long "dust" + <> metavar "INT" + <> value 5430 + <> showDefault + <> help "Amount (in satoshi) below which an output is considered dust" + +unitOption :: Parser AmountUnit +unitOption = satoshiOption <|> bitOption + +satoshiOption :: Parser AmountUnit +satoshiOption = + flag UnitBitcoin UnitSatoshi $ + short 's' + <> long "satoshi" + <> help "Use satoshis for parsing amounts (default: bitcoin)" + +bitOption :: Parser AmountUnit +bitOption = + flag UnitBitcoin UnitBit $ + short 'b' + <> long "bit" + <> help "Use bits for parsing amounts (default: bitcoin)" + +rcptPayOption :: Parser Bool +rcptPayOption = + switch $ + short 'r' + <> long "recipientpay" + <> showDefault + <> help "The transaction fee will be deducted from the recipient amounts" + +outputFileMaybeOption :: Parser (Maybe FilePath) +outputFileMaybeOption = + optional . strOption $ + short 'o' + <> long "output" + <> metavar "FILENAME" + <> action "file" + <> help "Write the result to this file" + +{- PendingTxs Parser -} + +pendingTxsParser :: ParserInfo Command +pendingTxsParser = do + let cmd = + CommandPendingTxs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "Display the pending transactions of an account" + <> footer + [r| +Pending transactions have been created with the `preparetx` command. They are +either unsigned and waiting to be signed, or signed and waiting to be sent to +the network. +|] + +{- ReviewTx Parser -} + +reviewTxParser :: ParserInfo Command +reviewTxParser = do + let cmd = + CommandReviewTx + <$> accountOption + <*> fileArgument "Path to the transaction file to review" + info cmd $ + progDesc "Review a transaction file" + <> footer + [r| +Review a pending transaction file that has been created with the --output option +of the `preparetx` command or the `exporttx` command. You can review a +transaction file this way before signing it on an offline computer for example. +|] + +{- ExportTx Parser -} + +exportTxParser :: ParserInfo Command +exportTxParser = do + let cmd = + CommandExportTx + <$> nosigHashArg + <*> fileArgument "File where the transaction data will be saved" + info cmd $ + progDesc "Export pending transaction data to a file" + <> footer importExportTxFooter + +importExportTxFooter :: String +importExportTxFooter = + [r| +A transaction that has been prepared with `preparetx` can be exported to a file +so that it can be signed on an offline computer. The transaction is identified +by its nosigHash (a hash of the transaction without its signatures) as this +identifier doesn't change when the transaction is unsigned or signed. Once +signed, you can `importtx` the transaction back into the computer that +prepared the transaction. +|] + +nosigHashArg :: Parser TxHash +nosigHashArg = + argument (maybeReader $ hexToTxHash . cs) $ + metavar "NOSIGHASH" + <> help "The nosigHash of the transaction" + +{- ImportTx Parser -} + +importTxParser :: ParserInfo Command +importTxParser = do + let cmd = + CommandImportTx + <$> accountOption + <*> fileArgument "Path to the transaction file to import" + info cmd $ + progDesc "Import a pending transaction" + <> footer importExportTxFooter + +{- DeleteTx Parser -} + +deleteTxParser :: ParserInfo Command +deleteTxParser = do + let cmd = + CommandDeleteTx + <$> accountOption + <*> nosigHashArg + info cmd $ + progDesc "Delete a pending transaction" + <> footer + [r| +A transaction that has been prepared with `preparetx` will lock the coins that +it has spent to prevent double-spending them. A pending transaction can be +deleted with `deletetx` to permanently remove it from the database. This will +also free any coins that have been locked by it. This will only be possible as +long as the transaction hasn't been signed and sent to the network. +|] + +{- SignTx Parser -} + +signTxParser :: ParserInfo Command +signTxParser = do + let cmd = + CommandSignTx + <$> accountOption + <*> optional nosigHashArg + <*> inputFileMaybeOption + <*> outputFileMaybeOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Sign a transaction") + <> footer + [r| +The next step after preparing a transaction is to sign it. This step can happen +on an offline computer if you export the unsigned transaction to a file. If the +transaction is stored in the wallet, it can be signed by using its nosigHash. +This will sign and replace the transaction in-place. Otherwise, you must specify +the --input file of the unsigned transaction and the --output file where the +signed transaction will be saved. The transaction still hasn't been uploaded to +the network. You may inspect it using either the `reviewtx` or the `pendingtxs` +command. The transaction can then be sent to the network with `sendtx` or +deleted with `deletetx`. +|] + +inputFileMaybeOption :: Parser (Maybe FilePath) +inputFileMaybeOption = + optional . strOption $ + short 'i' + <> long "input" + <> metavar "FILENAME" + <> action "file" + <> help "Read the input from this file" + +{- Coins Parser -} + +coinsParser :: ParserInfo Command +coinsParser = do + let cmd = + CommandCoins + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "List the account coins (unspent outputs)" + <> footer + [r| +These are all the coins in the account. Coins can be locked when preparing new +transactions. When sending those transactions to the network, the locked coins +will be spent and removed. Calling `deletetx` will remove a pending transaction +and free up any locked coins. +|] + +{- SendTx Parser -} + +sendTxParser :: ParserInfo Command +sendTxParser = do + let cmd = + CommandSendTx + <$> accountOption + <*> nosigHashArg + info cmd $ + progDesc "Send (upload) a signed transaction to the network" + <> footer + [r| +Once a transaction is signed, it can be sent to the network. This step is +irreversible and the transaction will become effective. Make sure everything is +correct with your transaction before sending it. You must `importtx` the +transaction before sending it if you have it in a file. +|] + +{- SyncAcc Parser -} + +syncAccParser :: ParserInfo Command +syncAccParser = do + let cmd = CommandSyncAcc <$> accountOption <*> fullOption + info cmd $ + progDesc "Download account data from the network" + <> footer + [r| +The `syncacc` command will download the latest address balances, transactions +and coins from the network. It will also update the account balances. +|] + +fullOption :: Parser Bool +fullOption = + switch $ + long "full" + <> showDefault + <> help + [r| +Force the syncacc command to re-download all the account data instead of only +the deltas (the data that has changed). This should normally not be required +unless some information is wrong, for example, when a previous syncacc was +called on a partially discovered account (the account was missing some +addresses). +|] + +{- DiscoverAcc Parser -} + +discoverAccParser :: ParserInfo Command +discoverAccParser = do + let cmd = CommandDiscoverAcc <$> accountOption + info cmd $ + progDesc "Scan the blockchain to generate missing addresses" + <> footer + [r| +`discoveracc` is typically called when restoring an account in a new wallet. +Initially, there will be no addresses stored in the account. `discoveracc` will +scan the blockchain and generate all the addresses (both external and internal) +that have received coins at some point. The search is stopped when a gap +(default = 20) of empty addresses is found. A full sync (syncacc --full) is +run automatically at the end of the `discoveracc` command. When restoring an +old wallet, it is important to discover it first before generating addresses +and receiving payments. Otherwise some addresses might be reused. +|] + +{- Version Parser -} + +versionParser :: ParserInfo Command +versionParser = do + let cmd = pure CommandVersion + info cmd $ progDesc "Display the version of hw" + +{- PrepareSweep Parser -} + +prepareSweepParser :: ParserInfo Command +prepareSweepParser = do + let cmd = + CommandPrepareSweep + <$> accountOption + <*> many sweepFromOption -- many: not optional + <*> addressFileOption + <*> some sweepToOption -- some: optional + <*> outputFileMaybeOption + <*> feeOption + <*> dustOption + info cmd $ + progDesc "Prepare a transaction to sweep funds" + <> footer + [r| +`preparesweep` will prepare a transaction that sweeps the funds available in the +given --sweepfrom addresses and sends them to the --sweepto addresses. The +typical use case for this command is to migrate an old wallet to a new mnemonic. +The addresses can also be parsed from a --addrfile. The best way to pass +multiple addresses on the command line is with the shorthand -s ADDR1 -s ADDR2 +for --sweepfrom addresses and -t ADDR1 -t ADDR2 for --sweepto addresses. You +can generate addresses to sweep to with the `receive` command. +|] + +sweepFromOption :: Parser Text +sweepFromOption = + strOption $ + short 's' + <> long "sweepfrom" + <> metavar "ADDRESS" + <> help "Addresses to sweep from" + +addressFileOption :: Parser (Maybe FilePath) +addressFileOption = + optional . strOption $ + long "addrfile" + <> metavar "FILENAME" + <> action "file" + <> help "File containing addresses to sweep from" + +sweepToOption :: Parser Text +sweepToOption = + strOption $ + short 't' + <> long "sweepto" + <> metavar "ADDRESS" + <> help "Addresses to sweep to" + +{- SignSweep Parser -} + +signSweepParser :: ParserInfo Command +signSweepParser = do + let cmd = + CommandSignSweep + <$> accountOption + <*> optional nosigHashArg + <*> inputFileMaybeOption + <*> outputFileMaybeOption + <*> prvKeyFileOption + info cmd $ + progDesc "Sign a sweep transaction" + <> footer + [r| +Sign a transaction that was prepared with the `preparesweep` command. As the +coins of this transaction are not from this wallet, the private keys for signing +must be passed in a separate --prvkeys file. The sweep transaction can be +referenced by its nosigHash if it exists in the wallet or you can pass it as a +file --input. +|] + +prvKeyFileOption :: Parser FilePath +prvKeyFileOption = + strOption $ + short 'k' + <> long "prvkeys" + <> metavar "FILENAME" + <> action "file" + <> help "File containing the private keys in WIF or MiniKey format" + +{- RollDice Parser -} + +rollDiceParser :: ParserInfo Command +rollDiceParser = do + let cmd = CommandRollDice <$> diceCountArg + info cmd $ + progDesc "Roll 6-sided dice using the systems internal entropy" + <> footer + [r| +By default, /dev/random is used on linux machines. The mapping from a byte to +dice rolls ensures that all dice rolls have the same probability of occuring. +Bytes 0x00 to 0xfb are used and anything above is dropped. +|] + +diceCountArg :: Parser Natural +diceCountArg = + argument (maybeReader $ readNatural . cs) $ + metavar "INT" + <> help "Number of 6-sided dice to roll" + +{- Argument parser helpers -} + +textArg :: String -> Parser Text +textArg desc = + argument str $ + metavar "TEXT" + <> help desc + +fileArgument :: String -> Parser FilePath +fileArgument desc = + strArgument $ + metavar "FILENAME" + <> action "file" + <> help desc diff --git a/src/Haskoin/Wallet/Signing.hs b/src/Haskoin/Wallet/Signing.hs new file mode 100644 index 00000000..6d8c05f4 --- /dev/null +++ b/src/Haskoin/Wallet/Signing.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.Signing where + +import Conduit (MonadUnliftIO) +import Control.Arrow (second) +import Control.Monad (unless, when, (<=<)) +import Control.Monad.Except +import Control.Monad.State +import qualified Data.ByteString as BS +import Data.Default (def) +import Data.Either (rights) +import Data.List (nub) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Word (Word64) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import System.Random (Random (randomR), StdGen, initStdGen) + +{- Building Transactions -} + +buildTxSignData :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Config -> + StdGen -> + DBAccountId -> + [(Address, Natural)] -> + Natural -> + Natural -> + Bool -> + ExceptT String (DB m) TxSignData +buildTxSignData net ctx cfg gen accId rcpts feeByte dust rcptPay + | null rcpts = throwError "No recipients provided" + | otherwise = do + -- Get all spendable coins in the account + allCoins <- getSpendableCoins accId + -- Get a change address + dbAddr <- nextFreeIntAddr ctx cfg accId + (change, changeDeriv) <- liftEither $ fromDBAddr net dbAddr + -- Build a transaction and pick the coins + (tx, pickedCoins) <- + liftEither $ + buildWalletTx net ctx gen rcpts change allCoins feeByte dust rcptPay + -- Get the derivations of our recipients and picked coins + rcptsDerivsE <- mapM (lift . getAddrDeriv net accId) $ fst <$> rcpts + let rcptsDerivs = rights rcptsDerivsE -- It's OK to fail here + inDerivs <- mapM (liftEither <=< lift . getCoinDeriv net accId) pickedCoins + -- Check if we have a change output + let noChange = length tx.outputs == length rcpts + outDerivs = + if noChange + then rcptsDerivs + else changeDeriv : rcptsDerivs + -- Get the dependent transactions + let depTxHash = (.hash) . (.outpoint) <$> tx.inputs + depTxs <- mapM getRawTx depTxHash + -- Return the result + return $ TxSignData tx depTxs (nub inDerivs) (nub outDerivs) False + +buildWalletTx :: + Network -> + Ctx -> + StdGen -> -- Randomness for coin selection and change address order + [(Address, Natural)] -> -- recipients + Address -> -- change + [Store.Unspent] -> -- Coins to choose from + Natural -> -- Fee per byte + Natural -> -- Dust + Bool -> -- Recipients Pay for Fee + Either String (Tx, [Store.Unspent]) +buildWalletTx net ctx gen rcptsN change coins feeByteN dustN rcptPay = + flip evalStateT gen $ do + rdmCoins <- randomShuffle coins + (pickedCoins, changeAmnt) <- + lift $ chooseCoins tot feeCoinSel (length rcptsN + 1) False rdmCoins + let nOuts = + if changeAmnt <= dust + then length rcptsN + else length rcptsN + 1 + totFee = + guessTxFee (fromIntegral feeByteN) nOuts (length pickedCoins) + rcptsPayN <- + if rcptPay + then lift $ makeRcptsPay (fromIntegral totFee) rcptsN + else return rcptsN + let rcpts = second fromIntegral <$> rcptsPayN + allRcpts + | changeAmnt <= dust = rcpts + | otherwise = (change, changeAmnt) : rcpts + ops = (.outpoint) <$> pickedCoins + when (any ((<= dust) . snd) allRcpts) $ + lift $ + Left "Recipient output is smaller than the dust value" + rdmRcpts <- randomShuffle allRcpts + tx <- lift $ buildAddrTx net ctx ops =<< mapM (addrToText2 net) rdmRcpts + return (tx, pickedCoins) + where + feeCoinSel = + if rcptPay + then 0 + else fromIntegral feeByteN :: Word64 + dust = fromIntegral dustN :: Word64 + tot = fromIntegral $ sum $ snd <$> rcptsN :: Word64 + +makeRcptsPay :: + Natural -> [(Address, Natural)] -> Either String [(Address, Natural)] +makeRcptsPay fee rcpts = + mapM f rcpts + where + f (a, v) = (a,) <$> maybeToEither err (v `safeSubtract` toPay) + err = "Recipients can't pay for the fee" + (q, r) = fee `quotRem` fromIntegral (length rcpts) + toPay = if r == 0 then q else q + 1 + +{- Signing Transactions -} + +data MnemonicPass = MnemonicPass + { mnemonicWords :: !Text, + mnemonicPass :: !Text + } + deriving (Eq, Show) + +-- Compute an account signing key +signingKey :: Network -> Ctx -> MnemonicPass -> Natural -> Either String XPrvKey +signingKey net ctx mnem acc = do + seed <- mnemonicToSeed (mnemonicPass mnem) (mnemonicWords mnem) + return $ derivePath ctx (bip44Deriv net acc) (makeXPrvKey seed) + +-- Compute the unique wallet fingerprint given a mnemonic +walletFingerprint :: Network -> Ctx -> MnemonicPass -> Either String Fingerprint +walletFingerprint net ctx mnem = do + xPrvKey <- signingKey net ctx mnem 0 + return $ xPubFP ctx $ deriveXPubKey ctx xPrvKey + +signWalletTx :: + Network -> + Ctx -> + TxSignData -> + XPrvKey -> + Either String (TxSignData, TxInfo) +signWalletTx net ctx tsd@TxSignData {txSignDataInputPaths = inPaths} signKey = + signTxWithKeys net ctx tsd publicKey prvKeys + where + publicKey = deriveXPubKey ctx signKey + prvKeys = (.key) . (\p -> derivePath ctx p signKey) <$> inPaths + +signTxWithKeys :: + Network -> + Ctx -> + TxSignData -> + XPubKey -> + [SecKey] -> + Either String (TxSignData, TxInfo) +signTxWithKeys net ctx tsd@(TxSignData tx _ _ _ signed) publicKey secKeys = do + when signed $ Left "The transaction is already signed" + when (null secKeys) $ Left "There are no private keys to sign" + txInfoU <- parseTxSignData net ctx publicKey tsd + -- signing + let myInputs = unsignedTxInfoMyInputs txInfoU + othInputs = unsignedTxInfoOtherInputs txInfoU + mySigInputs = mconcat $ myInputsSigInput <$> Map.elems myInputs + othSigInputs = mconcat $ otherInputsSigInput <$> Map.elems othInputs + sigInputs = mySigInputs <> othSigInputs + signedTx <- signTx net ctx tx sigInputs secKeys + let txInfo = unsignedToTxInfo signedTx txInfoU + isSigned = verifyTxInfo net ctx signedTx txInfo + unless isSigned $ Left "The transaction could not be signed" + return + ( tsd {txSignDataTx = signedTx, txSignDataSigned = True}, + txInfo + ) + +verifyTxInfo :: Network -> Ctx -> Tx -> TxInfo -> Bool +verifyTxInfo net ctx tx txInfo = + let myInputs = txInfoMyInputs txInfo + othInputs = txInfoOtherInputs txInfo + mySigInputs = mconcat $ myInputsSigInput <$> Map.elems myInputs + othSigInputs = mconcat $ otherInputsSigInput <$> Map.elems othInputs + sigInputs = mySigInputs <> othSigInputs + f i = (i.script, i.value, i.outpoint) + vDat = f <$> sigInputs + in txHash tx == txInfoHash txInfo + && noEmptyInputs tx + && verifyStdTx net ctx tx vDat + +noEmptyInputs :: Tx -> Bool +noEmptyInputs = (not . any BS.null) . fmap (.script) . (.inputs) + +{- Transaction Sweeping -} + +buildSweepSignData :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Config -> + DBAccountId -> + [Address] -> + [Address] -> + Natural -> + Natural -> + ExceptT String (DB m) TxSignData +buildSweepSignData net ctx cfg accId sweepFrom sweepTo feeByte dust + | null sweepFrom = throwError "No addresses to sweep from" + | null sweepTo = throwError "No addresses to sweep to" + | otherwise = do + let host = apiHost net cfg + -- Get the unspent coins of the sweepFrom addresses + Store.SerialList coins <- + liftExcept . apiBatch ctx (configCoinBatch cfg) host $ + GetAddrsUnspent sweepFrom def {limit = Just 0} + when (null coins) $ + throwError "There are no coins to sweep in those addresses" + -- Build a set of sweep transactions + gen <- liftIO initStdGen + tx <- liftEither $ buildSweepTx net ctx gen coins sweepTo feeByte dust + -- Get the dependent transactions + let depTxHash = (.hash) . (.outpoint) <$> (.inputs) tx + Store.RawResultList depTxs <- + liftExcept . apiBatch ctx (configTxFullBatch cfg) host $ + GetTxsRaw depTxHash + -- Check if any of the coins belong to us + inDerivs <- rights <$> lift (mapM (getAddrDeriv net accId) sweepFrom) + -- Check if any of the sweepTo addrs belong to us + outDerivs <- rights <$> lift (mapM (getAddrDeriv net accId) sweepTo) + return $ TxSignData tx depTxs (nub inDerivs) (nub outDerivs) False + +buildSweepTx :: + Network -> + Ctx -> + StdGen -> + [Store.Unspent] -> + [Address] -> + Natural -> + Natural -> + Either String Tx +buildSweepTx net ctx gen coins sweepTo feeByte dust = + flip evalStateT gen $ do + rdmOutpoints <- ((.outpoint) <$>) <$> randomShuffle coins + rdmSweepTo <- randomShuffle sweepTo + let coinsTot = sum $ (.value) <$> coins + fee = guessTxFee (fromIntegral feeByte) (length sweepTo) (length coins) + when (coinsTot < fee) $ + throwError "Could not find a sweep solution: fee is too large" + rdmAmntsM <- + randomSplitIn + (coinsTot - fee) -- will not overflow + (fromIntegral $ length sweepTo) + (fromIntegral $ dust + 1) + rdmAmnts <- lift $ maybeToEither "Could not find a sweep solution" rdmAmntsM + addrsT <- lift $ mapM (maybeToEither "Addr" . addrToText net) rdmSweepTo + lift $ buildAddrTx net ctx rdmOutpoints (zip addrsT rdmAmnts) + +-- Utilities -- + +randomRange :: (Random a, MonadState StdGen m) => a -> a -> m a +randomRange low hi = do + gen <- get + let (res, newGen) = randomR (low, hi) gen + put newGen + return res + +randomShuffle :: (MonadState StdGen m) => [a] -> m [a] +randomShuffle [] = return [] +randomShuffle [x] = return [x] +randomShuffle xs = do + i <- randomRange 0 (length xs - 1) + case splitAt i xs of + (as, e : bs) -> (e :) <$> randomShuffle (as <> bs) + _ -> error "randomShuffle" + +-- Split the number a into n parts of minimum value d +randomSplitIn :: + (Random a, Num a, Ord a, MonadState StdGen m) => a -> a -> a -> m (Maybe [a]) +randomSplitIn a n d + | a < n * d = return Nothing + | n == 1 = return $ Just [a] + | otherwise = do + randPart <- randomRange d (a - d * (n - 1)) + ((randPart :) <$>) <$> randomSplitIn (a - randPart) (n - 1) d diff --git a/src/Network/Haskoin/Wallet/TxInfo.hs b/src/Haskoin/Wallet/TxInfo.hs similarity index 88% rename from src/Network/Haskoin/Wallet/TxInfo.hs rename to src/Haskoin/Wallet/TxInfo.hs index f83138c1..33a57089 100644 --- a/src/Network/Haskoin/Wallet/TxInfo.hs +++ b/src/Haskoin/Wallet/TxInfo.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module Network.Haskoin.Wallet.TxInfo where +module Haskoin.Wallet.TxInfo where import Control.Arrow ((&&&)) import Control.Monad (unless) @@ -14,7 +14,6 @@ import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import qualified Data.Aeson as Json import Data.Aeson.Types (Parser) import qualified Data.ByteString as BS -import Data.Decimal as Decimal (Decimal, roundTo) import Data.Either (partitionEithers) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -23,43 +22,10 @@ import qualified Data.Serialize as S import Data.String.Conversions (cs) import Data.String.ToString (ToString (..)) import Data.Text (Text) -import Haskoin.Address - ( Address, - addressToOutput, - scriptToAddressBS, - ) -import Haskoin.Crypto - ( Ctx, - SoftPath, - XPubKey, - derivePubPath, - xPubAddr, - ) -import Haskoin.Network (Network (sigHashForkId)) -import Haskoin.Script (SigHash, setForkIdFlag, sigHashAll) +import Haskoin import qualified Haskoin.Store.Data as Store -import Haskoin.Transaction - ( OutPoint (OutPoint), - SigInput (SigInput), - Tx (inputs, outputs), - TxHash, - TxIn (outpoint), - TxOut (TxOut, value), - guessTxSize, - txHash, - ) -import Haskoin.Util - ( MarshalJSON (marshalValue, unmarshalValue), - fst3, - maybeToEither, - ) -import Network.Haskoin.Wallet.FileIO (TxSignData (TxSignData)) -import Network.Haskoin.Wallet.Util - ( addrToTextE, - safeSubtract, - textToAddrE, - (!!?), - ) +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Util import Numeric.Natural (Natural) data TxType = TxDebit | TxInternal | TxCredit @@ -84,7 +50,7 @@ instance Json.FromJSON TxType where _ -> fail "Invalid TxType" data TxInfo = TxInfo - { txInfoId :: !TxHash, + { txInfoHash :: !TxHash, txInfoType :: !TxType, txInfoAmount :: !Integer, txInfoMyOutputs :: !(Map Address MyOutputs), @@ -95,7 +61,7 @@ data TxInfo = TxInfo txInfoNonStdInputs :: ![Store.StoreInput], txInfoSize :: !Natural, txInfoFee :: !Natural, - txInfoFeeByte :: !Decimal, + txInfoFeeByte :: !Natural, txInfoBlockRef :: !Store.BlockRef, txInfoConfirmations :: !Natural } @@ -166,7 +132,7 @@ instance MarshalJSON Ctx OtherInputs where instance MarshalJSON (Network, Ctx) TxInfo where marshalValue (net, ctx) tx = object - [ "txid" .= txInfoId tx, + [ "txid" .= txInfoHash tx, "type" .= txInfoType tx, "amount" .= txInfoAmount tx, "myoutputs" .= mapAddrText net (txInfoMyOutputs tx), @@ -177,7 +143,7 @@ instance MarshalJSON (Network, Ctx) TxInfo where "nonstdinputs" .= (marshalValue net <$> txInfoNonStdInputs tx), "size" .= txInfoSize tx, "fee" .= txInfoFee tx, - "feebyte" .= show (txInfoFeeByte tx), + "feebyte" .= txInfoFeeByte tx, "block" .= txInfoBlockRef tx, "confirmations" .= txInfoConfirmations tx ] @@ -195,10 +161,38 @@ instance MarshalJSON (Network, Ctx) TxInfo where <*> (mapM (unmarshalValue net) =<< o .: "nonstdinputs") <*> o .: "size" <*> o .: "fee" - <*> (read <$> o .: "feebyte") + <*> o .: "feebyte" <*> o .: "block" <*> o .: "confirmations" +data NoSigTxInfo + = NoSigSigned !TxHash !TxInfo + | NoSigUnsigned !TxHash !UnsignedTxInfo + deriving (Eq, Show) + +instance MarshalJSON (Network, Ctx) NoSigTxInfo where + marshalValue (net, ctx) (NoSigSigned h t) = + object + [ "nosighash" .= h, + "txinfo" .= marshalValue (net, ctx) t, + "signed" .= True + ] + marshalValue (net, ctx) (NoSigUnsigned h t) = + object + [ "nosighash" .= h, + "txinfo" .= marshalValue (net, ctx) t, + "signed" .= False + ] + + unmarshalValue (net, ctx) = + Json.withObject "TxInfo" $ \o -> do + s <- o .: "signed" + tV <- o .: "txinfo" + h <- o .: "nosighash" + if s + then NoSigSigned h <$> unmarshalValue (net, ctx) tV + else NoSigUnsigned h <$> unmarshalValue (net, ctx) tV + marshalMap :: (MarshalJSON Ctx v) => Network -> @@ -231,7 +225,7 @@ toTxInfo :: Map Address SoftPath -> Natural -> Store.Transaction -> TxInfo toTxInfo walletAddrs currHeight sTx = TxInfo - { txInfoId = sTx.txid, + { txInfoHash = sTx.txid, txInfoType = txType amount fee, txInfoAmount = amount, txInfoMyOutputs = Map.map (uncurry MyOutputs) myOutputsMap, @@ -249,7 +243,7 @@ toTxInfo walletAddrs currHeight sTx = where size = fromIntegral sTx.size :: Natural fee = fromIntegral sTx.fee :: Natural - feeByte = Decimal.roundTo 2 $ fromIntegral fee / fromIntegral size + feeByte = fee `div` size (outputMap, nonStdOut) = outputAddressMap sTx.outputs myOutputsMap = Map.intersectionWith (,) outputMap walletAddrs othOutputsMap = Map.difference outputMap walletAddrs @@ -333,14 +327,14 @@ data UnsignedTxInfo = UnsignedTxInfo unsignedTxInfoOtherInputs :: !(Map Address OtherInputs), unsignedTxInfoSize :: !Natural, unsignedTxInfoFee :: !Natural, - unsignedTxInfoFeeByte :: !Decimal + unsignedTxInfoFeeByte :: !Natural } deriving (Eq, Show) unsignedToTxInfo :: Tx -> UnsignedTxInfo -> TxInfo unsignedToTxInfo tx uTx = TxInfo - { txInfoId = txHash tx, + { txInfoHash = txHash tx, txInfoType = unsignedTxInfoType uTx, txInfoAmount = unsignedTxInfoAmount uTx, txInfoMyOutputs = unsignedTxInfoMyOutputs uTx, @@ -357,9 +351,7 @@ unsignedToTxInfo tx uTx = } where size = BS.length $ S.encode tx - feeByte = - Decimal.roundTo 2 $ - fromIntegral (unsignedTxInfoFee uTx) / fromIntegral size + feeByte = unsignedTxInfoFee uTx `div` fromIntegral size instance MarshalJSON (Network, Ctx) UnsignedTxInfo where marshalValue (net, ctx) tx = @@ -372,7 +364,7 @@ instance MarshalJSON (Network, Ctx) UnsignedTxInfo where "otherinputs" .= marshalMap net ctx (unsignedTxInfoOtherInputs tx), "size" .= unsignedTxInfoSize tx, "fee" .= unsignedTxInfoFee tx, - "feebyte" .= show (unsignedTxInfoFeeByte tx) + "feebyte" .= unsignedTxInfoFeeByte tx ] unmarshalValue (net, ctx) = @@ -383,10 +375,10 @@ instance MarshalJSON (Network, Ctx) UnsignedTxInfo where <*> (mapTextAddr net <$> o .: "myoutputs") <*> (mapTextAddr net <$> o .: "otheroutputs") <*> (unmarshalMap net ctx =<< o .: "myinputs") - <*> (unmarshalMap net ctx =<< o .: "otherInputs") + <*> (unmarshalMap net ctx =<< o .: "otherinputs") <*> o .: "size" <*> o .: "fee" - <*> (read <$> o .: "feebyte") + <*> o .: "feebyte" parseTxSignData :: Network -> @@ -394,13 +386,13 @@ parseTxSignData :: XPubKey -> TxSignData -> Either String UnsignedTxInfo -parseTxSignData net ctx pubkey tsd@(TxSignData tx _ inPaths outPaths _ _ _) = do +parseTxSignData net ctx pubkey tsd@(TxSignData tx _ inPaths outPaths _) = do coins <- txSignDataCoins tsd -- Fees let outSum = fromIntegral $ sum $ (.value) <$> tx.outputs :: Natural inSum = fromIntegral $ sum $ (.value) . snd <$> coins :: Natural fee <- maybeToEither "Fee is negative" $ inSum `safeSubtract` outSum - let feeByte = Decimal.roundTo 2 $ fromIntegral fee / fromIntegral size + let feeByte = fee `div` fromIntegral size -- Outputs (outputMap, nonStdOut) = txOutAddressMap ctx tx.outputs myOutputsMap = Map.intersectionWith (,) outputMap outPathAddrs @@ -424,7 +416,7 @@ parseTxSignData net ctx pubkey tsd@(TxSignData tx _ inPaths outPaths _ _ _) = do unless (length coins == length tx.inputs) $ Left "Referenced input transactions are missing" unless (length inPaths == Map.size myInputsMap) $ - Left "Private key derivations don't match the transaction inputs" + Left "Input derivations don't match the transaction inputs" unless (length outPaths == Map.size myOutputsMap) $ Left "Output derivations don't match the transaction outputs" return $ @@ -446,11 +438,12 @@ parseTxSignData net ctx pubkey tsd@(TxSignData tx _ inPaths outPaths _ _ _) = do size = guessTxSize (length tx.inputs) [] (length tx.outputs) 0 txSignDataCoins :: TxSignData -> Either String [(OutPoint, TxOut)] -txSignDataCoins (TxSignData tx depTxs _ _ _ _ _) = +txSignDataCoins (TxSignData tx depTxs _ _ _) = maybeToEither "Referenced input transactions are missing" $ mapM f ops where ops = (.outpoint) <$> tx.inputs :: [OutPoint] - txMap = Map.fromList $ (txHash &&& (.outputs)) <$> depTxs :: Map TxHash [TxOut] + txMap = + Map.fromList $ (txHash &&& (.outputs)) <$> depTxs :: Map TxHash [TxOut] f :: OutPoint -> Maybe (OutPoint, TxOut) f op@(OutPoint h i) = (op,) <$> ((!!? fromIntegral i) =<< Map.lookup h txMap) diff --git a/src/Network/Haskoin/Wallet/Util.hs b/src/Haskoin/Wallet/Util.hs similarity index 91% rename from src/Network/Haskoin/Wallet/Util.hs rename to src/Haskoin/Wallet/Util.hs index 71382751..2489426a 100644 --- a/src/Network/Haskoin/Wallet/Util.hs +++ b/src/Haskoin/Wallet/Util.hs @@ -2,15 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module Network.Haskoin.Wallet.Util where +module Haskoin.Wallet.Util where import Control.Arrow (second) import Control.Monad.Except - ( ExceptT, - MonadError (throwError), - runExceptT, - ) -import Crypto.Secp256k1 (Ctx) import qualified Data.Aeson as JSON import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.ByteString as BS @@ -20,11 +15,8 @@ import Data.Maybe (fromMaybe) import qualified Data.Serialize as S import Data.Text (Text) import qualified Data.Text as Text -import Haskoin.Address (Address, addrToText, textToAddr) -import Haskoin.Crypto.Keys (XPubKey, xPubFP) -import Haskoin.Network (Network) +import Haskoin import qualified Haskoin.Store.Data as Store -import Haskoin.Util (encodeHex, maybeToEither) import Numeric.Natural (Natural) {- Data.Aeson Compatibility -} diff --git a/src/Network/Haskoin/Wallet.hs b/src/Network/Haskoin/Wallet.hs deleted file mode 100644 index 43a7cb05..00000000 --- a/src/Network/Haskoin/Wallet.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} - -module Network.Haskoin.Wallet where - -import qualified Data.ByteString.Char8 as C8 -import Haskoin.Crypto (Ctx, withContext) -import Haskoin.Util (MarshalJSON (marshalValue)) -import Network.Haskoin.Wallet.Commands - ( Response, - commandResponse, - ) -import Network.Haskoin.Wallet.Parser (programParser) -import Network.Haskoin.Wallet.Util (encodeJsonPretty) -import Options.Applicative - ( customExecParser, - prefs, - showHelpOnEmpty, - ) - -clientMain :: IO () -clientMain = - withContext $ \ctx -> do - cmd <- customExecParser (prefs showHelpOnEmpty) (programParser ctx) - res <- commandResponse ctx cmd - jsonPrinter ctx res - -jsonPrinter :: Ctx -> Response -> IO () -jsonPrinter ctx = C8.putStrLn . encodeJsonPretty . marshalValue ctx diff --git a/src/Network/Haskoin/Wallet/AccountStore.hs b/src/Network/Haskoin/Wallet/AccountStore.hs deleted file mode 100644 index d70cdfa2..00000000 --- a/src/Network/Haskoin/Wallet/AccountStore.hs +++ /dev/null @@ -1,426 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Wallet.AccountStore where - -import Control.Monad (MonadPlus (mzero), unless, void, when) -import Control.Monad.Except (MonadError (throwError), liftEither) -import Control.Monad.Reader (MonadIO (..), MonadTrans (lift)) -import Control.Monad.State - ( MonadState (get, put), - StateT (runStateT), - execStateT, - gets, - ) -import Data.Aeson.Types - ( FromJSON (parseJSON), - KeyValue ((.=)), - ToJSON (toJSON), - object, - withObject, - (.:), - ) -import Data.Bits (clearBit) -import Data.List (find, nub) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.String.Conversions (cs) -import Data.Text (Text) -import Haskoin.Address (Address) -import Haskoin.Crypto - ( Ctx, - DerivPathI (Deriv, (:/), (:|)), - HardPath, - SoftPath, - XPubKey, - derivePathAddr, - derivePathAddrs, - pathToList, - xPubChild, - ) -import Haskoin.Network (Network (bip44Coin, name), netByName) -import Haskoin.Util (MarshalJSON (marshalValue, unmarshalValue)) -import Network.Haskoin.Wallet.FileIO - ( hwDataDirectory, - readJsonFile, - readMarshalFile, - writeJsonFile, - ) -import Network.Haskoin.Wallet.Util (Page (Page), ()) -import Numeric.Natural (Natural) -import qualified System.Directory as D - -newtype AccountMap = AccountMap {getAccountMap :: Map Text AccountStore} - deriving (Eq, Show) - -instance MarshalJSON Ctx AccountMap where - marshalValue ctx (AccountMap m) = toJSON $ Map.map (marshalValue ctx) m - unmarshalValue ctx v = do - m <- parseJSON v - AccountMap <$> mapM (unmarshalValue ctx) m - -data AccountStore = AccountStore - { accountStoreXPubKey :: !XPubKey, - accountStoreExternal :: !Natural, - accountStoreInternal :: !Natural, - accountStoreDeriv :: !HardPath, - accountStoreNetwork :: !Network - } - deriving (Eq, Show) - -instance MarshalJSON Ctx AccountStore where - marshalValue ctx (AccountStore k e i d net) = - object - [ "xpubkey" .= marshalValue (net, ctx) k, - "external" .= e, - "internal" .= i, - "deriv" .= d, - "network" .= net.name - ] - unmarshalValue ctx = - withObject "accountstore" $ \o -> do - net <- maybe mzero return . netByName =<< o .: "network" - AccountStore - <$> (unmarshalValue (net, ctx) =<< o .: "xpubkey") - <*> o .: "external" - <*> o .: "internal" - <*> o .: "deriv" - <*> return net - -newtype LabelMap = LabelMap {getLabelMap :: Map Text (Map Natural Text)} - deriving (Eq, Show) - -instance ToJSON LabelMap where - toJSON (LabelMap m) = toJSON m - -instance FromJSON LabelMap where - parseJSON v = do - m <- parseJSON v - return $ LabelMap m - --- LabelMap IO -- - -labelMapFilePath :: IO FilePath -labelMapFilePath = do - dir <- hwDataDirectory Nothing - return $ dir "labels.json" - -readLabelMap :: IO (Either String LabelMap) -readLabelMap = do - fp <- labelMapFilePath - exists <- D.doesFileExist fp - unless exists $ writeLabelMap $ LabelMap Map.empty - readJsonFile fp - -writeLabelMap :: LabelMap -> IO () -writeLabelMap labelMap = do - file <- labelMapFilePath - writeJsonFile file $ toJSON labelMap - -readAccountLabels :: - (MonadIO m, MonadError String m) => Text -> m (Map Natural Text) -readAccountLabels accName = do - LabelMap m <- liftEither =<< liftIO readLabelMap - case Map.lookup accName m of - Just labels -> return labels - Nothing -> do - liftIO $ writeLabelMap $ LabelMap $ Map.insert accName Map.empty m - return Map.empty - -writeAccountLabel :: - (MonadIO m, MonadError String m) => Text -> Natural -> Text -> m () -writeAccountLabel accName d label = do - LabelMap m <- liftEither =<< liftIO readLabelMap - let lMap = case Map.lookup accName m of - Just x -> x - _ -> Map.empty - resMap = Map.insert d label lMap - liftIO $ writeLabelMap $ LabelMap $ Map.insert accName resMap m - --- Commit -- - -data Commit a - = NoCommit {commitValue :: !a} - | Commit {commitValue :: !a} - deriving (Eq, Show) - -toCommit :: (Eq a) => a -> a -> Commit a -toCommit old new = - if old == new - then NoCommit new - else Commit new - --- AccountMap State -- - -commitAccountMap :: Ctx -> Commit AccountMap -> IO AccountMap -commitAccountMap _ (NoCommit val) = return val -commitAccountMap ctx (Commit val) = do - writeAccountMap ctx val - return val - -runAccountMapT :: - (Monad m) => - StateT AccountMap m a -> - AccountMap -> - m (a, Commit AccountMap) -runAccountMapT m origMap = do - (a, newMap) <- runStateT m origMap - return (a, toCommit origMap newMap) - -execAccountMapT :: - (Monad m) => StateT AccountMap m a -> AccountMap -> m (Commit AccountMap) -execAccountMapT m origMap = do - newMap <- execStateT m origMap - return $ toCommit origMap newMap - -withAccountMap :: - (MonadError String m, MonadIO m) => Ctx -> StateT AccountMap m a -> m a -withAccountMap ctx m = do - accMap <- liftEither =<< liftIO (readAccountMap ctx) - (res, c) <- runAccountMapT m accMap - _ <- liftIO $ commitAccountMap ctx c - return res - --- AccountMap IO -- - -accountMapFilePath :: IO FilePath -accountMapFilePath = do - dir <- hwDataDirectory Nothing - return $ dir "bip44accounts.json" - -readAccountMap :: Ctx -> IO (Either String AccountMap) -readAccountMap ctx = do - fp <- accountMapFilePath - exists <- D.doesFileExist fp - unless exists $ writeAccountMap ctx $ AccountMap Map.empty - readMarshalFile ctx fp - -writeAccountMap :: Ctx -> AccountMap -> IO () -writeAccountMap ctx accMap = do - file <- accountMapFilePath - writeJsonFile file $ marshalValue ctx accMap - --- AccountMap -- - -accountMapKeys :: (MonadState AccountMap m, MonadError String m) => m [Text] -accountMapKeys = gets (Map.keys . getAccountMap) - -getAccountStore :: - (MonadState AccountMap m, MonadError String m) => - Maybe Text -> - m (Text, AccountStore) -getAccountStore keyM = do - accMap <- gets getAccountMap - case keyM of - Nothing -> - case Map.assocs accMap of - [keyval] -> return keyval - [] -> throwError "There are no accounts in the wallet" - _ -> throwError "Specify which account you want to use" - Just key -> - case key `Map.lookup` accMap of - Just val -> return (key, val) - _ -> throwError $ "The account " <> cs key <> " does not exist" - -getAccountStoreByDeriv :: - (MonadState AccountMap m, MonadError String m) => - Network -> - Natural -> - m (Text, AccountStore) -getAccountStoreByDeriv net acc = do - accMap <- gets getAccountMap - case find ((== path) . accountStoreDeriv . snd) $ Map.assocs accMap of - Just res -> return res - Nothing -> throwError $ "No account exists with derivation " <> show acc - where - path = bip44Deriv net acc - -nextAccountDeriv :: (MonadState AccountMap m, MonadError String m) => m Natural -nextAccountDeriv = do - accMap <- gets getAccountMap - ds <- mapM (liftEither . accountStoreAccount) $ Map.elems accMap - return $ if null ds then 0 else maximum ds + 1 - -alterAccountStore :: - (MonadState AccountMap m, MonadError String m) => - Text -> - (Maybe AccountStore -> Either String (Maybe AccountStore)) -> - m (Maybe AccountStore) -alterAccountStore key f = do - accMap <- gets getAccountMap - accM <- liftEither $ f (key `Map.lookup` accMap) - let newMap = AccountMap $ Map.alter (const accM) key accMap - unless (validAccountMap newMap) $ - throwError "Duplicate account public keys" - put newMap - return accM - -validAccountMap :: AccountMap -> Bool -validAccountMap (AccountMap accMap) = - length (nub pubKeys) == length pubKeys - where - pubKeys = accountStoreXPubKey <$> Map.elems accMap - -insertAccountStore :: - (MonadState AccountMap m, MonadError String m) => - Text -> - AccountStore -> - m () -insertAccountStore key store = - void $ alterAccountStore key $ \case - Nothing -> return $ Just store - _ -> Left "The account name already exists" - -renameAccountStore :: - (MonadState AccountMap m, MonadError String m) => - Text -> - Text -> - m AccountStore -renameAccountStore oldName newName - | oldName == newName = throwError "Old and new names are the same" - | otherwise = do - accMap <- gets getAccountMap - case Map.lookup oldName accMap of - Just store -> do - when (Map.member newName accMap) $ - throwError "New account name already exists" - put $ - AccountMap $ - Map.insert newName store $ - Map.delete oldName accMap - return store - _ -> throwError "Account does not exist" - --- AccountStore State -- - -commitAccountStore :: - (MonadIO m, MonadError String m, MonadState AccountMap m) => - Text -> - Commit AccountStore -> - m AccountStore -commitAccountStore _ (NoCommit val) = return val -commitAccountStore key (Commit val) = do - _ <- alterAccountStore key $ const $ return (Just val) - return val - -runAccountStoreT :: - (Monad m) => - StateT AccountStore m a -> - AccountStore -> - m (a, Commit AccountStore) -runAccountStoreT m origStore = do - (a, newStore) <- runStateT m origStore - return (a, toCommit origStore newStore) - -execAccountStoreT :: - (Monad m) => - StateT AccountStore m a -> - AccountStore -> - m (Commit AccountStore) -execAccountStoreT m origStore = do - newStore <- execStateT m origStore - return $ toCommit origStore newStore - -withAccountStore :: - (MonadIO m, MonadError String m) => - Ctx -> - Maybe Text -> - (Text -> StateT AccountStore m a) -> - m a -withAccountStore ctx accM m = - withAccountMap ctx $ do - (key, store) <- getAccountStore accM - (res, c) <- lift $ runAccountStoreT (m key) store - _ <- commitAccountStore key c - return res - --- AccountStore -- - -accountStoreAccount :: AccountStore -> Either String Natural -accountStoreAccount as = - case pathToList $ accountStoreDeriv as of - [] -> Left "Invalid account derivation" - xs -> return $ fromIntegral $ (`clearBit` 31) $ last xs - -emptyAccountStore :: Network -> XPubKey -> AccountStore -emptyAccountStore net xpub = - AccountStore - { accountStoreXPubKey = xpub, - accountStoreExternal = 0, - accountStoreInternal = 0, - accountStoreDeriv = bip44Deriv net $ fromIntegral $ xPubChild xpub, - accountStoreNetwork = net - } - -genExtAddress :: (MonadState AccountStore m) => Ctx -> m (Address, SoftPath) -genExtAddress ctx = - genAddress_ ctx accountStoreExternal extDeriv $ \f s -> - s {accountStoreExternal = f s} - -genIntAddress :: (MonadState AccountStore m) => Ctx -> m (Address, SoftPath) -genIntAddress ctx = - genAddress_ ctx accountStoreInternal intDeriv $ \f s -> - s {accountStoreInternal = f s} - -genAddress_ :: - (MonadState AccountStore m) => - Ctx -> - (AccountStore -> Natural) -> - SoftPath -> - ((AccountStore -> Natural) -> AccountStore -> AccountStore) -> - m (Address, SoftPath) -genAddress_ ctx getIdx deriv updAcc = do - store <- get - let idx = getIdx store - addr = - derivePathAddr ctx (accountStoreXPubKey store) deriv $ - fromIntegral idx - newStore = updAcc ((+ 1) . getIdx) store - put newStore - return (fst addr, deriv :/ fromIntegral idx) - -extAddresses :: Ctx -> AccountStore -> [(Address, SoftPath)] -extAddresses ctx = addresses_ ctx accountStoreExternal extDeriv - -intAddresses :: Ctx -> AccountStore -> [(Address, SoftPath)] -intAddresses ctx = addresses_ ctx accountStoreInternal intDeriv - -addresses_ :: - Ctx -> - (AccountStore -> Natural) -> - SoftPath -> - AccountStore -> - [(Address, SoftPath)] -addresses_ ctx getIdx deriv store = - fmap (\(a, _, i) -> (a, deriv :/ i)) addrs - where - xpub = accountStoreXPubKey store - idx = fromIntegral $ getIdx store - addrs = take idx $ derivePathAddrs ctx xpub deriv 0 - -storeAddressMap :: Ctx -> AccountStore -> Map Address SoftPath -storeAddressMap ctx store = - Map.fromList $ extAddresses ctx store <> intAddresses ctx store - --- Helpers -- - -extDeriv :: SoftPath -extDeriv = Deriv :/ 0 - -intDeriv :: SoftPath -intDeriv = Deriv :/ 1 - -bip44Deriv :: Network -> Natural -> HardPath -bip44Deriv net a = Deriv :| 44 :| net.bip44Coin :| fromIntegral a - -addrsDerivPage :: Ctx -> SoftPath -> Page -> XPubKey -> [(Address, SoftPath)] -addrsDerivPage ctx deriv (Page lim off) xpub = - fmap (\(a, _, i) -> (a, deriv :/ i)) addrs - where - addrs = - take (fromIntegral lim) $ - derivePathAddrs ctx xpub deriv (fromIntegral off) diff --git a/src/Network/Haskoin/Wallet/Commands.hs b/src/Network/Haskoin/Wallet/Commands.hs deleted file mode 100644 index 6f54deba..00000000 --- a/src/Network/Haskoin/Wallet/Commands.hs +++ /dev/null @@ -1,984 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Wallet.Commands where - -import Control.Monad (forM, mzero, unless, when, (<=<)) -import Control.Monad.Except - ( ExceptT, - MonadError (throwError), - liftEither, - runExceptT, - ) -import Control.Monad.Reader (MonadIO (..), MonadTrans (lift)) -import Control.Monad.State (MonadState (get), gets, modify) -import Data.Aeson (object, (.:), (.:?), (.=)) -import qualified Data.Aeson as Json -import qualified Data.ByteString as BS -import Data.Default (def) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.String (IsString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import Haskoin.Address (Address, addrToText, textToAddr) -import Haskoin.Crypto - ( Ctx, - Mnemonic, - SoftPath, - XPrvKey, - deriveXPubKey, - fromMnemonic, - pathToList, HardPath, - ) -import Haskoin.Network (Network (name), netByName) -import qualified Haskoin.Store.Data as Store -import Haskoin.Store.WebClient - ( GetAddrsBalance (GetAddrsBalance), - GetAddrsTxs (GetAddrsTxs), - GetBlockBest (GetBlockBest), - GetHealth (GetHealth), - GetTxs (GetTxs), - LimitsParam (limit), - PostTx (PostTx), - apiBatch, - apiCall, - ) -import Haskoin.Transaction (TxHash) -import Haskoin.Util - ( MarshalJSON (marshalValue, unmarshalValue), - maybeToEither, - ) -import Network.Haskoin.Wallet.AccountStore - ( AccountMap, - AccountStore - ( accountStoreExternal, - accountStoreInternal, - accountStoreNetwork, - accountStoreXPubKey, accountStoreDeriv - ), - accountStoreAccount, - addrsDerivPage, - emptyAccountStore, - extAddresses, - extDeriv, - genExtAddress, - getAccountStoreByDeriv, - insertAccountStore, - intDeriv, - nextAccountDeriv, - readAccountLabels, - readAccountMap, - renameAccountStore, - storeAddressMap, - withAccountMap, - withAccountStore, - writeAccountLabel, - ) -import Network.Haskoin.Wallet.Amounts - ( AmountUnit, - readAmount, - showUnit, - ) -import Network.Haskoin.Wallet.Entropy - ( genMnemonic, - mergeMnemonicParts, - systemEntropy, - word8ToBase6, - ) -import Network.Haskoin.Wallet.FileIO - ( HWFolder (PubKeyFolder, SweepFolder, TxFolder), - PubKeyDoc (PubKeyDoc), - TxSignData - ( TxSignData, - txSignDataAccount, - txSignDataNetwork, - txSignDataTx - ), - parseAddrsFile, - parseSecKeysFile, - readFileWords, - readMarshalFile, - txsChecksum, - writeDoc, - ) -import Network.Haskoin.Wallet.Parser (Command (..)) -import Network.Haskoin.Wallet.Signing - ( buildSweepSignData, - buildTxSignData, - conf, - signTxWithKeys, - signWalletTx, - signingKey, - ) -import Network.Haskoin.Wallet.TxInfo - ( TxInfo, - UnsignedTxInfo, - parseTxSignData, - toTxInfo, - unsignedToTxInfo, - ) -import Network.Haskoin.Wallet.Util - ( Page (Page), - addrToText3, - liftExcept, - sortDesc, - textToAddr3, - textToAddrE, - toPage, - (), - ) -import Numeric.Natural (Natural) -import qualified System.Console.Haskeline as Haskeline -import qualified System.Directory as D -import Data.Bits (clearBit) - --- | Version of Haskoin Wallet package. -versionString :: (IsString a) => a - -#ifdef CURRENT_PACKAGE_VERSION -versionString = CURRENT_PACKAGE_VERSION -#else -versionString = "Unavailable" -#endif - -data AddressResponse = AddressResponse - { addressResponseAddr :: !Address, - addressResponseSoftPath :: !SoftPath, - addressResponseLabel :: !Text - } - deriving (Eq, Show) - -instance MarshalJSON Network AddressResponse where - marshalValue net (AddressResponse a d l) = - case addrToText net a of - Just t -> object ["address" .= t, "derivation" .= d, "label" .= l] - _ -> jsonError "Invalid address" - unmarshalValue net = - Json.withObject "response" $ \o -> do - t <- o .: "address" - d <- o .: "derivation" - l <- o .: "label" - case textToAddr net t of - Just a -> return $ AddressResponse a d l - _ -> fail "Invalid address" - -data Response - = ResponseError - { responseError :: !Text - } - | ResponseMnemonic - { responseEntropySource :: !Text, - responseMnemonic :: ![Text], - responseSplitMnemonic :: ![[Text]] - } - | ResponseCreateAcc - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responsePubKeyFile :: !Text - } - | ResponseTestAcc - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseResult :: !Bool, - responseText :: !Text - } - | ResponseImportAcc - { responseAccountName :: !Text, - responseAccount :: !AccountStore - } - | ResponseRenameAcc - { responseOldName :: !Text, - responseNewName :: !Text, - responseAccount :: !AccountStore - } - | ResponseAccounts - { responseAccounts :: !AccountMap - } - | ResponseBalance - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseBalance :: !AccountBalance - } - | ResponseResetAcc - { responseAccountName :: !Text, - responseAccount :: !AccountStore - } - | ResponseAddresses - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseAddresses :: ![AddressResponse] - } - | ResponseReceive - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseAddress :: !(Address, SoftPath, Text) - } - | ResponseTransactions - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTransactions :: ![TxInfo] - } - | ResponsePrepareTx - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTxFile :: !Text, - responseUnsignedTx :: !UnsignedTxInfo - } - | ResponseReview - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTransactionM :: !(Maybe TxInfo), - responseUnsignedTxM :: !(Maybe UnsignedTxInfo) - } - | ResponseSignTx - { responseTxFile :: !Text, - responseTransaction :: !TxInfo, - responseNetwork :: !Network - } - | ResponseSendTx - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTransaction :: !TxInfo, - responseNetworkTxId :: !TxHash - } - | ResponseVersion - {responseVersion :: !Text} - | ResponsePrepareSweep - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTxFiles :: ![Text], - responseUnsignedTxs :: ![UnsignedTxInfo] - } - | ResponseSignSweep - { responseAccountName :: !Text, - responseAccount :: !AccountStore, - responseTxFiles :: ![Text], - responseTransactions :: ![TxInfo] - } - | ResponseRollDice - { responseRollDice :: ![Natural], - responseEntropySource :: !Text - } - deriving (Eq, Show) - -jsonError :: String -> Json.Value -jsonError err = object ["type" .= Json.String "error", "error" .= err] - -instance MarshalJSON Ctx Response where - marshalValue ctx = - \case - ResponseError err -> jsonError $ cs err - ResponseMnemonic e w ws -> - object - [ "type" .= Json.String "mnemonic", - "entropysource" .= e, - "mnemonic" .= w, - "splitmnemonic" .= ws - ] - ResponseCreateAcc n a f -> - object - [ "type" .= Json.String "createacc", - "accountname" .= n, - "account" .= marshalValue ctx a, - "pubkeyfile" .= f - ] - ResponseTestAcc n a b t -> - object - [ "type" .= Json.String "testacc", - "accountname" .= n, - "account" .= marshalValue ctx a, - "result" .= b, - "text" .= t - ] - ResponseImportAcc n a -> - object - [ "type" .= Json.String "importacc", - "accountname" .= n, - "account" .= marshalValue ctx a - ] - ResponseRenameAcc o n a -> - object - [ "type" .= Json.String "renameacc", - "oldname" .= o, - "newname" .= n, - "account" .= marshalValue ctx a - ] - ResponseAccounts a -> - object - ["type" .= Json.String "accounts", "accounts" .= marshalValue ctx a] - ResponseBalance n a b -> - object - [ "type" .= Json.String "balance", - "accountname" .= n, - "account" .= marshalValue ctx a, - "balance" .= b - ] - ResponseResetAcc n a -> - object - [ "type" .= Json.String "resetacc", - "accountname" .= n, - "account" .= marshalValue ctx a - ] - ResponseAddresses n a addrs -> - object - [ "type" .= Json.String "addresses", - "accountname" .= n, - "account" .= marshalValue ctx a, - "addresses" .= (marshalValue (accountStoreNetwork a) <$> addrs) - ] - ResponseReceive n a addr -> - case addrToText3 (accountStoreNetwork a) addr of - Right x -> - object - [ "type" .= Json.String "receive", - "accountname" .= n, - "account" .= marshalValue ctx a, - "address" .= x - ] - Left err -> jsonError err - ResponseTransactions n a txs -> - object - [ "type" .= Json.String "transactions", - "accountname" .= n, - "account" .= marshalValue ctx a, - "transactions" - .= Json.toJSON (marshalValue (accountStoreNetwork a, ctx) <$> txs) - ] - ResponsePrepareTx n a f t -> - object - [ "type" .= Json.String "preparetx", - "accountname" .= n, - "account" .= marshalValue ctx a, - "txfile" .= f, - "unsignedtx" .= marshalValue (accountStoreNetwork a, ctx) t - ] - ResponseReview n a wTxM uTxM -> do - let net = accountStoreNetwork a - wTx = marshalValue (net, ctx) <$> wTxM - uTx = marshalValue (net, ctx) <$> uTxM - in object - [ "type" .= Json.String "review", - "accountname" .= n, - "account" .= marshalValue ctx a, - "transaction" .= fromMaybe Json.Null wTx, - "unsignedtx" .= fromMaybe Json.Null uTx - ] - ResponseSignTx f t net -> - object - [ "type" .= Json.String "signtx", - "txfile" .= f, - "transaction" .= marshalValue (net, ctx) t, - "network" .= net.name - ] - ResponseSendTx n a t h -> - object - [ "type" .= Json.String "sendtx", - "accountname" .= n, - "account" .= marshalValue ctx a, - "transaction" .= marshalValue (accountStoreNetwork a, ctx) t, - "networktxid" .= h - ] - ResponseVersion v -> - object ["type" .= Json.String "version", "version" .= v] - ResponsePrepareSweep n a fs ts -> - object - [ "type" .= Json.String "preparesweep", - "accountname" .= n, - "account" .= marshalValue ctx a, - "txfiles" .= fs, - "unsignedtxs" - .= Json.toJSON (marshalValue (accountStoreNetwork a, ctx) <$> ts) - ] - ResponseSignSweep n a fs ts -> - object - [ "type" .= Json.String "signsweep", - "accountname" .= n, - "account" .= marshalValue ctx a, - "txfiles" .= fs, - "transactions" - .= Json.toJSON (marshalValue (accountStoreNetwork a, ctx) <$> ts) - ] - ResponseRollDice ns e -> - object - ["type" .= Json.String "rolldice", "entropysource" .= e, "dice" .= ns] - unmarshalValue ctx = - Json.withObject "response" $ \o -> do - Json.String resType <- o .: "type" - case resType of - "error" -> ResponseError <$> o .: "error" - "mnemonic" -> do - e <- o .: "entropysource" - m <- o .: "mnemonic" - ms <- o .: "splitmnemonic" - return $ ResponseMnemonic e m ms - "createacc" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - f <- o .: "pubkeyfile" - return $ ResponseCreateAcc n a f - "testacc" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - b <- o .: "result" - t <- o .: "text" - return $ ResponseTestAcc n a b t - "importacc" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - return $ ResponseImportAcc n a - "renameacc" -> do - old <- o .: "oldname" - new <- o .: "newname" - a <- unmarshalValue ctx =<< o .: "account" - return $ ResponseRenameAcc old new a - "accounts" -> do - as <- unmarshalValue ctx =<< o .: "accounts" - return $ ResponseAccounts as - "balance" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - b <- o .: "balance" - return $ ResponseBalance n a b - "resetacc" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - return $ ResponseResetAcc n a - "addresses" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - addrs <- - mapM (unmarshalValue (accountStoreNetwork a)) =<< o .: "addresses" - return $ ResponseAddresses n a addrs - "receive" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - let f = textToAddr3 (accountStoreNetwork a) - x <- either fail return . f =<< o .: "address" - return $ ResponseReceive n a x - "transactions" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - let f = unmarshalValue (accountStoreNetwork a, ctx) - txs <- mapM f =<< o .: "transactions" - return $ ResponseTransactions n a txs - "preparetx" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - f <- o .: "txfile" - let g = unmarshalValue (accountStoreNetwork a, ctx) - t <- g =<< o .: "unsignedtx" - return $ ResponsePrepareTx n a f t - "review" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - let f = unmarshalValue (accountStoreNetwork a, ctx) - g = unmarshalValue (accountStoreNetwork a, ctx) - wTxM <- - maybe (return Nothing) ((Just <$>) . f) =<< o .:? "transaction" - uTxM <- maybe (return Nothing) ((Just <$>) . g) =<< o .:? "unsignedtx" - return $ ResponseReview n a wTxM uTxM - "signtx" -> do - net <- maybe mzero return . netByName =<< o .: "network" - f <- o .: "txfile" - t <- unmarshalValue (net, ctx) =<< o .: "transaction" - return $ ResponseSignTx f t net - "sendtx" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - let f = unmarshalValue (accountStoreNetwork a, ctx) - t <- f =<< o .: "transaction" - h <- o .: "networktxid" - return $ ResponseSendTx n a t h - "version" -> do - v <- o .: "version" - return $ ResponseVersion v - "preparesweep" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - fs <- o .: "txfiles" - let g = unmarshalValue (accountStoreNetwork a, ctx) - ts <- mapM g =<< o .: "unsignedtxs" - return $ ResponsePrepareSweep n a fs ts - "signsweep" -> do - n <- o .: "accountname" - a <- unmarshalValue ctx =<< o .: "account" - fs <- o .: "txfiles" - let f = unmarshalValue (accountStoreNetwork a, ctx) - ts <- mapM f =<< o .: "transactions" - return $ ResponseSignSweep n a fs ts - "rolldice" -> do - ns <- o .: "dice" - e <- o .: "entropysource" - return $ ResponseRollDice ns e - _ -> fail "Invalid JSON response type" - -data AccountBalance = AccountBalance - { -- | confirmed balance - balanceConfirmed :: !Natural, - -- | unconfirmed balance - balanceUnconfirmed :: !Natural, - -- | number of unspent outputs - balanceUTXO :: !Natural - } - deriving (Show, Read, Eq, Ord) - -instance Json.ToJSON AccountBalance where - toJSON b = - object - [ "confirmed" .= balanceConfirmed b, - "unconfirmed" .= balanceUnconfirmed b, - "utxo" .= balanceUTXO b - ] - -instance Json.FromJSON AccountBalance where - parseJSON = - Json.withObject "accountbalance" $ \o -> - AccountBalance - <$> o .: "confirmed" - <*> o .: "unconfirmed" - <*> o .: "utxo" - -addrsToAccBalance :: [Store.Balance] -> AccountBalance -addrsToAccBalance xs = - AccountBalance - { balanceConfirmed = fromIntegral $ sum $ (.confirmed) <$> xs, - balanceUnconfirmed = fromIntegral $ sum $ (.unconfirmed) <$> xs, - balanceUTXO = fromIntegral $ sum $ (.utxo) <$> xs - } - -catchResponseError :: ExceptT String IO Response -> IO Response -catchResponseError m = do - resE <- runExceptT m - case resE of - Left err -> return $ ResponseError $ cs err - Right res -> return res - -commandResponse :: Ctx -> Command -> IO Response -commandResponse ctx = - \case - CommandMnemonic e d s -> mnemonic e d s - CommandCreateAcc t n dM s -> createAcc ctx t n dM s - CommandTestAcc accM s -> testAcc ctx accM s - CommandImportAcc f -> importAcc ctx f - CommandRenameAcc old new -> renameAcc ctx old new - CommandAccounts -> accounts ctx - CommandBalance accM -> balance ctx accM - CommandResetAcc accM -> resetAccount ctx accM - CommandAddresses accM p -> addresses ctx accM p - CommandReceive l accM -> receive ctx l accM - CommandTransactions accM p -> transactions ctx accM p - CommandPrepareTx rcpts accM unit fee dust rcptPay -> - prepareTx ctx rcpts accM unit fee dust rcptPay - CommandReview file -> cmdReview ctx file - CommandSignTx file s -> cmdSignTx ctx file s - CommandSendTx file -> cmdSendTx ctx file - CommandVersion -> cmdVersion - CommandPrepareSweep as fileM accM fee dust -> - prepareSweep ctx as fileM accM fee dust - CommandSignSweep dir keyFile accM -> signSweep ctx dir keyFile accM - CommandRollDice n -> rollDice n - -mnemonic :: Natural -> Bool -> Natural -> IO Response -mnemonic ent useDice splitIn = - catchResponseError $ do - (orig, ms, splitMs) <- genMnemonic ent useDice splitIn - return $ ResponseMnemonic orig (T.words ms) (T.words <$> splitMs) - -createAcc :: Ctx -> Text -> Network -> Maybe Natural -> Natural -> IO Response -createAcc ctx name net derivM splitIn = - catchResponseError $ - withAccountMap ctx $ do - d <- maybe nextAccountDeriv return derivM - prvKey <- lift $ askSigningKey ctx net d splitIn - let xpub = deriveXPubKey ctx prvKey - store = emptyAccountStore net xpub - path <- liftIO $ writeDoc PubKeyFolder $ PubKeyDoc xpub net name - insertAccountStore name store - return $ - ResponseCreateAcc - { responseAccountName = name, - responseAccount = store, - responsePubKeyFile = cs path - } - -testAcc :: Ctx -> Maybe Text -> Natural -> IO Response -testAcc ctx accM splitIn = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - store <- get - net <- gets accountStoreNetwork - d <- gets accountStoreDeriv - pubKey <- gets accountStoreXPubKey - prvKey <- lift $ askSigningKey ctx net (pathToAccount d) splitIn - return $ - if deriveXPubKey ctx prvKey == pubKey - then ResponseTestAcc - storeName - store - True - "The mnemonic and passphrase matched the account" - else ResponseTestAcc - storeName - store - False - "The mnemonic and passphrase did not match the account" - -pathToAccount :: HardPath -> Natural -pathToAccount = fromIntegral . (`clearBit` 31) . last . pathToList - -importAcc :: Ctx -> FilePath -> IO Response -importAcc ctx fp = - catchResponseError $ do - PubKeyDoc xpub net name <- liftEither =<< liftIO (readMarshalFile ctx fp) - let store = emptyAccountStore net xpub - withAccountMap ctx $ do - insertAccountStore name store - return $ ResponseImportAcc name store - -renameAcc :: Ctx -> Text -> Text -> IO Response -renameAcc ctx oldName newName = - catchResponseError $ - withAccountMap ctx $ do - store <- renameAccountStore oldName newName - return $ ResponseRenameAcc oldName newName store - -accounts :: Ctx -> IO Response -accounts ctx = - catchResponseError $ do - accMap <- liftEither =<< liftIO (readAccountMap ctx) - return $ ResponseAccounts accMap - -balance :: Ctx -> Maybe Text -> IO Response -balance ctx accM = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - net <- gets accountStoreNetwork - addrMap <- gets (storeAddressMap ctx) - when (Map.null addrMap) $ - throwError "The account has no addresses yet" - checkHealth ctx net - let req = GetAddrsBalance (Map.keys addrMap) - Store.SerialList bals <- - liftExcept $ apiCall ctx (conf net) req - store <- get - return $ ResponseBalance storeName store $ addrsToAccBalance bals - -addresses :: Ctx -> Maybe Text -> Page -> IO Response -addresses ctx accM page = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - store <- get - labels <- readAccountLabels storeName - let addrs = toPage page $ reverse $ extAddresses ctx store - return $ ResponseAddresses storeName store $ zipLabels addrs labels - -zipLabels :: - [(Address, SoftPath)] -> Map Natural Text -> [AddressResponse] -zipLabels addrs m = - f <$> addrs - where - f (a, p) = - AddressResponse a p $ - fromMaybe "No Label" $ - Map.lookup (fromIntegral $ last $ pathToList p) m - -receive :: Ctx -> Text -> Maybe Text -> IO Response -receive ctx label accM = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - (addr, path) <- genExtAddress ctx - store <- get - let d = last $ pathToList path - writeAccountLabel storeName (fromIntegral d) label - return $ ResponseReceive storeName store (addr, path, label) - -transactions :: Ctx -> Maybe Text -> Page -> IO Response -transactions ctx accM page = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - net <- gets accountStoreNetwork - addrMap <- gets (storeAddressMap ctx) - let allAddrs = Map.keys addrMap - checkHealth ctx net - best <- - (.height) - <$> liftExcept (apiCall ctx (conf net) (GetBlockBest def)) - -- TODO: This only works for small wallets. - Store.SerialList txRefs <- - liftExcept $ - apiBatch - ctx - 20 - (conf net) - (GetAddrsTxs allAddrs def {limit = Just 100}) - let sortedRefs = (.txid) <$> sortDesc txRefs - Store.SerialList txs <- - liftExcept $ - apiBatch ctx 20 (conf net) (GetTxs (toPage page sortedRefs)) - let txInfos = toTxInfo addrMap (fromIntegral best) <$> txs - store <- get - return $ ResponseTransactions storeName store txInfos - -prepareTx :: - Ctx -> - [(Text, Text)] -> - Maybe Text -> - AmountUnit -> - Natural -> - Natural -> - Bool -> - IO Response -prepareTx ctx rcpTxt accM unit feeByte dust rcptPay = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - net <- gets accountStoreNetwork - pub <- gets accountStoreXPubKey - rcpts <- liftEither $ mapM (toRecipient net unit) rcpTxt - checkHealth ctx net - signDat <- buildTxSignData net ctx rcpts feeByte dust rcptPay - path <- liftIO $ writeDoc TxFolder signDat - txInfoU <- liftEither $ parseTxSignData net ctx pub signDat - store <- get - return $ ResponsePrepareTx storeName store (cs path) txInfoU - -toRecipient :: - Network -> - AmountUnit -> - (Text, Text) -> - Either String (Address, Natural) -toRecipient net unit (a, v) = do - addr <- textToAddrE net a - val <- maybeToEither (cs badAmnt) (readAmount unit v) - return (addr, val) - where - badAmnt = - "Could not parse the amount " <> a <> " as " <> showUnit unit 1 - -cmdSignTx :: Ctx -> FilePath -> Natural -> IO Response -cmdSignTx ctx fp splitIn = - catchResponseError $ do - txSignData <- liftEither =<< liftIO (readMarshalFile ctx fp) - let net = txSignDataNetwork txSignData - acc = txSignDataAccount txSignData - prvKey <- askSigningKey ctx net acc splitIn - (newSignData, txInfo) <- liftEither $ signWalletTx ctx txSignData prvKey - path <- liftIO $ writeDoc TxFolder newSignData - return $ ResponseSignTx (cs path) txInfo net - -cmdReview :: Ctx -> FilePath -> IO Response -cmdReview ctx fp = - catchResponseError $ do - tsd@(TxSignData tx _ _ _ acc signed net) <- - liftEither =<< liftIO (readMarshalFile ctx fp) - withAccountMap ctx $ do - (storeName, store) <- getAccountStoreByDeriv net acc - let pub = accountStoreXPubKey store - txInfoU <- liftEither $ parseTxSignData net ctx pub tsd - let txInfo = unsignedToTxInfo tx txInfoU - return $ - if signed - then ResponseReview storeName store (Just txInfo) Nothing - else ResponseReview storeName store Nothing (Just txInfoU) - -cmdSendTx :: Ctx -> FilePath -> IO Response -cmdSendTx ctx fp = - catchResponseError $ do - tsd@(TxSignData signedTx _ _ _ acc signed net) <- - liftEither =<< liftIO (readMarshalFile ctx fp) - unless signed $ throwError "The transaction is not signed" - checkHealth ctx net - withAccountMap ctx $ do - (storeName, store) <- getAccountStoreByDeriv net acc - let pub = accountStoreXPubKey store - txInfoU <- liftEither $ parseTxSignData net ctx pub tsd - let txInfo = unsignedToTxInfo signedTx txInfoU - Store.TxId netTxId <- - liftExcept $ apiCall ctx (conf net) (PostTx signedTx) - return $ ResponseSendTx storeName store txInfo netTxId - -cmdVersion :: IO Response -cmdVersion = return $ ResponseVersion versionString - -prepareSweep :: - Ctx -> - [Text] -> - Maybe FilePath -> - Maybe Text -> - Natural -> - Natural -> - IO Response -prepareSweep ctx addrsTxt fileM accM feeByte dust = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - net <- gets accountStoreNetwork - pub <- gets accountStoreXPubKey - addrsArg <- liftEither $ mapM (textToAddrE net) addrsTxt - addrsFile <- - case fileM of - Just file -> parseAddrsFile net <$> liftIO (readFileWords file) - _ -> return [] - let addrs = addrsArg <> addrsFile - checkHealth ctx net - signDats <- buildSweepSignData net ctx addrs feeByte dust - let chksum = cs $ txsChecksum $ txSignDataTx <$> signDats - !txInfosU <- liftEither $ mapM (parseTxSignData net ctx pub) signDats - paths <- liftIO $ mapM (writeDoc (SweepFolder chksum)) signDats - store <- get - return $ ResponsePrepareSweep storeName store (cs <$> paths) txInfosU - -signSweep :: Ctx -> FilePath -> FilePath -> Maybe Text -> IO Response -signSweep ctx sweepDir keyFile accM = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - publicKey <- gets accountStoreXPubKey - net <- gets accountStoreNetwork - acc <- liftEither =<< gets accountStoreAccount - sweepFiles <- fmap (sweepDir ) <$> liftIO (D.listDirectory sweepDir) - tsds <- mapM (liftEither <=< liftIO . readMarshalFile ctx) sweepFiles - when (null tsds) $ throwError "No sweep transactions to sign" - unless (all (valid acc net) tsds) $ - throwError "Transactions do not match account information" - secKeys <- parseSecKeysFile net <$> liftIO (readFileWords keyFile) - when (null secKeys) $ throwError "No private keys to sign" - !signRes <- - forM tsds $ \tsd -> - liftEither $ signTxWithKeys ctx tsd publicKey secKeys - let initChksum = cs $ txsChecksum $ txSignDataTx <$> tsds - chksum = cs $ txsChecksum $ txSignDataTx . fst <$> signRes - when (initChksum /= chksum) $ - throwError "The transactions checksum do not match" - res <- - forM signRes $ \(newTsd, txInfo) -> do - path <- liftIO $ writeDoc (SweepFolder chksum) newTsd - return (path, txInfo) - store <- get - return $ - ResponseSignSweep storeName store (cs . fst <$> res) (snd <$> res) - where - valid acc net tsd = - txSignDataAccount tsd == acc && txSignDataNetwork tsd == net - -resetAccount :: Ctx -> Maybe Text -> IO Response -resetAccount ctx accM = - catchResponseError $ - withAccountStore ctx accM $ \storeName -> do - updateAccountIndices ctx storeName - gets (ResponseResetAcc storeName) - -updateAccountIndices :: - (MonadError String m, MonadIO m, MonadState AccountStore m) => - Ctx -> - Text -> - m () -updateAccountIndices ctx storeName = do - net <- gets accountStoreNetwork - pub <- gets accountStoreXPubKey - checkHealth ctx net - e <- go net pub extDeriv 0 (Page 20 0) - i <- go net pub intDeriv 0 (Page 20 0) - m <- readAccountLabels storeName - let eMax = maximum $ e : ((+ 1) <$> Map.keys m) - modify $ \s -> s {accountStoreExternal = eMax, accountStoreInternal = i} - where - go net pub deriv d page@(Page lim off) = do - let addrs = addrsDerivPage ctx deriv page pub - req = GetAddrsBalance $ fst <$> addrs - Store.SerialList bals <- - liftExcept $ apiCall ctx (conf net) req - let vBals = filter ((/= 0) . (.txs)) bals - if null vBals - then return d - else do - let d' = findMax addrs $ (.address) <$> vBals - go net pub deriv (d' + 1) (Page lim (off + lim)) - findMax :: [(Address, SoftPath)] -> [Address] -> Natural - findMax addrs balAddrs = - let fAddrs = filter ((`elem` balAddrs) . fst) addrs - in fromIntegral $ maximum $ last . pathToList . snd <$> fAddrs - -rollDice :: Natural -> IO Response -rollDice n = do - (res, origEnt) <- go [] "" - return $ ResponseRollDice (take (fromIntegral n) res) origEnt - where - go acc orig - | length acc >= fromIntegral n = return (acc, orig) - | otherwise = do - (origEnt, sysEnt) <- systemEntropy 1 - go (word8ToBase6 (head $ BS.unpack sysEnt) <> acc) origEnt - --- Utilities -- - -checkHealth :: (MonadIO m, MonadError String m) => Ctx -> Network -> m () -checkHealth ctx net = do - health <- liftExcept $ apiCall ctx (conf net) GetHealth - unless (Store.isOK health) $ - throwError "The indexer health check has failed" - --- Haskeline Helpers -- - -askInputLineHidden :: String -> IO String -askInputLineHidden message = do - inputM <- - Haskeline.runInputT Haskeline.defaultSettings $ - Haskeline.getPassword (Just '*') message - maybe - (error "No action due to EOF") - return - inputM - -askInputLine :: String -> IO String -askInputLine message = do - inputM <- - Haskeline.runInputT Haskeline.defaultSettings $ - Haskeline.getInputLine message - maybe - (error "No action due to EOF") - return - inputM - -askMnemonic :: String -> ExceptT String IO Mnemonic -askMnemonic txt = do - mnm <- liftIO $ askInputLineHidden txt - case fromMnemonic (cs mnm) of -- validate the mnemonic - Right _ -> return $ cs mnm - Left _ -> do - liftIO $ putStrLn "Invalid mnemonic" - askMnemonic txt - -askSigningKey :: - Ctx -> Network -> Natural -> Natural -> ExceptT String IO XPrvKey -askSigningKey _ _ _ 0 = throwError "Mnemonic split can not be 0" -askSigningKey ctx net acc splitIn = do - mnm <- - if splitIn == 1 - then askMnemonic "Enter your mnemonic: " - else do - ms <- forM [1 .. splitIn] $ \n -> - askMnemonic $ "Split mnemonic part #" <> show n <> ": " - liftEither $ mergeMnemonicParts ms - passStr <- askPassword - liftEither $ signingKey net ctx (cs passStr) (cs mnm) acc - -askPassword :: ExceptT String IO String -askPassword = do - pass <- liftIO $ askInputLineHidden "Mnemonic passphrase or leave empty: " - if null pass - then return pass - else do - pass2 <- - liftIO $ askInputLineHidden "Repeat your mnemonic passphrase: " - if pass == pass2 - then return pass - else do - liftIO $ putStrLn "The passphrases did not match" - askPassword diff --git a/src/Network/Haskoin/Wallet/FileIO.hs b/src/Network/Haskoin/Wallet/FileIO.hs deleted file mode 100644 index 9dab4f63..00000000 --- a/src/Network/Haskoin/Wallet/FileIO.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Wallet.FileIO where - -import Control.Applicative ((<|>)) -import Control.Monad (MonadPlus (mzero), (<=<)) -import Data.Aeson - ( object, - withObject, - (.:), - (.=), - ) -import qualified Data.Aeson as Json -import qualified Data.Aeson.Types as Json -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Short as BSS -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Serialize as S -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as Text -import Haskoin.Address (Address) -import Haskoin.Crypto - ( Ctx, - Hash256 (get), - PrivateKey (key), - SecKey, - SoftPath, - XPubKey, - fromMiniKey, - fromWif, - sha256, - withContext, - ) -import Haskoin.Network (Network (name), netByName) -import Haskoin.Transaction - ( Tx, - TxHash (TxHash, get), - nosigTxHash, - txHashToHex, - ) -import Haskoin.Util - ( MarshalJSON (marshalValue, unmarshalValue), - decodeHex, - eitherToMaybe, - encodeHex, - ) -import Network.Haskoin.Wallet.Util - ( encodeJsonPrettyLn, - textToAddrE, - xPubChecksum, - (), - ) -import Numeric.Natural (Natural) -import qualified System.Directory as D -import qualified System.IO as IO - -class HasFilePath a where - getFilePath :: Ctx -> a -> String - -data PubKeyDoc = PubKeyDoc - { documentPubKey :: !XPubKey, - documentNetwork :: !Network, - documentName :: !Text - } - deriving (Eq, Show) - -instance MarshalJSON Ctx PubKeyDoc where - unmarshalValue ctx = - withObject "pubkeydocument" $ \o -> do - net <- maybe mzero return . netByName =<< o .: "network" - PubKeyDoc - <$> (unmarshalValue (net, ctx) =<< o .: "xpubkey") - <*> return net - <*> (o .: "name") - - marshalValue ctx (PubKeyDoc k net name) = - object - [ "xpubkey" .= marshalValue (net, ctx) k, - "network" .= net.name, - "name" .= name - ] - -instance HasFilePath PubKeyDoc where - getFilePath ctx (PubKeyDoc xpub net _) = - net.name <> "-account-" <> cs (xPubChecksum ctx xpub) <> ".json" - -data TxSignData = TxSignData - { txSignDataTx :: !Tx, - txSignDataInputs :: ![Tx], - txSignDataInputPaths :: ![SoftPath], - txSignDataOutputPaths :: ![SoftPath], - txSignDataAccount :: !Natural, - txSignDataSigned :: !Bool, - txSignDataNetwork :: !Network - } - deriving (Eq, Show) - -instance MarshalJSON Ctx TxSignData where - unmarshalValue _ = - withObject "txsigndata" $ \o -> do - net <- maybe mzero return . netByName =<< o .: "network" - let f = eitherToMaybe . S.decode <=< decodeHex - t <- maybe mzero return . f =<< o .: "tx" - i <- maybe mzero return . mapM f =<< o .: "txinputs" - TxSignData t i - <$> o .: "inputpaths" - <*> o .: "outputpaths" - <*> o .: "account" - <*> o .: "signed" - <*> pure net - marshalValue _ (TxSignData t i oi op a s net) = - object - [ "tx" .= encodeHex (S.encode t), - "txinputs" .= (encodeHex . S.encode <$> i), - "inputpaths" .= oi, - "outputpaths" .= op, - "account" .= a, - "signed" .= s, - "network" .= net.name - ] - -instance HasFilePath TxSignData where - getFilePath _ (TxSignData tx _ _ _ _ s net) = - net.name <> heading <> cs (txChecksum tx) <> ".json" - where - heading = if s then "-signedtx-" else "-unsignedtx-" - -hwDataDirectory :: Maybe FilePath -> IO FilePath -hwDataDirectory subDirM = do - appDir <- D.getAppUserDataDirectory "hw" - let dir = maybe appDir (appDir ) subDirM - D.createDirectoryIfMissing True dir - return dir - -data HWFolder - = TxFolder - | PubKeyFolder - | SweepFolder !String - deriving (Eq, Show) - -toFolder :: HWFolder -> String -toFolder = - \case - TxFolder -> "transactions" - PubKeyFolder -> "pubkeys" - SweepFolder chksum -> "sweep-" <> chksum - -writeDoc :: (MarshalJSON Ctx a, HasFilePath a) => HWFolder -> a -> IO FilePath -writeDoc folder doc = - withContext $ \ctx -> do - dir <- hwDataDirectory $ Just $ toFolder folder - let path = dir getFilePath ctx doc - writeJsonFile path $ marshalValue ctx doc - return path - -txChecksum :: Tx -> Text -txChecksum = Text.take 8 . txHashToHex . nosigTxHash - -txsChecksum :: [Tx] -> Text -txsChecksum txs = - Text.take 8 $ txHashToHex $ TxHash $ sha256 $ mconcat bss - where - bss = BSS.fromShort . (.get) . (.get) . nosigTxHash <$> txs - --- JSON IO Helpers-- - -writeJsonFile :: String -> Json.Value -> IO () -writeJsonFile filePath doc = C8.writeFile filePath $ encodeJsonPrettyLn doc - -readJsonFile :: (Json.FromJSON a) => FilePath -> IO (Either String a) -readJsonFile = Json.eitherDecodeFileStrict' - -writeMarshalFile :: (MarshalJSON s a) => s -> String -> a -> IO () -writeMarshalFile s filePath a = writeJsonFile filePath $ marshalValue s a - -readMarshalFile :: (MarshalJSON s a) => s -> FilePath -> IO (Either String a) -readMarshalFile s filePath = do - vE <- readJsonFile filePath - return $ Json.parseEither (unmarshalValue s) =<< vE - --- Parse wallet dump files for sweeping -- - -readFileWords :: FilePath -> IO [[Text]] -readFileWords fp = do - strContents <- IO.readFile fp - return $ removeComments $ Text.words <$> Text.lines (cs strContents) - -parseAddrsFile :: Network -> [[Text]] -> [Address] -parseAddrsFile net = - withParser $ \w -> eitherToMaybe $ textToAddrE net $ strip "addr=" w - where - strip p w = fromMaybe w $ Text.stripPrefix p w - -parseSecKeysFile :: Network -> [[Text]] -> [SecKey] -parseSecKeysFile net = - withParser $ \w -> (.key) <$> (fromWif net w <|> fromMiniKey (cs w)) - -withParser :: (Text -> Maybe a) -> [[Text]] -> [a] -withParser parser = - mapMaybe go - where - go [] = Nothing - go (w : ws) = parser w <|> go ws - -removeComments :: [[Text]] -> [[Text]] -removeComments = - mapMaybe go - where - go [] = Nothing - go ws@(w : _) - | "#" `Text.isPrefixOf` w = Nothing - | otherwise = Just ws diff --git a/src/Network/Haskoin/Wallet/Parser.hs b/src/Network/Haskoin/Wallet/Parser.hs deleted file mode 100644 index 0df633e7..00000000 --- a/src/Network/Haskoin/Wallet/Parser.hs +++ /dev/null @@ -1,699 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Wallet.Parser where - -import Control.Monad.Except (runExceptT) -import Data.Either (fromRight) -import Data.List (isPrefixOf, nub, sort) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Haskoin.Crypto (Ctx) -import Haskoin.Network (Network (name), allNets, btc, netByName) -import Network.Haskoin.Wallet.AccountStore - ( accountMapKeys, - withAccountMap, - ) -import Network.Haskoin.Wallet.Amounts - ( AmountUnit (..), - readNatural, - ) -import Network.Haskoin.Wallet.Util (Page (Page)) -import Numeric.Natural (Natural) -import Options.Applicative - ( Alternative (many, some, (<|>)), - Parser, - ParserInfo, - action, - argument, - asum, - command, - commandGroup, - completeWith, - completer, - eitherReader, - flag, - footer, - fullDesc, - help, - helper, - hidden, - hsubparser, - info, - long, - maybeReader, - metavar, - mkCompleter, - option, - optional, - progDesc, - progDescDoc, - short, - showDefault, - showDefaultWith, - str, - strArgument, - strOption, - style, - switch, - value, - (<**>), - ) -import Options.Applicative.Help.Pretty - ( Color (Red), - Doc, - annotate, - color, - ) - -{- Command Parsers -} - -data Command - = CommandMnemonic - { commandEntropy :: !Natural, - commandUseDice :: !Bool, - commandSplitIn :: !Natural - } - | CommandCreateAcc - { commandName :: !Data.Text.Text, - commandNetwork :: !Network, - commandDerivation :: !(Maybe Natural), - commandSplitIn :: !Natural - } - | CommandTestAcc - { commandMaybeAcc :: !(Maybe Data.Text.Text), - commandSplitIn :: !Natural - } - | CommandImportAcc - { commandFilePath :: !FilePath - } - | CommandRenameAcc - { commandOldName :: !Data.Text.Text, - commandNewName :: !Data.Text.Text - } - | CommandAccounts - | CommandResetAcc - { commandMaybeAcc :: !(Maybe Data.Text.Text) - } - | CommandBalance - { commandMaybeAcc :: !(Maybe Data.Text.Text) - } - | CommandAddresses - { commandMaybeAcc :: !(Maybe Data.Text.Text), - commandPage :: !Page - } - | CommandReceive - { commandLabel :: !Data.Text.Text, - commandMaybeAcc :: !(Maybe Data.Text.Text) - } - | CommandTransactions - { commandMaybeAcc :: !(Maybe Data.Text.Text), - commandPage :: !Page - } - | CommandPrepareTx - { commandRecipients :: ![(Data.Text.Text, Data.Text.Text)], - commandMaybeAcc :: !(Maybe Data.Text.Text), - commandUnit :: !AmountUnit, - commandFeeByte :: !Natural, - commandDust :: !Natural, - commandRcptPay :: !Bool - } - | CommandReview - { commandFilePath :: !FilePath - } - | CommandSignTx - { commandFilePath :: !FilePath, - commandSplitIn :: !Natural - } - | CommandSendTx - { commandFilePath :: !FilePath - } - | CommandVersion - | CommandPrepareSweep - { commandSweepAddrs :: ![Data.Text.Text], - commandMaybeFilePath :: !(Maybe FilePath), - commandMaybeAcc :: !(Maybe Data.Text.Text), - commandFeeByte :: !Natural, - commandDust :: !Natural - } - | CommandSignSweep - { commandSweepPath :: !FilePath, - commandSecKeyPath :: !FilePath, - commandMaybeAcc :: !(Maybe Data.Text.Text) - } - | CommandRollDice - { commandCount :: !Natural - } - deriving (Eq, Show) - -programParser :: Ctx -> ParserInfo Command -programParser ctx = - info (commandParser ctx <**> helper) $ - mconcat - [ fullDesc, - progDesc - "hw is a lightweight BIP44 wallet for bitcoin and bitcoin-cash. \ - \ It is designed so that mnemonic generation, account creation and\ - \ transaction signing can happen on an offline, air-gapped computer.\ - \ It will always ask for the mnemonic when signing and never store\ - \ private keys on disk." - ] - -commandParser :: Ctx -> Parser Command -commandParser ctx = - asum - [ hsubparser $ - mconcat - [ commandGroup "Mnemonic and account management", - command "mnemonic" mnemonicParser, - command "createacc" createAccParser, - command "testacc" (testAccParser ctx), - command "importacc" importAccParser, - command "renameacc" (renameAccParser ctx), - command "accounts" accountsParser, - command "balance" (balanceParser ctx), - command "resetacc" (resetAccParser ctx), - metavar "COMMAND", - style (const "COMMAND --help") - ], - hsubparser $ - mconcat - [ commandGroup "Address management", - command "addresses" (addressesParser ctx), - command "receive" (receiveParser ctx), - hidden - ], - hsubparser $ - mconcat - [ commandGroup "Transaction management", - command "transactions" (transactionsParser ctx), - command "preparetx" (prepareTxParser ctx), - command "review" reviewParser, - command "signtx" signTxParser, - command "sendtx" sendTxParser, - hidden - ], - hsubparser $ - mconcat - [ commandGroup "Utilities", - command "version" versionParser, - command "preparesweep" (prepareSweepParser ctx), - command "signsweep" (signSweepParser ctx), - command "rolldice" rollDiceParser, - hidden - ] - ] - -offline :: Doc -> Maybe Doc -offline s = Just $ s <> annotate (color Red) " (Offline)" - -mnemonicParser :: ParserInfo Command -mnemonicParser = - info (CommandMnemonic <$> entropyOption <*> diceOption <*> splitInOption) $ - mconcat - [ progDescDoc $ offline "Generate a mnemonic", - footer - "Generate a mnemonic using the systems entropy pool.\ - \ By default it should be /dev/random on linux machines.\ - \ If you use the --dice option, the additional dice entropy will be\ - \ mixed with the system entropy. You should ideally run this\ - \ command on an offline (air-gapped) computer. The mnemonic will NOT\ - \ be stored on disk. It will only be printed to the screen and you\ - \ should write it down and keep it in a secure location. If you\ - \ choose to use the --split option, the mnemonic will be split into\ - \ different pieces that you can write down and store in separate\ - \ locations. ALL the pieces will be required for signing so make\ - \ sure you have copies of all of them." - ] - -createAccParser :: ParserInfo Command -createAccParser = - info - ( CommandCreateAcc - <$> textArg "Name of the new account" - <*> networkOption - <*> derivationOption - <*> splitInOption - ) - $ mconcat - [ progDescDoc $ offline "Create a new account", - footer - "Create a new account with a given name. This command requires you\ - \ to type your mnemonic and should ideally be run on an offline\ - \ computer. If you have a split mnemonic, you will need to use the\ - \ --split option. This command will derive the public component of\ - \ the account and store it on disk. No private keys will be stored\ - \ on disk. You will be asked for the mnemonic again when you will\ - \ sign transactions. The public key file for the account will be\ - \ stored in ~/.hw/pubkeys which can be imported on an online\ - \ computer." - ] - -testAccParser :: Ctx -> ParserInfo Command -testAccParser ctx = - info (CommandTestAcc <$> accountOption ctx <*> splitInOption) $ - mconcat - [ progDescDoc $ offline "Test your mnemonic and passphrase", - footer - "You should test regularly the mnemonic and passphrase of your account.\ - \ This command will derive the public key associated with the account\ - \ and make sure that it matches the account on file." - ] - -importAccParser :: ParserInfo Command -importAccParser = - info (CommandImportAcc <$> fileArgument "Path of the account file") $ - mconcat - [ progDesc "Import a public key account file", - footer - "When creating a new account using the createacc command, a\ - \ public key account file will be generated in ~/.hw/pubkeys\ - \ which can be imported into a different computer with importacc.\ - \ This will allow you to monitor the transactions of that account." - ] - -renameAccParser :: Ctx -> ParserInfo Command -renameAccParser ctx = - info - ( CommandRenameAcc - <$> accountArg ctx "Old account name" - <*> textArg "New account name" - ) - $ mconcat [progDesc "Rename an account"] - -accountsParser :: ParserInfo Command -accountsParser = - info (pure CommandAccounts) $ mconcat [progDesc "Display all accounts"] - -balanceParser :: Ctx -> ParserInfo Command -balanceParser ctx = - info (CommandBalance <$> accountOption ctx) $ - mconcat [progDesc "Get the account balance"] - -resetAccParser :: Ctx -> ParserInfo Command -resetAccParser ctx = - info (CommandResetAcc <$> accountOption ctx) $ - mconcat - [ progDesc "Reset the external and internal derivation indices", - footer - "If your account is somehow out of sync with the blockchain, you can\ - \ call resetacc to scan the blockchain and reset the indices for your\ - \ internal and external addresses." - ] - -addressesParser :: Ctx -> ParserInfo Command -addressesParser ctx = - info - ( CommandAddresses - <$> accountOption ctx - <*> (Page <$> limitOption <*> offsetOption) - ) - $ mconcat [progDesc "List the latest receiving addresses in the account"] - -receiveParser :: Ctx -> ParserInfo Command -receiveParser ctx = - info - ( CommandReceive - <$> textArg "Specify a label for the address" - <*> accountOption ctx - ) - $ mconcat [progDesc "Get a new address for receiving a payment"] - -transactionsParser :: Ctx -> ParserInfo Command -transactionsParser ctx = - info - ( CommandTransactions - <$> accountOption ctx - <*> (Page <$> limitOption <*> offsetOption) - ) - $ mconcat [progDesc "Display the transactions in an account"] - -prepareTxParser :: Ctx -> ParserInfo Command -prepareTxParser ctx = - info - ( CommandPrepareTx - <$> some recipientArg - <*> accountOption ctx - <*> unitOption - <*> feeOption - <*> dustOption - <*> rcptPayOption - ) - $ mconcat - [ progDesc "Prepare a new unsigned transaction", - footer - "You can call preparetx on an online computer to create an unsigned\ - \ transaction that spends funds from your account. This can be done\ - \ without having access to your mnemonic. A file containing your\ - \ unsigned transaction will be created in ~/.hw/transactions.\ - \ You can then inspect the transaction using the review command.\ - \ If you are unhappy with the transaction, you can simply delete the\ - \ file in ~/.hw/transactions. Otherwise, you can move the transaction\ - \ file to an offline computer and sign it with the signtx command.\ - \ Once signed, you can move the signed transaction file back to an\ - \ online computer and broadcast it using the sendtx command." - ] - -reviewParser :: ParserInfo Command -reviewParser = - info (CommandReview <$> fileArgument "Path of the transaction file") $ - mconcat - [ progDesc "Review the contents of a transaction file", - footer - "The review command allows you to inspect the details of a transaction\ - \ file that was created using the preparetx command. This might be\ - \ useful to check that everything is correct before signing (signtx) and\ - \ broadcasting (sendtx) the transaction." - ] - -signTxParser :: ParserInfo Command -signTxParser = - info - ( CommandSignTx - <$> fileArgument "Path of the transaction file" - <*> splitInOption - ) - $ mconcat - [ progDescDoc $ - offline "Sign a transaction that was created with preparetx", - footer - "The signtx command allows you to sign an unsigned transaction file\ - \ that was created using the preparetx command. Ideally you want to\ - \ run signtx on an offline computer as you will have to type the\ - \ mnemonic. Once signed, a new signed transaction file will be created\ - \ in ~/.hw/transactions. You can move this file to an online computer\ - \ and broadcast it using the sendtx command. The mnemonic is only used\ - \ to sign the transaction. The mnemonic or the private keys will not\ - \ be stored on disk. If you want to sign another transaction, you will\ - \ have to enter the mnemonic again. If you have a split mnemonic, you\ - \ will have to use the --split option." - ] - -sendTxParser :: ParserInfo Command -sendTxParser = - info (CommandSendTx <$> fileArgument "Path of the transaction file") $ - mconcat [progDesc "Broadcast a signed transaction file to the network"] - -versionParser :: ParserInfo Command -versionParser = - info (pure CommandVersion) $ - mconcat - [progDesc "Display the version of hw"] - -prepareSweepParser :: Ctx -> ParserInfo Command -prepareSweepParser ctx = - info - ( CommandPrepareSweep - <$> many (addressArg "List of addresses to sweep") - <*> maybeFileOption "File containing addresses to sweep" - <*> accountOption ctx - <*> feeOption - <*> dustOption - ) - $ mconcat - [ progDesc "Sweep funds into this wallet", - footer - "This utility command will prepare a set of unsigned transactions\ - \ that will send all the funds available in the given addresses to\ - \ your hw account. The typical use case for this command is to\ - \ migrate an old wallet to hw. You can pass the addresses on the\ - \ command line or they can be parsed from a file. The preparesweep\ - \ command will randomize all the coins and create a number of transactions\ - \ containing between 1 and 5 inputs and 2 outputs. The transactions\ - \ will be available in the ~/.hw/sweep-[id] folder. You can then\ - \ use the signsweep command to sign the transactions." - ] - -signSweepParser :: Ctx -> ParserInfo Command -signSweepParser ctx = - info - ( CommandSignSweep - <$> dirArgument "Folder containing the sweep transactions" - <*> fileArgument "Path to the file containing the private keys" - <*> accountOption ctx - ) - $ mconcat - [ progDesc "Sign all the transactions contained in a sweep folder", - footer - "The private keys have to be provided in a separate file.\ - \ The currently supported formats are WIF and MiniKey." - ] - -rollDiceParser :: ParserInfo Command -rollDiceParser = - info (CommandRollDice <$> diceCountArgument) $ - mconcat - [progDesc "Roll dice with the systems internal entropy"] - -{- Option Parsers -} - -textArg :: String -> Parser Data.Text.Text -textArg desc = argument str $ mconcat [help desc, metavar "TEXT"] - -fileArgument :: String -> Parser FilePath -fileArgument desc = - strArgument $ - mconcat - [ help desc, - metavar "FILENAME", - action "file" - ] - -dirArgument :: String -> Parser FilePath -dirArgument desc = - strArgument $ - mconcat - [ help desc, - metavar "DIRNAME", - action "file" - ] - -maybeFileOption :: String -> Parser (Maybe FilePath) -maybeFileOption desc = - optional $ - strOption $ - mconcat - [ long "file", - help desc, - metavar "FILENAME", - action "file" - ] - -diceOption :: Parser Bool -diceOption = - switch $ - mconcat - [ short 'd', - long "dice", - help "Provide additional entropy using 6-sided dice", - showDefault - ] - -splitInOption :: Parser Natural -splitInOption = - option (eitherReader $ f . cs) $ - mconcat - [ short 's', - long "split", - help - "Split the mnemonic into different pieces using an xor algorithm.\ - \ All the pieces will be required for signing.", - metavar "INT", - value 1 - ] - where - f s = - case readNatural s of - Just n -> - if n >= 2 && n <= 12 - then Right n - else Left "Split value has to be in the range [2-12]" - Nothing -> Left "Could not parse the split option" - -entropyOption :: Parser Natural -entropyOption = - option (maybeReader f) $ - mconcat - [ short 'e', - long "entropy", - help - "Amount of entropy to use in bytes. Valid values are [16,20..32]", - metavar "BYTES", - value 16, - showDefault, - completeWith valid - ] - where - valid = ["16", "20", "24", "28", "32"] - f s - | s `elem` valid = fromIntegral <$> readNatural (cs s) - | otherwise = Nothing - -derivationOption :: Parser (Maybe Natural) -derivationOption = - optional $ - option (maybeReader $ readNatural . cs) $ - mconcat - [ short 'd', - long "derivation", - help "Specify a different bip44 account derivation", - metavar "INT" - ] - -networkOption :: Parser Network -networkOption = - option (eitherReader (f . netByName)) $ - mconcat - [ short 'n', - long "network", - help $ - unwords $ - "Specify which coin network to use: " : ((.name) <$> allNets), - metavar "TEXT", - value btc, - showDefaultWith (.name), - completeWith ((.name) <$> allNets) - ] - where - f :: Maybe Network -> Either String Network - f Nothing = - Left $ - unwords $ - "Invalid network name. Select one of the following:" - : ((.name) <$> allNets) - f (Just res) = Right res - -accountOption :: Ctx -> Parser (Maybe Data.Text.Text) -accountOption ctx = - optional $ - strOption $ - mconcat - [ short 'a', - long "account", - help "Specify the account to use for this command", - metavar "TEXT", - completer (mkCompleter $ accountCompleter ctx) - ] - -accountArg :: Ctx -> String -> Parser Data.Text.Text -accountArg ctx desc = - argument str $ - mconcat - [ help desc, - metavar "TEXT", - completer (mkCompleter $ accountCompleter ctx) - ] - -accountCompleter :: Ctx -> String -> IO [String] -accountCompleter ctx pref = do - keys <- fromRight [] <$> run - return $ sort $ nub $ filter (pref `isPrefixOf`) (cs <$> keys) - where - run = runExceptT $ withAccountMap ctx accountMapKeys - -recipientArg :: Parser (Data.Text.Text, Data.Text.Text) -recipientArg = - (,) <$> addressArg "Recipient address" <*> amountArg - -amountArg :: Parser Data.Text.Text -amountArg = - strArgument $ - mconcat - [ help "Recipient amount", - metavar "AMOUNT" - ] - -addressArg :: String -> Parser Data.Text.Text -addressArg desc = - strArgument $ - mconcat - [ help desc, - metavar "ADDRESS" - ] - -diceCountArgument :: Parser Natural -diceCountArgument = - argument (maybeReader $ readNatural . cs) $ - mconcat - [ help "Number of dice to roll", - metavar "INT" - ] - -rcptPayOption :: Parser Bool -rcptPayOption = - switch $ - mconcat - [ short 'r', - long "recipientpay", - help "The transaction fee will be deducted from the recipient amounts", - showDefault - ] - -offsetOption :: Parser Natural -offsetOption = - option (maybeReader $ readNatural . cs) $ - mconcat - [ short 'o', - long "offset", - help "Offset the result set", - metavar "INT", - value 0, - showDefault - ] - -limitOption :: Parser Natural -limitOption = - option (maybeReader $ readNatural . cs) $ - mconcat - [ short 'l', - long "limit", - help "Limit the result set", - metavar "INT", - value 5, - showDefault - ] - -feeOption :: Parser Natural -feeOption = - option (maybeReader $ readNatural . cs) $ - mconcat - [ short 'f', - long "fee", - help "Fee to pay in satoshi/bytes", - metavar "INT", - value 200, - showDefault - ] - -dustOption :: Parser Natural -dustOption = - option (maybeReader $ readNatural . cs) $ - mconcat - [ short 'd', - long "dust", - help "Smallest allowed satoshi value for change outputs", - metavar "INT", - value 5430, - showDefault - ] - -unitOption :: Parser AmountUnit -unitOption = satoshiOption <|> bitOption - -satoshiOption :: Parser AmountUnit -satoshiOption = - flag UnitBitcoin UnitSatoshi $ - mconcat - [ short 's', - long "satoshi", - help "Use satoshis for parsing amounts (default: bitcoin)" - ] - -bitOption :: Parser AmountUnit -bitOption = - flag UnitBitcoin UnitBit $ - mconcat - [ short 'b', - long "bit", - help "Use bits for parsing amounts (default: bitcoin)" - ] diff --git a/src/Network/Haskoin/Wallet/Signing.hs b/src/Network/Haskoin/Wallet/Signing.hs deleted file mode 100644 index 94dee74c..00000000 --- a/src/Network/Haskoin/Wallet/Signing.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Network.Haskoin.Wallet.Signing where - -import Control.Arrow (second) -import Control.Monad (forM, unless, when, (<=<)) -import Control.Monad.Except - ( MonadError (throwError), - liftEither, - runExceptT, - ) -import Control.Monad.State - ( MonadIO (..), - MonadState (get, put), - MonadTrans (lift), - StateT, - evalStateT, - gets, - ) -import qualified Data.ByteString as BS -import Data.Default (def) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Data.Text (Text) -import Data.Word (Word64) -import Haskoin.Address (Address) -import Haskoin.Crypto - ( Ctx, - SecKey, - SoftPath, - XPrvKey (key), - XPubKey, - derivePath, - deriveXPubKey, - makeXPrvKey, - mnemonicToSeed, - ) -import Haskoin.Network (Network) -import qualified Haskoin.Store.Data as Store -import Haskoin.Store.WebClient - ( ApiConfig (ApiConfig, host), - GetAddrsUnspent (GetAddrsUnspent), - GetTxsRaw (GetTxsRaw), - LimitsParam (limit), - apiBatch, - ) -import Haskoin.Transaction - ( OutPoint (hash), - SigInput (outpoint, script, value), - Tx (inputs, outputs), - TxIn (outpoint, script), - buildAddrTx, - chooseCoins, - guessTxFee, - signTx, - verifyStdTx, - ) -import Haskoin.Util (maybeToEither) -import Network.Haskoin.Wallet.AccountStore - ( AccountStore, - accountStoreAccount, - bip44Deriv, - genExtAddress, - genIntAddress, - storeAddressMap, - ) -import Network.Haskoin.Wallet.FileIO - ( TxSignData - ( TxSignData, - txSignDataInputPaths, - txSignDataSigned, - txSignDataTx - ), - ) -import Network.Haskoin.Wallet.TxInfo - ( MyInputs (myInputsSigInput), - OtherInputs (otherInputsSigInput), - TxInfo, - UnsignedTxInfo (unsignedTxInfoMyInputs, unsignedTxInfoOtherInputs), - parseTxSignData, - unsignedToTxInfo, - ) -import Network.Haskoin.Wallet.Util - ( addrToText2, - liftExcept, - safeSubtract, - ) -import Numeric.Natural (Natural) -import System.Random (Random (randomR), StdGen, newStdGen) - --- Building Transactions -- - -conf :: Network -> ApiConfig -conf net = ApiConfig net (def :: ApiConfig).host - -buildTxSignData :: - (MonadIO m, MonadError String m, MonadState AccountStore m) => - Network -> - Ctx -> - [(Address, Natural)] -> - Natural -> - Natural -> - Bool -> - m TxSignData -buildTxSignData net ctx rcpts feeByte dust rcptPay - | null rcpts = throwError "No recipients provided" - | otherwise = do - origStore <- get - acc <- liftEither =<< gets accountStoreAccount - walletAddrMap <- gets (storeAddressMap ctx) - let req = GetAddrsUnspent (Map.keys walletAddrMap) def - Store.SerialList allCoins <- liftExcept $ apiBatch ctx 20 (conf net) req - (change, changeDeriv) <- genIntAddress ctx - gen <- liftIO newStdGen - (tx, pickedCoins) <- - liftEither $ - buildWalletTx net ctx gen rcpts change allCoins feeByte dust rcptPay - (inDerivs, outDerivs') <- - liftEither $ getDerivs pickedCoins rcpts walletAddrMap - let noChange = length tx.outputs == length rcpts - outDerivs = - if noChange - then outDerivs' - else changeDeriv : outDerivs' - -- Get dependant transactions - let depTxHash = (.hash) . (.outpoint) <$> tx.inputs - depTxsRaw <- liftExcept $ apiBatch ctx 20 (conf net) (GetTxsRaw depTxHash) - let depTxs = depTxsRaw.get - when noChange $ put origStore -- Rollback store changes - return $ TxSignData tx depTxs inDerivs outDerivs acc False net - -buildWalletTx :: - Network -> - Ctx -> - StdGen -> -- Randomness for coin selection and change address order - [(Address, Natural)] -> -- recipients - Address -> -- change - [Store.Unspent] -> -- Coins to choose from - Natural -> -- Fee per byte - Natural -> -- Dust - Bool -> -- Recipients Pay for Fee - Either String (Tx, [Store.Unspent]) -buildWalletTx net ctx gen rcptsN change coins feeByteN dustN rcptPay = - flip evalStateT gen $ do - rdmCoins <- randomShuffle coins - (pickedCoins, changeAmnt) <- - lift $ chooseCoins tot feeCoinSel (length rcptsN + 1) False rdmCoins - let nOuts = - if changeAmnt <= dust - then length rcptsN - else length rcptsN + 1 - totFee = - guessTxFee (fromIntegral feeByteN) nOuts (length pickedCoins) - rcptsPayN <- - if rcptPay - then lift $ makeRcptsPay (fromIntegral totFee) rcptsN - else return rcptsN - let rcpts = second fromIntegral <$> rcptsPayN - allRcpts - | changeAmnt <= dust = rcpts - | otherwise = (change, changeAmnt) : rcpts - ops = (.outpoint) <$> pickedCoins - when (any ((<= dust) . snd) allRcpts) $ - lift $ - Left "Recipient output is smaller than the dust value" - rdmRcpts <- randomShuffle allRcpts - tx <- lift $ buildAddrTx net ctx ops =<< mapM (addrToText2 net) rdmRcpts - return (tx, pickedCoins) - where - feeCoinSel = - if rcptPay - then 0 - else fromIntegral feeByteN :: Word64 - dust = fromIntegral dustN :: Word64 - tot = fromIntegral $ sum $ snd <$> rcptsN :: Word64 - -makeRcptsPay :: - Natural -> [(Address, Natural)] -> Either String [(Address, Natural)] -makeRcptsPay fee rcpts = - mapM f rcpts - where - f (a, v) = (a,) <$> maybeToEither err (v `safeSubtract` toPay) - err = "Recipients can't pay for the fee" - (q, r) = fee `quotRem` fromIntegral (length rcpts) - toPay = if r == 0 then q else q + 1 - -getDerivs :: - [Store.Unspent] -> - [(Address, Natural)] -> - Map Address SoftPath -> - Either String ([SoftPath], [SoftPath]) -getDerivs pickedCoins rcpts walletAddrMap = do - selCoinAddrs <- maybeToEither err $ mapM (.address) pickedCoins - let inDerivs = - Map.elems $ - Map.restrictKeys walletAddrMap $ - Set.fromList selCoinAddrs - return (inDerivs, outDerivs) - where - outDerivs = Map.elems $ Map.intersection walletAddrMap $ Map.fromList rcpts - err = "Could not read unspent address in getDerivs" - --- Signing Transactions -- - -signingKey :: Network -> Ctx -> Text -> Text -> Natural -> Either String XPrvKey -signingKey net ctx pass mnem acc = do - seed <- mnemonicToSeed pass mnem - return $ derivePath ctx (bip44Deriv net acc) (makeXPrvKey seed) - -signWalletTx :: - Ctx -> - TxSignData -> - XPrvKey -> - Either String (TxSignData, TxInfo) -signWalletTx ctx tsd@TxSignData {txSignDataInputPaths = inPaths} signKey = - signTxWithKeys ctx tsd publicKey prvKeys - where - publicKey = deriveXPubKey ctx signKey - prvKeys = (.key) . (\p -> derivePath ctx p signKey) <$> inPaths - -signTxWithKeys :: - Ctx -> - TxSignData -> - XPubKey -> - [SecKey] -> - Either String (TxSignData, TxInfo) -signTxWithKeys ctx tsd@(TxSignData tx _ _ _ _ signed net) publicKey secKeys = do - when signed $ Left "The transaction is already signed" - txInfoU <- parseTxSignData net ctx publicKey tsd - -- signing - let myInputs = unsignedTxInfoMyInputs txInfoU - othInputs = unsignedTxInfoOtherInputs txInfoU - mySigInputs = mconcat $ myInputsSigInput <$> Map.elems myInputs - othSigInputs = mconcat $ otherInputsSigInput <$> Map.elems othInputs - sigInputs = mySigInputs <> othSigInputs - signedTx <- signTx net ctx tx sigInputs secKeys - -- validation - let f i = (i.script, i.value, i.outpoint) - vDat = f <$> sigInputs - isSigned = noEmptyInputs signedTx && verifyStdTx net ctx signedTx vDat - unless isSigned $ Left "The transaction could not be signed" - return - ( tsd {txSignDataTx = signedTx, txSignDataSigned = True}, - unsignedToTxInfo signedTx txInfoU - ) - -noEmptyInputs :: Tx -> Bool -noEmptyInputs = (not . any BS.null) . fmap (.script) . (.inputs) - --- Transaction Sweeping -- - -buildSweepSignData :: - (MonadIO m, MonadError String m, MonadState AccountStore m) => - Network -> - Ctx -> - [Address] -> - Natural -> - Natural -> - m [TxSignData] -buildSweepSignData net ctx addrs feeByte dust - | null addrs = throwError "No addresses provided to sweep" - | otherwise = do - acc <- liftEither =<< gets accountStoreAccount - walletAddrMap <- gets (storeAddressMap ctx) - let req = GetAddrsUnspent addrs def {limit = Just 0} - Store.SerialList coins <- - liftExcept $ apiBatch ctx 20 (conf net) req - when (null coins) $ - throwError "There are no coins to sweep in those addresses" - gen <- liftIO newStdGen - txs <- evalStateT (buildSweepTxs net ctx coins feeByte dust) gen - forM txs $ \(tx, pickedCoins, outDerivs) -> do - let depTxHash = (.hash) . (.outpoint) <$> (.inputs) tx - depTxsRaw <- - liftExcept $ - apiBatch ctx 20 (conf net) (GetTxsRaw depTxHash) - let depTxs = depTxsRaw.get - (inDerivs, _) <- liftEither $ getDerivs pickedCoins [] walletAddrMap - return $ TxSignData tx depTxs inDerivs outDerivs acc False net - -buildSweepTxs :: - (MonadError String m, MonadState AccountStore m) => - Network -> - Ctx -> - [Store.Unspent] -> - Natural -> - Natural -> - StateT StdGen m [(Tx, [Store.Unspent], [SoftPath])] -buildSweepTxs net ctx allCoins feeByte dust = do - origStore <- lift get - liftEither <=< retryEither 10 $ do - lift $ put origStore -- Retry with the original store - shuffledCoins <- randomShuffle allCoins - runExceptT $ go shuffledCoins [] - where - go [] acc = return acc - go coins acc = do - nIns <- randomRange 1 5 - let (pickedCoins, restCoins) = splitAt nIns coins - coinsTot = sum $ (.value) <$> pickedCoins - fee = guessTxFee (fromIntegral feeByte) 2 (length pickedCoins) - amntTot = coinsTot - fee - amntMin = fromIntegral dust + 1 - when (amntTot < 2 * amntMin) $ - throwError "Could not find a sweep solution" - amnt1 <- randomRange amntMin (amntTot - amntMin) - let amnt2 = amntTot - amnt1 - (addr1, deriv1) <- lift $ lift (genExtAddress ctx) - (addr2, deriv2) <- lift $ lift (genExtAddress ctx) - rcpts <- randomShuffle [(addr1, amnt1), (addr2, amnt2)] - rcptsTxt <- liftEither $ mapM (addrToText2 net) rcpts - tx <- - liftEither $ - buildAddrTx net ctx ((.outpoint) <$> pickedCoins) rcptsTxt - go restCoins ((tx, pickedCoins, [deriv1, deriv2]) : acc) - --- Utilities -- - -randomRange :: (Random a, MonadState StdGen m) => a -> a -> m a -randomRange low hi = do - gen <- get - let (res, newGen) = randomR (low, hi) gen - put newGen - return res - -randomShuffle :: (MonadState StdGen m) => [a] -> m [a] -randomShuffle [] = return [] -randomShuffle [x] = return [x] -randomShuffle xs = do - i <- randomRange 0 (length xs - 1) - case splitAt i xs of - (as, e : bs) -> (e :) <$> randomShuffle (as <> bs) - _ -> error "randomShuffle" - -retryEither :: - (MonadState StdGen m) => - Natural -> - m (Either err a) -> - m (Either err a) -retryEither 0 _ = error "Must retryEither at least 1 time" -retryEither 1 m = m -retryEither i m = either (const $ retryEither (i - 1) m) (return . Right) =<< m diff --git a/stack.yaml b/stack.yaml index 0f7528bd..82c4babc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ nix: - pkg-config extra-deps: - git: https://github.com/haskoin/haskoin-core.git - commit: 520b0b241f7e108771b0b0fd274a7c329f65ce1c + commit: 88ff19c35ad2f3d8afdf2a2970342990b40b6f40 - git: https://github.com/haskoin/haskoin-store.git commit: bc8b99428fedbe88b3dcf80dd4ae298b682112fb subdirs: diff --git a/stack.yaml.lock b/stack.yaml.lock index 60b24226..8f1a7b9b 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,15 +5,15 @@ packages: - completed: - commit: 520b0b241f7e108771b0b0fd274a7c329f65ce1c + commit: 88ff19c35ad2f3d8afdf2a2970342990b40b6f40 git: https://github.com/haskoin/haskoin-core.git name: haskoin-core pantry-tree: - sha256: 5b6b7ddc6eae4d0c56f8af5f2485476a47ea82ecfcc97a70f1ff3524f3f269d9 + sha256: a323582c92bcc45fc6d4f567ed69f9d1d65c3fcd30c0b4d18ac77d0a59b8ca62 size: 7357 - version: 1.0.3 + version: 1.0.4 original: - commit: 520b0b241f7e108771b0b0fd274a7c329f65ce1c + commit: 88ff19c35ad2f3d8afdf2a2970342990b40b6f40 git: https://github.com/haskoin/haskoin-core.git - completed: commit: bc8b99428fedbe88b3dcf80dd4ae298b682112fb diff --git a/test/Network/Haskoin/Wallet/AmountsSpec.hs b/test/Haskoin/Wallet/AmountsSpec.hs similarity index 93% rename from test/Network/Haskoin/Wallet/AmountsSpec.hs rename to test/Haskoin/Wallet/AmountsSpec.hs index 6547abaa..150dbd37 100644 --- a/test/Network/Haskoin/Wallet/AmountsSpec.hs +++ b/test/Haskoin/Wallet/AmountsSpec.hs @@ -1,16 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.Haskoin.Wallet.AmountsSpec where +module Haskoin.Wallet.AmountsSpec where -import Network.Haskoin.Wallet.Amounts - ( AmountUnit (..), - readAmount, - readIntegerAmount, - showAmount, - showIntegerAmount, - ) -import Network.Haskoin.Wallet.TestUtils (genNatural) +import Haskoin.Wallet.Amounts +import Haskoin.Wallet.TestUtils (genNatural) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary (arbitrary), elements, forAll) diff --git a/test/Haskoin/Wallet/CommandsSpec.hs b/test/Haskoin/Wallet/CommandsSpec.hs new file mode 100644 index 00000000..ba7d10ed --- /dev/null +++ b/test/Haskoin/Wallet/CommandsSpec.hs @@ -0,0 +1,768 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields -fno-warn-orphans #-} + +module Haskoin.Wallet.CommandsSpec where + +import Conduit (MonadIO, liftIO) +import Control.Arrow (second) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans (lift) +import Data.Default (def) +import Data.Either +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Serialize as S +import Data.Text (Text) +import Database.Esqueleto.Legacy hiding (isNothing) +import qualified Database.Persist as P +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Signing +import Haskoin.Wallet.SigningSpec +import Haskoin.Wallet.TestUtils +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Test.Hspec + +identityTests :: Ctx -> IdentityTests +identityTests ctx = + def + { jsonTests = + [ JsonBox $ arbitraryDBAccount btc ctx, + JsonBox $ arbitraryDBAddress btc, + JsonBox arbitraryAddressBalance, + JsonBox $ arbitraryTxSignData btc ctx + ], + marshalJsonTests = + [ MarshalJsonBox ((btc,) <$> arbitraryJsonCoin), + MarshalJsonBox ((ctx,) <$> arbitraryPubKeyDoc ctx), + MarshalJsonBox (((btc, ctx),) <$> arbitraryTxInfo btc ctx), + MarshalJsonBox (((btc, ctx),) <$> arbitraryUnsignedTxInfo btc ctx), + MarshalJsonBox (((btc, ctx),) <$> arbitraryNoSigTxInfo btc ctx), + MarshalJsonBox ((ctx,) <$> arbitraryResponse btc ctx) + ] + } + +spec :: Spec +spec = do + let cfg = def :: Config + prepareContext $ \ctx -> do + testIdentity $ identityTests ctx + describe "Database" $ do + bestSpec + accountSpec ctx + extAddressSpec ctx cfg + intAddressSpec ctx cfg + txsSpec ctx + coinSpec ctx + pendingTxsSpec ctx cfg + +liftTest :: (MonadIO m) => Expectation -> m () +liftTest = liftIO + +shouldBeLeft :: (Show a) => ExceptT String (DB IO) a -> DB IO () +shouldBeLeft action = liftTest . (`shouldSatisfy` isLeft) =<< runExceptT action + +shouldBeLeft' :: + (Show a, Eq a) => String -> ExceptT String (DB IO) a -> DB IO () +shouldBeLeft' err action = + liftTest . (`shouldBe` Left err) =<< runExceptT action + +dbShouldBe :: (Show a, Eq a) => DB IO a -> a -> DB IO () +dbShouldBe action a = liftTest . (`shouldBe` a) =<< action + +dbShouldBeE :: + (Show a, Eq a) => + ExceptT String (DB IO) a -> + a -> + ExceptT String (DB IO) () +dbShouldBeE action a = liftTest . (`shouldBe` a) =<< action + +dbShouldSatisfy :: (Show a) => DB IO a -> (a -> Bool) -> DB IO () +dbShouldSatisfy action f = liftTest . (`shouldSatisfy` f) =<< action + +testNewAcc :: Ctx -> Text -> ExceptT String (DB IO) (DBAccountId, DBAccount) +testNewAcc ctx name = do + let fp = forceRight $ walletFingerprint btc ctx mnemPass + d <- lift $ nextAccountDeriv fp btc + let prv = forceRight $ signingKey btc ctx mnemPass d + pub = deriveXPubKey ctx prv + insertAccount btc ctx fp name pub + +testNewAcc2 :: Ctx -> Text -> ExceptT String (DB IO) (DBAccountId, DBAccount) +testNewAcc2 ctx name = do + let fp = forceRight $ walletFingerprint btc ctx mnemPass2 + d <- lift $ nextAccountDeriv fp btc + let prv = forceRight $ signingKey btc ctx mnemPass2 d + pub = deriveXPubKey ctx prv + insertAccount btc ctx fp name pub + +bestSpec :: Spec +bestSpec = + it "can insert and get the best block" $ + runDBMemory $ do + res1 <- getBest btcTest + liftTest $ res1 `shouldBe` Nothing + updateBest + btc + "00000000000000000004727b3cc0946dc2054f59e362369e0437325c0a992efb" + 814037 + updateBest + btcTest + "000000000000001400d91785c92efc15ccfc1949e8581f06db7914a707c3f81d" + 2535443 + res2 <- getBest btc + res3 <- getBest btcTest + liftTest $ do + res2 + `shouldBe` Just + ( "00000000000000000004727b3cc0946dc2054f59e362369e0437325c0a992efb", + 814037 + ) + res3 + `shouldBe` Just + ( "000000000000001400d91785c92efc15ccfc1949e8581f06db7914a707c3f81d", + 2535443 + ) + +accountSpec :: Ctx -> Spec +accountSpec ctx = + it "can create and rename accounts" $ do + runDBMemoryE $ do + -- No accounts + lift $ shouldBeLeft $ getAccountByName $ Just "acc1" + lift $ shouldBeLeft $ getAccountByName Nothing + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 0 + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 0 -- Still 0 + lift $ getAccounts `dbShouldBe` [] + -- Check basic account properties + (accId, acc) <- testNewAcc ctx "acc1" + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 1 + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 1 -- Still 1 + liftTest $ do + dBAccountName acc `shouldBe` "acc1" + dBAccountWallet acc `shouldBe` DBWalletKey walletFPText + dBAccountIndex acc `shouldBe` 0 + dBAccountNetwork acc `shouldBe` "btc" + dBAccountDerivation acc `shouldBe` "/44'/0'/0'" + dBAccountExternal acc `shouldBe` 0 + dBAccountInternal acc `shouldBe` 0 + dBAccountXPubKey acc `shouldBe` snd keysT + dBAccountBalanceConfirmed acc `shouldBe` 0 + dBAccountBalanceUnconfirmed acc `shouldBe` 0 + dBAccountBalanceCoins acc `shouldBe` 0 + -- Check account retrieval + lift $ getAccounts `dbShouldBe` [(accId, acc)] + getAccountByName (Just "acc1") `dbShouldBeE` (accId, acc) + getAccountByName Nothing `dbShouldBeE` (accId, acc) -- There is just 1 account + getAccountById accId `dbShouldBeE` acc + lift $ getAccounts `dbShouldBe` [(accId, acc)] + -- Check the creation of a second account + (accId2, acc2) <- testNewAcc ctx "acc2" + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 2 + getAccountByName (Just "acc2") `dbShouldBeE` (accId2, acc2) + lift $ getAccounts `dbShouldBe` [(accId, acc), (accId2, acc2)] + lift $ shouldBeLeft $ getAccountByName Nothing -- There are > 1 accounts + liftTest $ do + dBAccountWallet acc2 `shouldBe` DBWalletKey walletFPText + dBAccountDerivation acc2 `shouldBe` "/44'/0'/1'" + dBAccountIndex acc2 `shouldBe` 1 + -- Create an account in a new wallet + (accId3, acc3) <- testNewAcc2 ctx "acc3" + liftTest $ do + dBAccountName acc3 `shouldBe` "acc3" + dBAccountWallet acc3 `shouldBe` DBWalletKey walletFPText2 + dBAccountIndex acc3 `shouldBe` 0 + dBAccountNetwork acc3 `shouldBe` "btc" + dBAccountDerivation acc3 `shouldBe` "/44'/0'/0'" + dBAccountXPubKey acc3 `shouldBe` snd keysT2 + lift $ nextAccountDeriv walletFP2 btc `dbShouldBe` 1 + lift $ + getAccounts `dbShouldBe` [(accId, acc), (accId2, acc2), (accId3, acc3)] + getAccountByName (Just "acc3") `dbShouldBeE` (accId3, acc3) + lift $ shouldBeLeft $ getAccountByName Nothing -- There are > 1 accounts + getAccountById accId3 `dbShouldBeE` acc3 + -- Rename an account + lift $ shouldBeLeft $ renameAccount "acc2" "acc2" + lift $ shouldBeLeft $ renameAccount "acc2" "acc3" + lift $ shouldBeLeft $ renameAccount "doesnotexist" "hello world" + acc2' <- renameAccount "acc2" "hello world" + liftIO $ acc2' `shouldBe` acc2 {dBAccountName = "hello world"} + lift $ getAccountNames `dbShouldBe` ["acc1", "hello world", "acc3"] + _ <- renameAccount "hello world" "acc2" + lift $ getAccountNames `dbShouldBe` ["acc1", "acc2", "acc3"] + +extAddressSpec :: Ctx -> Config -> Spec +extAddressSpec ctx cfg = + it "can generate external addresses" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- No addresses yet + lift $ bestAddrWithFunds accId AddrInternal `dbShouldBe` Nothing + lift $ bestAddrWithFunds accId AddrExternal `dbShouldBe` Nothing + lift $ addressPage accId (Page 5 0) `dbShouldBe` [] + -- Generate external addresses + ext1 <- genExtAddress ctx cfg accId "Address 1" + liftTest $ do + dBAddressIndex ext1 `shouldBe` 0 + dBAddressAccountWallet ext1 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation ext1 `shouldBe` "/44'/0'/0'" + dBAddressDerivation ext1 `shouldBe` "/0/0" + dBAddressAddress ext1 `shouldBe` head extAddrsT + dBAddressLabel ext1 `shouldBe` "Address 1" + dBAddressInternal ext1 `shouldBe` False + dBAddressFree ext1 `shouldBe` False + lift $ addressPage accId (Page 5 0) `dbShouldBe` [ext1] + ext2 <- genExtAddress ctx cfg accId "Address 2" + liftTest $ do + dBAddressIndex ext2 `shouldBe` 1 + dBAddressAccountWallet ext2 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation ext2 `shouldBe` "/44'/0'/0'" + dBAddressDerivation ext2 `shouldBe` "/0/1" + dBAddressAddress ext2 `shouldBe` extAddrsT !! 1 + dBAddressLabel ext2 `shouldBe` "Address 2" + dBAddressInternal ext2 `shouldBe` False + dBAddressFree ext2 `shouldBe` False + -- Test Paging + lift $ addressPage accId (Page 5 0) `dbShouldBe` [ext2, ext1] + lift $ addressPage accId (Page 1 0) `dbShouldBe` [ext2] + lift $ addressPage accId (Page 1 1) `dbShouldBe` [ext1] + lift $ addressPage accId (Page 1 2) `dbShouldBe` [] + -- Set address labels + _ <- setAddrLabel accId 0 "test address" + lift $ + addressPage accId (Page 5 0) + `dbShouldBe` [ext2, ext1 {dBAddressLabel = "test address"}] + -- Test the gap + replicateM_ 18 $ genExtAddress ctx cfg accId "" -- We have 20 addresses + lift $ shouldBeLeft $ genExtAddress ctx cfg accId "" -- fail gap + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 20) . length) + updateAddressBalances btc [Store.Balance (extAddrs !! 2) 0 0 0 1 1] + updateAddressBalances btc [Store.Balance (extAddrs !! 4) 0 0 0 1 1] + lift $ bestAddrWithFunds accId AddrExternal `dbShouldBe` Just 4 + replicateM_ 5 $ genExtAddress ctx cfg accId "" -- We have 25 addresses + lift $ shouldBeLeft $ genExtAddress ctx cfg accId "" -- fail gap + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + -- Test discoverAccGenAddrs + updateAddressBalances btc [Store.Balance (extAddrs !! 9) 0 0 0 1 1] + discoverAccGenAddrs ctx cfg accId AddrExternal 0 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + discoverAccGenAddrs ctx cfg accId AddrExternal 25 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + discoverAccGenAddrs ctx cfg accId AddrExternal 26 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 26) . length) + -- Test getAddrDeriv + lift $ + getAddrDeriv btc accId (head extAddrs) + `dbShouldBe` Right (Deriv :/ 0 :/ 0) + lift $ + getAddrDeriv btc accId (extAddrs !! 7) + `dbShouldBe` Right (Deriv :/ 0 :/ 7) + -- Test accound balances + acc1 <- lift $ updateAccountBalances accId + liftTest $ do + dBAccountBalanceConfirmed acc1 `shouldBe` 0 + dBAccountBalanceUnconfirmed acc1 `shouldBe` 0 + dBAccountBalanceCoins acc1 `shouldBe` 0 + updateAddressBalances btc [Store.Balance (extAddrs !! 1) 2 0 1 1 2] + updateAddressBalances btc [Store.Balance (extAddrs !! 4) 2 8 2 2 10] + _ <- nextFreeIntAddr ctx cfg accId + updateAddressBalances btc [Store.Balance (head intAddrs) 3 2 1 1 5] + acc1' <- lift $ updateAccountBalances accId + liftTest $ do + dBAccountBalanceConfirmed acc1' `shouldBe` 7 + dBAccountBalanceUnconfirmed acc1' `shouldBe` 10 + dBAccountBalanceCoins acc1' `shouldBe` 4 + -- Test account indices + liftTest $ do + dBAccountInternal acc1' `shouldBe` 1 + dBAccountExternal acc1' `shouldBe` 26 + +intAddressSpec :: Ctx -> Config -> Spec +intAddressSpec ctx cfg = + it "can generate internal addresses" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Generate internal addresses + int1 <- nextFreeIntAddr ctx cfg accId + liftTest $ do + dBAddressIndex int1 `shouldBe` 0 + dBAddressAccountWallet int1 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation int1 `shouldBe` "/44'/0'/0'" + dBAddressDerivation int1 `shouldBe` "/1/0" + dBAddressAddress int1 `shouldBe` head intAddrsT + dBAddressLabel int1 `shouldBe` "Internal Address" + dBAddressInternal int1 `shouldBe` True + dBAddressFree int1 `shouldBe` True + -- Test the Free status + nextFreeIntAddr ctx cfg accId `dbShouldBeE` int1 -- Should return the same address + lift $ setAddrsFree AddrBusy [head intAddrsT] `dbShouldBe` 1 + lift $ setAddrsFree AddrBusy [intAddrsT !! 1] `dbShouldBe` 0 + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + _ <- lift $ setAddrsFree AddrFree [head intAddrsT] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 0 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 1] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 0 + _ <- lift $ setAddrsFree AddrBusy [head intAddrsT] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 2] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 3 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 3] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 4 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 5 + _ <- lift $ setAddrsFree AddrFree [intAddrsT !! 2] + _ <- lift $ setAddrsFree AddrFree [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 2] + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 5] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 4 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 6 + -- Test account indices + acc <- getAccountById accId + liftTest $ do + dBAccountInternal acc `shouldBe` 7 + dBAccountExternal acc `shouldBe` 0 + +emptyTxInfo :: TxInfo +emptyTxInfo = + TxInfo + (txid' 0) + TxInternal + 0 + Map.empty + Map.empty + [] + Map.empty + Map.empty + [] + 0 + 0 + 0 + (Store.MemRef 0) + 0 + +txsSpec :: Ctx -> Spec +txsSpec ctx = + it "can manage transactions" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Simple insert and retrieval + (dbInfo, change) <- lift $ repsertTxInfo btc ctx accId emptyTxInfo + liftTest $ do + change `shouldBe` True + dBTxInfoAccountWallet dbInfo `shouldBe` DBWalletKey walletFPText + dBTxInfoAccountDerivation dbInfo `shouldBe` "/44'/0'/0'" + dBTxInfoBlockRef dbInfo `shouldBe` S.encode (Store.MemRef 0) + dBTxInfoConfirmed dbInfo `shouldBe` False + -- Reinserting should produce no change + (dbInfo2, change2) <- lift $ repsertTxInfo btc ctx accId emptyTxInfo + liftTest $ do + change2 `shouldBe` False + dbInfo2 `shouldBe` dbInfo + txsPage ctx accId (Page 5 0) `dbShouldBeE` [emptyTxInfo] + -- Check that confirmations are updated correctly + lift $ updateBest btc (bid' 0) 0 + getConfirmedTxs accId True `dbShouldBeE` [] + getConfirmedTxs accId False `dbShouldBeE` [txid' 0] + txsPage ctx accId (Page 5 0) `dbShouldBeE` [emptyTxInfo] + (dbInfo', change') <- + lift $ + repsertTxInfo + btc + ctx + accId + emptyTxInfo {txInfoBlockRef = Store.BlockRef 0 0} + liftTest $ do + change' `shouldBe` True + dBTxInfoBlockRef dbInfo' `shouldBe` S.encode (Store.BlockRef 0 0) + dBTxInfoConfirmed dbInfo' `shouldBe` True + dBTxInfoCreated dbInfo' `shouldBe` dBTxInfoCreated dbInfo + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 0 0, + txInfoConfirmations = 1 + } + ] + getConfirmedTxs accId True `dbShouldBeE` [txid' 0] + getConfirmedTxs accId False `dbShouldBeE` [] + lift $ updateBest btcTest (bid' 0) 10 + lift $ updateBest btc (bid' 0) 20 + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 0 0, + txInfoConfirmations = 21 + } + ] + (dbInfo'', change'') <- + lift $ + repsertTxInfo + btc + ctx + accId + emptyTxInfo {txInfoBlockRef = Store.BlockRef 10 0} + liftTest $ do + change'' `shouldBe` True + dBTxInfoBlockRef dbInfo'' `shouldBe` S.encode (Store.BlockRef 10 0) + dBTxInfoConfirmed dbInfo'' `shouldBe` True + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 10 0, + txInfoConfirmations = 11 + } + ] + +coinSpec :: Ctx -> Spec +coinSpec ctx = + it "can manage coins" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Insert a single coin + let coin1 = coin' ctx (txid' 0, 0) Nothing (head extAddrs) 10 + (c, dbCoin) <- second head <$> refreshCoins btc accId extAddrs [coin1] + liftTest $ do + c `shouldBe` 1 + dBCoinAccountWallet dbCoin `shouldBe` DBWalletKey walletFPText + dBCoinAccountDerivation dbCoin `shouldBe` "/44'/0'/0'" + dBCoinAddress dbCoin `shouldBe` head extAddrsT + dBCoinConfirmed dbCoin `shouldBe` False + dBCoinLocked dbCoin `shouldBe` False + -- Test JSON coins + let jsonCoin1 = forceRight $ toJsonCoin btc Nothing dbCoin + liftTest $ + jsonCoin1 + `shouldBe` JsonCoin + { jsonCoinOutpoint = OutPoint (txid' 0) 0, + jsonCoinAddress = head extAddrs, + jsonCoinValue = 10, + jsonCoinBlock = Store.MemRef 0, + jsonCoinConfirmations = 0, + jsonCoinLocked = False + } + coinPage btc accId (Page 5 0) `dbShouldBeE` [jsonCoin1] + getSpendableCoins accId `dbShouldBeE` [] + -- Nothing should happen when refreshing the same data + refreshCoins btc accId extAddrs [coin1] `dbShouldBeE` (0, []) + -- Confirm and update the coin + let coin1' = coin1 {Store.block = Store.BlockRef 1 0} :: Store.Unspent + refreshCoins btc accId extAddrs [coin1'] `dbShouldBeE` (1, []) + getSpendableCoins accId `dbShouldBeE` [coin1'] + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + lift $ updateBest btc (bid' 0) 0 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + lift $ updateBest btc (bid' 0) 1 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + lift $ updateBest btc (bid' 0) 10 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 10 + } + ] + let coin1'' = coin1 {Store.block = Store.BlockRef 10 0} :: Store.Unspent + refreshCoins btc accId extAddrs [coin1''] `dbShouldBeE` (1, []) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1 + } + ] + -- Lock the coin + lift $ setLockCoin (OutPoint (txid' 0) 0) True `dbShouldBe` 1 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1, + jsonCoinLocked = True + } + ] + getSpendableCoins accId `dbShouldBeE` [] + lift $ setLockCoin (OutPoint (txid' 0) 0) True `dbShouldBe` 0 + lift $ setLockCoin (OutPoint (txid' 0) 0) False `dbShouldBe` 1 + lift $ setLockCoin (OutPoint (txid' 0) 0) False `dbShouldBe` 0 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1, + jsonCoinLocked = False + } + ] + getSpendableCoins accId `dbShouldBeE` [coin1''] + -- Delete the coin + refreshCoins btc accId extAddrs [] `dbShouldBeE` (1, []) + getSpendableCoins accId `dbShouldBeE` [] + coinPage btc accId (Page 5 0) `dbShouldBeE` [] + +checkFree :: Int -> Bool -> ExceptT String (DB IO) () +checkFree i free = + lift $ + ( dBAddressFree . entityVal . fromJust + <$> P.getBy (UniqueAddress (intAddrsT !! i)) + ) + `dbShouldBe` free + +pendingTxsSpec :: Ctx -> Config -> Spec +pendingTxsSpec ctx cfg = + it "can manage pending transactions" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + lift $ updateBest btc (bid' 0) 0 + -- Build some test data coins/txs + (dBAddressAddress <$> genExtAddress ctx cfg accId "") + `dbShouldBeE` head extAddrsT + (dBAddressAddress <$> nextFreeIntAddr ctx cfg accId) + `dbShouldBeE` head intAddrsT + checkFree 0 True + lift $ setAddrsFree AddrBusy [head intAddrsT] `dbShouldBe` 1 + checkFree 0 False + let fundTx1 = tx' ctx [(txid' 1, 0)] [(addr' 0, 20)] + fundTx2 = tx' ctx [(txid' 1, 1)] [(iAddr' 0, 10)] + coin1 = coin' ctx (txHash fundTx1, 0) (Just 0) (addr' 0) 20 + coin2 = coin' ctx (txHash fundTx2, 0) (Just 0) (iAddr' 0) 10 + -- Insert the dependent transactions + lift $ insertRawTx fundTx1 + lift $ insertRawTx fundTx2 + -- Insert two coins in the database + (c, dbCoins) <- refreshCoins btc accId (extAddrs <> intAddrs) [coin1, coin2] + liftTest $ c `shouldBe` 2 + let jsonCoin1 = forceRight $ toJsonCoin btc Nothing (head dbCoins) + jsonCoin2 = forceRight $ toJsonCoin btc Nothing (dbCoins !! 1) + tsd <- buildTxSignData btc ctx cfg gen accId [(oAddr' 0, 8)] 0 0 False + liftTest $ + tsd + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(iAddr' 1, 12), (oAddr' 0, 8)], + txSignDataInputs = [fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [Deriv :/ 1 :/ 1], + txSignDataSigned = False + } + -- Import the pending transaction + checkFree 0 False + checkFree 1 True + let h1 = "db1085753d1d9b14005dd2951ff643803d4fa7ffa3bde6841dbb817958cb74e1" + importPendingTx btc ctx accId tsd `dbShouldBeE` h1 + liftTest $ nosigTxHash (txSignDataTx tsd) `shouldBe` h1 + -- Check locked coins + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + pendingTxPage accId (Page 5 0) `dbShouldBeE` [(h1, tsd)] + -- Check address free status + checkFree 0 False + checkFree 1 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + lift $ + shouldBeLeft' "chooseCoins: No solution found" $ + buildTxSignData btc ctx cfg gen accId [(oAddr' 1, 12)] 0 0 False + lift $ + shouldBeLeft' "The transaction already exists" $ + importPendingTx btc ctx accId tsd + -- Create second pending transaction + tsd2 <- buildTxSignData btc ctx cfg gen accId [(oAddr' 1, 7)] 0 0 False + liftTest $ + tsd2 + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx2, 0)] + [(iAddr' 2, 3), (oAddr' 1, 7)], + txSignDataInputs = [fundTx2], + txSignDataInputPaths = [Deriv :/ 1 :/ 0], + txSignDataOutputPaths = [Deriv :/ 1 :/ 2], + txSignDataSigned = False + } + -- Import the second transaction + checkFree 2 True + let h2 = "bb0e46f95f90bf0d2b0805655a77e632a0bd5088d5722d0055bc2862158ba747" + importPendingTx btc ctx accId tsd2 `dbShouldBeE` h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + pendingTxPage accId (Page 5 0) + `dbShouldBeE` [(h2, tsd2), (h1, tsd)] + checkFree 0 False + checkFree 1 False + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 3 + lift $ + shouldBeLeft' "chooseCoins: No solution found" $ + buildTxSignData btc ctx cfg gen accId [(oAddr' 2, 1)] 0 0 False + -- Delete first transaction + deletePendingTx btc ctx accId h1 `dbShouldBeE` (1, 1) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = False} + ] + pendingTxPage accId (Page 5 0) `dbShouldBeE` [(h2, tsd2)] + checkFree 0 False + checkFree 1 True + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + -- Create transaction with no change + tsd3 <- buildTxSignData btc ctx cfg gen accId [(oAddr' 2, 20)] 0 0 False + liftTest $ + tsd3 + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(oAddr' 2, 20)], + txSignDataInputs = [fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + let h3 = "abe82b09dddb8abdb5490c3d404d34f2ff3c8f7b893bbe80f0af4018576e1f9e" + importPendingTx btc ctx accId tsd3 `dbShouldBeE` h3 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + pendingTxPage accId (Page 5 0) + `dbShouldBeE` [(h3, tsd3), (h2, tsd2)] + checkFree 0 False + checkFree 1 True + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + -- Import a signed transaction + let resE = signWalletTx btc ctx tsd2 (fst $ keys ctx) + liftTest $ resE `shouldSatisfy` isRight + let tsd2' = fst $ forceRight resE + liftTest $ txSignDataSigned tsd2' `shouldBe` True + importPendingTx btc ctx accId tsd2' `dbShouldBeE` h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + pendingTxPage accId (Page 5 0) + `dbShouldBeE` [(h3, tsd3), (h2, tsd2')] + checkFree 0 False + checkFree 1 True + checkFree 2 False + lift $ do + shouldBeLeft' "The transaction already exists" $ + importPendingTx btc ctx accId tsd2' + shouldBeLeft' "Can not replace a signed transaction with an unsigned one" $ + importPendingTx btc ctx accId tsd2 + -- Set tsd2 to online + lift $ do + setPendingTxOnline h2 `dbShouldBe` 1 + shouldBeLeft' "The transaction is already online" $ + importPendingTx btc ctx accId tsd2' + -- Can not delete an online transaction + shouldBeLeft $ deletePendingTx btc ctx accId h2 + lift $ deletePendingTxOnline $ DBPendingTxKey $ txHashToHex h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + pendingTxPage accId (Page 5 0) `dbShouldBeE` [(h3, tsd3)] + checkFree 0 False + checkFree 1 True + checkFree 2 False + -- Check for other errors + let fundTx3 = tx' ctx [(txid' 2, 0)] [(addr' 8, 30)] + coin3 = coin' ctx (txHash fundTx3, 0) (Just 0) (addr' 8) 30 + lift $ do + shouldBeLeft' "A coin referenced by the transaction is locked" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(oAddr' 3, 20)], + txSignDataInputs = [fundTx3, fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + shouldBeLeft' "A coin referenced by the transaction does not exist" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(oAddr' 3, 20)], + txSignDataInputs = [fundTx3, fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + (_, dbCoins3) <- refreshCoins btc accId (extAddrs <> intAddrs) [coin1, coin3] + let jsonCoin3 = forceRight $ toJsonCoin btc Nothing (head dbCoins3) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin3 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + lift $ + shouldBeLeft' "Some referenced addresses do not exist" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(iAddr' 1, 5), (oAddr' 3, 25)], + txSignDataInputs = [fundTx3], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [Deriv :/ 1 :/ 1], + txSignDataSigned = False + } + -- The transaction is not being rolled back so we roll it back manually + replicateM_ 10 $ genExtAddress ctx cfg accId "" + _ <- lift $ setLockCoin (jsonCoinOutpoint jsonCoin3) False + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin3 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + checkFree 0 False + checkFree 1 True + checkFree 2 False + lift $ + shouldBeLeft' "Some of the internal output addresses are not free" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(iAddr' 2, 1), (oAddr' 3, 25)], + txSignDataInputs = [fundTx3], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [Deriv :/ 1 :/ 2], + txSignDataSigned = False + } diff --git a/test/Network/Haskoin/Wallet/EntropySpec.hs b/test/Haskoin/Wallet/EntropySpec.hs similarity index 62% rename from test/Network/Haskoin/Wallet/EntropySpec.hs rename to test/Haskoin/Wallet/EntropySpec.hs index e2b8ae2b..047cc964 100644 --- a/test/Network/Haskoin/Wallet/EntropySpec.hs +++ b/test/Haskoin/Wallet/EntropySpec.hs @@ -1,56 +1,34 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.Haskoin.Wallet.EntropySpec where +module Haskoin.Wallet.EntropySpec where import Control.Exception (evaluate) -import Control.Monad (forM_) +import Control.Monad +import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS -import Data.Functor.Identity (Identity (runIdentity)) +import Data.Default (def) +import Data.Maybe import Data.Text (Text) import Haskoin - ( Ctx, - addrToText, - btc, - derivePathAddr, - deriveXPubKey, - prepareContext, - ) -import Haskoin.Util.Arbitrary (arbitraryBSn) -import Network.Haskoin.Wallet.AccountStore - ( emptyAccountStore, - extDeriv, - genExtAddress, - genIntAddress, - runAccountStoreT, - ) -import Network.Haskoin.Wallet.Entropy - ( base6ToWord8, - splitEntropyWith, - word8ToBase6, - xorBytes, mergeMnemonicParts, - ) -import Network.Haskoin.Wallet.Signing (signingKey) -import Network.Haskoin.Wallet.TestUtils (forceRight) -import Test.HUnit (Assertion, assertEqual) +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.Entropy +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TestUtils +import Test.HUnit import Test.Hspec - ( Spec, - anyException, - describe, - expectationFailure, - it, - shouldBe, - shouldThrow, - ) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (forAll) -import Haskoin.Crypto (toMnemonic) +import Test.Hspec.QuickCheck +import Test.QuickCheck spec :: Spec -spec = prepareContext $ \ctx -> do - diceSpec - entropySpec - mnemonicSpec ctx +spec = do + let cfg = def :: Config + prepareContext $ \ctx -> do + diceSpec + entropySpec + mnemonicSpec ctx cfg diceSpec :: Spec diceSpec = @@ -131,7 +109,7 @@ entropySpec = do case splitEntropyWith s [k1, k2] of [a, b, c] -> (a `xorBytes` b `xorBytes` c) `shouldBe` s _ -> expectationFailure "Invalid splitEntropyWith" - prop "prop: can reconstruct original mnemonic" $ + prop "prop: can reconstruct original mnemonic" $ forAll (arbitraryBSn 32) $ \s -> forAll (arbitraryBSn 32) $ \k1 -> case splitEntropyWith s [k1] of @@ -142,35 +120,83 @@ entropySpec = do in unsplitMnem `shouldBe` mnem _ -> expectationFailure "Invalid splitEntropyWith" --- https://github.com/iancoleman/bip39/issues/58 -mnemonicSpec :: Ctx -> Spec -mnemonicSpec ctx = +mnemonicSpec :: Ctx -> Config -> Spec +mnemonicSpec ctx cfg = describe "Mnemonic API" $ do + -- https://github.com/iancoleman/bip39/issues/58 it "Can derive iancoleman issue 58" $ do - let m = - "fruit wave dwarf banana earth journey tattoo true farm silk olive fence" + let m = "fruit wave dwarf banana earth journey tattoo true farm silk olive fence" p = "banana" - xpub = forceRight $ deriveXPubKey ctx <$> signingKey btc ctx p m 0 + mnemPass = MnemonicPass m p + xpub = forceRight $ deriveXPubKey ctx <$> signingKey btc ctx mnemPass 0 (addr0, _) = derivePathAddr ctx xpub extDeriv 0 addrToText btc addr0 `shouldBe` Just "17rxURoF96VhmkcEGCj5LNQkmN9HVhWb7F" - it "Passes the bip44 test vectors" $ - mapM_ (testBip44Vector ctx) bip44Vectors + it "Passes the test vectors 3 (zero padding)" $ + mapM_ (testVector ctx) testVectors3 + it "Passes the test vectors 4 (zero padding)" $ + mapM_ (testVector ctx) testVectors4 + it "Passes the BIP-44 test vectors" $ + mapM_ (testBip44Vector ctx cfg) bip44Vectors -testBip44Vector :: Ctx -> (Text, Text, Text, Text) -> Assertion -testBip44Vector ctx (mnem, pass, addr0, addr1) = do - assertEqual - "Addr External" - (Just addr0) - (addrToText btc $ fst $ r (genExtAddress ctx)) - assertEqual - "Addr Internal" - (Just addr1) - (addrToText btc $ fst $ r (genIntAddress ctx)) +testVector :: Ctx -> (Text, HardPath, Text, Text) -> Assertion +testVector ctx (seedT, deriv, pubT, prvT) = do + xPrvExport btc xPrv `shouldBe` prvT + xPubExport btc ctx xPub `shouldBe` pubT where - k = forceRight $ signingKey btc ctx pass mnem 0 - p = deriveXPubKey ctx k - s = emptyAccountStore btc p - r a = fst $ runIdentity $ runAccountStoreT a s + seed = fromJust $ decodeHex seedT + xPrv = derivePath ctx deriv (makeXPrvKey seed) + xPub = deriveXPubKey ctx xPrv + +-- bitpay/bitcore-lib#47 and iancoleman/bip39#58 +-- https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki#test-vector-3 +testVectors3 :: [(Text, HardPath, Text, Text)] +testVectors3 = + [ ( "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be", + Deriv, -- m/ + "xpub661MyMwAqRbcEZVB4dScxMAdx6d4nFc9nvyvH3v4gJL378CSRZiYmhRoP7mBy6gSPSCYk6SzXPTf3ND1cZAceL7SfJ1Z3GC8vBgp2epUt13", + "xprv9s21ZrQH143K25QhxbucbDDuQ4naNntJRi4KUfWT7xo4EKsHt2QJDu7KXp1A3u7Bi1j8ph3EGsZ9Xvz9dGuVrtHHs7pXeTzjuxBrCmmhgC6" + ), + ( "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be", + Deriv :| 0, -- m/0' + "xpub68NZiKmJWnxxS6aaHmn81bvJeTESw724CRDs6HbuccFQN9Ku14VQrADWgqbhhTHBaohPX4CjNLf9fq9MYo6oDaPPLPxSb7gwQN3ih19Zm4Y", + "xprv9uPDJpEQgRQfDcW7BkF7eTya6RPxXeJCqCJGHuCJ4GiRVLzkTXBAJMu2qaMWPrS7AANYqdq6vcBcBUdJCVVFceUvJFjaPdGZ2y9WACViL4L" + ) + ] + +-- btcsuite/btcutil#172 +-- https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki#test-vector-4 +testVectors4 :: [(Text, HardPath, Text, Text)] +testVectors4 = + [ ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv, -- m/ + "xpub661MyMwAqRbcGczjuMoRm6dXaLDEhW1u34gKenbeYqAix21mdUKJyuyu5F1rzYGVxyL6tmgBUAEPrEz92mBXjByMRiJdba9wpnN37RLLAXa", + "xprv9s21ZrQH143K48vGoLGRPxgo2JNkJ3J3fqkirQC2zVdk5Dgd5w14S7fRDyHH4dWNHUgkvsvNDCkvAwcSHNAQwhwgNMgZhLtQC63zxwhQmRv" + ), + ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv :| 0, -- m/0' + "xpub69AUMk3qDBi3uW1sXgjCmVjJ2G6WQoYSnNHyzkmdCHEhSZ4tBok37xfFEqHd2AddP56Tqp4o56AePAgCjYdvpW2PU2jbUPFKsav5ut6Ch1m", + "xprv9vB7xEWwNp9kh1wQRfCCQMnZUEG21LpbR9NPCNN1dwhiZkjjeGRnaALmPXCX7SgjFTiCTT6bXes17boXtjq3xLpcDjzEuGLQBM5ohqkao9G" + ), + ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv :| 0 :| 1, -- m/0'/1' + "xpub6BJA1jSqiukeaesWfxe6sNK9CCGaujFFSJLomWHprUL9DePQ4JDkM5d88n49sMGJxrhpjazuXYWdMf17C9T5XnxkopaeS7jGk1GyyVziaMt", + "xprv9xJocDuwtYCMNAo3Zw76WENQeAS6WGXQ55RCy7tDJ8oALr4FWkuVoHJeHVAcAqiZLE7Je3vZJHxspZdFHfnBEjHqU5hG1Jaj32dVoS6XLT1" + ) + ] + +testBip44Vector :: Ctx -> Config -> (Text, Text, Text, Text) -> Assertion +testBip44Vector ctx cfg (mnem, pass, addr0, addr1) = do + runDBMemoryE $ do + (accId, _) <- insertAccount btc ctx walletFP "test" pub + extAddr <- genExtAddress ctx cfg accId "" + intAddr <- nextFreeIntAddr ctx cfg accId + liftIO $ addr0 `shouldBe` dBAddressAddress extAddr + liftIO $ addr1 `shouldBe` dBAddressAddress intAddr + where + mnemPass = MnemonicPass mnem pass + walletFP = forceRight $ walletFingerprint btc ctx mnemPass + prv = forceRight $ signingKey btc ctx mnemPass 0 + pub = deriveXPubKey ctx prv -- (Mnemonic, BIP38 password, external 0/0, internal 1/0) bip44Vectors :: [(Text, Text, Text, Text)] diff --git a/test/Haskoin/Wallet/SigningSpec.hs b/test/Haskoin/Wallet/SigningSpec.hs new file mode 100644 index 00000000..8fa59a8d --- /dev/null +++ b/test/Haskoin/Wallet/SigningSpec.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.SigningSpec where + +import Control.Arrow (second) +import qualified Data.ByteString as BS +import Data.Either (fromRight) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Serialize as S +import Data.Text (Text) +import Data.Word (Word32, Word8) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TestUtils +import Haskoin.Wallet.TxInfo +import Numeric.Natural (Natural) +import System.Random (StdGen, mkStdGen) +import Test.Hspec + +spec :: Spec +spec = + prepareContext $ \ctx -> do + buildWalletTxSpec ctx + signWalletTxSpec ctx + +buildWalletTxSpec :: Ctx -> Spec +buildWalletTxSpec ctx = + describe "Transaction builder" $ do + it "can build a transaction" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] + resE = buildWalletTx btc ctx gen rcps change coins 314 10000 False + (fst <$> resE) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] -- Greedy algorithm + ((rcps !! 1) : (change, 199825416) : [head rcps]) + ) + (snd <$> resE) + `shouldBe` Right [coins !! 2, coins !! 1, head coins] + it "can fail to build a transaction if funds are insufficient" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 500000000)] + resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False + resE `shouldBe` Left "chooseCoins: No solution found" + it "will drop the change output if it is dust" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 499990000)] + resE1 = buildWalletTx btc ctx gen rcps change coins 0 9999 False + resE2 = buildWalletTx btc ctx gen rcps change coins 0 10000 False + resE3 = buildWalletTx btc ctx gen rcps change coins 1 9999 False + (fst <$> resE1) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : (change, 10000) : [head rcps]) + ) + (fst <$> resE2) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : [head rcps]) + ) + (fst <$> resE3) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : [head rcps]) + ) + it "will fail if sending dust" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 10000)] + resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False + resE `shouldBe` Left "Recipient output is smaller than the dust value" + it "can make the recipient pay for the fees" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] + resE = buildWalletTx btc ctx gen rcps change coins 314 10000 True + (fst <$> resE) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ( (oAddr' 1, 199912708) + : (change, 200000000) + : [(oAddr' 0, 199912708)] + ) + ) + it "fails when recipients cannot pay" $ + do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps1 = [(oAddr' 0, 400000000), (oAddr' 1, 87291)] -- fee is 2*87292 + rcps2 = [(oAddr' 0, 400000000), (oAddr' 1, 87292)] + rcps3 = [(oAddr' 0, 400000000), (oAddr' 1, 97293)] + resE1 = buildWalletTx btc ctx gen rcps1 change coins 314 10000 True + resE2 = buildWalletTx btc ctx gen rcps2 change coins 314 10000 True + resE3 = buildWalletTx btc ctx gen rcps3 change coins 314 10000 True + resE1 `shouldBe` Left "Recipients can't pay for the fee" + resE2 `shouldBe` Left "Recipient output is smaller than the dust value" + (fst <$> resE3) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((oAddr' 1, 10001) : (change, 199902707) : [(oAddr' 0, 399912708)]) + ) + +signWalletTxSpec :: Ctx -> Spec +signWalletTxSpec ctx = + describe "Transaction signer" $ do + it "can derive private signing keys" $ do + let xPrvE = signingKey btc ctx mnemPass 0 + xPubE = deriveXPubKey ctx <$> xPrvE + xPrvE `shouldBe` Right (fst $ keys ctx) + xPubE `shouldBe` Right (snd $ keys ctx) + it "can sign a simple transaction" $ do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + (resDat, resTxInfo) = fromRight (error "fromRight") resE + signedTx = txSignDataTx resDat + txSignDataSigned resDat `shouldBe` True + resTxInfo + `shouldBe` TxInfo + { txInfoHash = + "e66b790c73d4e72fe13a07e247e4439bdea210cac2f947040e901f1e0ce59ac2", + txInfoType = TxDebit, + txInfoAmount = -60000000, + txInfoMyOutputs = + Map.fromList [(iAddr' 0, MyOutputs 40000000 (intDeriv :/ 0))], + txInfoOtherOutputs = Map.fromList [(oAddr' 0, 50000000)], + txInfoNonStdOutputs = [], + txInfoMyInputs = + Map.fromList + [ ( addr' 0, + MyInputs + 100000000 + (extDeriv :/ 0) + [ SigInput + (PayPKHash (addr' 0).hash160) + 100000000 + (OutPoint (txHash fundTx) 0) + sigHashAll + Nothing + ] + ) + ], + txInfoOtherInputs = Map.empty, + txInfoNonStdInputs = [], + txInfoSize = fromIntegral $ BS.length $ S.encode signedTx, + txInfoFee = 10000000, + txInfoFeeByte = 44247, + txInfoBlockRef = Store.MemRef 0, + txInfoConfirmations = 0 + } + it "can set the correct TxInternal transaction types" $ do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 200000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(iAddr' 0, 50000000), (addr' 2, 200000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0, extDeriv :/ 1] + [intDeriv :/ 0, extDeriv :/ 2] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + (txInfoType . snd <$> resE) `shouldBe` Right TxInternal + it "fails when an input is not signed" $ do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] -- We omit derivation 1 + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "The transaction could not be signed" + it "fails when referenced input transactions are missing" $ do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0, extDeriv :/ 1] -- 1 is missing in fundTx + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Referenced input transactions are missing" + it "fails when private key derivations don't match the Tx inputs" $ + do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 1, extDeriv :/ 2] -- 1 and 2 instead of 0 and 1 + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Input derivations don't match the transaction inputs" + it "fails when output derivations don't match the Tx outputs" $ + do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] + [intDeriv :/ 1] -- 1 instead of 0 + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Output derivations don't match the transaction outputs" + +-- Test Helpers -- + +tx' :: Ctx -> [(TxHash, Word32)] -> [(Address, Natural)] -> Tx +tx' ctx xs ys = Tx 1 txi txo [] 0 + where + txi = + fmap + (\(h, p) -> TxIn (OutPoint h p) BS.empty maxBound) + xs + f = marshal ctx . PayPKHash . (.hash160) + txo = fmap (\(a, v) -> TxOut v $ f a) (Control.Arrow.second fromIntegral <$> ys) + +txid' :: Word8 -> TxHash +txid' w = + fromRight (error "Could not decode txhash") $ + S.decode $ + w `BS.cons` BS.replicate 31 0x00 + +bid' :: Word8 -> BlockHash +bid' w = + fromRight (error "Could not decode block hash") $ + S.decode $ + w `BS.cons` BS.replicate 31 0x00 + +coin' :: + Ctx -> + (TxHash, Word32) -> + Maybe Natural -> + Address -> + Natural -> + Store.Unspent +coin' ctx (h, p) hM a v = + Store.Unspent + { Store.block = + maybe (Store.MemRef 0) ((`Store.BlockRef` 0) . fromIntegral) hM, + Store.outpoint = OutPoint h p, + Store.value = fromIntegral v, + Store.script = marshal ctx $ PayPKHash $ (.hash160) a, + Store.address = Just a + } + +addr' :: Int -> Address +addr' i = extAddrs !! i + +iAddr' :: Int -> Address +iAddr' i = intAddrs !! i + +oAddr' :: Int -> Address +oAddr' i = othAddrs !! i + +-- Test Constants + +-- Use a predictable seed for tests +gen :: StdGen +gen = mkStdGen 0 + +mnemPass :: MnemonicPass +mnemPass = + MnemonicPass + "snow senior nerve virus fabric now \ + \fringe clip marble interest analyst can" + "correct horse battery staple" + +mnemPass2 :: MnemonicPass +mnemPass2 = + MnemonicPass + "boring auction demand filter frog accuse \ + \company exchange rely slogan trim typical" + "correct horse battery staple" + +walletFPText :: Text +walletFPText = "892eb8e4" + +walletFPText2 :: Text +walletFPText2 = "807a5cfb" + +walletFP :: Fingerprint +walletFP = forceRight $ textToFingerprint walletFPText + +walletFP2 :: Fingerprint +walletFP2 = forceRight $ textToFingerprint walletFPText2 + +-- Keys for account 0 +keys :: Ctx -> (XPrvKey, XPubKey) +keys ctx = + ( fromJust $ + xPrvImport + btc + (fst keysT), + fromJust $ + xPubImport + btc + ctx + (snd keysT) + ) + +-- Account /44'/0'/0' mnemonic 1 +keysT :: (Text, Text) +keysT = + ( "xprv9yHxeaLAZvxXb9VtJNesqk8avfN8misGAW9DUW9eacZJNqsfZxqKLmK5jfmvFideQqGesviJeagzSQYCuQySjgvt7TdfowKja5aJqbgyuNh", + "xpub6CHK45s4QJWpodaMQQBtCt5KUhCdBBb7Xj4pGtZG8x6HFeCp7W9ZtZdZaxA34YtFAhuebiKqLqHLYoB8HDadGutW8kEH4HeMdeS1KJz8Uah" + ) + +-- Account /44'/0'/0' mnemonic 2 +keysT2 :: (Text, Text) +keysT2 = + ( "xprv9yXnZpEVdonEtT3strknsAgso5qq1cwRooo6susmzVmB5E2vvNw1KKRBgvwvNLxXdBHnkEN5R5uXi2QDs3tpkoBbL61NE6bnSbcrvH6keGa", + "xpub6CX8yKmPUBLY6w8LztHoEJdcM7gKR5fHB2ihgJHPYqJ9x2N5TvFFs7jfYCX6So9oYyu6eLDTG5dbQWPncv1PYJtXLJ4cwymhoCpeTEmnZFZ" + ) + +extAddrs :: [Address] +extAddrs = fromMaybe (error "extAddrs no parse") . textToAddr btc <$> extAddrsT + +extAddrsT :: [Text] +extAddrsT = + [ "1KEn7jEXa7KCLeZy59dka5qRJBLnPMmrLj", + "1AVj9WSYayTwUd8rS1mTTo4A6CPsS83VTg", + "1Dg6Kg7kQuyiZz41HRWXKUWKRu6ZyEf1Nr", + "1yQZuJjA6w7hXpc3C2LRiCv22rKCas7F1", + "1cWcYiGK7NwjPBJuKRqZxV4aymUnPu1mx", + "1MZuimSXigp8oqxkVUvZofqHNtVjdcdAqc", + "1JReTkpFnsrMqhSEJwUNZXPAyeTo2HQfnE", + "1Hx9xWAHhcjea5uJnyADktCfcLbuBnRnwA", + "1HXJhfiD7JFCGMFZnhKRsZxoPF7xDTqWXP", + "1MZpAt1FofY69B6fzooFxZqe6SdrVrC3Yw" + ] + +intAddrs :: [Address] +intAddrs = fromMaybe (error "intAddrs no parse") . textToAddr btc <$> intAddrsT + +intAddrsT :: [Text] +intAddrsT = + [ "17KiDLpE3r92gWR8kFGkYDtgHqEVJrznvn", + "1NqNFsuS7K3dfF8RnAVr9YYCMvJuF9GCn6", + "1MZNPWwFwy2CqVgWBq6unPWBWrZTQ7WTnr", + "19XbPiR98wmoJQZ42K8pVMzdCwSXZBh7iz", + "1Gkn7EsphiaYuv6XXvG4Kyg3LSfqFMeXHX", + "14VkCGcLkNqUwRMVjpLEyodAhXvzUWLqPM", + "1PkyVUxPMGTLzUWNFNraMagACA1x3eD4CF", + "1M2mmDhWTjEuqPfUdaQH6XPsr5i29gx581", + "184JdZjasQUmNo2AimkbKAW2sxXMF9BAvK", + "13b1QVnWFRwCrjvhthj4JabpnJ4nyxbBqm" + ] + +othAddrs :: [Address] +othAddrs = + fromMaybe (error "othAddrs no parse") . textToAddr btc + <$> [ "1JCq8Aa9d9rg4T4XV93RV3DMxd5u7GkSSU", + "1PxH6Yutj49mRAabGvcTxnLkFZCuXDXvRJ", + "191J7K3FaXXyM7C9ceSMRsJNF6aWCvvf1Q", + "1FVnYNLRdR5vQkynApupUez6ZfcDqsLHdj", + "1PmNJHnbk7Kct5FMqbEVRxqqR2mXVQKK5P", + "18CaQNcVwzUkE9KvwmMd6a5UWNgqJFEAh1", + "1M2Cv69B7LRud8su2wdd7HV2i6MrXqzdKP", + "19xYPmoJ2XV1vJnSkzsrXUJXCgKvPE3ri4", + "1N2JAKWVFAoKFEUci3tY3kvrGFY6poRgvm", + "15EANoYyJoo1J51ERdQzNwZCyhEtPfcP8g" + ] diff --git a/test/Haskoin/Wallet/TestUtils.hs b/test/Haskoin/Wallet/TestUtils.hs new file mode 100644 index 00000000..26fc8ca8 --- /dev/null +++ b/test/Haskoin/Wallet/TestUtils.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.TestUtils where + +import Control.Monad +import Control.Monad.Except (ExceptT) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Except (runExceptT) +import Data.Either +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word +import Database.Persist.Sql (runMigrationQuiet) +import Database.Persist.Sqlite (runSqlite) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Commands +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.TxInfo +import Numeric.Natural +import Test.HUnit +import Test.Hspec +import Test.QuickCheck + +genNatural :: Test.QuickCheck.Gen Natural +genNatural = arbitrarySizedNatural + +forceRight :: Either a b -> b +forceRight = fromRight (error "fromRight") + +runDBMemory :: DB IO a -> Assertion +runDBMemory action = do + runSqlite ":memory:" $ do + _ <- runMigrationQuiet migrateAll + void action + +runDBMemoryE :: (Show a) => ExceptT String (DB IO) a -> Assertion +runDBMemoryE action = do + runSqlite ":memory:" $ do + _ <- runMigrationQuiet migrateAll + resE <- runExceptT action + liftIO $ resE `shouldSatisfy` isRight + +arbitraryText :: Gen Text +arbitraryText = cs <$> (arbitrary :: Gen String) + +arbitraryPositive :: (Arbitrary a, Integral a) => Gen a +arbitraryPositive = abs <$> arbitrary + +arbitraryNatural :: Gen Natural +arbitraryNatural = fromIntegral <$> (arbitraryPositive :: Gen Word64) + +arbitraryBlockRef :: Gen Store.BlockRef +arbitraryBlockRef = + oneof [a, b] + where + a = Store.BlockRef <$> arbitraryPositive <*> arbitraryPositive + b = Store.MemRef <$> arbitrary + +arbitraryDBAccount :: Network -> Ctx -> Gen DBAccount +arbitraryDBAccount net ctx = + DBAccount + <$> arbitraryText + <*> (DBWalletKey . fingerprintToText <$> arbitraryFingerprint) + <*> arbitraryPositive + <*> (cs . (.name) <$> arbitraryNetwork) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> arbitraryPositive + <*> arbitraryPositive + <*> (xPubExport net ctx <$> arbitraryXPubKey ctx) + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryUTCTime + +arbitraryDBAddress :: Network -> Gen DBAddress +arbitraryDBAddress net = + DBAddress + <$> arbitraryPositive + <*> (DBWalletKey . fingerprintToText <$> arbitraryFingerprint) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> (fromJust . addrToText net <$> arbitraryAddress) + <*> arbitraryText + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitrary + <*> arbitrary + <*> arbitraryUTCTime + +arbitraryAddressBalance :: Gen AddressBalance +arbitraryAddressBalance = + AddressBalance + <$> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + +arbitraryJsonCoin :: Gen JsonCoin +arbitraryJsonCoin = + JsonCoin + <$> arbitraryOutPoint + <*> arbitraryAddress + <*> arbitraryPositive + <*> arbitraryBlockRef + <*> arbitraryNatural + <*> arbitrary + +arbitraryPubKeyDoc :: Ctx -> Gen PubKeyDoc +arbitraryPubKeyDoc ctx = + PubKeyDoc + <$> arbitraryXPubKey ctx + <*> arbitraryNetwork + <*> arbitraryText + <*> arbitraryFingerprint + +arbitraryTxSignData :: Network -> Ctx -> Gen TxSignData +arbitraryTxSignData net ctx = + TxSignData + <$> arbitraryTx net ctx + <*> resize 10 (listOf (arbitraryTx net ctx)) + <*> resize 10 (listOf arbitrarySoftPath) + <*> resize 10 (listOf arbitrarySoftPath) + <*> arbitrary + +arbitraryMyOutputs :: Gen MyOutputs +arbitraryMyOutputs = + MyOutputs + <$> arbitraryNatural + <*> arbitrarySoftPath + +arbitraryMyInputs :: Network -> Ctx -> Gen MyInputs +arbitraryMyInputs net ctx = + MyInputs + <$> arbitraryNatural + <*> arbitrarySoftPath + <*> resize 10 (listOf $ fst <$> arbitrarySigInput net ctx) + +arbitraryOtherInputs :: Network -> Ctx -> Gen OtherInputs +arbitraryOtherInputs net ctx = + OtherInputs + <$> arbitraryNatural + <*> resize 10 (listOf $ fst <$> arbitrarySigInput net ctx) + +arbitraryTxType :: Gen TxType +arbitraryTxType = oneof [pure TxDebit, pure TxInternal, pure TxCredit] + +arbitraryStoreOutput :: Gen Store.StoreOutput +arbitraryStoreOutput = + Store.StoreOutput + <$> arbitrary + <*> arbitraryBS1 + <*> arbitraryMaybe arbitrarySpender + <*> arbitraryMaybe arbitraryAddress + +arbitrarySpender :: Gen Store.Spender +arbitrarySpender = Store.Spender <$> arbitraryTxHash <*> arbitrary + +arbitraryStoreInput :: Gen Store.StoreInput +arbitraryStoreInput = + oneof + [ Store.StoreCoinbase + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> listOf arbitraryBS1, + Store.StoreInput + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryBS1 + <*> arbitrary + <*> listOf arbitraryBS1 + <*> arbitraryMaybe arbitraryAddress + ] + +arbitraryTxInfo :: Network -> Ctx -> Gen TxInfo +arbitraryTxInfo net ctx = + TxInfo + <$> arbitraryTxHash + <*> arbitraryTxType + <*> arbitrary + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyOutputs) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryNatural) + ) + <*> resize 10 (listOf arbitraryStoreOutput) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyInputs net ctx) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryOtherInputs net ctx) + ) + <*> resize 10 (listOf arbitraryStoreInput) + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryBlockRef + <*> arbitraryNatural + +arbitraryUnsignedTxInfo :: Network -> Ctx -> Gen UnsignedTxInfo +arbitraryUnsignedTxInfo net ctx = + UnsignedTxInfo + <$> arbitraryTxType + <*> arbitrary + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyOutputs) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryNatural) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyInputs net ctx) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryOtherInputs net ctx) + ) + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + +arbitraryNoSigTxInfo :: Network -> Ctx -> Gen NoSigTxInfo +arbitraryNoSigTxInfo net ctx = + oneof + [ NoSigSigned <$> arbitraryTxHash <*> arbitraryTxInfo net ctx, + NoSigUnsigned <$> arbitraryTxHash <*> arbitraryUnsignedTxInfo net ctx + ] + +arbitraryResponse :: Network -> Ctx -> Gen Response +arbitraryResponse net ctx = + oneof + [ ResponseError <$> arbitraryText, + ResponseMnemonic + <$> arbitraryText + <*> resize 12 (listOf arbitraryText) + <*> resize 12 (listOf $ resize 12 $ listOf arbitraryText), + ResponseCreateAcc <$> arbitraryDBAccount net ctx, + ResponseTestAcc + <$> arbitraryDBAccount net ctx + <*> arbitrary + <*> arbitraryText, + ResponseImportAcc + <$> arbitraryDBAccount net ctx, + ResponseExportAcc + <$> arbitraryDBAccount net ctx + <*> (cs <$> arbitraryText), + ResponseRenameAcc + <$> arbitraryDBAccount net ctx + <*> arbitraryText + <*> arbitraryText, + ResponseAccounts + <$> resize 20 (listOf $ arbitraryDBAccount net ctx), + ResponseReceive + <$> arbitraryDBAccount net ctx + <*> arbitraryDBAddress net, + ResponseAddresses + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf $ arbitraryDBAddress net), + ResponseLabel + <$> arbitraryDBAccount net ctx + <*> arbitraryDBAddress net, + ResponseTxs + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf $ arbitraryTxInfo net ctx), + ResponsePrepareTx + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponsePendingTxs + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf $ arbitraryNoSigTxInfo net ctx), + ResponseReviewTx + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponseExportTx + <$> (cs <$> arbitraryText), + ResponseImportTx + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponseDeleteTx + <$> arbitraryNatural + <*> arbitraryNatural, + ResponseSignTx + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponseCoins + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf arbitraryJsonCoin), + ResponseSendTx + <$> arbitraryDBAccount net ctx + <*> arbitraryTxInfo net ctx + <*> arbitraryTxHash, + ResponseSyncAcc + <$> arbitraryDBAccount net ctx + <*> arbitraryBlockHash + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural, + ResponseDiscoverAcc + <$> arbitraryDBAccount net ctx + <*> arbitraryBlockHash + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural, + ResponseVersion <$> arbitraryText, + ResponsePrepareSweep + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponseSignSweep + <$> arbitraryDBAccount net ctx + <*> arbitraryNoSigTxInfo net ctx, + ResponseRollDice + <$> resize 20 (listOf arbitraryNatural) + <*> arbitraryText + ] diff --git a/test/Network/Haskoin/Wallet/AccountStoreSpec.hs b/test/Network/Haskoin/Wallet/AccountStoreSpec.hs deleted file mode 100644 index e3449204..00000000 --- a/test/Network/Haskoin/Wallet/AccountStoreSpec.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.Haskoin.Wallet.AccountStoreSpec where - -import Control.Monad (replicateM_, void) -import Control.Monad.Except (Except, runExcept) -import Control.Monad.State (StateT, gets) -import Data.Default (def) -import Data.Either (isLeft) -import qualified Data.Map.Strict as Map -import Haskoin.Crypto - ( Ctx, - DerivPathI (Deriv, (:|)), - HardPath, - derivePath, - deriveXPubKey, - makeXPrvKey, - ) -import Haskoin.Network (btc) -import Haskoin.Util (prepareContext) -import Haskoin.Util.Arbitrary - ( IdentityTests (marshalJsonTests), - MarshalJsonBox (MarshalJsonBox), - arbitraryHardPath, - arbitraryNetwork, - arbitraryXPubKey, - testIdentity, - ) -import Network.Haskoin.Wallet.AccountStore - ( AccountMap (AccountMap), - AccountStore (AccountStore), - Commit (NoCommit, commitValue), - accountStoreAccount, - emptyAccountStore, - execAccountMapT, - execAccountStoreT, - genExtAddress, - genIntAddress, - getAccountStore, - getAccountStoreByDeriv, - insertAccountStore, - renameAccountStore, - runAccountMapT, - runAccountStoreT, - ) -import Network.Haskoin.Wallet.TestUtils (forceRight, genNatural) -import Test.HUnit (assertBool, assertEqual) -import Test.Hspec (Spec, describe, it) -import Test.QuickCheck (Gen) - -identityTests :: Ctx -> IdentityTests -identityTests ctx = - def - { marshalJsonTests = - [MarshalJsonBox $ (ctx,) <$> arbitraryAccountStore ctx] - } - -spec :: Spec -spec = - prepareContext $ \ctx -> do - testIdentity $ identityTests ctx - let mast = makeXPrvKey "1" - pub1 = - deriveXPubKey ctx $ - derivePath ctx (Deriv :| 44 :| 0 :| 0 :: HardPath) mast - pub2 = - deriveXPubKey ctx $ - derivePath ctx (Deriv :| 44 :| 0 :| 1 :: HardPath) mast - acc1 e i = - AccountStore pub1 e i (Deriv :| 44 :| 0 :| 0) Haskoin.Network.btc - acc2 e i = - AccountStore pub2 e i (Deriv :| 44 :| 0 :| 1) Haskoin.Network.btc - describe "AccountMap" $ do - let s0 = AccountMap Map.empty - it "Reading an account from an empty map fails" $ do - let res1 = run s0 $ getAccountStore Nothing - res2 = run s0 $ getAccountStore (Just "acc1") - assertBool "res1" $ isLeft res1 - assertBool "res2" $ isLeft res2 - let s1 = - commitValue $ - forceRight $ - exec s0 $ - insertAccountStore - "acc1" - (emptyAccountStore Haskoin.Network.btc pub1) - it "Can insert a new account" $ - s1 == AccountMap (Map.fromList [("acc1", acc1 0 0)]) - it "Can read the new account" $ do - let a0 = run s1 $ getAccountStore Nothing - a1 = run s1 $ getAccountStore (Just "acc1") - assertEqual "acc1 a0" (Right ("acc1", acc1 0 0)) (fst <$> a0) - assertEqual "acc1 a1" (Right ("acc1", acc1 0 0)) (fst <$> a1) - it "Can read the new account by derivation" $ do - let a = run s1 $ getAccountStoreByDeriv Haskoin.Network.btc 0 - assertEqual "acc1" (Right ("acc1", acc1 0 0)) (fst <$> a) - it "Reading an invalid account fails" $ do - let a = run s1 $ getAccountStore (Just "acc2") - assertBool "acc2" $ isLeft a - it "Inserting duplicate accounts fails" $ do - let a1 = - exec s1 $ - insertAccountStore - "acc1" - (emptyAccountStore Haskoin.Network.btc pub2) - a2 = - exec s1 $ - insertAccountStore - "acc2" - (emptyAccountStore Haskoin.Network.btc pub1) - assertBool "acc1 a1" $ isLeft a1 - assertBool "acc2 a2" $ isLeft a2 - let s2 = - commitValue $ - forceRight $ - exec s1 $ - insertAccountStore - "acc2" - (emptyAccountStore Haskoin.Network.btc pub2) - it "Can add a second account" $ - assertEqual - "map" - (AccountMap (Map.fromList [("acc1", acc1 0 0), ("acc2", acc2 0 0)])) - s2 - it "Can query both accounts" $ do - let a0 = run s2 $ getAccountStore Nothing - a1 = run s2 $ getAccountStore (Just "acc1") - a2 = run s2 $ getAccountStore (Just "acc2") - assertBool "acc1 a0" $ isLeft a0 - assertEqual "acc1 a1" (Right ("acc1", acc1 0 0)) (fst <$> a1) - assertEqual "acc2 a2" (Right ("acc2", acc2 0 0)) (fst <$> a2) - it "Can rename accounts" $ do - let a = - commitValue $ - forceRight $ - exec s2 $ - renameAccountStore "acc1" "acc3" - assertEqual - "Rename map" - (AccountMap (Map.fromList [("acc3", acc1 0 0), ("acc2", acc2 0 0)])) - a - it "Can query the account derivations" $ do - let ((_, a1), _) = forceRight $ run s2 $ getAccountStore (Just "acc1") - ((_, a2), _) = forceRight $ run s2 $ getAccountStore (Just "acc2") - (d1, _) = forceRight $ runAcc a1 $ gets accountStoreAccount - (d2, _) = forceRight $ runAcc a2 $ gets accountStoreAccount - assertEqual "Derivation d1" (Right 0) d1 - assertEqual "Derivation d2" (Right 1) d2 - it "Produces correct Commit/Nocommit" $ do - let c1 = forceRight $ exec s2 $ getAccountStore (Just "acc1") - c2 = forceRight $ exec s2 $ renameAccountStore "acc1" "acc3" - c3 = forceRight $ execAcc (acc1 0 0) $ gets accountStoreAccount - c4 = - forceRight $ - execAcc (acc1 0 0) $ - Control.Monad.void (genExtAddress ctx) - assertBool "Commit c1" $ not $ isCommit c1 - assertBool "Commit c2" $ isCommit c2 - assertBool "Commit c3" $ not $ isCommit c3 - assertBool "Commit c4" $ isCommit c4 - it "Updates indices when generating addresses" $ do - let a1 = - commitValue $ - forceRight $ - execAcc (acc1 0 0) $ - Control.Monad.replicateM_ 10 (genExtAddress ctx) - >> Control.Monad.replicateM_ 7 (genIntAddress ctx) - assertEqual "Gen addrs" (acc1 10 7) a1 - -isCommit :: Commit a -> Bool -isCommit (NoCommit _) = False -isCommit _ = True - -exec :: - AccountMap -> - StateT AccountMap (Except String) a -> - Either String (Commit AccountMap) -exec s a = runExcept $ execAccountMapT a s - -run :: - AccountMap -> - StateT AccountMap (Except String) a -> - Either String (a, Commit AccountMap) -run s a = runExcept $ runAccountMapT a s - -execAcc :: - AccountStore -> - StateT AccountStore (Except String) a -> - Either String (Commit AccountStore) -execAcc s a = runExcept $ execAccountStoreT a s - -runAcc :: - AccountStore -> - StateT AccountStore (Except String) a -> - Either String (a, Commit AccountStore) -runAcc s a = runExcept $ runAccountStoreT a s - -arbitraryAccountStore :: Ctx -> Gen AccountStore -arbitraryAccountStore ctx = - AccountStore - <$> arbitraryXPubKey ctx - <*> genNatural - <*> genNatural - <*> arbitraryHardPath - <*> arbitraryNetwork diff --git a/test/Network/Haskoin/Wallet/SigningSpec.hs b/test/Network/Haskoin/Wallet/SigningSpec.hs deleted file mode 100644 index 79707b46..00000000 --- a/test/Network/Haskoin/Wallet/SigningSpec.hs +++ /dev/null @@ -1,514 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.Haskoin.Wallet.SigningSpec where - -import Control.Arrow (second) -import qualified Data.ByteString as BS -import Data.Either (fromRight) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Serialize (encode) -import qualified Data.Serialize as S -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32, Word8) -import Haskoin - ( Address (hash160), - BlockHash, - Ctx, - DerivPathI ((:/)), - OutPoint (OutPoint), - ScriptOutput (PayPKHash), - SigInput (SigInput), - Tx (Tx), - TxHash, - TxIn (TxIn), - TxOut (TxOut), - XPrvKey, - XPubKey, - btc, - deriveXPubKey, - hexToBlockHash, - marshal, - prepareContext, - sigHashAll, - textToAddr, - txHash, - xPrvImport, - xPubImport, - ) -import qualified Haskoin.Store.Data as Store -import Network.Haskoin.Wallet.AccountStore (extDeriv, intDeriv) -import Network.Haskoin.Wallet.FileIO - ( TxSignData (TxSignData, txSignDataSigned, txSignDataTx), - ) -import Network.Haskoin.Wallet.Signing - ( buildWalletTx, - signWalletTx, - signingKey, - ) -import Network.Haskoin.Wallet.TxInfo - ( MyInputs (MyInputs), - MyOutputs (MyOutputs), - TxInfo - ( TxInfo, - txInfoAmount, - txInfoBlockRef, - txInfoConfirmations, - txInfoFee, - txInfoFeeByte, - txInfoId, - txInfoMyInputs, - txInfoMyOutputs, - txInfoNonStdInputs, - txInfoNonStdOutputs, - txInfoOtherInputs, - txInfoOtherOutputs, - txInfoSize, - txInfoType - ), - TxType (TxDebit, TxInternal), - ) -import Numeric.Natural (Natural) -import System.Random (mkStdGen) -import Test.HUnit (assertBool, assertEqual) -import Test.Hspec (Spec, describe, it) - -spec :: Spec -spec = - prepareContext $ \ctx -> do - buildSpec ctx - signingSpec ctx - -buildSpec :: Ctx -> Spec -buildSpec ctx = - describe "Transaction builder" $ do - it "can build a transaction" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] - gen = mkStdGen 0 -- Use a predictable seed for tests - resE = buildWalletTx btc ctx gen rcps change coins 314 10000 False - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] -- Greedy algorithm - ((rcps !! 1) : (change, 199825416) : [head rcps]) - ) - (fst <$> resE) - assertEqual - "Coins" - (Right [coins !! 2, coins !! 1, head coins]) - (snd <$> resE) - it "can fail to build a transaction if funds are insufficient" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps = [(oAddr' 0, 500000000), (oAddr' 1, 500000000)] - gen = mkStdGen 0 - resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False - assertEqual "Tx" (Left "chooseCoins: No solution found") resE - it "will drop the change output if it is dust" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps = [(oAddr' 0, 500000000), (oAddr' 1, 499990000)] - gen = mkStdGen 0 - resE1 = buildWalletTx btc ctx gen rcps change coins 0 9999 False - resE2 = buildWalletTx btc ctx gen rcps change coins 0 10000 False - resE3 = buildWalletTx btc ctx gen rcps change coins 1 9999 False - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] - ((rcps !! 1) : (change, 10000) : [head rcps]) - ) - (fst <$> resE1) - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] - ((rcps !! 1) : [head rcps]) - ) - (fst <$> resE2) - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] - ((rcps !! 1) : [head rcps]) - ) - (fst <$> resE3) - it "will fail if sending dust" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps = [(oAddr' 0, 500000000), (oAddr' 1, 10000)] - gen = mkStdGen 0 - resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False - assertEqual - "Tx" - (Left "Recipient output is smaller than the dust value") - resE - it "can make the recipient pay for the fees" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] - gen = mkStdGen 0 - resE = buildWalletTx btc ctx gen rcps change coins 314 10000 True - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] - ( (oAddr' 1, 199912708) - : (change, 200000000) - : [(oAddr' 0, 199912708)] - ) - ) - (fst <$> resE) - it "fails when recipients cannot pay" $ do - let coins = - [ coin' ctx (txid' 1, 0) (addr' 0) 100000000, - coin' ctx (txid' 1, 1) (addr' 1) 200000000, - coin' ctx (txid' 1, 2) (addr' 1) 300000000, - coin' ctx (txid' 1, 3) (addr' 2) 400000000 - ] - change = iAddr' 0 - rcps1 = [(oAddr' 0, 400000000), (oAddr' 1, 87291)] -- fee is 2*87292 - rcps2 = [(oAddr' 0, 400000000), (oAddr' 1, 87292)] - rcps3 = [(oAddr' 0, 400000000), (oAddr' 1, 97293)] - gen = mkStdGen 0 - resE1 = buildWalletTx btc ctx gen rcps1 change coins 314 10000 True - resE2 = buildWalletTx btc ctx gen rcps2 change coins 314 10000 True - resE3 = buildWalletTx btc ctx gen rcps3 change coins 314 10000 True - assertEqual "Tx" (Left "Recipients can't pay for the fee") resE1 - assertEqual - "Tx" - (Left "Recipient output is smaller than the dust value") - resE2 - assertEqual - "Tx" - ( Right $ - tx' - ctx - [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] - ((oAddr' 1, 10001) : (change, 199902707) : [(oAddr' 0, 399912708)]) - ) - (fst <$> resE3) - -signingSpec :: Ctx -> Spec -signingSpec ctx = - describe "Transaction signer" $ do - it "can derive private signing keys" $ do - let xPrvE = signingKey btc ctx pwd mnem 0 - xPubE = deriveXPubKey ctx <$> xPrvE - assertEqual "XPrvKey" (Right $ fst $ keys ctx) xPrvE - assertEqual "XPubKey" (Right $ snd $ keys ctx) xPubE - it "can sign a simple transaction" $ do - let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0)] - [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 0] - [intDeriv :/ 0] - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - (resDat, resTxInfo) = fromRight (error "fromRight") resE - signedTx = txSignDataTx resDat - assertEqual - "TxInfo" - ( TxInfo - { txInfoId = txHash signedTx, - txInfoType = TxDebit, - txInfoAmount = -60000000, - txInfoMyOutputs = - Map.fromList [(iAddr' 0, MyOutputs 40000000 (intDeriv :/ 0))], - txInfoOtherOutputs = Map.fromList [(oAddr' 0, 50000000)], - txInfoNonStdOutputs = [], - txInfoMyInputs = - Map.fromList - [ ( addr' 0, - MyInputs - 100000000 - (extDeriv :/ 0) - [ SigInput - (PayPKHash (addr' 0).hash160) - 100000000 - (OutPoint (txHash fundTx) 0) - sigHashAll - Nothing - ] - ) - ], - txInfoOtherInputs = Map.empty, - txInfoNonStdInputs = [], - txInfoSize = fromIntegral $ BS.length $ encode signedTx, - txInfoFee = 10000000, - txInfoFeeByte = 44247.79, - txInfoBlockRef = Store.MemRef 0, - txInfoConfirmations = 0 - } - ) - resTxInfo - assertBool "The transaction was not signed" (txSignDataSigned resDat) - it "can set the correct TxInternal transaction types" $ do - let fundTx = - tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 200000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0), (txHash fundTx, 1)] - [(iAddr' 0, 50000000), (addr' 2, 200000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 0, extDeriv :/ 1] - [intDeriv :/ 0, extDeriv :/ 2] - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - assertEqual "TxInternal" (Right TxInternal) $ txInfoType . snd <$> resE - it "fails when an input is not signed" $ do - let fundTx = - tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0), (txHash fundTx, 1)] - [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 0] -- We omit derivation 1 - [intDeriv :/ 0] - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - assertEqual "TxSignData" (Left "The transaction could not be signed") resE - it "fails when referenced input transactions are missing" $ do - let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0), (txHash fundTx, 1)] - [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 0, extDeriv :/ 1] -- 1 is missing in fundTx - [intDeriv :/ 0] - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - assertEqual - "TxSignData" - (Left "Referenced input transactions are missing") - resE - it "fails when private key derivations don't match the Tx inputs" $ do - let fundTx = - tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0), (txHash fundTx, 1)] - [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 1, extDeriv :/ 2] -- 1 and 2 instead of 0 and 1 - [intDeriv :/ 0] - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - assertEqual - "TxSignData" - (Left "Private key derivations don't match the transaction inputs") - resE - it "fails when output derivations don't match the Tx outputs" $ do - let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] - newTx = - tx' - ctx - [(txHash fundTx, 0)] - [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] - dat = - TxSignData - newTx - [fundTx] - [extDeriv :/ 0] - [intDeriv :/ 1] -- 1 instead of 0 - 0 - False - btc - xPrv = fst $ keys ctx - let resE = signWalletTx ctx dat xPrv - assertEqual - "TxSignData" - (Left "Output derivations don't match the transaction outputs") - resE - --- Test Helpers -- - -tx' :: Ctx -> [(TxHash, Word32)] -> [(Address, Natural)] -> Tx -tx' ctx xs ys = Tx 1 txi txo [] 0 - where - txi = - fmap - (\(h, p) -> TxIn (OutPoint h p) BS.empty maxBound) - xs - f = marshal ctx . PayPKHash . (.hash160) - txo = fmap (\(a, v) -> TxOut v $ f a) (Control.Arrow.second fromIntegral <$> ys) - -txid' :: Word8 -> TxHash -txid' w = - fromRight undefined $ S.decode $ w `BS.cons` BS.replicate 31 0x00 - -bid' :: Word8 -> BlockHash -bid' w = - fromMaybe (error "Could not decode block hash") $ - hexToBlockHash $ - cs $ - w `BS.cons` BS.replicate 31 0x00 - -coin' :: Ctx -> (TxHash, Word32) -> Address -> Natural -> Store.Unspent -coin' ctx (h, p) a v = - Store.Unspent - { Store.block = Store.MemRef 0, - Store.outpoint = OutPoint h p, - Store.value = fromIntegral v, - Store.script = marshal ctx $ PayPKHash $ (.hash160) a, - Store.address = Just a - } - -addr' :: Int -> Address -addr' i = extAddrs !! i - -iAddr' :: Int -> Address -iAddr' i = intAddrs !! i - -oAddr' :: Int -> Address -oAddr' i = othAddrs !! i - --- Test Constants - -pwd :: Text -pwd = "correct horse battery staple" - -mnem :: Text -mnem = - "snow senior nerve virus fabric now fringe clip marble interest analyst can" - --- Keys for account 0 -keys :: Ctx -> (XPrvKey, XPubKey) -keys ctx = - ( fromJust $ - xPrvImport - btc - "xprv9yHxeaLAZvxXb9VtJNesqk8avfN8misGAW9DUW9eacZJNqsfZxqKLmK5jfmvFideQqGesviJeagzSQYCuQySjgvt7TdfowKja5aJqbgyuNh", - fromJust $ - xPubImport - btc - ctx - "xpub6CHK45s4QJWpodaMQQBtCt5KUhCdBBb7Xj4pGtZG8x6HFeCp7W9ZtZdZaxA34YtFAhuebiKqLqHLYoB8HDadGutW8kEH4HeMdeS1KJz8Uah" - ) - -extAddrs :: [Address] -extAddrs = - fromMaybe (error "extAddrs no parse") . textToAddr btc - <$> [ "1KEn7jEXa7KCLeZy59dka5qRJBLnPMmrLj", - "1AVj9WSYayTwUd8rS1mTTo4A6CPsS83VTg", - "1Dg6Kg7kQuyiZz41HRWXKUWKRu6ZyEf1Nr", - "1yQZuJjA6w7hXpc3C2LRiCv22rKCas7F1", - "1cWcYiGK7NwjPBJuKRqZxV4aymUnPu1mx", - "1MZuimSXigp8oqxkVUvZofqHNtVjdcdAqc", - "1JReTkpFnsrMqhSEJwUNZXPAyeTo2HQfnE", - "1Hx9xWAHhcjea5uJnyADktCfcLbuBnRnwA", - "1HXJhfiD7JFCGMFZnhKRsZxoPF7xDTqWXP", - "1MZpAt1FofY69B6fzooFxZqe6SdrVrC3Yw" - ] - -intAddrs :: [Address] -intAddrs = - fromMaybe (error "intAddrs no parse") . textToAddr btc - <$> [ "17KiDLpE3r92gWR8kFGkYDtgHqEVJrznvn", - "1NqNFsuS7K3dfF8RnAVr9YYCMvJuF9GCn6", - "1MZNPWwFwy2CqVgWBq6unPWBWrZTQ7WTnr", - "19XbPiR98wmoJQZ42K8pVMzdCwSXZBh7iz", - "1Gkn7EsphiaYuv6XXvG4Kyg3LSfqFMeXHX", - "14VkCGcLkNqUwRMVjpLEyodAhXvzUWLqPM", - "1PkyVUxPMGTLzUWNFNraMagACA1x3eD4CF", - "1M2mmDhWTjEuqPfUdaQH6XPsr5i29gx581", - "184JdZjasQUmNo2AimkbKAW2sxXMF9BAvK", - "13b1QVnWFRwCrjvhthj4JabpnJ4nyxbBqm" - ] - -othAddrs :: [Address] -othAddrs = - fromMaybe (error "othAddrs no parse") . textToAddr btc - <$> [ "1JCq8Aa9d9rg4T4XV93RV3DMxd5u7GkSSU", - "1PxH6Yutj49mRAabGvcTxnLkFZCuXDXvRJ", - "191J7K3FaXXyM7C9ceSMRsJNF6aWCvvf1Q", - "1FVnYNLRdR5vQkynApupUez6ZfcDqsLHdj", - "1PmNJHnbk7Kct5FMqbEVRxqqR2mXVQKK5P", - "18CaQNcVwzUkE9KvwmMd6a5UWNgqJFEAh1", - "1M2Cv69B7LRud8su2wdd7HV2i6MrXqzdKP", - "19xYPmoJ2XV1vJnSkzsrXUJXCgKvPE3ri4", - "1N2JAKWVFAoKFEUci3tY3kvrGFY6poRgvm", - "15EANoYyJoo1J51ERdQzNwZCyhEtPfcP8g" - ] diff --git a/test/Network/Haskoin/Wallet/TestUtils.hs b/test/Network/Haskoin/Wallet/TestUtils.hs deleted file mode 100644 index 566388e1..00000000 --- a/test/Network/Haskoin/Wallet/TestUtils.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.Haskoin.Wallet.TestUtils where - -import Data.Either (fromRight) -import Numeric.Natural (Natural) -import Test.QuickCheck (Gen, arbitrarySizedNatural) - -genNatural :: Test.QuickCheck.Gen Natural -genNatural = Test.QuickCheck.arbitrarySizedNatural - -forceRight :: Either a b -> b -forceRight = fromRight (error "fromRight")