haskoin-wallet 0.0.1 → 0.2.0
raw patch · 38 files changed
+7303/−6594 lines, 38 filesdep +SafeSemaphoredep +daemonsdep +data-defaultdep −binarydep −eitherdep −haskoin-cryptodep ~QuickCheckdep ~aesondep ~base
Dependencies added: SafeSemaphore, daemons, data-default, deepseq, esqueleto, exceptions, file-embed, filepath, haskoin-core, haskoin-node, haskoin-wallet, leveldb-haskell, lifted-async, lifted-base, monad-control, monad-logger, persistent-mysql, resourcet, split, stm, stm-chans, stm-conduit, string-conversions, transformers-base, unix, zeromq4-haskell
Dependencies removed: binary, either, haskoin-crypto, haskoin-protocol, haskoin-script, haskoin-util, vector
Dependency ranges changed: QuickCheck, aeson, base, conduit, mtl, persistent, persistent-sqlite, persistent-template, text, time
Files
- Network/Haskoin/Wallet.hs +105/−110
- Network/Haskoin/Wallet/Arbitrary.hs +0/−136
- Network/Haskoin/Wallet/Client.hs +230/−0
- Network/Haskoin/Wallet/Client/Commands.hs +692/−0
- Network/Haskoin/Wallet/Internals.hs +31/−0
- Network/Haskoin/Wallet/KeyRing.hs +720/−0
- Network/Haskoin/Wallet/Keys.hs +0/−322
- Network/Haskoin/Wallet/Manager.hs +0/−292
- Network/Haskoin/Wallet/Model.hs +219/−0
- Network/Haskoin/Wallet/Server.hs +378/−0
- Network/Haskoin/Wallet/Server/Handler.hs +626/−0
- Network/Haskoin/Wallet/Settings.hs +173/−0
- Network/Haskoin/Wallet/Store.hs +0/−534
- Network/Haskoin/Wallet/Store/CoinStatus.hs +0/−51
- Network/Haskoin/Wallet/Store/DbAccount.hs +0/−153
- Network/Haskoin/Wallet/Store/DbAddress.hs +0/−199
- Network/Haskoin/Wallet/Store/DbCoin.hs +0/−91
- Network/Haskoin/Wallet/Store/DbTx.hs +0/−441
- Network/Haskoin/Wallet/Store/Util.hs +0/−337
- Network/Haskoin/Wallet/Transaction.hs +1306/−0
- Network/Haskoin/Wallet/TxBuilder.hs +0/−357
- Network/Haskoin/Wallet/Types.hs +705/−0
- app/Main.hs +7/−0
- config/config.yml +120/−0
- config/help +47/−0
- config/models +93/−0
- database/mysql/Network/Haskoin/Wallet/Database.hs +21/−0
- database/sqlite/Network/Haskoin/Wallet/Database.hs +21/−0
- haskoin-wallet.cabal +136/−108
- script/hw.hs +0/−269
- stack.yaml +16/−0
- tests/Main.hs +8/−7
- tests/Network/Haskoin/Wallet/Arbitrary.hs +38/−0
- tests/Network/Haskoin/Wallet/Store/Units.hs +0/−2548
- tests/Network/Haskoin/Wallet/Tests.hs +9/−143
- tests/Network/Haskoin/Wallet/Units.hs +1602/−0
- tests/QuickCheckUtils.hs +0/−44
- tests/Units.hs +0/−452
Network/Haskoin/Wallet.hs view
@@ -1,128 +1,123 @@ {-|- This package provides functions for generating hierarchical deterministic- keys (BIP32). It also provides functions for building and signing both- simple transactions and multisignature transactions. This package also- provides a command line application called /hw/ (haskoin wallet). It is a- lightweight bitcoin wallet featuring BIP32 key management, deterministic- signatures (RFC-6979) and first order support for multisignature- transactions. A library API for /hw/ is also exposed.+ This package provides a command line application called /hw/ (haskoin+ wallet). It is a lightweight bitcoin wallet featuring BIP32 key management,+ deterministic signatures (RFC-6979) and first order support for+ multisignature transactions. A library API for /hw/ is also exposed. -} module Network.Haskoin.Wallet-( - -- *Extended Keys- ChainCode-- -- **Extended Private Keys-, XPrvKey(..)-, makeXPrvKey-, xPrvIsPrime-, xPrvChild-, xPrvID-, xPrvFP-, xPrvExport-, xPrvImport-, xPrvWIF-- -- **Extended Public Keys-, XPubKey(..)-, deriveXPubKey-, xPubIsPrime-, xPubChild-, xPubID-, xPubFP-, xPubAddr-, xPubExport-, xPubImport-- -- **Child key derivations-, prvSubKey-, pubSubKey-, primeSubKey-, prvSubKeys-, pubSubKeys-, primeSubKeys+(+-- *Client+ clientMain+, OutputFormat(..)+, Config(..) - -- ***Multisig derivations-, mulSigSubKey-, mulSigSubKeys+-- *Server+, runSPVServer+, stopSPVServer+, SPVMode(..) - -- *Derivation tree interoperability+-- *API JSON Types+, JsonKeyRing(..)+, JsonAccount(..)+, JsonAddr(..)+, JsonCoin(..)+, JsonTx(..)+, JsonWithKeyRing(..)+, JsonWithAccount(..)+, JsonWithAddr(..) - -- | To improve BIP32 wallet interoperability, a standard derivation tree- -- is used. All accounts are generated through prime derivations from the- -- master key. This ensures that the master key is not compromised if- -- an account is compromised. Every account will generate receiving- -- addresses from the non-prime subtree index 0 and internal change- -- addresses from the non-prime subtree index 1. MasterKey, AccountKey- -- and AddressKey types are defined to conform to the wallet interoperability- -- format.+-- *API Request Types+, WalletRequest(..)+, PageRequest(..)+, validPageRequest+, NewKeyRing(..)+, NewAccount(..)+, SetAccountGap(..)+, OfflineTxData(..)+, CoinSignData(..)+, TxAction(..)+, AddressLabel(..)+, NodeAction(..)+, AccountType(..)+, AddressType(..)+, addrTypeIndex+, TxType(..)+, TxConfidence(..)+, AddressInfo(..)+, BalanceInfo(..) -, KeyIndex+-- *API Response Types+, WalletResponse(..)+, TxCompleteRes(..)+, AddrTx(..)+, PageRes(..)+, RescanRes(..) - -- **Master keys-, MasterKey(..)-, makeMasterKey-, loadMasterKey+-- *Database KeyRings+, initWallet+, newKeyRing+, keyRings+, keyRingSource+, getKeyRing - -- **Account keys-, AccPrvKey(..)-, AccPubKey(..)-, loadPrvAcc-, loadPubAcc-, accPrvKey-, accPubKey-, accPrvKeys-, accPubKeys+-- *Database Accounts+, accounts+, accountSource+, newAccount+, addAccountKeys+, getAccount+, isMultisigAccount+, isReadAccount+, isCompleteAccount - -- **Address keys-, AddrPrvKey(..)-, AddrPubKey(..)-, addr-, extPrvKey-, extPubKey-, intPrvKey-, intPubKey-, extPrvKeys-, extPubKeys-, intPrvKeys-, intPubKeys-, extAddr-, intAddr-, extAddrs-, intAddrs-, extAddrs'-, intAddrs'+-- *Database Addresses+, getAddress+, addressSourceAll+, addressSource+, addressPage+, unusedAddresses+, addressCount+, setAddrLabel+, addressPrvKey+, useAddress+, setAccountGap+, firstAddrTime+, getPathRedeem+, getPathPubKey - -- ***Multisig address keys-, extMulSigKey-, intMulSigKey-, extMulSigKeys-, intMulSigKeys-, extMulSigAddr-, intMulSigAddr-, extMulSigAddrs-, intMulSigAddrs+-- *Database Bloom Filter+, getBloomFilter - -- *Build Transactions-, buildTx-, buildAddrTx+-- *Database transactions+, txPage+, addrTxPage+, getTx+, getAccountTx+, importTx+, importNetTx+, signKeyRingTx+, createTx+, signOfflineTx+, getOfflineTxData - -- *Transaction signing-, SigInput(..)-, signTx-, detSignTx-, isTxComplete+-- *Database blocks+, importMerkles+, getBestBlock - -- *Coin selection-, Coin(..)-, chooseCoins-, chooseMSCoins-, guessTxSize+-- *Database coins and balances+, spendableCoins+, spendableCoinsSource+, accountBalance+, addressBalances +-- *Rescan+, resetRescan ) where -import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Manager-import Network.Haskoin.Wallet.TxBuilder-+import Network.Haskoin.Wallet.Client+import Network.Haskoin.Wallet.Server+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Transaction
− Network/Haskoin/Wallet/Arbitrary.hs
@@ -1,136 +0,0 @@-{-|- Arbitrary instances for wallet data types.--}-module Network.Haskoin.Wallet.Arbitrary -( genPubKeyC-, genMulSigInput-, genRegularInput -, genAddrOutput-, RegularTx(..)-, MSParam(..)-) where--import Test.QuickCheck - ( Gen- , Arbitrary- , arbitrary- , vectorOf- , oneof- , choose- , elements- )--import Control.Monad (liftM)-import Control.Applicative ((<$>),(<*>))--import Data.Maybe (fromJust)--import Network.Haskoin.Crypto.Arbitrary -import Network.Haskoin.Protocol.Arbitrary ()-import Network.Haskoin.Script.Arbitrary ()--import Network.Haskoin.Wallet-import Network.Haskoin.Script-import Network.Haskoin.Protocol-import Network.Haskoin.Crypto---- | Data type for generating arbitrary valid multisignature parameters (m of n)-data MSParam = MSParam Int Int deriving (Eq, Show)--instance Arbitrary MSParam where- arbitrary = do- n <- choose (1,16)- m <- choose (1,n)- return $ MSParam m n---- | Data type for generating arbitrary transaction with inputs and outputs--- consisting only of script hash or pub key hash scripts.-data RegularTx = RegularTx Tx deriving (Eq, Show)---- | Generate an arbitrary compressed public key.-genPubKeyC :: Gen PubKey-genPubKeyC = derivePubKey <$> genPrvKeyC---- | Generate an arbitrary script hash input spending a multisignature--- pay to script hash.-genMulSigInput :: Gen ScriptHashInput-genMulSigInput = do- (MSParam m n) <- arbitrary- rdm <- PayMulSig <$> (vectorOf n genPubKeyC) <*> (return m)- inp <- SpendMulSig <$> (vectorOf m arbitrary) <*> (return m)- return $ ScriptHashInput inp rdm---- | Generate an arbitrary transaction input spending a public key hash or--- script hash output.-genRegularInput :: Gen TxIn-genRegularInput = do- op <- arbitrary- sq <- arbitrary- sc <- oneof [ encodeScriptHash <$> genMulSigInput- , encodeInput <$> (SpendPKHash <$> arbitrary <*> genPubKeyC)- ]- return $ TxIn op sc sq---- | Generate an arbitrary output paying to a public key hash or script hash--- address.-genAddrOutput :: Gen TxOut-genAddrOutput = do- v <- arbitrary- sc <- oneof [ (PayPKHash . pubKeyAddr) <$> arbitrary- , (PayScriptHash . scriptAddr) <$> arbitrary- ]- return $ TxOut v $ encodeOutput sc--instance Arbitrary RegularTx where- arbitrary = do- x <- choose (1,10)- y <- choose (1,10)- liftM RegularTx $ Tx <$> arbitrary - <*> (vectorOf x genRegularInput) - <*> (vectorOf y genAddrOutput) - <*> arbitrary--instance Arbitrary XPrvKey where- arbitrary = XPrvKey <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> genPrvKeyC--instance Arbitrary XPubKey where- arbitrary = deriveXPubKey <$> arbitrary--instance Arbitrary MasterKey where- arbitrary = fromJust . makeMasterKey <$> arbitrary--instance Arbitrary AccPrvKey where- arbitrary = do- master <- arbitrary- index <- choose (0,0x7fffffff)- return $ fromJust $ accPrvKey master index--instance Arbitrary AccPubKey where- arbitrary = do- master <- arbitrary- index <- choose (0,0x7fffffff)- return $ fromJust $ accPubKey master index--instance Arbitrary AddrPrvKey where- arbitrary = do- accKey <- arbitrary- index <- arbitrary- elements [ fromJust $ extPrvKey accKey index- , fromJust $ intPrvKey accKey index- ]--instance Arbitrary AddrPubKey where- arbitrary = do- accKey <- arbitrary- index <- arbitrary- elements [ fromJust $ extPubKey accKey index- , fromJust $ intPubKey accKey index- ]--instance Arbitrary Coin where- arbitrary = Coin <$> arbitrary <*> arbitrary <*> arbitrary-
+ Network/Haskoin/Wallet/Client.hs view
@@ -0,0 +1,230 @@+module Network.Haskoin.Wallet.Client (clientMain) where++import System.FilePath ((</>))+import System.Directory (createDirectoryIfMissing)+import System.Posix.Directory (changeWorkingDirectory)+import System.Posix.Files+ ( setFileMode+ , setFileCreationMask+ , unionFileModes+ , ownerModes+ , groupModes+ , otherModes+ , fileExist+ )+import System.Environment (getArgs, lookupEnv)+import System.Info (os)+import System.Console.GetOpt+ ( getOpt+ , usageInfo+ , OptDescr (Option)+ , ArgDescr (NoArg, ReqArg)+ , ArgOrder (Permute)+ )++import Control.Monad (when, forM_)+import Control.Monad.Trans (liftIO)+import qualified Control.Monad.Reader as R (runReaderT)++import Data.Default (def)+import Data.FileEmbed (embedFile)+import qualified Data.Text as T (pack, unpack)+import Data.Yaml (decodeFileEither)+import Data.String.Conversions (cs)++import Network.Haskoin.Constants+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Client.Commands+import Network.Haskoin.Wallet.Types++import System.FilePath.Posix (isAbsolute)++usageHeader :: String+usageHeader = "Usage: hw [<options>] <command> [<args>]"++cmdHelp :: [String]+cmdHelp = lines $ cs $ $(embedFile "config/help")++warningMsg :: String+warningMsg = unwords+ [ "!!!", "This software is experimental."+ , "Use only small amounts of Bitcoins.", "!!!"+ ]++usage :: [String]+usage = warningMsg : usageInfo usageHeader options : cmdHelp++options :: [OptDescr (Config -> Config)]+options =+ [ Option "k" ["keyring"]+ (ReqArg (\s cfg -> cfg { configKeyRing = T.pack s }) "NAME") $+ "Default: " ++ T.unpack (configKeyRing def)+ , Option "c" ["count"]+ (ReqArg (\s cfg -> cfg { configCount = read s }) "INT") $+ "Items per page. Default: " ++ show (configCount def)+ , Option "m" ["minconf"]+ (ReqArg (\s cfg -> cfg { configMinConf = read s }) "INT") $+ "Minimum confirmations. Default: "+ ++ show (configMinConf def)+ , Option "f" ["fee"]+ (ReqArg (\s cfg -> cfg { configFee = read s }) "INT") $+ "Fee per kilobyte. Default: " ++ show (configFee def)+ , Option "R" ["rcptfee"]+ (NoArg $ \cfg -> cfg { configRcptFee = True }) $+ "Recipient pays fee. Default: " ++ show (configRcptFee def)+ , Option "S" ["nosig"]+ (NoArg $ \cfg -> cfg { configSignTx = False }) $+ "Do not sign. Default: " ++ show (not $ configSignTx def)+ , Option "i" ["internal"]+ (NoArg $ \cfg -> cfg { configAddrType = AddressInternal }) $+ "Internal addresses. Default: "+ ++ show (configAddrType def == AddressInternal)+ , Option "o" ["offline"]+ (NoArg $ \cfg -> cfg { configOffline = True }) $+ "Offline balance. Default: " ++ show (configOffline def)+ , Option "r" ["revpage"]+ (NoArg $ \cfg -> cfg { configReversePaging = True }) $+ "Reverse paging. Default: "+ ++ show (configReversePaging def)+ , Option "p" ["pass"]+ (ReqArg (\s cfg -> cfg { configPass = Just $ T.pack s }) "PASS")+ "Mnemonic passphrase"+ , Option "j" ["json"]+ (NoArg $ \cfg -> cfg { configFormat = OutputJSON })+ "Output JSON"+ , Option "y" ["yaml"]+ (NoArg $ \cfg -> cfg { configFormat = OutputYAML })+ "Output YAML"+ , Option "s" ["socket"]+ (ReqArg (\s cfg -> cfg { configConnect = s }) "URI") $+ "Server socket. Default: " ++ configConnect def+ , Option "d" ["detach"]+ (NoArg $ \cfg -> cfg { configDetach = True }) $+ "Detach server. Default: " ++ show (configDetach def)+ , Option "t" ["testnet"]+ (NoArg $ \cfg -> cfg { configTestnet = True }) "Testnet3 network"+ , Option "g" ["config"]+ (ReqArg (\s cfg -> cfg { configFile = s }) "FILE") $+ "Config file. Default: " ++ configFile def+ , Option "w" ["workdir"]+ (ReqArg (\s cfg -> cfg { configDir = s }) "DIR")+ "Working directory. OS-dependent default"+ , Option "v" ["verbose"]+ (NoArg $ \cfg -> cfg { configVerbose = True }) "Verbose output"+ ]++-- Create and change current working directory+setWorkDir :: Config -> IO ()+setWorkDir cfg = do+ let workDir = configDir cfg </> networkName+ _ <- setFileCreationMask $ otherModes `unionFileModes` groupModes+ createDirectoryIfMissing True workDir+ setFileMode workDir ownerModes+ changeWorkingDirectory workDir++-- Build application configuration+getConfig :: [Config -> Config] -> IO Config+getConfig fs = do+ -- Create initial configuration from defaults and command-line arguments+ let initCfg = foldr ($) def fs++ -- If working directory set in initial configuration, use it+ dir <- case configDir initCfg of "" -> appDir+ d -> return d++ -- Make configuration file relative to working directory+ let cfgFile = if isAbsolute (configFile initCfg)+ then configFile initCfg+ else dir </> configFile initCfg++ -- Get configuration from file, if it exists+ e <- fileExist cfgFile+ if e then do+ cfgE <- decodeFileEither cfgFile+ case cfgE of+ Left x -> error $ show x+ -- Override settings from file using command-line+ Right cfg -> return $ fixConfigDir (foldr ($) cfg fs) dir+ else return $ fixConfigDir initCfg dir+ where+ -- If working directory not set, use default+ fixConfigDir cfg dir = case configDir cfg of "" -> cfg{ configDir = dir }+ _ -> cfg+++clientMain :: IO ()+clientMain = getArgs >>= \args -> case getOpt Permute options args of+ (fs, commands, []) -> do+ cfg <- getConfig fs+ when (configTestnet cfg) switchToTestnet3+ setWorkDir cfg+ dispatchCommand cfg commands+ (_, _, msgs) -> forM_ (msgs ++ usage) putStrLn++dispatchCommand :: Config -> [String] -> IO ()+dispatchCommand cfg args = flip R.runReaderT cfg $ case args of+ ["start"] -> cmdStart+ ["stop"] -> cmdStop+ "newkeyring" : mnemonic -> cmdNewKeyRing mnemonic+ ["keyring"] -> cmdKeyRing+ ["keyrings"] -> cmdKeyRings+ "newacc" : [name] -> cmdNewAcc name+ "newms" : name : m : n : ks -> cmdNewMS False name m n ks+ "newread" : [name, key] -> cmdNewRead name key+ "newreadms" : name : m : n : ks -> cmdNewMS True name m n ks+ "addkeys" : name : ks -> cmdAddKeys name ks+ "setgap" : [name, gap] -> cmdSetGap name gap+ "account" : [name] -> cmdAccount name+ ["accounts"] -> cmdAccounts+ "list" : name : page -> cmdList name page+ "unused" : [name] -> cmdUnused name+ "label" : [name, index, label] -> cmdLabel name index label+ "txs" : name : page -> cmdTxs name page+ "addrtxs" : name : index : page -> cmdAddrTxs name index page+ "genaddrs" : [name, i] -> cmdGenAddrs name i+ "send" : [name, add, amnt] -> cmdSend name add amnt+ "sendmany" : name : xs -> cmdSendMany name xs+ "import" : [name, tx] -> cmdImport name tx+ "sign" : [name, txid] -> cmdSign name txid+ "gettx" : [name, txid] -> cmdGetTx name txid+ "balance" : [name] -> cmdBalance name+ "getoffline" : [name, txid] -> cmdGetOffline name txid+ "signoffline" : [name, tx, dat] -> cmdSignOffline name tx dat+ "rescan" : rescantime -> cmdRescan rescantime+ "decodetx" : [tx] -> cmdDecodeTx tx+ ["status"] -> cmdStatus+ ["version"] -> cmdVersion+ ["help"] -> liftIO $ forM_ usage putStrLn+ [] -> liftIO $ forM_ usage putStrLn+ _ -> liftIO $ forM_ ("Invalid command" : usage) putStrLn+++appDir :: IO FilePath+appDir = case os of "mingw" -> windows+ "mingw32" -> windows+ "mingw64" -> windows+ "darwin" -> osx+ "linux" -> unix+ _ -> unix+ where+ windows = do+ localAppData <- lookupEnv "LOCALAPPDATA"+ dirM <- case localAppData of+ Nothing -> lookupEnv "APPDATA"+ Just l -> return $ Just l+ case dirM of+ Just d -> return $ d </> "Haskoin Wallet"+ Nothing -> return "."+ osx = do+ homeM <- lookupEnv "HOME"+ case homeM of+ Just home -> return $ home </> "Library"+ </> "Application Support"+ </> "Haskoin Wallet"+ Nothing -> return "."+ unix = do+ homeM <- lookupEnv "HOME"+ case homeM of+ Just home -> return $ home </> ".hw"+ Nothing -> return "."+
+ Network/Haskoin/Wallet/Client/Commands.hs view
@@ -0,0 +1,692 @@+module Network.Haskoin.Wallet.Client.Commands+( cmdStart+, cmdStop+, cmdNewKeyRing+, cmdKeyRing+, cmdKeyRings+, cmdNewAcc+, cmdNewMS+, cmdNewRead+, cmdAddKeys+, cmdSetGap+, cmdAccount+, cmdAccounts+, cmdList+, cmdUnused+, cmdLabel+, cmdTxs+, cmdAddrTxs+, cmdGenAddrs+, cmdSend+, cmdSendMany+, cmdImport+, cmdSign+, cmdBalance+, cmdGetTx+, cmdGetOffline+, cmdSignOffline+, cmdRescan+, cmdDecodeTx+, cmdVersion+, cmdStatus+)+where++import System.ZMQ4.Monadic+ ( Req(..)+ , runZMQ+ , socket+ , send+ , receive+ , connect+ )++import Control.Monad (forM_, when, liftM2)+import Control.Monad.Trans (liftIO)+import qualified Control.Monad.Reader as R (ReaderT, ask, asks)++import Data.Maybe+ (listToMaybe, isNothing, fromJust, fromMaybe, isJust, maybeToList)+import Data.List (intercalate, intersperse)+import Data.Text (Text, pack, unpack, splitOn)+import Data.Word (Word64)+import qualified Data.Yaml as YAML (encode)+import qualified Data.Aeson.Encode.Pretty as JSON+ ( Config(..)+ , encodePretty'+ , defConfig+ )+import Data.Aeson+ ( Value(..)+ , FromJSON+ , ToJSON+ , toJSON+ , object+ , encode+ , decode+ , eitherDecode+ , (.=)+ )+import Data.String.Conversions (cs)++import Network.Haskoin.Block+import Network.Haskoin.Crypto+import Network.Haskoin.Transaction+import Network.Haskoin.Script+import Network.Haskoin.Util+import Network.Haskoin.Constants+import Network.Haskoin.Node.STM++import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Server+import Network.Haskoin.Wallet.Database++type Handler = R.ReaderT Config IO++-- hw start [config] [--detach]+cmdStart :: Handler ()+cmdStart = do+ cfg <- R.ask+ liftIO $ runSPVServer cfg+ liftIO $ putStrLn "Process started"++-- hw stop [config]+cmdStop :: Handler ()+cmdStop = R.ask >>= \cfg -> liftIO $ do+ stopSPVServer cfg+ putStrLn "Process stopped"++cmdNewKeyRing :: [String] -> Handler ()+cmdNewKeyRing mnemonicLs = do+ keyRingName <- R.asks configKeyRing+ passphraseM <- R.asks configPass+ let mnemonicM = pack <$> listToMaybe mnemonicLs+ newKeyRing = NewKeyRing keyRingName passphraseM mnemonicM+ sendZmq (PostKeyRingsR newKeyRing) $ putStr . printKeyRing++cmdKeyRing :: Handler ()+cmdKeyRing = do+ k <- R.asks configKeyRing+ sendZmq (GetKeyRingR k) $ putStr . printKeyRing++cmdKeyRings :: Handler ()+cmdKeyRings = sendZmq GetKeyRingsR $ \ks -> do+ let xs = map (putStr . printKeyRing) ks+ sequence_ $ intersperse (putStrLn "-") xs++cmdNewAcc :: String -> Handler ()+cmdNewAcc name = do+ k <- R.asks configKeyRing+ sendZmq (PostAccountsR k newAcc) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ where+ newAcc = NewAccount (pack name) (AccountRegular False) []++-- First argument: is account read-only?+cmdNewMS :: Bool -> String -> String -> String -> [String] -> Handler ()+cmdNewMS r name mStr nStr ks = case keysM of+ Just keys -> do+ k <- R.asks configKeyRing+ let newAcc = NewAccount (pack name) (AccountMultisig r m n) keys+ sendZmq (PostAccountsR k newAcc) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ _ -> error "Could not parse key(s)"+ where+ m = read mStr+ n = read nStr+ keysM = mapM (xPubImport . cs) ks++cmdNewRead :: String -> String -> Handler ()+cmdNewRead name keyStr = case keyM of+ Just key -> do+ k <- R.asks configKeyRing+ let newAcc = NewAccount (pack name) (AccountRegular True) [key]+ sendZmq (PostAccountsR k newAcc) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ _ -> error "Could not parse key"+ where+ keyM = xPubImport $ cs keyStr++cmdAddKeys :: String -> [String] -> Handler ()+cmdAddKeys name ks = case keysM of+ Just keys -> do+ k <- R.asks configKeyRing+ sendZmq (PostAccountKeysR k (pack name) keys) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ _ -> error "Could not parse key(s)"+ where+ keysM = mapM (xPubImport . cs) ks++cmdSetGap :: String -> String -> Handler ()+cmdSetGap name gap = do+ k <- R.asks configKeyRing+ sendZmq (PostAccountGapR k (pack name) setGap) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ where+ setGap = SetAccountGap $ read gap++cmdAccount :: String -> Handler ()+cmdAccount name = do+ k <- R.asks configKeyRing+ sendZmq (GetAccountR k $ pack name) $+ \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc++cmdAccounts :: Handler ()+cmdAccounts = do+ k <- R.asks configKeyRing+ sendZmq (GetAccountsR k) $ \(JsonWithKeyRing _ as) -> do+ let xs = map (putStr . printAccount) as+ sequence_ $ intersperse (putStrLn "-") xs++pagedAction :: (FromJSON a, ToJSON a)+ => [String]+ -> (PageRequest -> WalletRequest)+ -> ([a] -> IO ())+ -> Handler ()+pagedAction pageLs requestBuilder action = do+ c <- R.asks configCount+ r <- R.asks configReversePaging+ let pageReq = PageRequest page c r+ sendZmq (requestBuilder pageReq) $ \(JsonWithAccount _ _ (PageRes a m)) -> do+ putStrLn $ unwords [ "Page", show page, "of", show m ]+ action a+ where+ page = fromMaybe 1 (read <$> listToMaybe pageLs)++cmdList :: String -> [String] -> Handler ()+cmdList name pageLs = do+ k <- R.asks configKeyRing+ t <- R.asks configAddrType+ m <- R.asks configMinConf+ o <- R.asks configOffline+ let f = GetAddressesR k (pack name) t m o+ pagedAction pageLs f $ \as -> forM_ as (putStrLn . printAddress)++cmdUnused :: String -> Handler ()+cmdUnused name = do+ k <- R.asks configKeyRing+ t <- R.asks configAddrType+ sendZmq (GetAddressesUnusedR k (pack name) t) $+ \(JsonWithAccount _ _ as) -> forM_ (as :: [JsonAddr]) $ putStrLn . printAddress++cmdLabel :: String -> String -> String -> Handler ()+cmdLabel name iStr label = do+ k <- R.asks configKeyRing+ t <- R.asks configAddrType+ sendZmq (PutAddressR k (pack name) i t addrLabel) $+ \(JsonWithAccount _ _ a) -> putStrLn $ printAddress a+ where+ i = read iStr+ addrLabel = AddressLabel $ pack label++cmdTxs :: String -> [String] -> Handler ()+cmdTxs name pageLs = do+ k <- R.asks configKeyRing+ pagedAction pageLs (GetTxsR k (pack name)) $ \ts -> do+ let xs = map (putStr . printTx) ts+ sequence_ $ intersperse (putStrLn "-") xs++cmdAddrTxs :: String -> String -> [String] -> Handler ()+cmdAddrTxs name i pageLs = do+ k <- R.asks configKeyRing+ t <- R.asks configAddrType+ c <- R.asks configCount+ r <- R.asks configReversePaging+ let req = GetAddrTxsR k (pack name) index t $ PageRequest page c r+ sendZmq req $ \(JsonWithAddr _ _ _ (PageRes ts m)) -> do+ putStrLn $ unwords [ "Page", show page, "of", show m ]+ let xs = map (putStr . printAddrTx) ts+ sequence_ $ intersperse (putStrLn "-") xs+ where+ page = fromMaybe 1 (read <$> listToMaybe pageLs)+ index = read i++cmdGenAddrs :: String -> String -> Handler ()+cmdGenAddrs name i = do+ k <- R.asks configKeyRing+ t <- R.asks configAddrType+ let req = PostAddressesR k (pack name) index t+ sendZmq req $ \(JsonWithAccount _ _ cnt) ->+ putStrLn $ unwords [ "Generated", show (cnt :: Int), "addresses" ]+ where+ index = read i++cmdSend :: String -> String -> String -> Handler ()+cmdSend name addrStr amntStr = cmdSendMany name [addrStr ++ ":" ++ amntStr]++cmdSendMany :: String -> [String] -> Handler ()+cmdSendMany name xs = case rcpsM of+ Just rcps -> do+ k <- R.asks configKeyRing+ fee <- R.asks configFee+ rcptFee <- R.asks configRcptFee+ minconf <- R.asks configMinConf+ sign <- R.asks configSignTx+ let action = CreateTx rcps fee minconf rcptFee sign+ sendZmq (PostTxsR k (pack name) action) $+ \(JsonWithAccount _ _ tx) -> putStr $ printTx tx+ _ -> error "Could not parse recipient information"+ where+ g str = map cs $ splitOn ":" (pack str)+ f [a,v] = liftM2 (,) (base58ToAddr a) (return $ read $ cs v)+ f _ = Nothing+ rcpsM = mapM (f . g) xs++cmdImport :: String -> String -> Handler ()+cmdImport name txStr = case txM of+ Just tx -> do+ k <- R.asks configKeyRing+ let action = ImportTx tx+ sendZmq (PostTxsR k (pack name) action) $+ \(JsonWithAccount _ _ t) -> putStr $ printTx t+ _ -> error "Could not parse transaction"+ where+ txM = decodeToMaybe =<< decodeHex (cs txStr)++cmdSign :: String -> String -> Handler ()+cmdSign name txidStr = case txidM of+ Just txid -> do+ k <- R.asks configKeyRing+ let action = SignTx txid+ sendZmq (PostTxsR k (pack name) action) $+ \(JsonWithAccount _ _ tx) -> putStr $ printTx tx+ _ -> error "Could not parse txid"+ where+ txidM = hexToTxHash $ cs txidStr++cmdGetOffline :: String -> String -> Handler ()+cmdGetOffline name tidStr = case tidM of+ Just tid -> do+ k <- R.asks configKeyRing+ sendZmq (GetOfflineTxR k (pack name) tid) $+ \(OfflineTxData tx dat) -> do+ putStrLn $ unwords+ [ "Tx :", cs $ encodeHex $ encode' tx ]+ putStrLn $ unwords+ [ "CoinData:", cs $ encodeHex $ cs $ encode dat ]+ _ -> error "Could not parse txid"+ where+ tidM = hexToTxHash $ cs tidStr++cmdSignOffline :: String -> String -> String -> Handler ()+cmdSignOffline name txStr datStr = case (txM, datM) of+ (Just tx, Just dat) -> do+ k <- R.asks configKeyRing+ sendZmq (PostOfflineTxR k (pack name) tx dat) $+ \(TxCompleteRes tx' c) -> do+ putStrLn $ unwords [ "Tx :", cs $ encodeHex $ encode' tx' ]+ putStrLn $ unwords [ "Complete:", if c then "Yes" else "No" ]+ _ -> error "Could not decode input data"+ where+ datM = decode . cs =<< decodeHex (cs datStr)+ txM = decodeToMaybe =<< decodeHex (cs txStr)++cmdBalance :: String -> Handler ()+cmdBalance name = do+ k <- R.asks configKeyRing+ m <- R.asks configMinConf+ o <- R.asks configOffline+ sendZmq (GetBalanceR k (pack name) m o) $+ \(JsonWithAccount _ _ bal) ->+ putStrLn $ unwords [ "Balance:", show (bal :: Word64) ]++cmdGetTx :: String -> String -> Handler ()+cmdGetTx name tidStr = case tidM of+ Just tid -> do+ k <- R.asks configKeyRing+ sendZmq (GetTxR k (pack name) tid) $+ \(JsonWithAccount _ _ tx) -> putStr $ printTx tx+ _ -> error "Could not parse txid"+ where+ tidM = hexToTxHash $ cs tidStr++cmdRescan :: [String] -> Handler ()+cmdRescan timeLs =+ sendZmq (PostNodeR $ NodeActionRescan timeM) $ \(RescanRes ts) ->+ putStrLn $ unwords [ "Timestamp:", show ts]+ where+ timeM = read <$> listToMaybe timeLs++cmdDecodeTx :: String -> Handler ()+cmdDecodeTx txStr = do+ when (isNothing txM) $ error "Could not parse transaction"+ format <- R.asks configFormat+ liftIO $ formatStr $ cs $ case format of+ OutputJSON -> cs jsn+ _ -> YAML.encode val+ where+ txM = decodeToMaybe =<< decodeHex (cs txStr)+ val = encodeTxJSON $ fromJust txM+ jsn = JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } val++cmdVersion :: Handler ()+cmdVersion = liftIO $ do+ putStrLn $ unwords [ "network :", cs networkName ]+ putStrLn $ unwords [ "user-agent:", cs haskoinUserAgent ]+ putStrLn $ unwords [ "database :", cs databaseEngine ]++cmdStatus :: Handler ()+cmdStatus = do+ v <- R.asks configVerbose+ sendZmq (PostNodeR NodeActionStatus) $ mapM_ putStrLn . printNodeStatus v++{- Helpers -}++sendZmq :: (FromJSON a, ToJSON a)+ => WalletRequest -> (a -> IO ()) -> Handler ()+sendZmq req handle = do+ sockName <- R.asks configConnect+ resE <- liftIO $ runZMQ $ do+ sock <- socket Req+ connect sock sockName+ send sock [] (cs $ encode req)+ eitherDecode . cs <$> receive sock+ case resE of+ Right (ResponseValid (Just a)) -> formatOutput a =<< R.asks configFormat+ Right (ResponseValid Nothing) -> return ()+ Right (ResponseError err) -> error $ unpack err+ Left err -> error err+ where+ formatOutput a format = liftIO $ case format of+ OutputJSON -> formatStr $ cs $+ JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } a+ OutputYAML -> formatStr $+ cs $ YAML.encode a+ OutputNormal -> handle a++formatStr :: String -> IO ()+formatStr str = forM_ (lines str) putStrLn++encodeTxJSON :: Tx -> Value+encodeTxJSON tx@(Tx v is os i) = object+ [ "txid" .= (cs $ txHashToHex (txHash tx) :: Text)+ , "version" .= v+ , "inputs" .= zipWith input is [0..]+ , "outputs" .= zipWith output os [0..]+ , "locktime" .= i+ ]+ where+ input x j = object+ [pack ("input " ++ show (j :: Int)) .= encodeTxInJSON x]+ output x j = object+ [pack ("output " ++ show (j :: Int)) .= encodeTxOutJSON x]++encodeTxInJSON :: TxIn -> Value+encodeTxInJSON (TxIn o s i) = object $+ [ "outpoint" .= encodeOutPointJSON o+ , "sequence" .= i+ , "raw-script" .= (cs $ encodeHex s :: Text)+ , "script" .= encodeScriptJSON sp+ ] ++ decoded+ where+ sp = fromMaybe (Script []) $ decodeToMaybe s+ decoded = either (const []) f $ decodeInputBS s+ f inp = ["decoded-script" .= encodeScriptInputJSON inp]++encodeTxOutJSON :: TxOut -> Value+encodeTxOutJSON (TxOut v s) = object $+ [ "value" .= v+ , "raw-script" .= (cs $ encodeHex s :: Text)+ , "script" .= encodeScriptJSON sp+ ] ++ decoded+ where+ sp = fromMaybe (Script []) $ decodeToMaybe s+ decoded = either (const [])+ (\out -> ["decoded-script" .= encodeScriptOutputJSON out])+ (decodeOutputBS s)++encodeOutPointJSON :: OutPoint -> Value+encodeOutPointJSON (OutPoint h i) = object+ [ "txid" .= (cs $ txHashToHex h :: Text)+ , "pos" .= i+ ]++encodeScriptJSON :: Script -> Value+encodeScriptJSON (Script ops) =+ toJSON $ map f ops+ where+ f (OP_PUSHDATA bs _) = String $ pack $ unwords+ ["OP_PUSHDATA", cs $ encodeHex bs]+ f x = String $ pack $ show x++encodeScriptInputJSON :: ScriptInput -> Value+encodeScriptInputJSON si = case si of+ RegularInput (SpendPK s) -> object+ [ "spendpubkey" .= object [ "sig" .= encodeSigJSON s ] ]+ RegularInput (SpendPKHash s p) -> object+ [ "spendpubkeyhash" .= object+ [ "sig" .= encodeSigJSON s+ , "pubkey" .= (cs $ encodeHex (encode' p) :: Text)+ , "sender-address" .= (cs $ addrToBase58 (pubKeyAddr p) :: Text)+ ]+ ]+ RegularInput (SpendMulSig sigs) -> object+ [ "spendmulsig" .= object [ "sigs" .= map encodeSigJSON sigs ] ]+ ScriptHashInput s r -> object+ [ "spendscripthash" .= object+ [ "scriptinput" .= encodeScriptInputJSON (RegularInput s)+ , "redeem" .= encodeScriptOutputJSON r+ , "raw-redeem" .= (cs $ encodeHex (encodeOutputBS r) :: Text)+ , "sender-address" .= (cs $ addrToBase58 (scriptAddr r) :: Text)+ ]+ ]++encodeScriptOutputJSON :: ScriptOutput -> Value+encodeScriptOutputJSON so = case so of+ PayPK p -> object+ [ "pay2pubkey" .= object+ [ "pubkey" .= (cs $ encodeHex (encode' p) :: Text) ]+ ]+ PayPKHash a -> object+ [ "pay2pubkeyhash" .= object+ [ "address-base64" .=+ (cs $ encodeHex (encode' $ getAddrHash a) :: Text)+ , "address-base58" .= (cs $ addrToBase58 a :: Text)+ ]+ ]+ PayMulSig ks r -> object+ [ "pay2mulsig" .= object+ [ "required-keys" .= r+ , "pubkeys" .= (map (cs . encodeHex . encode') ks :: [Text])+ ]+ ]+ PayScriptHash a -> object+ [ "pay2scripthash" .= object+ [ "address-base64" .= (cs $ encodeHex $ encode' $ getAddrHash a :: Text)+ , "address-base58" .= (cs (addrToBase58 a) :: Text)+ ]+ ]++encodeSigJSON :: TxSignature -> Value+encodeSigJSON ts@(TxSignature _ sh) = object+ [ "raw-sig" .= (cs $ encodeHex (encodeSig ts) :: Text)+ , "sighash" .= encodeSigHashJSON sh+ ]++encodeSigHashJSON :: SigHash -> Value+encodeSigHashJSON sh = case sh of+ SigAll acp -> object+ [ "type" .= String "SigAll"+ , "acp" .= acp+ ]+ SigNone acp -> object+ [ "type" .= String "SigNone"+ , "acp" .= acp+ ]+ SigSingle acp -> object+ [ "type" .= String "SigSingle"+ , "acp" .= acp+ ]+ SigUnknown acp v -> object+ [ "type" .= String "SigUnknown"+ , "acp" .= acp+ , "value" .= v+ ]++{- Print utilities -}++printKeyRing :: JsonKeyRing -> String+printKeyRing JsonKeyRing{..} = unlines $+ [ "KeyRing: " ++ unpack jsonKeyRingName ]+ +++ [ "Master key: " ++ cs (xPrvExport m)+ | m <- maybeToList jsonKeyRingMaster+ ]+ +++ [ "Mnemonic: " ++ cs m+ | m <- maybeToList jsonKeyRingMnemonic+ ]++printAccount :: JsonAccount -> String+printAccount JsonAccount{..} = unlines $+ [ "Account: " ++ unpack jsonAccountName+ , "Type : " ++ showType+ , "Gap : " ++ show jsonAccountGap+ ]+ +++ [ "Deriv : " ++ pathToStr d+ | d <- maybeToList jsonAccountDerivation+ ]+ +++ concat [ printKeys | not (null jsonAccountKeys) ]+ where+ printKeys =+ ("Keys : " ++ cs (xPubExport (head jsonAccountKeys))) :+ map ((" " ++) . cs . xPubExport) (tail jsonAccountKeys)+ showType = case jsonAccountType of+ AccountRegular r -> if r then "Read-Only" else "Regular"+ AccountMultisig r m n -> unwords+ [ if r then "Read-Only Multisig" else "Multisig"+ , show m, "of", show n+ ]++printAddress :: JsonAddr -> String+printAddress JsonAddr{..} = unwords $+ [ show jsonAddrIndex, ":", cs (addrToBase58 jsonAddrAddress) ]+ +++ [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]+ ++ concat+ [ [ "[Received: " ++ show (balanceInfoInBalance bal) ++ "]"+ , "[Coins: " ++ show (balanceInfoCoins bal) ++ "]"+ , "[Spent Coins: " ++ show (balanceInfoSpentCoins bal) ++ "]"+ ]+ | isJust jsonAddrBalance && balanceInfoCoins bal > 0+ ]+ where+ bal = fromMaybe (error "Could not get address balance") jsonAddrBalance++printTx :: JsonTx -> String+printTx tx@JsonTx{..} = unlines $+ [ "Value : " ++ printTxType jsonTxType ++ " " ++ show jsonTxValue ]+ +++ [ "Confidence : " ++ printTxConfidence tx ]+ ++ concat+ [ printAddrInfos "Inputs : " jsonTxInputs+ | not (null jsonTxInputs)+ ]+ ++ concat+ [ printAddrInfos "Outputs : " jsonTxOutputs+ | not (null jsonTxOutputs)+ ]+ ++ concat+ [ printAddrInfos "Change : " jsonTxChange+ | not (null jsonTxChange)+ ]+ where+ printAddrInfos header xs =+ (header ++ f (head xs)) :+ map ((" " ++) . f) (tail xs)+ f (AddressInfo addr valM local) = unwords $+ cs (addrToBase58 addr) :+ [ show v | v <- maybeToList valM ]+ +++ [ if local then "<-" else "" ]++printAddrTx :: AddrTx -> String+printAddrTx (AddrTx tx BalanceInfo{..}) = unlines $+ concat+ [ [ "Incoming value: " ++ show balanceInfoInBalance+ , "Incoming coins: " ++ show balanceInfoCoins+ ]+ | balanceInfoInBalance > 0+ ] ++ concat+ [ [ "Outgoing value: " ++ show balanceInfoOutBalance+ , "Spent coins : " ++ show balanceInfoSpentCoins+ ]+ | balanceInfoOutBalance > 0+ ] +++ [ "Confidence : " ++ printTxConfidence tx ]++printTxConfidence :: JsonTx -> String+printTxConfidence JsonTx{..} = case jsonTxConfidence of+ TxBuilding -> "Building" ++ confirmations+ TxPending -> "Pending" ++ confirmations+ TxDead -> "Dead" ++ confirmations+ TxOffline -> "Offline"+ where+ confirmations = case jsonTxConfirmations of+ Just conf -> " (Confirmations: " ++ show conf ++ ")"+ _ -> ""++printTxType :: TxType -> String+printTxType t = case t of+ TxIncoming -> "Incoming"+ TxOutgoing -> "Outgoing"+ TxSelf -> "Self"++printNodeStatus :: Bool -> NodeStatus -> [String]+printNodeStatus verbose NodeStatus{..} =+ [ "Network Height : " ++ show nodeStatusNetworkHeight+ , "Best Header : " ++ cs (blockHashToHex nodeStatusBestHeader)+ , "Best Header Height: " ++ show nodeStatusBestHeaderHeight+ , "Best Block : " ++ cs (blockHashToHex nodeStatusBestBlock)+ , "Bloom Filter Size : " ++ show nodeStatusBloomSize+ ] +++ [ "Header Peer : " ++ show h+ | h <- maybeToList nodeStatusHeaderPeer, verbose+ ] +++ [ "Merkle Peer : " ++ show m+ | m <- maybeToList nodeStatusMerklePeer, verbose+ ] +++ [ "Pending Headers : " ++ show nodeStatusHaveHeaders | verbose ] +++ [ "Pending Tickles : " ++ show nodeStatusHaveTickles | verbose ] +++ [ "Pending Txs : " ++ show nodeStatusHaveTxs | verbose ] +++ [ "Pending GetData : " ++ show (map txHashToHex nodeStatusGetData)+ | verbose+ ] +++ [ "Pending Rescan : " ++ show r+ | r <- maybeToList nodeStatusRescan, verbose+ ] +++ [ "Synced Mempool : " ++ show nodeStatusMempool | verbose ] +++ [ "HeaderSync Lock : " ++ show nodeStatusSyncLock | verbose ] +++ [ "LevelDB Lock : " ++ show nodeStatusLevelDBLock | verbose ] +++ [ "Peers: " ] +++ intercalate ["-"] (map (printPeerStatus verbose) nodeStatusPeers)++printPeerStatus :: Bool -> PeerStatus -> [String]+printPeerStatus verbose PeerStatus{..} =+ [ " Peer Id : " ++ show peerStatusPeerId+ , " Peer Host: " ++ peerHostString peerStatusHost+ , " Connected: " ++ if peerStatusConnected then "yes" else "no"+ , " Height : " ++ show peerStatusHeight+ ] +++ [ " Protocol : " ++ show p | p <- maybeToList peerStatusProtocol+ ] +++ [ " UserAgent: " ++ ua | ua <- maybeToList peerStatusUserAgent+ ] +++ [ " Avg Ping : " ++ p | p <- maybeToList peerStatusPing+ ] +++ [ " DoS Score: " ++ show d | d <- maybeToList peerStatusDoSScore+ ] +++ [ " ThreadId : " ++ peerStatusThreadId | verbose ] +++ [ " Merkles : " ++ show peerStatusHaveMerkles | verbose ] +++ [ " Messages : " ++ show peerStatusHaveMessage | verbose ] +++ [ " Nonces : " ++ show peerStatusPingNonces | verbose ] +++ [ " Reconnect: " ++ show t+ | t <- maybeToList peerStatusReconnectTimer, verbose+ ] +++ [ " Logs : " | verbose ] +++ [ " - " ++ msg | msg <- maybe [] id peerStatusLog, verbose]++
+ Network/Haskoin/Wallet/Internals.hs view
@@ -0,0 +1,31 @@+{-|+This module expose haskoin-wallet internals. No guarantee is made on the+stability of the interface of these internal modules.+-}++module Network.Haskoin.Wallet.Internals+( module Network.Haskoin.Wallet+, module Network.Haskoin.Wallet.KeyRing+, module Network.Haskoin.Wallet.Transaction+, module Network.Haskoin.Wallet.Client+, module Network.Haskoin.Wallet.Client.Commands+, module Network.Haskoin.Wallet.Server+, module Network.Haskoin.Wallet.Server.Handler+, module Network.Haskoin.Wallet.Settings+, module Network.Haskoin.Wallet.Database+, module Network.Haskoin.Wallet.Types+, module Network.Haskoin.Wallet.Model+) where++import Network.Haskoin.Wallet+import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Client+import Network.Haskoin.Wallet.Client.Commands+import Network.Haskoin.Wallet.Server+import Network.Haskoin.Wallet.Server.Handler+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Database+import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Model+
+ Network/Haskoin/Wallet/KeyRing.hs view
@@ -0,0 +1,720 @@+module Network.Haskoin.Wallet.KeyRing+(+-- *Database KeyRings+ initWallet+, newKeyRing+, keyRings+, keyRingSource+, getKeyRing++-- *Database Accounts+, accounts+, accountSource+, newAccount+, addAccountKeys+, getAccount+, isMultisigAccount+, isReadAccount+, isCompleteAccount++-- *Database Addresses+, getAddress+, addressSourceAll+, addressSource+, addressPage+, unusedAddresses+, addressCount+, setAddrLabel+, addressPrvKey+, useAddress+, generateAddrs+, setAccountGap+, firstAddrTime+, getPathRedeem+, getPathPubKey++-- *Database Bloom Filter+, getBloomFilter++-- * Helpers+, subSelectAddrCount+) where++import Control.Monad (unless, when, liftM)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Exception (throwIO, throw)++import Data.Text (Text, unpack)+import Data.Maybe (mapMaybe, listToMaybe)+import Data.Time.Clock (getCurrentTime)+import Data.Conduit (Source, mapOutput, await, ($$))+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.List (nub)+import Data.Word (Word32)+import qualified Data.ByteString as BS (ByteString, null)++import qualified Database.Persist as P (updateWhere, update , (=.))+import Database.Esqueleto+ ( Value(..), SqlExpr, SqlQuery+ , InnerJoin(..), on+ , select, from, where_, val, sub_select, countRows, count, unValue+ , orderBy, limit, asc, desc, offset, selectSource, get+ , max_, not_, isNothing, case_, when_, then_, else_+ , (^.), (==.), (&&.), (>.), (-.), (<.)+ -- Reexports from Database.Persist+ , SqlPersistT, Entity(..)+ , getBy, insertUnique, insertMany_, insert_+ )++import Network.Haskoin.Crypto+import Network.Haskoin.Block+import Network.Haskoin.Script+import Network.Haskoin.Node+import Network.Haskoin.Util+import Network.Haskoin.Constants+import Network.Haskoin.Node.HeaderTree++import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Model++{- Initialization -}++initWallet :: MonadIO m => Double -> SqlPersistT m ()+initWallet fpRate = do+ prevConfigRes <- select $ from $ \c -> return $ count $ c ^. KeyRingConfigId+ let cnt = maybe 0 unValue $ listToMaybe prevConfigRes+ if cnt == (0 :: Int)+ then do+ time <- liftIO getCurrentTime+ -- Create an initial bloom filter+ -- TODO: Compute a random nonce+ let bloom = bloomCreate (filterLen 0) fpRate 0 BloomUpdateNone+ insert_ $ KeyRingConfig+ { keyRingConfigHeight = 0+ , keyRingConfigBlock = headerHash genesisHeader+ , keyRingConfigBloomFilter = bloom+ , keyRingConfigBloomElems = 0+ , keyRingConfigBloomFp = fpRate+ , keyRingConfigVersion = 1+ , keyRingConfigCreated = time+ }+ else return () -- Nothing to do++{- KeyRing -}++-- | Create a new KeyRing from a seed+newKeyRing :: MonadIO m+ => KeyRingName+ -> BS.ByteString+ -> SqlPersistT m (Entity KeyRing)+newKeyRing name seed+ | BS.null seed = liftIO . throwIO $ WalletException "The seed is empty"+ | otherwise = do+ now <- liftIO getCurrentTime+ let keyRing = KeyRing+ { keyRingName = name+ , keyRingMaster = makeXPrvKey seed+ , keyRingCreated = now+ }+ insertUnique keyRing >>= \resM -> case resM of+ Just ki -> return (Entity ki keyRing)+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "KeyRing", unpack name, "already exists" ]++keyRings :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => SqlPersistT m [KeyRing]+keyRings = liftM (map entityVal) $ select $ from return++-- | Stream all KeyRings+keyRingSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Source (SqlPersistT m) KeyRing+keyRingSource = mapOutput entityVal $ selectSource $ from return++-- Helper functions to get a KeyRing if it exists, or throw an exception+-- otherwise.+getKeyRing :: MonadIO m => KeyRingName -> SqlPersistT m (Entity KeyRing)+getKeyRing name = getBy (UniqueKeyRing name) >>= \resM -> case resM of+ Just keyRingEnt -> return keyRingEnt+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "KeyRing", unpack name, "does not exist." ]++{- Account -}++-- | Fetch all the accounts in a keyring+accounts :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingId -> SqlPersistT m [KeyRingAccount]+accounts ki = liftM (map entityVal) $ select $ accountsFrom ki++-- | Stream all accounts in a keyring+accountSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingId -> Source (SqlPersistT m) KeyRingAccount+accountSource ki = mapOutput entityVal $ selectSource $ accountsFrom ki++accountsFrom :: KeyRingId -> SqlQuery (SqlExpr (Entity KeyRingAccount))+accountsFrom ki =+ from $ \a -> do+ where_ $ a ^. KeyRingAccountKeyRing ==. val ki+ return a++-- | Create a new account+newAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRing+ -> AccountName+ -> AccountType+ -> [XPubKey]+ -> SqlPersistT m (Entity KeyRingAccount)+newAccount (Entity ki keyRing) accountName accountType extraKeys = do+ unless (validAccountType accountType) $+ liftIO . throwIO $ WalletException "Invalid account type"++ -- Get the next account derivation+ derivM <- if accountTypeRead accountType then return Nothing else+ liftM Just $ nextAccountDeriv ki++ -- Derive the next account key+ let f d = [ deriveXPubKey (derivePath d $ keyRingMaster keyRing) ]+ keys = (maybe [] f derivM) ++ extraKeys++ -- Build the account+ now <- liftIO getCurrentTime+ let acc = KeyRingAccount+ { keyRingAccountKeyRing = ki+ , keyRingAccountName = accountName+ , keyRingAccountType = accountType+ , keyRingAccountDerivation = derivM+ , keyRingAccountKeys = keys+ , keyRingAccountGap = 0+ , keyRingAccountCreated = now+ }++ -- Check if all the keys are valid+ unless (isValidAccKeys acc) $+ liftIO . throwIO $ WalletException "Invalid account keys"++ -- Insert our account in the database+ let canSetGap = isCompleteAccount acc+ newAcc = acc{ keyRingAccountGap = if canSetGap then 10 else 0 }++ insertUnique newAcc >>= \resM -> case resM of+ -- The account got created.+ Just ai -> do+ let accE = Entity ai newAcc+ -- If we can set the gap, create the gap addresses+ when canSetGap $ do+ _ <- createAddrs accE AddressExternal 20+ _ <- createAddrs accE AddressInternal 20+ return ()+ return accE+ -- The account already exists+ Nothing -> liftIO . throwIO $ WalletException $ unwords+ [ "Account", unpack accountName, "already exists" ]++-- | Add new thirdparty keys to a multisignature account. This function can+-- fail if the multisignature account already has all required keys.+addAccountKeys :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount -- ^ Account Entity+ -> [XPubKey] -- ^ Thirdparty public keys to add+ -> SqlPersistT m KeyRingAccount -- ^ Account information+addAccountKeys (Entity ai acc) keys+ -- We can only add keys on incomplete accounts+ | isCompleteAccount acc = liftIO . throwIO $+ WalletException "The account is already complete"+ | null keys || (not $ isValidAccKeys accKeys) = liftIO . throwIO $+ WalletException "Invalid account keys"+ | otherwise = do+ let canSetGap = isCompleteAccount accKeys+ updGap = if canSetGap then [ KeyRingAccountGap P.=. 10 ] else []+ newAcc = accKeys{ keyRingAccountGap = if canSetGap then 10 else 0 }+ -- Update the account with the keys and the new gap if it is complete+ P.update ai $ (KeyRingAccountKeys P.=. newKeys) : updGap+ -- If we can set the gap, create the gap addresses+ when canSetGap $ do+ let accE = Entity ai newAcc+ _ <- createAddrs accE AddressExternal 20+ _ <- createAddrs accE AddressInternal 20+ return ()+ return newAcc+ where+ newKeys = keyRingAccountKeys acc ++ keys+ accKeys = acc{ keyRingAccountKeys = newKeys }++isValidAccKeys :: KeyRingAccount -> Bool+isValidAccKeys KeyRingAccount{..} = case keyRingAccountType of+ AccountRegular _ -> length keyRingAccountKeys == 1+ -- read-only accounts can have 0 keys. Otherwise 1 key is required.+ AccountMultisig r _ n -> goMultisig n (if r then 0 else 1)+ where+ goMultisig n minLen =+ length keyRingAccountKeys == length (nub keyRingAccountKeys) &&+ length keyRingAccountKeys <= n &&+ length keyRingAccountKeys >= minLen++-- | Compute the next derivation path for a new account+nextAccountDeriv :: MonadIO m => KeyRingId -> SqlPersistT m HardPath+nextAccountDeriv ki = do+ lastRes <- select $ from $ \a -> do+ where_ ( a ^. KeyRingAccountKeyRing ==. val ki+ &&. not_ (isNothing (a ^. KeyRingAccountDerivation))+ )+ orderBy [ desc (a ^. KeyRingAccountId) ]+ limit 1+ return $ a ^. KeyRingAccountDerivation+ return $ case lastRes of+ (Value (Just (prev :| i)):_) -> prev :| (i + 1)+ _ -> Deriv :| 0++-- Helper functions to get an Account if it exists, or throw an exception+-- otherwise.+getAccount :: MonadIO m => KeyRingName -> AccountName+ -> SqlPersistT m (KeyRing, Entity KeyRingAccount)+getAccount keyRingName accountName = do+ as <- select $ from $ \(k `InnerJoin` a) -> do+ on $ a ^. KeyRingAccountKeyRing ==. k ^. KeyRingId+ where_ ( k ^. KeyRingName ==. val keyRingName+ &&. a ^. KeyRingAccountName ==. val accountName+ )+ return (k, a)+ case as of+ ((Entity _ k, accEnt):_) -> return (k, accEnt)+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "Account", unpack accountName, "does not exist" ]++{- Addresses -}++-- | Get an address if it exists, or throw an exception otherwise. Fetching+-- addresses in the hidden gap will also throw an exception.+getAddress :: MonadIO m+ => Entity KeyRingAccount -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> KeyIndex -- ^ Derivation index (key)+ -> SqlPersistT m (Entity KeyRingAddr) -- ^ Address+getAddress accE@(Entity ai _) addrType index = do+ res <- select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ &&. x ^. KeyRingAddrIndex ==. val index+ &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType+ )+ limit 1+ return x+ case res of+ (addrE:_) -> return addrE+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "Invalid address index", show index ]++-- | Stream all addresses in the wallet, including hidden gap addresses. This+-- is useful for building a bloom filter.+addressSourceAll :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Source (SqlPersistT m) KeyRingAddr+addressSourceAll = mapOutput entityVal $ selectSource $ from return++-- | Stream all addresses in one account. Hidden gap addresses are not included.+addressSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount -- ^ Account Entity+ -> AddressType -- ^ Address Type+ -> Source (SqlPersistT m) KeyRingAddr -- ^ Source of addresses+addressSource accE@(Entity ai _) addrType = mapOutput entityVal $+ selectSource $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType+ )+ return x++-- | Get addresses by pages.+addressPage :: MonadIO m+ => Entity KeyRingAccount -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> PageRequest -- ^ Page request+ -> SqlPersistT m ([KeyRingAddr], Word32)+ -- ^ Page result+addressPage accE@(Entity ai _) addrType page@PageRequest{..}+ | validPageRequest page = do+ cnt <- addressCount accE addrType++ let (d, m) = cnt `divMod` pageLen+ maxPage = max 1 $ d + min 1 m++ when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $+ unwords [ "Invalid page number", show pageNum ]++ if cnt == 0 then return ([], maxPage) else do+ res <- liftM (map entityVal) $ select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ &&. x ^. KeyRingAddrIndex <. val cnt+ )+ let order = if pageReverse then asc else desc+ orderBy [ order (x ^. KeyRingAddrIndex) ]+ limit $ fromIntegral pageLen+ offset $ fromIntegral $ (pageNum - 1) * pageLen+ return x++ -- Flip the order back to ASC if we had it DEC+ let f = if pageReverse then id else reverse+ return (f res, maxPage)++ | otherwise = liftIO . throwIO $ WalletException $+ concat [ "Invalid page request"+ , " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"+ ]++-- | Get a count of all the addresses in an account+addressCount :: MonadIO m+ => Entity KeyRingAccount -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> SqlPersistT m Word32 -- ^ Address Count+addressCount (Entity ai acc) addrType = do+ res <- select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ )+ return countRows+ let cnt = maybe 0 unValue $ listToMaybe res+ return $ if cnt > keyRingAccountGap acc+ then cnt - keyRingAccountGap acc+ else 0++-- | Get a list of all unused addresses.+unusedAddresses :: MonadIO m+ => Entity KeyRingAccount -- ^ Account ID+ -> AddressType -- ^ Address type+ -> SqlPersistT m [KeyRingAddr] -- ^ Unused addresses+unusedAddresses (Entity ai acc) addrType = do+ liftM (reverse . map entityVal) $ select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ )+ orderBy [ desc $ x ^. KeyRingAddrIndex ]+ limit $ fromIntegral $ keyRingAccountGap acc+ offset $ fromIntegral $ keyRingAccountGap acc+ return x++-- | Add a label to an address.+setAddrLabel :: MonadIO m+ => Entity KeyRingAccount -- ^ Account ID+ -> KeyIndex -- ^ Derivation index+ -> AddressType -- ^ Address type+ -> Text -- ^ New label+ -> SqlPersistT m KeyRingAddr+setAddrLabel accE i addrType label = do+ Entity addrI addr <- getAddress accE addrType i+ P.update addrI [ KeyRingAddrLabel P.=. label ]+ return $ addr{ keyRingAddrLabel = label }++-- | Returns the private key of an address.+addressPrvKey :: MonadIO m+ => KeyRing -- ^ KeyRing+ -> Entity KeyRingAccount -- ^ Account Entity+ -> KeyIndex -- ^ Derivation index of the address+ -> AddressType -- ^ Address type+ -> SqlPersistT m PrvKeyC -- ^ Private key+addressPrvKey keyRing accE@(Entity ai _) index addrType = do+ res <- select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ &&. x ^. KeyRingAddrIndex ==. val index+ &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType+ )+ return (x ^. KeyRingAddrFullDerivation)+ case res of+ (Value (Just deriv):_) ->+ return $ xPrvKey $ derivePath deriv $ keyRingMaster keyRing+ _ -> liftIO . throwIO $ WalletException "Invalid address"++-- | Create new addresses in an account and increment the internal bloom filter.+-- This is a low-level function that simply creates the desired amount of new+-- addresses in an account, disregarding visible and hidden address gaps. You+-- should use the function `setAccountGap` if you want to control the gap of an+-- account instead.+createAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount+ -> AddressType+ -> Word32+ -> SqlPersistT m [KeyRingAddr]+createAddrs (Entity ai acc) addrType n+ | n == 0 = liftIO . throwIO $ WalletException $+ unwords [ "Invalid value", show n ]+ | not (isCompleteAccount acc) =+ liftIO . throwIO $ WalletException $ unwords+ [ "Keys are still missing from the incomplete account"+ , unpack $ keyRingAccountName acc+ ]+ | otherwise = do+ now <- liftIO getCurrentTime+ -- Find the next derivation index from the last address+ lastRes <- select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ )+ return $ max_ (x ^. KeyRingAddrIndex)+ let nextI = case lastRes of+ (Value (Just lastI):_) -> lastI + 1+ _ -> 0+ build (addr, keyM, rdmM, i) = KeyRingAddr+ { keyRingAddrAccount = ai+ , keyRingAddrAddress = addr+ , keyRingAddrIndex = i+ , keyRingAddrType = addrType+ , keyRingAddrLabel = ""+ -- Full derivation from the master key+ , keyRingAddrFullDerivation =+ let f d = toMixed d :/ branchType :/ i+ in f <$> keyRingAccountDerivation acc+ -- Partial derivation under the account derivation+ , keyRingAddrDerivation = Deriv :/ branchType :/ i+ , keyRingAddrRedeem = rdmM+ , keyRingAddrKey = keyM+ , keyRingAddrCreated = now+ }+ res = map build $ take (fromIntegral n) $ deriveFrom nextI++ -- Save the addresses and increment the bloom filter+ insertMany_ res+ incrementFilter res+ return res+ where+ -- Branch type (external = 0, internal = 1)+ branchType = addrTypeIndex addrType+ deriveFrom = case keyRingAccountType acc of+ AccountMultisig _ m _ ->+ let f (a, r, i) = (a, Nothing, Just r, i)+ deriv = Deriv :/ branchType+ in map f . derivePathMSAddrs (keyRingAccountKeys acc) deriv m+ AccountRegular _ -> case keyRingAccountKeys acc of+ (key:_) -> let f (a, k, i) = (a, Just k, Nothing, i)+ in map f . derivePathAddrs key (Deriv :/ branchType)+ [] -> throw $ WalletException $ unwords+ [ "createAddrs: No key available in regular account"+ , unpack $ keyRingAccountName acc+ ]++-- | Generate all the addresses up to a certain index+generateAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount+ -> AddressType+ -> KeyIndex+ -> SqlPersistT m Int+generateAddrs accE@(Entity _ _) addrType genIndex = do+ cnt <- addressCount accE addrType+ let toGen = (fromIntegral genIndex) - (fromIntegral cnt) + 1+ if toGen > 0+ then do+ _ <- createAddrs accE addrType $ fromIntegral toGen+ return toGen+ else return 0++-- | Use an address and make sure we have enough gap addresses after it.+-- Returns the new addresses that have been created.+useAddress :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingAddr -> SqlPersistT m [KeyRingAddr]+useAddress KeyRingAddr{..} = do+ res <- select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val keyRingAddrAccount+ &&. x ^. KeyRingAddrType ==. val keyRingAddrType+ &&. x ^. KeyRingAddrIndex >. val keyRingAddrIndex+ )+ return countRows+ case res of+ ((Value cnt):_) -> get keyRingAddrAccount >>= \accM -> case accM of+ Just acc -> do+ let accE = Entity keyRingAddrAccount acc+ gap = fromIntegral (keyRingAccountGap acc) :: Int+ missing = 2*gap - cnt+ if missing > 0+ then createAddrs accE keyRingAddrType $ fromIntegral missing+ else return []+ _ -> return [] -- Should not happen+ _ -> return [] -- Should not happen++-- | Set the address gap of an account to a new value. This will create new+-- internal and external addresses as required. The gap can only be increased,+-- not decreased in size.+setAccountGap :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount -- ^ Account Entity+ -> Word32 -- ^ New gap value+ -> SqlPersistT m KeyRingAccount+setAccountGap accE@(Entity ai acc) gap+ | not (isCompleteAccount acc) =+ liftIO . throwIO $ WalletException $ unwords+ [ "Keys are still missing from the incomplete account"+ , unpack $ keyRingAccountName acc+ ]+ | missing <= 0 = liftIO . throwIO $ WalletException+ "The gap of an account can only be increased"+ | otherwise = do+ _ <- createAddrs accE AddressExternal $ fromInteger $ missing*2+ _ <- createAddrs accE AddressInternal $ fromInteger $ missing*2+ P.update ai [ KeyRingAccountGap P.=. gap ]+ return $ acc{ keyRingAccountGap = gap }+ where+ missing = toInteger gap - toInteger (keyRingAccountGap acc)++-- Return the creation time of the first address in the wallet.+firstAddrTime :: MonadIO m => SqlPersistT m (Maybe Timestamp)+firstAddrTime = do+ res <- select $ from $ \x -> do+ orderBy [ asc (x ^. KeyRingAddrId) ]+ limit 1+ return $ x ^. KeyRingAddrCreated+ return $ case res of+ (Value d:_) -> Just $ toPOSIX d+ _ -> Nothing+ where+ toPOSIX = fromInteger . round . utcTimeToPOSIXSeconds++{- Bloom filters -}++-- | Add the given addresses to the bloom filter. If the number of elements+-- becomes too large, a new bloom filter is computed from scratch.+incrementFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => [KeyRingAddr]+ -> SqlPersistT m ()+incrementFilter addrs = do+ (bloom, elems, _) <- getBloomFilter+ let newElems = elems + (length addrs * 2)+ if filterLen newElems > filterLen elems+ then computeNewFilter+ else setBloomFilter (addToFilter bloom addrs) newElems++-- | Generate a new bloom filter from the data in the database+computeNewFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => SqlPersistT m ()+computeNewFilter = do+ (_, _, fpRate) <- getBloomFilter+ -- Create a new empty bloom filter+ -- TODO: Choose a random nonce for the bloom filter+ -- TODO: Check global bloom filter length limits+ cntRes <- select $ from $ \x -> return $ count $ x ^. KeyRingAddrId+ let elems = maybe 0 unValue $ listToMaybe cntRes+ newBloom = bloomCreate (filterLen elems) fpRate 0 BloomUpdateNone+ bloom <- addressSourceAll $$ bloomSink newBloom+ setBloomFilter bloom elems+ where+ bloomSink bloom = await >>= \addrM -> case addrM of+ Just addr -> bloomSink $ addToFilter bloom [addr]+ _ -> return bloom++-- Compute the size of a filter given a number of elements. Scale+-- the filter length by powers of 2.+filterLen :: Int -> Int+filterLen = round . pow2 . ceiling . log2+ where+ pow2 x = (2 :: Double) ** fromInteger x+ log2 x = logBase (2 :: Double) (fromIntegral x)++-- | Add elements to a bloom filter+addToFilter :: BloomFilter -> [KeyRingAddr] -> BloomFilter+addToFilter bloom addrs =+ bloom3+ where+ pks = mapMaybe keyRingAddrKey addrs+ rdms = mapMaybe keyRingAddrRedeem addrs+ -- Add the Hash160 of the addresses+ f1 b a = bloomInsert b $ encode' $ getAddrHash a+ bloom1 = foldl f1 bloom $ map keyRingAddrAddress addrs+ -- Add the redeem scripts+ f2 b r = bloomInsert b $ encodeOutputBS r+ bloom2 = foldl f2 bloom1 rdms+ -- Add the public keys+ f3 b p = bloomInsert b $ encode' p+ bloom3 = foldl f3 bloom2 pks++-- | Returns a bloom filter containing all the addresses in this wallet. This+-- includes internal and external addresses. The bloom filter can be set on a+-- peer connection to filter the transactions received by that peer.+getBloomFilter :: MonadIO m => SqlPersistT m (BloomFilter, Int, Double)+getBloomFilter = do+ res <- select $ from $ \c -> do+ limit 1+ return ( c ^. KeyRingConfigBloomFilter+ , c ^. KeyRingConfigBloomElems+ , c ^. KeyRingConfigBloomFp+ )+ case res of+ ((Value b, Value n, Value fp):_) -> return (b, n, fp)+ _ -> liftIO . throwIO $+ WalletException "getBloomFilter: Database not initialized"++-- | Save a bloom filter and the number of elements it contains+setBloomFilter :: MonadIO m => BloomFilter -> Int -> SqlPersistT m ()+setBloomFilter bloom elems =+ P.updateWhere [] [ KeyRingConfigBloomFilter P.=. bloom+ , KeyRingConfigBloomElems P.=. elems+ ]++-- Helper function to compute the redeem script of a given derivation path+-- for a given multisig account.+getPathRedeem :: KeyRingAccount -> SoftPath -> RedeemScript+getPathRedeem acc@KeyRingAccount{..} deriv = case keyRingAccountType of+ AccountMultisig _ m _ -> if isCompleteAccount acc+ then sortMulSig $ PayMulSig pubKeys m+ else throw $ WalletException $ unwords+ [ "getPathRedeem: Incomplete multisig account"+ , unpack keyRingAccountName+ ]+ _ -> throw $ WalletException $ unwords+ [ "getPathRedeem: Account", unpack keyRingAccountName+ , "is not a multisig account"+ ]+ where+ f = toPubKeyG . xPubKey . derivePubPath deriv+ pubKeys = map f keyRingAccountKeys++-- Helper function to compute the public key of a given derivation path for+-- a given non-multisig account.+getPathPubKey :: KeyRingAccount -> SoftPath -> PubKeyC+getPathPubKey acc@KeyRingAccount{..} deriv+ | isMultisigAccount acc = throw $ WalletException $+ unwords [ "getPathPubKey: Account", unpack keyRingAccountName+ , "is not a regular non-multisig account"+ ]+ | otherwise = case keyRingAccountKeys of+ (key:_) -> xPubKey $ derivePubPath deriv key+ _ -> throw $ WalletException $ unwords+ [ "getPathPubKey: No keys are available in account"+ , unpack keyRingAccountName+ ]++{- Helpers -}++subSelectAddrCount :: Entity KeyRingAccount+ -> AddressType+ -> SqlExpr (Value KeyIndex)+subSelectAddrCount (Entity ai acc) addrType =+ sub_select $ from $ \x -> do+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. x ^. KeyRingAddrType ==. val addrType+ )+ let gap = val $ keyRingAccountGap acc+ return $ case_+ [ when_ (countRows >. gap)+ then_ (countRows -. gap)+ ] (else_ $ val 0)++validMultisigParams :: Int -> Int -> Bool+validMultisigParams m n = n >= 1 && n <= 15 && m >= 1 && m <= n++validAccountType :: AccountType -> Bool+validAccountType t = case t of+ AccountRegular _ -> True+ AccountMultisig _ m n -> validMultisigParams m n++isMultisigAccount :: KeyRingAccount -> Bool+isMultisigAccount acc = case keyRingAccountType acc of+ AccountRegular _ -> False+ AccountMultisig _ _ _ -> True++isReadAccount :: KeyRingAccount -> Bool+isReadAccount acc = case keyRingAccountType acc of+ AccountRegular r -> r+ AccountMultisig r _ _ -> r++isCompleteAccount :: KeyRingAccount -> Bool+isCompleteAccount acc = case keyRingAccountType acc of+ AccountRegular _ -> length (keyRingAccountKeys acc) == 1+ AccountMultisig _ _ n -> length (keyRingAccountKeys acc) == n+
− Network/Haskoin/Wallet/Keys.hs
@@ -1,322 +0,0 @@-module Network.Haskoin.Wallet.Keys-( XPubKey(..)-, XPrvKey(..)-, ChainCode-, makeXPrvKey-, deriveXPubKey-, prvSubKey-, pubSubKey-, primeSubKey-, prvSubKeys-, pubSubKeys-, primeSubKeys-, mulSigSubKey-, mulSigSubKeys-, xPrvIsPrime-, xPubIsPrime-, xPrvChild-, xPubChild-, xPubID-, xPrvID-, xPubFP-, xPrvFP-, xPubAddr-, xPubExport-, xPrvExport-, xPubImport-, xPrvImport-, xPrvWIF-, cycleIndex-, cycleIndex'-) where--import Control.Monad - ( guard- , unless- , when- , liftM2- )-import Data.Binary (Binary, get, put)-import Data.Binary.Get (Get, getWord8, getWord32be)-import Data.Binary.Put (Put, runPut, putWord8, putWord32be)-import Data.Word (Word8, Word32)-import Data.Bits - ( shiftR- , setBit- , testBit- , clearBit- )-import Data.Maybe (mapMaybe)-import qualified Data.ByteString as BS - ( ByteString- , append- )--import Network.Haskoin.Util-import Network.Haskoin.Util.Network-import Network.Haskoin.Crypto--{- See BIP32 for details: https://en.bitcoin.it/wiki/BIP_0032 -}--type ChainCode = Hash256---- | Data type representing an extended BIP32 private key. An extended key--- is a node in a tree of key derivations. It has a depth in the tree, a --- parent node and an index to differentiate it from other siblings.-data XPrvKey = XPrvKey- { xPrvDepth :: !Word8 -- ^ Depth in the tree of key derivations.- , xPrvParent :: !Word32 -- ^ Fingerprint of the parent key.- , xPrvIndex :: !Word32 -- ^ Key derivation index.- , xPrvChain :: !ChainCode -- ^ Chain code.- , xPrvKey :: !PrvKey -- ^ The private key of this extended key node.- } deriving (Eq, Show)---- | Data type representing an extended BIP32 public key.-data XPubKey = XPubKey- { xPubDepth :: !Word8 -- ^ Depth in the tree of key derivations.- , xPubParent :: !Word32 -- ^ Fingerprint of the parent key.- , xPubIndex :: !Word32 -- ^ Key derivation index.- , xPubChain :: !ChainCode -- ^ Chain code.- , xPubKey :: !PubKey -- ^ The public key of this extended key node.- } deriving (Eq, Show)---- | Build a BIP32 compatible extended private key from a bytestring. This will--- produce a root node (depth=0 and parent=0).-makeXPrvKey :: BS.ByteString -> Maybe XPrvKey-makeXPrvKey bs = do- pk' <- makePrvKey $ fromIntegral pk- return $ XPrvKey 0 0 0 c pk'- where (pk,c) = split512 $ hmac512 (stringToBS "Bitcoin seed") bs---- | Derive an extended public key from an extended private key. This function--- will preserve the depth, parent, index and chaincode fields of the extended--- private keys.-deriveXPubKey :: XPrvKey -> XPubKey-deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k)---- | Compute a private, non-prime child key derivation. A private non-prime--- derivation will allow the equivalent extended public key to derive the--- public key for this child. Given a parent key /m/ and a derivation index /i/,--- this function will compute m\/i\/. ------ Non-prime derivations allow for more flexibility such as read-only wallets.--- However, care must be taken not the leak both the parent extended public--- key and one of the extended child private keys as this would compromise the--- extended parent private key.-prvSubKey :: XPrvKey -- ^ Extended parent private key- -> Word32 -- ^ Child derivation index- -> Maybe XPrvKey -- ^ Extended child private key -prvSubKey xkey child = guardIndex child >> do- k <- addPrvKeys (xPrvKey xkey) a- return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k- where pK = xPubKey $ deriveXPubKey xkey- msg = BS.append (encode' pK) (encode' child)- (a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg---- | Compute a public, non-prime child key derivation. Given a parent key /M/--- and a derivation index /i/, this function will compute M\/i\/. -pubSubKey :: XPubKey -- ^ Extended Parent public key- -> Word32 -- ^ Child derivation index- -> Maybe XPubKey -- ^ Extended child public key-pubSubKey xKey child = guardIndex child >> do- pK <- addPubKeys (xPubKey xKey) a- return $ XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK- where msg = BS.append (encode' $ xPubKey xKey) (encode' child)- (a,c) = split512 $ hmac512 (encode' $ xPubChain xKey) msg---- | Compute a prime child key derivation. Prime derivations can only be--- computed for private keys. Prime derivations do not allow the parent --- public key to derive the child public keys. However, they are safer as--- a breach of the parent public key and child private keys does not lead--- to a breach of the parent private key. Given a parent key /m/ and a--- derivation index /i/, this function will compute m\/i'\/.-primeSubKey :: XPrvKey -- ^ Extended Parent private key- -> Word32 -- ^ Child derivation index- -> Maybe XPrvKey -- ^ Extended child private key-primeSubKey xkey child = guardIndex child >> do- k <- addPrvKeys (xPrvKey xkey) a- return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k- where i = setBit child 31- msg = BS.append (bsPadPrvKey $ xPrvKey xkey) (encode' i)- (a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg---- | Cyclic list of all private non-prime child key derivations of a parent key--- starting from an offset index.-prvSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)]-prvSubKeys k i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (prvSubKey k j) (return j)---- | Cyclic list of all public non-prime child key derivations of a parent key--- starting from an offset index.-pubSubKeys :: XPubKey -> Word32 -> [(XPubKey,Word32)]-pubSubKeys k i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (pubSubKey k j) (return j)---- | Cyclic list of all prime child key derivations of a parent key starting--- from an offset index.-primeSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)]-primeSubKeys k i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (primeSubKey k j) (return j)---- | Compute a public, non-prime subkey derivation for all of the parent public--- keys in the input. This function will succeed only if the child key--- derivations for all the parent keys are valid. ------ This function is intended to be used in the context of multisignature--- accounts. Parties exchanging their master public keys to create a--- multisignature account can then individually generate all the receiving--- multisignature addresses without further communication.-mulSigSubKey :: [XPubKey] -- ^ List of extended parent public keys- -> Word32 -- ^ Child key derivation index- -> Maybe [XPubKey] -- ^ List of extended child public keys-mulSigSubKey pubs i = mapM (flip pubSubKey i) pubs---- | Cyclic list of all public, non-prime multisig key derivations of a list--- of parent keys starting from an offset index.-mulSigSubKeys :: [XPubKey] -> Word32 -> [([XPubKey],Word32)]-mulSigSubKeys pubs i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (mulSigSubKey pubs j) (return j)--cycleIndex :: Word32 -> [Word32]-cycleIndex i- | i == 0 = cycle [0..0x7fffffff]- | i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i-1)]- | otherwise = error $ "cycleIndex: invalid index " ++ (show i)---- Cycle in reverse-cycleIndex' :: Word32 -> [Word32]-cycleIndex' i- | i == 0 = cycle $ 0 : [0x7fffffff,0x7ffffffe..1]- | i == 0x7fffffff = cycle [0x7fffffff,0x7ffffffe..0]- | i == 0x7ffffffe = cycle $ [0x7ffffffe,0x7ffffffd..0] ++ [0x7fffffff]- | i < 0x80000000 = cycle $ [i,(i-1)..0] ++ [0x7fffffff,0x7ffffffe..(i+1)]- | otherwise = error $ "cycleIndex: invalid index " ++ (show i)--guardIndex :: Word32 -> Maybe ()-guardIndex child = guard $ child >= 0 && child < 0x80000000---- | Returns True if the extended private key was derived through a prime--- derivation.-xPrvIsPrime :: XPrvKey -> Bool-xPrvIsPrime k = testBit (xPrvIndex k) 31---- | Returns True if the extended public key was derived through a prime--- derivation.-xPubIsPrime :: XPubKey -> Bool-xPubIsPrime k = testBit (xPubIndex k) 31---- | Returns the derivation index of this extended private key without the--- prime bit set.-xPrvChild :: XPrvKey -> Word32-xPrvChild k = clearBit (xPrvIndex k) 31---- | Returns the derivation index of this extended public key without the prime--- bit set.-xPubChild :: XPubKey -> Word32-xPubChild k = clearBit (xPubIndex k) 31---- | Computes the key identifier of an extended private key.-xPrvID :: XPrvKey -> Hash160-xPrvID = xPubID . deriveXPubKey---- | Computes the key identifier of an extended public key.-xPubID :: XPubKey -> Hash160-xPubID = hash160 . hash256BS . encode' . xPubKey ---- | Computes the key fingerprint of an extended private key.-xPrvFP :: XPrvKey -> Word32-xPrvFP = fromIntegral . (`shiftR` 128) . xPrvID---- | Computes the key fingerprint of an extended public key.-xPubFP :: XPubKey -> Word32-xPubFP = fromIntegral . (`shiftR` 128) . xPubID---- | Computer the 'Address' of an extended public key.-xPubAddr :: XPubKey -> Address-xPubAddr = pubKeyAddr . xPubKey---- | Exports an extended private key to the BIP32 key export format (base 58).-xPrvExport :: XPrvKey -> String-xPrvExport = bsToString . encodeBase58Check . encode' ---- | Exports an extended public key to the BIP32 key export format (base 58).-xPubExport :: XPubKey -> String-xPubExport = bsToString . encodeBase58Check . encode'---- | Decodes a BIP32 encoded extended private key. This function will fail if--- invalid base 58 characters are detected or if the checksum fails.-xPrvImport :: String -> Maybe XPrvKey-xPrvImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str)---- | Decodes a BIP32 encoded extended public key. This function will fail if--- invalid base 58 characters are detected or if the checksum fails.-xPubImport :: String -> Maybe XPubKey-xPubImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str)---- | Export an extended private key to WIF (Wallet Import Format).-xPrvWIF :: XPrvKey -> String-xPrvWIF = toWIF . xPrvKey--instance Binary XPrvKey where-- get = do- ver <- getWord32be- unless (ver == extSecretPrefix) $ fail $- "Get: Invalid version for extended private key"- dep <- getWord8- par <- getWord32be- idx <- getWord32be- chn <- get - prv <- getPadPrvKey- return $ XPrvKey dep par idx chn prv-- put k = do- putWord32be extSecretPrefix- putWord8 $ xPrvDepth k- putWord32be $ xPrvParent k- putWord32be $ xPrvIndex k- put $ xPrvChain k- putPadPrvKey $ xPrvKey k--instance Binary XPubKey where-- get = do- ver <- getWord32be- unless (ver == extPubKeyPrefix) $ fail $- "Get: Invalid version for extended public key"- dep <- getWord8- par <- getWord32be- idx <- getWord32be- chn <- get - pub <- get - when (isPubKeyU pub) $ fail $- "Invalid public key. Only compressed format is supported"- return $ XPubKey dep par idx chn pub-- put k = do- putWord32be extPubKeyPrefix- putWord8 $ xPubDepth k- putWord32be $ xPubParent k- putWord32be $ xPubIndex k- put $ xPubChain k- when (isPubKeyU (xPubKey k)) $ fail $- "Only compressed public keys are supported"- put $ xPubKey k- -{- Utilities for extended keys -}---- De-serialize HDW-specific private key-getPadPrvKey :: Get PrvKey-getPadPrvKey = do- pad <- getWord8- unless (pad == 0x00) $ fail $- "Private key must be padded with 0x00"- getPrvKey -- Compressed version---- Serialize HDW-specific private key-putPadPrvKey :: PrvKey -> Put -putPadPrvKey p = putWord8 0x00 >> putPrvKey p--bsPadPrvKey :: PrvKey -> BS.ByteString-bsPadPrvKey = toStrictBS . runPut . putPadPrvKey -
− Network/Haskoin/Wallet/Manager.hs
@@ -1,292 +0,0 @@-module Network.Haskoin.Wallet.Manager-( MasterKey(..)-, AccPrvKey(..)-, AccPubKey(..)-, AddrPrvKey(..)-, AddrPubKey(..)-, KeyIndex-, makeMasterKey-, loadMasterKey-, loadPrvAcc-, loadPubAcc-, addr-, accPrvKey-, accPubKey-, extPrvKey-, extPubKey-, intPrvKey-, intPubKey-, accPrvKeys-, accPubKeys-, extPrvKeys-, extPubKeys-, intPrvKeys-, intPubKeys-, extAddr-, intAddr-, extAddrs-, intAddrs-, extAddrs'-, intAddrs'-, extMulSigKey-, intMulSigKey-, extMulSigKeys-, intMulSigKeys-, extMulSigAddr-, intMulSigAddr-, extMulSigAddrs-, intMulSigAddrs-) where--import Control.Monad (liftM2, guard)-import Control.Applicative ((<$>))--import Data.Word (Word32)-import Data.Maybe (mapMaybe, fromJust, isJust)-import qualified Data.ByteString as BS (ByteString)--import Network.Haskoin.Crypto-import Network.Haskoin.Script-import Network.Haskoin.Wallet.Keys--type KeyIndex = Word32---- | Data type representing an extended private key at the root of the--- derivation tree. Master keys have depth 0 and no parents. They are--- represented as m\/ in BIP32 notation.-newtype MasterKey = MasterKey { masterKey :: XPrvKey }- deriving (Eq, Show)---- | Data type representing a private account key. Account keys are generated--- from a 'MasterKey' through prime derivation. This guarantees that the--- 'MasterKey' will not be compromised if the account key is compromised. --- 'AccPrvKey' is represented as m\/i'\/ in BIP32 notation.-newtype AccPrvKey = AccPrvKey { getAccPrvKey :: XPrvKey }- deriving (Eq, Show)---- | Data type representing a public account key. It is computed through--- derivation from an 'AccPrvKey'. It can not be derived from the 'MasterKey'--- directly (property of prime derivation). It is represented as M\/i'\/ in--- BIP32 notation. 'AccPubKey' is used for generating receiving payment--- addresses without the knowledge of the 'AccPrvKey'.-newtype AccPubKey = AccPubKey { getAccPubKey :: XPubKey }- deriving (Eq, Show)---- | Data type representing a private address key. Private address keys are--- generated through a non-prime derivation from an 'AccPrvKey'. Non-prime--- derivation is used so that the public account key can generate the receiving--- payment addresses without knowledge of the private account key. 'AccPrvKey'--- is represented as m\/i'\/0\/j\/ in BIP32 notation if it is a regular--- receiving address. Internal (change) addresses are represented as--- m\/i'\/1\/j\/. Non-prime subtree 0 is used for regular receiving addresses--- and non-prime subtree 1 for internal (change) addresses.-newtype AddrPrvKey = AddrPrvKey { getAddrPrvKey :: XPrvKey }- deriving (Eq, Show)---- | Data type representing a public address key. They are generated through--- non-prime derivation from an 'AccPubKey'. This is a useful feature for--- read-only wallets. They are represented as M\/i'\/0\/j in BIP32 notation--- for regular receiving addresses and by M\/i'\/1\/j for internal (change)--- addresses.-newtype AddrPubKey = AddrPubKey { getAddrPubKey :: XPubKey }- deriving (Eq, Show)---- | Create a 'MasterKey' from a seed.-makeMasterKey :: BS.ByteString -> Maybe MasterKey-makeMasterKey bs = MasterKey <$> makeXPrvKey bs---- | Load a 'MasterKey' from an 'XPrvKey'. This function will fail if the--- extended private key does not have the properties of a 'MasterKey'.-loadMasterKey :: XPrvKey -> Maybe MasterKey-loadMasterKey k- | xPrvDepth k == 0 && - xPrvParent k == 0 && - xPrvIndex k == 0 = Just $ MasterKey k- | otherwise = Nothing---- | Load a private account key from an 'XPrvKey'. This function will fail if--- the extended private key does not have the properties of a 'AccPrvKey'.-loadPrvAcc :: XPrvKey -> Maybe AccPrvKey-loadPrvAcc k- | xPrvDepth k == 1 &&- xPrvIsPrime k = Just $ AccPrvKey k- | otherwise = Nothing---- | Load a public account key from an 'XPubKey'. This function will fail if--- the extended public key does not have the properties of a 'AccPubKey'.-loadPubAcc :: XPubKey -> Maybe AccPubKey-loadPubAcc k- | xPubDepth k == 1 &&- xPubIsPrime k = Just $ AccPubKey k- | otherwise = Nothing---- | Computes an 'AccPrvKey' from a 'MasterKey' and a derivation index.-accPrvKey :: MasterKey -> KeyIndex -> Maybe AccPrvKey-accPrvKey (MasterKey par) i = AccPrvKey <$> (f =<< primeSubKey par i)- where f k = guard (isJust $ prvSubKey k 0) >>- guard (isJust $ prvSubKey k 1) >>- return k---- | Computes an 'AccPubKey' from a 'MasterKey' and a derivation index.-accPubKey :: MasterKey -> KeyIndex -> Maybe AccPubKey-accPubKey (MasterKey par) i = f <$> primeSubKey par i- where f = AccPubKey . deriveXPubKey---- | Computes an external 'AddrPrvKey' from an 'AccPrvKey' and a derivation--- index.-extPrvKey :: AccPrvKey -> KeyIndex -> Maybe AddrPrvKey-extPrvKey (AccPrvKey par) i = AddrPrvKey <$> prvSubKey extKey i- where extKey = fromJust $ prvSubKey par 0---- | Computes an external 'AddrPubKey' from an 'AccPubKey' and a derivation--- index.-extPubKey :: AccPubKey -> KeyIndex -> Maybe AddrPubKey-extPubKey (AccPubKey par) i = AddrPubKey <$> pubSubKey extKey i- where extKey = fromJust $ pubSubKey par 0---- | Computes an internal 'AddrPrvKey' from an 'AccPrvKey' and a derivation--- index.-intPrvKey :: AccPrvKey -> KeyIndex -> Maybe AddrPrvKey-intPrvKey (AccPrvKey par) i = AddrPrvKey <$> prvSubKey intKey i- where intKey = fromJust $ prvSubKey par 1---- | Computes an internal 'AddrPubKey' from an 'AccPubKey' and a derivation--- index.-intPubKey :: AccPubKey -> KeyIndex -> Maybe AddrPubKey-intPubKey (AccPubKey par) i = AddrPubKey <$> pubSubKey intKey i- where intKey = fromJust $ pubSubKey par 1---- | Cyclic list of all valid 'AccPrvKey' derived from a 'MasterKey' and--- starting from an offset index.-accPrvKeys :: MasterKey -> KeyIndex -> [(AccPrvKey,KeyIndex)]-accPrvKeys m i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (accPrvKey m j) (return j)---- | Cyclic list of all valid 'AccPubKey' derived from a 'MasterKey' and--- starting from an offset index.-accPubKeys :: MasterKey -> KeyIndex -> [(AccPubKey,KeyIndex)]-accPubKeys m i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (accPubKey m j) (return j)---- | Cyclic list of all valid external 'AddrPrvKey' derived from a 'AccPrvKey'--- and starting from an offset index.-extPrvKeys :: AccPrvKey -> KeyIndex -> [(AddrPrvKey,KeyIndex)]-extPrvKeys a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (extPrvKey a j) (return j)---- | Cyclic list of all valid external 'AddrPubKey' derived from a 'AccPubKey'--- and starting from an offset index.-extPubKeys :: AccPubKey -> KeyIndex -> [(AddrPubKey,KeyIndex)]-extPubKeys a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (extPubKey a j) (return j)---- | Cyclic list of all internal 'AddrPrvKey' derived from a 'AccPrvKey' and--- starting from an offset index.-intPrvKeys :: AccPrvKey -> KeyIndex -> [(AddrPrvKey,KeyIndex)]-intPrvKeys a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (intPrvKey a j) (return j)---- | Cyclic list of all internal 'AddrPubKey' derived from a 'AccPubKey' and--- starting from an offset index.-intPubKeys :: AccPubKey -> KeyIndex -> [(AddrPubKey,KeyIndex)]-intPubKeys a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (intPubKey a j) (return j)--{- Generate addresses -}---- | Computes an 'Address' from an 'AddrPubKey'.-addr :: AddrPubKey -> Address-addr = xPubAddr . getAddrPubKey---- | Computes an external base58 address from an 'AccPubKey' and a --- derivation index.-extAddr :: AccPubKey -> KeyIndex -> Maybe String-extAddr a i = addrToBase58 . addr <$> extPubKey a i---- | Computes an internal base58 addres from an 'AccPubKey' and a --- derivation index.-intAddr :: AccPubKey -> KeyIndex -> Maybe String-intAddr a i = addrToBase58 . addr <$> intPubKey a i---- | Cyclic list of all external base58 addresses derived from a 'AccPubKey'--- and starting from an offset index.-extAddrs :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]-extAddrs a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (extAddr a j) (return j)---- | Cyclic list of all internal base58 addresses derived from a 'AccPubKey'--- and starting from an offset index.-intAddrs :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]-intAddrs a i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (intAddr a j) (return j)---- | Same as 'extAddrs' with the list reversed.-extAddrs' :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]-extAddrs' a i = mapMaybe f $ cycleIndex' i- where f j = liftM2 (,) (extAddr a j) (return j)---- | Same as 'intAddrs' with the list reversed.-intAddrs' :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]-intAddrs' a i = mapMaybe f $ cycleIndex' i- where f j = liftM2 (,) (intAddr a j) (return j)--{- MultiSig -}---- | Computes a list of external 'AddrPubKey' from an 'AccPubKey', a list--- of thirdparty multisig keys and a derivation index. This is useful for --- computing the public keys associated with a derivation index for--- multisig accounts.-extMulSigKey :: AccPubKey -> [XPubKey] -> KeyIndex -> Maybe [AddrPubKey]-extMulSigKey a ps i = (map AddrPubKey) <$> mulSigSubKey keys i- where keys = map (fromJust . (flip pubSubKey 0)) $ (getAccPubKey a) : ps---- | Computes a list of internal 'AddrPubKey' from an 'AccPubKey', a list--- of thirdparty multisig keys and a derivation index. This is useful for --- computing the public keys associated with a derivation index for--- multisig accounts.-intMulSigKey :: AccPubKey -> [XPubKey] -> KeyIndex -> Maybe [AddrPubKey]-intMulSigKey a ps i = (map AddrPubKey) <$> mulSigSubKey keys i- where keys = map (fromJust . (flip pubSubKey 1)) $ (getAccPubKey a) : ps---- | Cyclic list of all external multisignature 'AddrPubKey' derivations --- starting from an offset index.-extMulSigKeys :: AccPubKey -> [XPubKey] -> KeyIndex -> [([AddrPubKey],KeyIndex)]-extMulSigKeys a ps i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (extMulSigKey a ps j) (return j)---- | Cyclic list of all internal multisignature 'AddrPubKey' derivations--- starting from an offset index.-intMulSigKeys :: AccPubKey -> [XPubKey] -> KeyIndex -> [([AddrPubKey],KeyIndex)]-intMulSigKeys a ps i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (intMulSigKey a ps j) (return j)---- | Computes an external base58 multisig address from an 'AccPubKey', a--- list of thirdparty multisig keys and a derivation index.-extMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String-extMulSigAddr a ps r i = do- xs <- (map (xPubKey . getAddrPubKey)) <$> extMulSigKey a ps i- return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r---- | Computes an internal base58 multisig address from an 'AccPubKey', a--- list of thirdparty multisig keys and a derivation index.-intMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String-intMulSigAddr a ps r i = do- xs <- (map (xPubKey . getAddrPubKey)) <$> intMulSigKey a ps i- return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r---- | Cyclic list of all external base58 multisig addresses derived from--- an 'AccPubKey' and a list of thirdparty multisig keys. The list starts--- at an offset index.-extMulSigAddrs :: AccPubKey -> [XPubKey] -> Int -> KeyIndex - -> [(String,KeyIndex)]-extMulSigAddrs a ps r i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (extMulSigAddr a ps r j) (return j)---- | Cyclic list of all internal base58 multisig addresses derived from--- an 'AccPubKey' and a list of thirdparty multisig keys. The list starts--- at an offset index.-intMulSigAddrs :: AccPubKey -> [XPubKey] -> Int -> KeyIndex - -> [(String,KeyIndex)]-intMulSigAddrs a ps r i = mapMaybe f $ cycleIndex i- where f j = liftM2 (,) (intMulSigAddr a ps r j) (return j)-
+ Network/Haskoin/Wallet/Model.hs view
@@ -0,0 +1,219 @@+module Network.Haskoin.Wallet.Model+( -- Database types+ KeyRing(..)+, KeyRingId+, KeyRingAccount(..)+, KeyRingAccountId+, KeyRingAddr(..)+, KeyRingAddrId+, KeyRingConfig(..)+, KeyRingConfigId+, KeyRingCoin(..)+, KeyRingCoinId+, KeyRingSpentCoin(..)+, KeyRingSpentCoinId+, KeyRingTx(..)+, KeyRingTxId+, EntityField(..)+, Unique(..)+, migrateWallet++-- JSON conversion+, toJsonKeyRing+, toJsonAccount+, toJsonAddr+, toJsonCoin+, toJsonTx++) where++import Control.DeepSeq (NFData(..))++import Data.Word (Word32, Word64)+import Data.Time (UTCTime)+import Data.Text (Text)++import Database.Persist (EntityField, Unique)+import Database.Persist.Quasi (lowerCaseSettings)+import Database.Persist.TH+ ( share+ , mkPersist+ , sqlSettings+ , mkMigrate+ , persistFileWith+ )++import Network.Haskoin.Wallet.Types+import Network.Haskoin.Block+import Network.Haskoin.Transaction+import Network.Haskoin.Script+import Network.Haskoin.Crypto+import Network.Haskoin.Node+import Network.Haskoin.Node.HeaderTree++share [ mkPersist sqlSettings+ , mkMigrate "migrateWallet"+ ]+ $(persistFileWith lowerCaseSettings "config/models")++instance NFData KeyRing where+ rnf KeyRing{..} =+ rnf keyRingName `seq`+ rnf keyRingMaster `seq`+ rnf keyRingCreated++instance NFData KeyRingAccount where+ rnf KeyRingAccount{..} =+ keyRingAccountKeyRing `seq`+ rnf keyRingAccountName `seq`+ rnf keyRingAccountType `seq`+ rnf keyRingAccountDerivation `seq`+ rnf keyRingAccountKeys `seq`+ rnf keyRingAccountGap `seq`+ rnf keyRingAccountCreated++instance NFData KeyRingAddr where+ rnf KeyRingAddr{..} =+ keyRingAddrAccount `seq`+ rnf keyRingAddrAddress `seq`+ rnf keyRingAddrIndex `seq`+ rnf keyRingAddrType `seq`+ rnf keyRingAddrLabel `seq`+ rnf keyRingAddrFullDerivation `seq`+ rnf keyRingAddrDerivation `seq`+ rnf keyRingAddrRedeem `seq`+ rnf keyRingAddrKey `seq`+ rnf keyRingAddrCreated++instance NFData KeyRingTx where+ rnf KeyRingTx{..} =+ keyRingTxAccount `seq`+ rnf keyRingTxHash `seq`+ rnf keyRingTxNosigHash `seq`+ rnf keyRingTxType `seq`+ rnf keyRingTxInValue `seq`+ rnf keyRingTxOutValue `seq`+ rnf keyRingTxInputs `seq`+ rnf keyRingTxOutputs `seq`+ rnf keyRingTxChange `seq`+ rnf keyRingTxTx `seq`+ rnf keyRingTxIsCoinbase `seq`+ rnf keyRingTxConfidence `seq`+ rnf keyRingTxConfirmedBy `seq`+ rnf keyRingTxConfirmedHeight `seq`+ rnf keyRingTxConfirmedDate `seq`+ rnf keyRingTxCreated++instance NFData KeyRingCoin where+ rnf KeyRingCoin{..} =+ keyRingCoinAccount `seq`+ rnf keyRingCoinHash `seq`+ rnf keyRingCoinPos `seq`+ keyRingCoinTx `seq`+ keyRingCoinAddr `seq`+ rnf keyRingCoinValue `seq`+ rnf keyRingCoinScript `seq`+ rnf keyRingCoinCreated++instance NFData KeyRingSpentCoin where+ rnf KeyRingSpentCoin{..} =+ keyRingSpentCoinAccount `seq`+ rnf keyRingSpentCoinHash `seq`+ rnf keyRingSpentCoinPos `seq`+ keyRingSpentCoinSpendingTx `seq`+ rnf keyRingSpentCoinCreated++instance NFData KeyRingConfig where+ rnf KeyRingConfig{..} =+ rnf keyRingConfigHeight `seq`+ rnf keyRingConfigBlock `seq`+ rnf keyRingConfigBloomFilter `seq`+ rnf keyRingConfigBloomElems `seq`+ rnf keyRingConfigBloomFp `seq`+ rnf keyRingConfigVersion `seq`+ rnf keyRingConfigCreated++{- JSON Types -}++toJsonKeyRing :: KeyRing -> Maybe XPrvKey -> Maybe Mnemonic -> JsonKeyRing+toJsonKeyRing keyRing masterM mnemonicM = JsonKeyRing+ { jsonKeyRingName = keyRingName keyRing+ , jsonKeyRingMaster = masterM+ , jsonKeyRingMnemonic = mnemonicM+ , jsonKeyRingCreated = keyRingCreated keyRing+ }++toJsonAccount :: KeyRingAccount -> JsonAccount+toJsonAccount acc = JsonAccount+ { jsonAccountName = keyRingAccountName acc+ , jsonAccountType = keyRingAccountType acc+ , jsonAccountDerivation = keyRingAccountDerivation acc+ , jsonAccountKeys = keyRingAccountKeys acc+ , jsonAccountGap = keyRingAccountGap acc+ , jsonAccountCreated = keyRingAccountCreated acc+ }++toJsonAddr :: KeyRingAddr -- ^ The address+ -> Maybe BalanceInfo -- ^ The addresses balance+ -> JsonAddr+toJsonAddr addr balM = JsonAddr+ { jsonAddrAddress = keyRingAddrAddress addr+ , jsonAddrIndex = keyRingAddrIndex addr+ , jsonAddrType = keyRingAddrType addr+ , jsonAddrLabel = keyRingAddrLabel addr+ , jsonAddrFullDerivation = keyRingAddrFullDerivation addr+ , jsonAddrDerivation = keyRingAddrDerivation addr+ , jsonAddrRedeem = keyRingAddrRedeem addr+ , jsonAddrKey = keyRingAddrKey addr+ , jsonAddrCreated = keyRingAddrCreated addr+ , jsonAddrBalance = balM+ }++toJsonTx :: KeyRingTx -- ^ The transaction+ -> Maybe BlockHeight -- ^ The current best block height+ -> JsonTx+toJsonTx tx currentHeightM = JsonTx+ { jsonTxHash = keyRingTxHash tx+ , jsonTxNosigHash = keyRingTxNosigHash tx+ , jsonTxType = keyRingTxType tx+ , jsonTxInValue = keyRingTxInValue tx+ , jsonTxOutValue = keyRingTxOutValue tx+ , jsonTxValue = fromIntegral (keyRingTxInValue tx) -+ fromIntegral (keyRingTxOutValue tx)+ , jsonTxInputs = keyRingTxInputs tx+ , jsonTxOutputs = keyRingTxOutputs tx+ , jsonTxChange = keyRingTxChange tx+ , jsonTxTx = keyRingTxTx tx+ , jsonTxIsCoinbase = keyRingTxIsCoinbase tx+ , jsonTxConfidence = keyRingTxConfidence tx+ , jsonTxConfirmedBy = keyRingTxConfirmedBy tx+ , jsonTxConfirmedHeight = keyRingTxConfirmedHeight tx+ , jsonTxConfirmedDate = keyRingTxConfirmedDate tx+ , jsonTxCreated = keyRingTxCreated tx+ , jsonTxConfirmations = f =<< keyRingTxConfirmedHeight tx+ }+ where+ f confirmedHeight = case currentHeightM of+ Just h -> return $ fromInteger $+ max 0 $ toInteger h - toInteger confirmedHeight + 1+ _ -> Nothing++toJsonCoin :: KeyRingCoin -- ^ The coin+ -> Maybe JsonTx -- ^ The coins transaction+ -> Maybe JsonAddr -- ^ The coins address+ -> Maybe JsonTx -- ^ The coins spending transaction+ -> JsonCoin+toJsonCoin coin txM addrM spendM = JsonCoin+ { jsonCoinHash = keyRingCoinHash coin+ , jsonCoinPos = keyRingCoinPos coin+ , jsonCoinValue = keyRingCoinValue coin+ , jsonCoinScript = keyRingCoinScript coin+ , jsonCoinCreated = keyRingCoinCreated coin+ -- Optional tx+ , jsonCoinTx = txM+ -- Optional address+ , jsonCoinAddress = addrM+ -- Optional spending tx+ , jsonCoinSpendingTx = spendM+ }+
+ Network/Haskoin/Wallet/Server.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE TemplateHaskell #-}+module Network.Haskoin.Wallet.Server+( runSPVServer+, stopSPVServer+) where++import System.Posix.Daemon (runDetached, Redirection (ToFile), killAndWait)+import System.ZMQ4+ ( Rep(..), bind, receive, send+ , withContext, withSocket+ )++import Control.Monad (when, unless, forever, liftM)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOpDiscard)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Resource (MonadResource, runResourceT)+import Control.DeepSeq (NFData(..))+import Control.Concurrent.STM (retry)+import Control.Concurrent.Async.Lifted (async, waitAnyCancel)+import Control.Exception.Lifted (SomeException(..), ErrorCall(..), catches)+import qualified Control.Exception.Lifted as E (Handler(..))+import qualified Control.Concurrent.MSem as Sem (MSem, new)+import Control.Monad.Logger+ ( MonadLogger+ , runStdoutLoggingT+ , logDebug+ , logWarn+ , logInfo+ , filterLogger+ )++import qualified Data.ByteString.Lazy as BL (fromStrict, toStrict)+import qualified Data.HashMap.Strict as H (lookup)+import Data.Text (pack)+import Data.Maybe (fromMaybe)+import Data.Aeson (Value, decode, encode)+import Data.Conduit (await, awaitForever, ($$))+import Data.Word (Word32)+import qualified Data.Map.Strict as M+ (Map, unionWith, null, empty, fromListWith, assocs, elems)+import Data.String.Conversions (cs)++import Database.Persist.Sql (ConnectionPool, runMigration)+import qualified Database.LevelDB.Base as DB (Options(..), defaultOptions)++import Database.Esqueleto (from, where_, val , (^.), (==.), (&&.), (<=.))++import Network.Haskoin.Constants+import Network.Haskoin.Block+import Network.Haskoin.Transaction+import Network.Haskoin.Node.Peer+import Network.Haskoin.Node.BlockChain+import Network.Haskoin.Node.STM+import Network.Haskoin.Node.HeaderTree++import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Server.Handler+import Network.Haskoin.Wallet.Database++data EventSession = EventSession+ { eventBatchSize :: !Int+ , eventNewAddrs :: !(M.Map KeyRingAccountId Word32)+ }+ deriving (Eq, Show, Read)++instance NFData EventSession where+ rnf EventSession{..} =+ rnf eventBatchSize `seq`+ rnf (M.elems eventNewAddrs)++runSPVServer :: Config -> IO ()+runSPVServer cfg = maybeDetach cfg $ do -- start the server process+ -- Initialize the database+ (sem, pool) <- initDatabase cfg+ -- Check the operation mode of the server.+ run $ case configMode cfg of+ -- In this mode, we do not launch an SPV node. We only accept+ -- client requests through the ZMQ API.+ SPVOffline -> runWalletApp $ HandlerSession cfg pool Nothing sem+ -- In this mode, we launch the client ZMQ API and we sync the+ -- wallet database with an SPV node.+ SPVOnline -> do+ -- Initialize the node state+ nodeState <- getNodeState fp opts+ -- Spin up the node threads+ as <- mapM async+ -- Start the SPV node+ [ runNodeT nodeState $ do+ -- Get our bloom filter+ (bloom, elems, _) <- runDBPool sem pool getBloomFilter+ startSPVNode hosts bloom elems+ -- Merkle block synchronization+ , runMerkleSync nodeState sem pool+ -- Import solo transactions as they arrive from peers+ , runNodeT nodeState $ txSource $$ processTx sem pool+ -- Respond to transaction GetData requests+ , runNodeT nodeState $+ handleGetData $ runDBPool sem pool . getTx+ -- Re-broadcast pending transactions+ , broadcastPendingTxs nodeState sem pool+ -- Run the ZMQ API server+ , runWalletApp $ HandlerSession cfg pool (Just nodeState) sem+ ]+ _ <- waitAnyCancel as+ return ()+ where+ -- Setup logging monads+ run = runResourceT . runLogging+ runLogging = runStdoutLoggingT . filterLogger logFilter+ logFilter _ level = level >= configLogLevel cfg+ -- Bitcoin nodes to connect to+ nodes = fromMaybe+ (error $ "BTC nodes for " ++ networkName ++ " not found")+ (pack networkName `H.lookup` configBTCNodes cfg)+ hosts = map (uncurry PeerHost) nodes+ -- LevelDB options+ fp = "headertree"+ opts = DB.defaultOptions { DB.createIfMissing = True+ , DB.cacheSize = 2048+ }+ -- Run the merkle syncing thread+ runMerkleSync nodeState sem pool = runNodeT nodeState $ do+ $(logDebug) "Waiting for a valid bloom filter for merkle downloads..."++ -- Only download merkles if we have a valid bloom filter+ _ <- atomicallyNodeT waitBloomFilter++ -- Provide a fast catchup time if we are at height 0+ fcM <- liftM (fmap adjustFCTime) $ runDBPool sem pool $ do+ (_, h) <- getBestBlock+ if h == 0 then firstAddrTime else return Nothing+ maybe (return ()) (atomicallyNodeT . rescanTs) fcM++ -- Start the merkle sync+ merkleSync sem pool 500+ -- Run a thread that will re-broadcast pending transactions+ broadcastPendingTxs nodeState sem pool = runNodeT nodeState $ forever $ do+ -- Wait until we are synced+ atomicallyNodeT $ do+ synced <- areBlocksSynced+ unless synced $ lift retry+ -- Send an INV for those transactions to all peers+ broadcastTxs =<< runDBPool sem pool (getPendingTxs 100)+ -- Wait until we are not synced+ atomicallyNodeT $ do+ synced <- areBlocksSynced+ when synced $ lift retry+ processTx sem pool = awaitForever $ \tx -> lift $ do+ (_, newAddrs) <- runDBPool sem pool $ importNetTx tx+ unless (null newAddrs) $ do+ $(logInfo) $ pack $ unwords+ [ "Generated", show $ length newAddrs+ , "new addresses while importing the tx."+ , "Updating the bloom filter"+ ]+ (bloom, elems, _) <- runDBPool sem pool getBloomFilter+ atomicallyNodeT $ sendBloomFilter bloom elems++initDatabase :: Config -> IO (Sem.MSem Int, ConnectionPool)+initDatabase cfg = do+ -- Create a semaphore with 1 resource+ sem <- Sem.new 1+ -- Create a database pool+ let dbCfg = fromMaybe+ (error $ "DB config settings for " ++ networkName ++ " not found")+ (pack networkName `H.lookup` configDatabase cfg)+ pool <- getDatabasePool dbCfg+ -- Initialize wallet database+ runDBPool sem pool $ do+ _ <- runMigration migrateWallet+ initWallet $ configBloomFP cfg+ -- Return the semaphrone and the connection pool+ return (sem, pool)++merkleSync+ :: ( MonadLogger m+ , MonadIO m+ , MonadBaseControl IO m+ , MonadThrow m+ , MonadResource m+ )+ => Sem.MSem Int+ -> ConnectionPool+ -> Int+ -> NodeT m ()+merkleSync sem pool bSize = do+ -- Get our best block+ best <- fst <$> runDBPool sem pool getBestBlock+ $(logDebug) "Starting merkle batch download"+ -- Wait for a new block or a rescan+ (action, source) <- merkleDownload best bSize+ $(logDebug) "Received a merkle action and source. Processing the source..."++ -- Read and process the data from the source+ (lastMerkleM, mTxsAcc, aMap) <- source $$ go Nothing [] M.empty+ $(logDebug) "Merkle source processed and closed"++ -- Send a new bloom filter to our peers if new addresses were generated+ unless (M.null aMap) $ do+ $(logInfo) $ pack $ unwords+ [ "Generated", show $ sum $ M.elems aMap+ , "new addresses while importing the merkle block."+ , "Sending our bloom filter."+ ]+ (bloom, elems, _) <- runDBPool sem pool getBloomFilter+ atomicallyNodeT $ sendBloomFilter bloom elems++ -- Check if we should rescan the current merkle batch+ $(logDebug) "Checking if we need to rescan the current batch..."+ rescan <- lift $ shouldRescan aMap+ when rescan $ $(logDebug) "We need to rescan the current batch"+ -- Compute the new batch size+ let newBSize | rescan = max 1 $ bSize `div` 2+ | otherwise = min 500 $ bSize + max 1 (bSize `div` 20)++ when (newBSize /= bSize) $ $(logDebug) $ pack $ unwords+ [ "Changing block batch size from", show bSize, "to", show newBSize ]++ -- Did we receive all the merkles that we asked for ?+ let missing = (headerHash <$> lastMerkleM) /=+ Just (nodeBlockHash $ last $ actionNodes action)++ when missing $ $(logWarn) $ pack $ unwords+ [ "Merkle block stream closed prematurely"+ , show lastMerkleM+ ]++ -- TODO: We could still salvage a partially received batch+ unless (rescan || missing) $ do+ $(logDebug) "Importing merkles into the wallet..."+ -- Confirm the transactions+ runDBPool sem pool $ importMerkles action mTxsAcc+ $(logDebug) "Done importing merkles into the wallet"+ logBlockChainAction action++ merkleSync sem pool newBSize+ where+ go lastMerkleM mTxsAcc aMap = await >>= \resM -> case resM of+ Just (Right tx) -> do+ $(logDebug) $ pack $ unwords+ [ "Importing merkle tx", cs $ txHashToHex $ txHash tx ]+ (_, newAddrs) <- lift $ runDBPool sem pool $ importNetTx tx+ $(logDebug) $ pack $ unwords+ [ "Generated", show $ length newAddrs+ , "new addresses while importing tx"+ , cs $ txHashToHex $ txHash tx+ ]+ let newMap = M.unionWith (+) aMap $ groupByAcc newAddrs+ go lastMerkleM mTxsAcc newMap+ Just (Left (MerkleBlock mHead _ _ _, mTxs)) -> do+ $(logDebug) $ pack $ unwords+ [ "Buffering merkle block"+ , cs $ blockHashToHex $ headerHash mHead+ ]+ go (Just mHead) (mTxs:mTxsAcc) aMap+ -- Done processing this batch. Reverse mTxsAcc as we have been+ -- prepending new values to it.+ _ -> return (lastMerkleM, reverse mTxsAcc, aMap)+ groupByAcc addrs =+ let xs = map (\a -> (keyRingAddrAccount a, 1)) addrs+ in M.fromListWith (+) xs+ shouldRescan aMap = do+ -- Try to find an account whos gap is smaller than the number of new+ -- addresses generated in that account.+ res <- runDBPool sem pool $ splitSelect (M.assocs aMap) $ \ks ->+ from $ \a -> do+ let andCond (ai, cnt) =+ a ^. KeyRingAccountId ==. val ai &&.+ a ^. KeyRingAccountGap <=. val cnt+ where_ $ join2 $ map andCond ks+ return $ a ^. KeyRingAccountId+ return $ not $ null res+ -- Some logging of the blocks+ logBlockChainAction action = case action of+ BestChain nodes -> $(logInfo) $ pack $ unwords+ [ "Best chain height"+ , show $ nodeHeaderHeight $ last nodes+ , "(", cs $ blockHashToHex $ nodeBlockHash $ last nodes, ")"+ ]+ ChainReorg _ o n -> $(logInfo) $ pack $ unlines $+ [ "Chain reorg."+ , "Orphaned blocks:"+ ]+ ++ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) o+ ++ [ "New blocks:" ]+ ++ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n+ ++ [ unwords [ "Best merkle chain height"+ , show $ nodeHeaderHeight $ last n+ ]+ ]+ SideChain n -> $(logWarn) $ pack $ unlines $+ "Side chain:" :+ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n+ KnownChain n -> $(logWarn) $ pack $ unlines $+ "Known chain:" :+ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n++maybeDetach :: Config -> IO () -> IO ()+maybeDetach cfg action =+ if configDetach cfg then runDetached pidFile logFile action else action+ where+ pidFile = Just $ configPidFile cfg+ logFile = ToFile $ configLogFile cfg++stopSPVServer :: Config -> IO ()+stopSPVServer cfg =+ -- TODO: Should we send a message instead of killing the process ?+ killAndWait $ configPidFile cfg++-- Run the main ZeroMQ loop+-- TODO: Support concurrent requests using DEALER socket when we can do+-- concurrent MySQL requests.+runWalletApp :: ( MonadIO m+ , MonadLogger m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadThrow m+ , MonadResource m+ )+ => HandlerSession -> m ()+runWalletApp session =+ liftBaseOpDiscard withContext $ \ctx ->+ liftBaseOpDiscard (withSocket ctx Rep) $ \sock -> do+ liftIO $ bind sock $ configBind $ handlerConfig session+ forever $ do+ bs <- liftIO $ receive sock+ res <- case decode $ BL.fromStrict bs of+ Just r -> catchErrors $+ runHandler session $ dispatchRequest r+ Nothing -> return $ ResponseError "Could not decode request"+ liftIO $ send sock [] $ BL.toStrict $ encode res+ where+ catchErrors m = catches m+ [ E.Handler $ \(WalletException err) ->+ return $ ResponseError $ pack err+ , E.Handler $ \(ErrorCall err) ->+ return $ ResponseError $ pack err+ , E.Handler $ \(SomeException exc) ->+ return $ ResponseError $ pack $ show exc+ ]++dispatchRequest :: ( MonadLogger m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadThrow m+ , MonadResource m+ , MonadIO m+ )+ => WalletRequest -> Handler m (WalletResponse Value)+dispatchRequest req = liftM ResponseValid $ case req of+ GetKeyRingsR -> getKeyRingsR+ GetKeyRingR r -> getKeyRingR r+ PostKeyRingsR r -> postKeyRingsR r+ GetAccountsR r -> getAccountsR r+ PostAccountsR r na -> postAccountsR r na+ GetAccountR r n -> getAccountR r n+ PostAccountKeysR r n ks -> postAccountKeysR r n ks+ PostAccountGapR r n g -> postAccountGapR r n g+ GetAddressesR r n t m o p -> getAddressesR r n t m o p+ GetAddressesUnusedR r n t -> getAddressesUnusedR r n t+ GetAddressR r n i t m o -> getAddressR r n i t m o+ PutAddressR r n i t l -> putAddressR r n i t l+ PostAddressesR r n i t -> postAddressesR r n i t+ GetTxsR r n p -> getTxsR r n p+ GetAddrTxsR r n i t p -> getAddrTxsR r n i t p+ PostTxsR r n a -> postTxsR r n a+ GetTxR r n h -> getTxR r n h+ GetOfflineTxR r n h -> getOfflineTxR r n h+ PostOfflineTxR r n t c -> postOfflineTxR r n t c+ GetBalanceR r n mc o -> getBalanceR r n mc o+ PostNodeR na -> postNodeR na+
+ Network/Haskoin/Wallet/Server/Handler.hs view
@@ -0,0 +1,626 @@+module Network.Haskoin.Wallet.Server.Handler where++import Control.Arrow (first)+import Control.Monad (when, unless, liftM)+import Control.Exception (SomeException(..), throwIO, tryJust)+import Control.Monad.Trans (liftIO, MonadIO, lift)+import Control.Monad.Logger (MonadLogger, logInfo, logError)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)+import qualified Control.Concurrent.MSem as Sem (MSem, with)+import qualified Control.Monad.State as S (StateT, evalStateT, gets)++import Data.Aeson (Value(..), toJSON)+import Data.Word (Word32)+import Data.Text (Text, pack, unpack)+import qualified Data.Map.Strict as M (intersectionWith, fromList, elems)+import Data.String.Conversions (cs)++import Database.Esqueleto (SqlPersistT, Entity(..))++import Database.Persist.Sql+ ( SqlPersistM+ , ConnectionPool+ , runSqlPool+ , runSqlPersistMPool+ )++import Network.Haskoin.Crypto+import Network.Haskoin.Transaction+import Network.Haskoin.Node.STM+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.BlockChain+import Network.Haskoin.Node.Peer++import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Types++type Handler m = S.StateT HandlerSession m++data HandlerSession = HandlerSession+ { handlerConfig :: !Config+ , handlerPool :: !ConnectionPool+ , handlerNodeState :: !(Maybe SharedNodeState)+ , handlerSem :: !(Sem.MSem Int)+ }++runHandler :: Monad m => HandlerSession -> Handler m a -> m a+runHandler = flip S.evalStateT++runDB :: MonadBaseControl IO m => SqlPersistT m a -> Handler m a+runDB action = do+ sem <- S.gets handlerSem+ pool <- S.gets handlerPool+ lift $ runDBPool sem pool action++runDBPool :: MonadBaseControl IO m+ => Sem.MSem Int -> ConnectionPool -> SqlPersistT m a -> m a+runDBPool sem pool action = liftBaseOp_ (Sem.with sem) $ runSqlPool action pool++tryDBPool :: (MonadIO m, MonadLogger m)+ => Sem.MSem Int -> ConnectionPool -> SqlPersistM a -> m (Maybe a)+tryDBPool sem pool action = do+ resE <- liftIO $ Sem.with sem $ tryJust f $ runSqlPersistMPool action pool+ case resE of+ Right res -> return $ Just res+ Left err -> do+ $(logError) $ pack $ unwords [ "A database error occured:", err]+ return Nothing+ where+ f (SomeException e) = Just $ show e++runNode :: MonadIO m => NodeT m a -> Handler m a+runNode action = do+ nodeStateM <- S.gets handlerNodeState+ case nodeStateM of+ Just nodeState -> lift $ runNodeT nodeState action+ _ -> error "runNode: No node state available"++{- Server Handlers -}++getKeyRingsR :: ( MonadLogger m+ , MonadIO m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadThrow m+ , MonadResource m+ )+ => Handler m (Maybe Value)+getKeyRingsR = do+ $(logInfo) $ format "GetKeyRingsR"+ res <- runDB keyRings+ return $ Just $ toJSON $ map (\k -> toJsonKeyRing k Nothing Nothing) res++getKeyRingR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> Handler m (Maybe Value)+getKeyRingR name = do+ $(logInfo) $ format $ unwords [ "GetKeyRingR", unpack name ]+ Entity _ keyRing <- runDB $ getKeyRing name+ return $ Just $ toJSON $ toJsonKeyRing keyRing Nothing Nothing++postKeyRingsR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => NewKeyRing -> Handler m (Maybe Value)+postKeyRingsR (NewKeyRing name passM msM) = do+ $(logInfo) $ format $ unwords [ "PostKeyRingsR", unpack name ]+ (ms, seed) <- case msM of+ Just ms -> case mnemonicToSeed pass (cs ms) of+ Left err -> liftIO $ throwIO $ WalletException err+ Right seed -> return (cs ms, seed)+ Nothing -> do+ ent <- liftIO $ getEntropy 16+ either (liftIO . throwIO . WalletException) return $ do+ ms <- toMnemonic ent+ seed <- mnemonicToSeed pass ms+ return (cs ms, seed)+ Entity _ keyRing <- runDB $ newKeyRing name seed+ return $ Just $ toJSON $ toJsonKeyRing keyRing Nothing (Just ms)+ where+ pass = maybe "" cs passM++getAccountsR :: ( MonadLogger m+ , MonadIO m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadThrow m+ , MonadResource m+ )+ => KeyRingName -> Handler m (Maybe Value)+getAccountsR keyRingName = do+ $(logInfo) $ format $ unwords [ "GetAccountsR", unpack keyRingName ]+ (keyRing, accs) <- runDB $ do+ Entity ki keyRing <- getKeyRing keyRingName+ accs <- accounts ki+ return (keyRing, accs)+ return $ Just $ toJSON JsonWithKeyRing+ { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withKeyRingData = map toJsonAccount accs+ }++postAccountsR+ :: ( MonadResource m, MonadThrow m, MonadLogger m+ , MonadBaseControl IO m, MonadIO m+ )+ => KeyRingName -> NewAccount -> Handler m (Maybe Value)+postAccountsR keyRingName NewAccount{..} = do+ $(logInfo) $ format $ unlines+ [ "PostAccountsR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account type: " ++ show newAccountType+ , " Account name: " ++ unpack newAccountAccountName+ ]+ (keyRing, Entity _ newAcc) <- runDB $ do+ keyRingE@(Entity _ keyRing) <- getKeyRing keyRingName+ newAcc <- newAccount+ keyRingE newAccountAccountName newAccountType newAccountKeys+ return (keyRing, newAcc)+ -- Update the bloom filter if the account is complete+ whenOnline $ when (isCompleteAccount newAcc) updateNodeFilter+ return $ Just $ toJSON JsonWithKeyRing+ { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withKeyRingData = toJsonAccount newAcc+ }++getAccountR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> Handler m (Maybe Value)+getAccountR keyRingName name = do+ $(logInfo) $ format $ unlines+ [ "GetAccountR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ ]+ (keyRing, Entity _ acc) <- runDB $ getAccount keyRingName name+ return $ Just $ toJSON JsonWithKeyRing+ { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withKeyRingData = toJsonAccount acc+ }++postAccountKeysR+ :: ( MonadResource m, MonadThrow m, MonadLogger m+ , MonadBaseControl IO m, MonadIO m+ )+ => KeyRingName -> AccountName -> [XPubKey] -> Handler m (Maybe Value)+postAccountKeysR keyRingName name keys = do+ $(logInfo) $ format $ unlines+ [ "PostAccountKeysR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Key count : " ++ show (length keys)+ ]+ (keyRing, newAcc) <- runDB $ do+ (keyRing, accE) <- getAccount keyRingName name+ newAcc <- addAccountKeys accE keys+ return (keyRing, newAcc)+ -- Update the bloom filter if the account is complete+ whenOnline $ when (isCompleteAccount newAcc) updateNodeFilter+ return $ Just $ toJSON JsonWithKeyRing+ { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withKeyRingData = toJsonAccount newAcc+ }++postAccountGapR :: ( MonadLogger m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadIO m+ , MonadThrow m+ , MonadResource m+ )+ => KeyRingName -> AccountName -> SetAccountGap+ -> Handler m (Maybe Value)+postAccountGapR keyRingName name (SetAccountGap gap) = do+ $(logInfo) $ format $ unlines+ [ "PostAccountGapR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " New gap size: " ++ show gap+ ]+ -- Update the gap+ (keyRing, newAcc) <- runDB $ do+ (keyRing, accE) <- getAccount keyRingName name+ newAcc <- setAccountGap accE gap+ return (keyRing, newAcc)+ -- Update the bloom filter+ whenOnline updateNodeFilter+ return $ Just $ toJSON JsonWithKeyRing+ { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withKeyRingData = toJsonAccount newAcc+ }++getAddressesR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName+ -> AccountName+ -> AddressType+ -> Word32+ -> Bool+ -> PageRequest+ -> Handler m (Maybe Value)+getAddressesR keyRingName name addrType minConf offline page = do+ $(logInfo) $ format $ unlines+ [ "GetAddressesR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Address type: " ++ show addrType+ , " Page number : " ++ show (pageNum page)+ , " Page size : " ++ show (pageLen page)+ , " Page reverse: " ++ show (pageReverse page)+ , " MinConf : " ++ show minConf+ , " Offline : " ++ show offline+ ]++ (keyRing, acc, res, bals, maxPage) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ (res, maxPage) <- addressPage accE addrType page+ case res of+ [] -> return (keyRing, acc, res, [], maxPage)+ _ -> do+ let is = map keyRingAddrIndex res+ (iMin, iMax) = (minimum is, maximum is)+ bals <- addressBalances accE iMin iMax addrType minConf offline+ return (keyRing, acc, res, bals, maxPage)++ -- Join addresses and balances together+ let g (addr, bal) = toJsonAddr addr (Just bal)+ addrBals = map g $ M.elems $ joinAddrs res bals+ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = PageRes addrBals maxPage+ }+ where+ joinAddrs addrs bals =+ let f addr = (keyRingAddrIndex addr, addr)+ in M.intersectionWith (,) (M.fromList $ map f addrs) (M.fromList bals)++getAddressesUnusedR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> AddressType+ -> Handler m (Maybe Value)+getAddressesUnusedR keyRingName name addrType = do+ $(logInfo) $ format $ unlines+ [ "GetAddressesUnusedR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Address type: " ++ show addrType+ ]++ (keyRing, acc, addrs) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ addrs <- unusedAddresses accE addrType+ return (keyRing, acc, addrs)++ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = map (`toJsonAddr` Nothing) addrs+ }++getAddressR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> KeyIndex -> AddressType+ -> Word32 -> Bool+ -> Handler m (Maybe Value)+getAddressR keyRingName name i addrType minConf offline = do+ $(logInfo) $ format $ unlines+ [ "GetAddressR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Index : " ++ show i+ , " Address type: " ++ show addrType+ ]++ (keyRing, acc, addr, balM) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ addrE <- getAddress accE addrType i+ bals <- addressBalances accE i i addrType minConf offline+ return $ case bals of+ ((_,bal):_) -> (keyRing, acc, entityVal addrE, Just bal)+ _ -> (keyRing, acc, entityVal addrE, Nothing)+ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = toJsonAddr addr balM+ }++putAddressR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName+ -> AccountName+ -> KeyIndex+ -> AddressType+ -> AddressLabel+ -> Handler m (Maybe Value)+putAddressR keyRingName name i addrType (AddressLabel label) = do+ $(logInfo) $ format $ unlines+ [ "PutAddressR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Index : " ++ show i+ , " Label : " ++ unpack label+ ]++ (keyRing, acc, newAddr) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ newAddr <- setAddrLabel accE i addrType label+ return (keyRing, acc, newAddr)++ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = toJsonAddr newAddr Nothing+ }++postAddressesR :: ( MonadLogger m+ , MonadBaseControl IO m+ , MonadIO m+ , MonadThrow m+ , MonadBase IO m+ , MonadResource m+ )+ => KeyRingName+ -> AccountName+ -> KeyIndex+ -> AddressType+ -> Handler m (Maybe Value)+postAddressesR keyRingName name i addrType = do+ $(logInfo) $ format $ unlines+ [ "PostAddressesR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Index : " ++ show i+ ]++ (keyRing, acc, cnt) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ cnt <- generateAddrs accE addrType i+ return (keyRing, acc, cnt)++ -- Update the bloom filter+ whenOnline updateNodeFilter++ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = cnt+ }++getTxsR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> PageRequest -> Handler m (Maybe Value)+getTxsR keyRingName name page = do+ $(logInfo) $ format $ unlines+ [ "GetTxsR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Page number : " ++ show (pageNum page)+ , " Page size : " ++ show (pageLen page)+ , " Page reverse: " ++ show (pageReverse page)+ ]++ (keyRing, acc, res, maxPage, height) <- runDB $ do+ (keyRing, Entity ai acc) <- getAccount keyRingName name+ (_, height) <- getBestBlock+ (res, maxPage) <- txPage ai page+ return (keyRing, acc, res, maxPage, height)++ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData =+ PageRes (map (`toJsonTx` Just height) res) maxPage+ }++getAddrTxsR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName+ -> KeyIndex -> AddressType -> PageRequest+ -> Handler m (Maybe Value)+getAddrTxsR keyRingName name index addrType page = do+ $(logInfo) $ format $ unlines+ [ "GetAddrTxsR"+ , " KeyRing name : " ++ unpack keyRingName+ , " Account name : " ++ unpack name+ , " Address index: " ++ show index+ , " Address type : " ++ show addrType+ , " Page number : " ++ show (pageNum page)+ , " Page size : " ++ show (pageLen page)+ , " Page reverse : " ++ show (pageReverse page)+ ]++ (keyRing, acc, res, maxPage, height, addr) <- runDB $ do+ (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name+ Entity addrI addr <- getAddress accE addrType index+ (_, height) <- getBestBlock+ (res, maxPage) <- addrTxPage accE addrI page+ return (keyRing, acc, res, maxPage, height, addr)++ return $ Just $ toJSON JsonWithAddr+ { withAddrKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAddrAccount = toJsonAccount acc+ , withAddrAddress = toJsonAddr addr Nothing+ , withAddrData = PageRes (map (f height) res) maxPage+ }+ where+ f height (tx, bal) = AddrTx (toJsonTx tx (Just height)) bal++postTxsR :: ( MonadLogger m, MonadBaseControl IO m, MonadBase IO m+ , MonadIO m, MonadThrow m, MonadResource m+ )+ => KeyRingName -> AccountName -> TxAction -> Handler m (Maybe Value)+postTxsR keyRingName name action = do+ (keyRing, accE@(Entity ai acc), height) <- runDB $ do+ (keyRing, accE) <- getAccount keyRingName name+ (_, height) <- getBestBlock+ return (keyRing, accE, height)++ (txRes, newAddrs) <- case action of+ CreateTx rs fee minconf rcptFee sign -> do+ $(logInfo) $ format $ unlines+ [ "PostTxsR CreateTx"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Recipients : " ++ show (map (first addrToBase58) rs)+ , " Fee : " ++ show fee+ , " Minconf : " ++ show minconf+ , " Rcpt. Fee : " ++ show rcptFee+ , " Sign : " ++ show sign+ ]+ runDB $ createTx keyRing accE rs fee minconf rcptFee sign+ ImportTx tx -> do+ $(logInfo) $ format $ unlines+ [ "PostTxsR ImportTx"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Txid : " ++ cs (txHashToHex (txHash tx))+ ]+ runDB $ do+ (res, newAddrs) <- importTx tx ai+ case filter ((== ai) . keyRingTxAccount) res of+ (txRes:_) -> return (txRes, newAddrs)+ _ -> liftIO . throwIO $ WalletException+ "Could not import the transaction"+ SignTx txid -> do+ $(logInfo) $ format $ unlines+ [ "PostTxsR SignTx"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Txid : " ++ cs (txHashToHex txid)+ ]+ runDB $ do+ (res, newAddrs) <- signKeyRingTx keyRing accE txid+ case filter ((== ai) . keyRingTxAccount) res of+ (txRes:_) -> return (txRes, newAddrs)+ _ -> liftIO . throwIO $ WalletException+ "Could not import the transaction"+ whenOnline $ do+ -- Update the bloom filter+ unless (null newAddrs) updateNodeFilter+ -- If the transaction is pending, broadcast it to the network+ when (keyRingTxConfidence txRes == TxPending) $+ runNode $ broadcastTxs [keyRingTxHash txRes]+ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = toJsonTx txRes (Just height)+ }++getTxR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> TxHash -> Handler m (Maybe Value)+getTxR keyRingName name txid = do+ $(logInfo) $ format $ unlines+ [ "GetTxR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Txid : " ++ cs (txHashToHex txid)+ ]+ (keyRing, acc, res, height) <- runDB $ do+ (keyRing, Entity ai acc) <- getAccount keyRingName name+ (_, height) <- getBestBlock+ res <- getAccountTx ai txid+ return (keyRing, acc, res, height)+ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = toJsonTx res (Just height)+ }++getBalanceR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => KeyRingName -> AccountName -> Word32 -> Bool+ -> Handler m (Maybe Value)+getBalanceR keyRingName name minconf offline = do+ $(logInfo) $ format $ unlines+ [ "GetBalanceR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack name+ , " Minconf : " ++ show minconf+ , " Offline : " ++ show offline+ ]+ (keyRing, acc, bal) <- runDB $ do+ (keyRing, Entity ai acc) <- getAccount keyRingName name+ bal <- accountBalance ai minconf offline+ return (keyRing, acc, bal)+ return $ Just $ toJSON JsonWithAccount+ { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing+ , withAccountAccount = toJsonAccount acc+ , withAccountData = bal+ }++getOfflineTxR :: ( MonadLogger m, MonadIO m, MonadBaseControl IO m+ , MonadBase IO m, MonadThrow m, MonadResource m+ )+ => KeyRingName -> AccountName -> TxHash -> Handler m (Maybe Value)+getOfflineTxR keyRingName accountName txid = do+ $(logInfo) $ format $ unlines+ [ "GetOfflineTxR"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack accountName+ , " Txid : " ++ cs (txHashToHex txid)+ ]+ (dat, _) <- runDB $ do+ (_, Entity ai _) <- getAccount keyRingName accountName+ getOfflineTxData ai txid+ return $ Just $ toJSON dat++postOfflineTxR :: ( MonadLogger m, MonadIO m, MonadBaseControl IO m+ , MonadBase IO m, MonadThrow m, MonadResource m+ )+ => KeyRingName+ -> AccountName+ -> Tx+ -> [CoinSignData]+ -> Handler m (Maybe Value)+postOfflineTxR keyRingName accountName tx signData = do+ $(logInfo) $ format $ unlines+ [ "PostTxsR SignOfflineTx"+ , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack accountName+ , " Txid : " ++ cs (txHashToHex (txHash tx))+ ]+ (keyRing, Entity _ acc) <- runDB $ getAccount keyRingName accountName+ let signedTx = signOfflineTx keyRing acc tx signData+ complete = verifyStdTx signedTx $ map toDat signData+ toDat CoinSignData{..} = (coinSignScriptOutput, coinSignOutPoint)+ return $ Just $ toJSON $ TxCompleteRes signedTx complete++postNodeR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => NodeAction -> Handler m (Maybe Value)+postNodeR action = case action of+ NodeActionRescan tM -> do+ t <- case tM of+ Just t -> return $ adjustFCTime t+ Nothing -> do+ timeM <- runDB firstAddrTime+ maybe err (return . adjustFCTime) timeM+ $(logInfo) $ format $ unlines+ [ "NodeR Rescan"+ , " Timestamp: " ++ show t+ ]+ whenOnline $ do+ runDB resetRescan+ runNode $ atomicallyNodeT $ rescanTs t+ return $ Just $ toJSON $ RescanRes t+ NodeActionStatus -> do+ status <- runNode $ atomicallyNodeT nodeStatus+ return $ Just $ toJSON status+ where+ err = liftIO . throwIO $ WalletException+ "No keys have been generated in the wallet"++{- Helpers -}++whenOnline :: Monad m => Handler m () -> Handler m ()+whenOnline handler = do+ mode <- configMode `liftM` S.gets handlerConfig+ when (mode == SPVOnline) handler++updateNodeFilter :: (MonadBaseControl IO m, MonadIO m, MonadLogger m)+ => Handler m ()+updateNodeFilter = do+ $(logInfo) $ format "Sending a new bloom filter"+ (bloom, elems, _) <- runDB getBloomFilter+ runNode $ atomicallyNodeT $ sendBloomFilter bloom elems++adjustFCTime :: Timestamp -> Timestamp+adjustFCTime ts = fromInteger $ max 0 $ toInteger ts - 86400 * 7++format :: String -> Text+format str = pack $ "[ZeroMQ] " ++ str+
+ Network/Haskoin/Wallet/Settings.hs view
@@ -0,0 +1,173 @@+module Network.Haskoin.Wallet.Settings+( SPVMode(..)+, OutputFormat(..)+, Config(..)+) where++import Control.Monad (forM, mzero)+import Control.Exception (throw)+import Control.Monad.Logger (LogLevel(..))++import Data.Default (Default, def)+import Data.FileEmbed (embedFile)+import Data.Yaml (decodeEither')+import Data.Word (Word32, Word64)+import Data.HashMap.Strict (HashMap)+import qualified Data.Traversable as V (mapM)+import qualified Data.ByteString as BS (ByteString)+import qualified Data.Text as T (Text)+import Data.Aeson+ ( Value(..)+ , FromJSON+ , parseJSON+ , withObject+ , (.:), (.:?), (.!=)+ )++import Network.Haskoin.Wallet.Database+import Network.Haskoin.Wallet.Types++data SPVMode = SPVOnline | SPVOffline+ deriving (Eq, Show, Read)++data OutputFormat+ = OutputNormal+ | OutputJSON+ | OutputYAML++data Config = Config+ { configKeyRing :: !T.Text+ -- ^ Keyring to use in commands+ , configCount :: !Word32+ -- ^ Output size of commands+ , configMinConf :: !Word32+ -- ^ Minimum number of confirmations+ , configSignTx :: !Bool+ -- ^ Sign transactions+ , configFee :: !Word64+ -- ^ Fee to pay per 1000 bytes when creating new transactions+ , configRcptFee :: !Bool+ -- ^ Recipient pays fee (dangerous, no config file setting)+ , configAddrType :: !AddressType+ -- ^ Return internal instead of external addresses+ , configOffline :: !Bool+ -- ^ Display the balance including offline transactions+ , configReversePaging :: !Bool+ -- ^ Use reverse paging for displaying addresses and transactions+ , configPass :: !(Maybe T.Text)+ -- ^ Passphrase to use when creating new keyrings (bip39 mnemonic)+ , configFormat :: !OutputFormat+ -- ^ How to format the command-line results+ , configConnect :: !String+ -- ^ ZeroMQ socket to connect to (location of the server)+ , configDetach :: !Bool+ -- ^ Detach server when launched from command-line+ , configFile :: !FilePath+ -- ^ Configuration file+ , configTestnet :: !Bool+ -- ^ Use Testnet3 network+ , configDir :: !FilePath+ -- ^ Working directory+ , configBind :: !String+ -- ^ Bind address for the zeromq socket+ , configBTCNodes :: !(HashMap T.Text [(String, Int)])+ -- ^ Trusted Bitcoin full nodes to connect to+ , configMode :: !SPVMode+ -- ^ Operation mode of the SPV node.+ , configBloomFP :: !Double+ -- ^ False positive rate for the bloom filter.+ , configDatabase :: !(HashMap T.Text DatabaseConfType)+ -- ^ Database configuration+ , configLogFile :: !FilePath+ -- ^ Log file+ , configPidFile :: !FilePath+ -- ^ PID File+ , configLogLevel :: !LogLevel+ -- ^ Log level+ , configVerbose :: !Bool+ -- ^ Verbose+ }++configBS :: BS.ByteString+configBS = $(embedFile "config/config.yml")++instance Default Config where+ def = either throw id $ decodeEither' configBS++instance FromJSON Config where+ parseJSON = withObject "Config" $ \o -> do+ let configRcptFee = False+ configFile = "config.yml"+ configPass = Nothing+ configKeyRing <- o .:? "keyring-name"+ .!= configKeyRing def+ configCount <- o .:? "output-size"+ .!= configCount def+ configMinConf <- o .:? "minimum-confirmations"+ .!= configMinConf def+ configSignTx <- o .:? "sign-transactions"+ .!= configSignTx def+ configFee <- o .:? "transaction-fee"+ .!= configFee def+ configAddrType <- k =<< o .:? "address-type"+ configOffline <- o .:? "offline"+ .!= configOffline def+ configReversePaging <- o .:? "reverse-paging"+ .!= configReversePaging def+ configFormat <- f =<< o .:? "display-format"+ configConnect <- o .:? "connect-uri"+ .!= configConnect def+ configDetach <- o .:? "detach-server"+ .!= configDetach def+ configTestnet <- o .:? "use-testnet"+ .!= configTestnet def+ configDir <- o .:? "work-dir"+ .!= configDir def+ configBind <- o .:? "bind-socket"+ .!= configBind def+ configBTCNodes <- g =<< o .:? "bitcoin-full-nodes"+ configMode <- h =<< o .:? "server-mode"+ configBloomFP <- o .:? "bloom-false-positive"+ .!= configBloomFP def+ configDatabase <- i =<< o .:? "database"+ configLogFile <- o .:? "log-file"+ .!= configLogFile def+ configPidFile <- o .:? "pid-file"+ .!= configPidFile def+ configLogLevel <- j =<< o .:? "log-level"+ configVerbose <- o .:? "verbose"+ .!= configVerbose def+ return Config {..}+ where+ f format = case format of+ Just (String "normal") -> return OutputNormal+ Just (String "json") -> return OutputJSON+ Just (String "yaml") -> return OutputYAML+ Just _ -> mzero+ Nothing -> return $ configFormat def+ g (Just x) = flip (withObject "btcnodesobj") x $ V.mapM $ \a -> do+ ls <- parseJSON a+ forM ls $ withObject "bitcoinnode" $ \o ->+ (,) <$> (o .: "host") <*> (o .: "port")+ g Nothing = return $ configBTCNodes def+ h mode = case mode of+ Just (String "online") -> return SPVOnline+ Just (String "offline") -> return SPVOffline+ Just _ -> mzero+ Nothing -> return $ configMode def+ i (Just x) = flip (withObject "databases") x $ V.mapM .+ withObject "database" $ \v -> v .: databaseEngine+ i Nothing = return $ configDatabase def+ j level = case level of+ Just (String "debug") -> return LevelDebug+ Just (String "info") -> return LevelInfo+ Just (String "warn") -> return LevelWarn+ Just (String "error") -> return LevelError+ Just _ -> mzero+ Nothing -> return $ configLogLevel def+ k addrtype = case addrtype of+ Just (String "internal") -> return AddressInternal+ Just (String "external") -> return AddressExternal+ Just _ -> mzero+ Nothing -> return $ configAddrType def+
− Network/Haskoin/Wallet/Store.hs
@@ -1,534 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-|- This module provides an API to the Haskoin wallet. All commands return a- 'Value' result which can be encoded to JSON or YAML. The wallet commands- run within the Persistent framework for database support:-- <http://hackage.haskell.org/package/persistent>--}-module Network.Haskoin.Wallet.Store-( - cmdInit---- *Account Commands-, cmdNewAcc-, cmdNewMS-, cmdAddKeys-, cmdAccInfo-, cmdListAcc-, cmdDumpKeys---- *Address Commands-, cmdList-, cmdGenAddrs-, cmdGenWithLabel-, cmdLabel-, cmdWIF---- *Coin Commands-, cmdBalance-, cmdBalances-, cmdCoins-, cmdAllCoins---- *Tx Commands-, cmdImportTx -, cmdRemoveTx-, cmdListTx-, cmdSend-, cmdSendMany-, cmdSignTx---- *Utility Commands-, cmdDecodeTx-, cmdBuildRawTx-, cmdSignRawTx--) where--import Control.Applicative ((<$>))-import Control.Monad (when)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Either (EitherT, left)--import Data.Time (getCurrentTime)-import Data.Yaml - ( Value (Null)- , object - , (.=)- , toJSON- )-import Data.Maybe (isJust, fromJust)-import Data.List (sortBy)-import qualified Data.Aeson as Json (decode)-import qualified Data.Text as T (pack)--import Database.Persist- ( PersistStore- , PersistUnique- , PersistQuery- , PersistMonadBackend- , Entity(..)- , entityVal- , entityKey- , get- , getBy- , selectList- , insert_- , replace- , count- , (<=.), (==.)- , SelectOpt( Asc, OffsetBy, LimitTo )- )-import Database.Persist.Sqlite (SqlBackend)--import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Manager-import Network.Haskoin.Wallet.TxBuilder-import Network.Haskoin.Wallet.Store.DbAccount-import Network.Haskoin.Wallet.Store.DbAddress-import Network.Haskoin.Wallet.Store.DbCoin-import Network.Haskoin.Wallet.Store.DbTx-import Network.Haskoin.Wallet.Store.Util-import Network.Haskoin.Script-import Network.Haskoin.Protocol-import Network.Haskoin.Crypto-import Network.Haskoin.Util-import Network.Haskoin.Util.BuildMonad---- | Initialize a wallet from a secret seed. This function will fail if the--- wallet is already initialized.-cmdInit :: PersistUnique m- => String -- ^ Secret seed.- -> EitherT String m Value -- ^ Returns Null.-cmdInit seed - | null seed = left "cmdInit: seed can not be empty"- | otherwise = do- time <- liftIO getCurrentTime- master <- liftMaybe err $ makeMasterKey $ stringToBS seed- let str = xPrvExport $ masterKey master- prev <- getBy $ UniqueWalletName "main"- when (isJust prev) $ left- "cmdInit: Wallet is already initialized"- insert_ $ DbWallet "main" "full" str (-1) time- return Null- where - err = "cmdInit: Invalid master key generated from seed"--{- Account Commands -}---- | Create a new account from an account name. Accounts are identified by--- their name and they must be unique.-cmdNewAcc :: (PersistUnique m, PersistQuery m) - => String -- ^ Account name.- -> EitherT String m Value -- ^ Returns the new account information.-cmdNewAcc name = do- acc <- dbNewAcc name- -- Generate gap addresses- dbSetGap name 30 False- dbSetGap name 30 True- return $ yamlAcc acc---- | Create a new multisignature account. The thirdparty keys can be provided--- now or later using the 'cmdAddKeys' command. The number of thirdparty keys--- can not exceed n-1 as your own account key will be used as well in the--- multisignature scheme. If less than n-1 keys are provided, the account will--- be in a pending state and no addresses can be generated.------ In order to prevent usage mistakes, you can not create a multisignature --- account with other keys from your own wallet.-cmdNewMS :: (PersistUnique m, PersistQuery m)- => String -- ^ Account name.- -> Int -- ^ Required number of keys (m in m of n).- -> Int -- ^ Total number of keys (n in m of n).- -> [XPubKey] -- ^ Thirdparty public keys.- -> EitherT String m Value -- ^ Returns the new account information.-cmdNewMS name m n mskeys = do- acc <- dbNewMS name m n mskeys- when (length (dbAccountMsKeys acc) == n - 1) $ do- -- Generate gap addresses- dbSetGap name 30 False- dbSetGap name 30 True- return $ yamlAcc acc---- | Add new thirdparty keys to a multisignature account. This function can--- fail if the multisignature account already has all required keys. In order--- to prevent usage mistakes, adding a key from your own wallet will fail.-cmdAddKeys :: (PersistUnique m, PersistQuery m)- => AccountName -- ^ Account name.- -> [XPubKey] -- ^ Thirdparty public keys to add.- -> EitherT String m Value -- ^ Returns the account information.-cmdAddKeys name keys = do- acc <- dbAddKeys name keys- let n = fromJust $ dbAccountMsTotal acc- when (length (dbAccountMsKeys acc) == n - 1) $ do- -- Generate gap addresses- dbSetGap name 30 False- dbSetGap name 30 True- return $ yamlAcc acc---- | Returns information on an account.-cmdAccInfo :: PersistUnique m - => AccountName -- ^ Account name.- -> EitherT String m Value -- ^ Account information.-cmdAccInfo name = yamlAcc . entityVal <$> dbGetAcc name---- | Returns a list of all accounts in the wallet.-cmdListAcc :: PersistQuery m - => EitherT String m Value -- ^ List of accounts-cmdListAcc = toJSON . (map (yamlAcc . entityVal)) <$> selectList [] []---- | Returns information on extended public and private keys of an account.--- For a multisignature account, thirdparty keys are also returned.-cmdDumpKeys :: PersistUnique m- => AccountName -- ^ Account name.- -> EitherT String m Value -- ^ Extended key information.-cmdDumpKeys name = do- (Entity _ acc) <- dbGetAcc name- w <- liftMaybe walErr =<< (get $ dbAccountWallet acc)- let keyM = loadMasterKey =<< (xPrvImport $ dbWalletMaster w)- master <- liftMaybe keyErr keyM- prv <- liftMaybe prvErr $ - accPrvKey master (fromIntegral $ dbAccountIndex acc)- let prvKey = getAccPrvKey prv- pubKey = deriveXPubKey prvKey- ms | isMSAcc acc = ["MSKeys" .= (toJSON $ dbAccountMsKeys acc)]- | otherwise = []- return $ object $- [ "Account" .= yamlAcc acc- , "PubKey" .= xPubExport pubKey - , "PrvKey" .= xPrvExport prvKey - ] ++ ms- where keyErr = "cmdDumpKeys: Could not decode master key"- prvErr = "cmdDumpKeys: Could not derive account private key"- walErr = "cmdDumpKeys: Could not find account wallet"--{- Address Commands -}---- | Returns a page of addresses for an account. Pages are numbered starting--- from page 1. Requesting page 0 will return the last page. -cmdList :: (PersistUnique m, PersistQuery m) - => AccountName -- ^ Account name.- -> Int -- ^ Requested page number.- -> Int -- ^ Number of addresses per page.- -> EitherT String m Value -- ^ The requested page.-cmdList name pageNum resPerPage - | pageNum < 0 = left $ - unwords ["cmdList: Invalid page number", show pageNum]- | resPerPage < 1 = left $ - unwords ["cmdList: Invalid results per page",show resPerPage]- | otherwise = do- (Entity ai acc) <- dbGetAcc name- addrCount <- count - [ DbAddressAccount ==. ai- , DbAddressInternal ==. False- , DbAddressIndex <=. dbAccountExtIndex acc- ] - let maxPage = max 1 $ (addrCount + resPerPage - 1) `div` resPerPage- page | pageNum == 0 = maxPage- | otherwise = pageNum- when (page > maxPage) $ left "cmdList: Page number too high"- addrs <- selectList [ DbAddressAccount ==. ai- , DbAddressInternal ==. False- , DbAddressIndex <=. dbAccountExtIndex acc- ] - [ Asc DbAddressId- , LimitTo resPerPage- , OffsetBy $ (page - 1) * resPerPage- ]- return $ yamlAddrList (map entityVal addrs) page resPerPage addrCount---- | Generate new payment addresses for an account. -cmdGenAddrs :: (PersistUnique m, PersistQuery m)- => AccountName -- ^ Account name.- -> Int -- ^ Number of addresses to generate.- -> EitherT String m Value -- ^ List of new addresses.-cmdGenAddrs name c = cmdGenWithLabel name (replicate c "")---- | Generate new payment addresses with labels for an account.-cmdGenWithLabel :: (PersistUnique m, PersistQuery m)- => AccountName -- ^ Account name.- -> [String] -- ^ List of address labels. - -> EitherT String m Value -- ^ List of new addresses.-cmdGenWithLabel name labels = do- addrs <- dbGenAddrs name labels False- return $ toJSON $ map yamlAddr addrs---- | Add a label to an address.-cmdLabel :: PersistUnique m- => AccountName -- ^ Account name.- -> Int -- ^ Derivation index of the address. - -> String -- ^ New label.- -> EitherT String m Value -- ^ New address information.-cmdLabel name key label = do- (Entity ai acc) <- dbGetAcc name- (Entity i add) <- liftMaybe keyErr =<< - (getBy $ UniqueAddressKey ai key False)- when (dbAddressIndex add > dbAccountExtIndex acc) $ left keyErr- let newAddr = add{dbAddressLabel = label}- replace i newAddr- return $ yamlAddr newAddr- where - keyErr = unwords ["cmdLabel: Key",show key,"does not exist"]---- | Returns the private key tied to a payment address in WIF format.-cmdWIF :: PersistUnique m- => AccountName -- ^ Account name.- -> Int -- ^ Derivation index of the address. - -> EitherT String m Value -- ^ WIF value.-cmdWIF name key = do- (Entity _ w) <- dbGetWallet "main"- (Entity ai acc) <- dbGetAcc name- (Entity _ add) <- liftMaybe keyErr =<< - (getBy $ UniqueAddressKey ai key False)- when (dbAddressIndex add > dbAccountExtIndex acc) $ left keyErr- mst <- liftMaybe mstErr $ loadMasterKey =<< xPrvImport (dbWalletMaster w)- aKey <- liftMaybe prvErr $ accPrvKey mst $ fromIntegral $ dbAccountIndex acc- let index = fromIntegral $ dbAddressIndex add- addrPrvKey <- liftMaybe addErr $ extPrvKey aKey index- let prvKey = xPrvKey $ getAddrPrvKey addrPrvKey- return $ object [ "WIF" .= T.pack (toWIF prvKey) ]- where - keyErr = unwords ["cmdWIF: Key",show key,"does not exist"]- mstErr = "cmdWIF: Could not load master key"- prvErr = "cmdWIF: Invalid account derivation index"- addErr = "cmdWIF: Invalid address derivation index"--{- Coin Commands -}---- | Returns the balance of an account.-cmdBalance :: (PersistUnique m, PersistQuery m)- => AccountName -- ^ Account name.- -> EitherT String m Value -- ^ Account balance.-cmdBalance name = do- acc <- dbGetAcc name- balance <- dbBalance acc- return $ object [ "Balance" .= toJSON balance ]---- | Returns a list of balances for every account in the wallet.-cmdBalances :: PersistQuery m- => EitherT String m Value -- ^ All account balances-cmdBalances = do- accs <- selectList [] []- bals <- mapM dbBalance accs- return $ toJSON $ map f $ zip accs bals- where - f (acc,b) = object- [ "Account" .= (dbAccountName $ entityVal acc)- , "Balance" .= b- ]---- | Returns the list of unspent coins for an account.-cmdCoins :: ( PersistQuery m, PersistUnique m - , PersistMonadBackend m ~ SqlBackend- )- => AccountName -- ^ Account name.- -> EitherT String m Value -- ^ List of unspent coins.-cmdCoins name = do- (Entity ai _) <- dbGetAcc name- coins <- dbCoins ai- return $ toJSON $ map yamlCoin coins---- | Returns a list of all the unspent coins for every account in the wallet.-cmdAllCoins :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- )- => EitherT String m Value -- ^ Unspent coins for all accounts.-cmdAllCoins = do- accs <- selectList [] []- coins <- mapM (dbCoins . entityKey) accs- return $ toJSON $ map g $ zip accs coins- where - g (acc,cs) = object- [ "Account" .= (dbAccountName $ entityVal acc)- , "Coins" .= (toJSON $ map yamlCoin cs)- ]--{- Tx Commands -}---- | Import a transaction into the wallet. If called multiple times, this--- command will only update the existing transaction in the wallet. A new--- transaction entry will be created for every account affected by this--- transaction. Every transaction entry will summarize the information related--- to its account only (such as total movement for this account).-cmdImportTx :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- ) - => Tx -- ^ Transaction to import.- -> EitherT String m Value -- ^ New transaction entries created.-cmdImportTx tx = do- accTx <- dbImportTx tx- return $ toJSON $ map yamlTx $ sortBy f accTx- where- f a b = (dbTxCreated a) `compare` (dbTxCreated b)----- | Remove a transaction from the database. This will remove all transaction--- entries for this transaction as well as any child transactions and coins--- deriving from it.-cmdRemoveTx :: PersistQuery m- => String -- ^ Transaction id (txid)- -> EitherT String m Value -- ^ List of removed transaction entries-cmdRemoveTx tid = do- removed <- dbRemoveTx tid- return $ toJSON removed---- | List all the transaction entries for an account. Transaction entries--- summarize information for a transaction in a specific account only (such as--- the total movement of for this account).------ Transaction entries can also be tagged as /Orphan/ or /Partial/. Orphaned--- transactions are transactions with a parent transaction that should be in--- the wallet but has not been imported yet. Balances for orphaned transactions--- can not be accurately computed until the parent transaction is imported.------ Partial transactions are transactions that are not fully signed yet, such--- as a partially signed multisignature transaction. Partial transactions--- are visible in the wallet mostly for informational purposes. They can not--- generate any coins as the txid or partial transactions will change once--- they are fully signed. However, importing a partial transaction will /lock/--- the coins that it spends so that you don't mistakenly spend them. Partial--- transactions are replaced once the fully signed transaction is imported.-cmdListTx :: (PersistQuery m, PersistUnique m)- => AccountName -- ^ Account name.- -> EitherT String m Value -- ^ List of transaction entries.-cmdListTx name = do- (Entity ai _) <- dbGetAcc name- txs <- selectList [ DbTxAccount ==. ai- ] - [ Asc DbTxCreated ]- return $ toJSON $ map (yamlTx . entityVal) txs---- | Create a transaction sending some coins to a single recipient address.-cmdSend :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- )- => AccountName -- ^ Account name.- -> String -- ^ Recipient address. - -> Int -- ^ Amount to send. - -> Int -- ^ Fee per 1000 bytes. - -> EitherT String m Value -- ^ Payment transaction.-cmdSend name a v fee = do- (tx,complete) <- dbSendTx name [(a,fromIntegral v)] (fromIntegral fee)- return $ object [ "Tx" .= (toJSON $ bsToHex $ encode' tx)- , "Complete" .= complete- ]---- | Create a transaction sending some coins to a list of recipient addresses.-cmdSendMany :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- )- => AccountName -- ^ Account name.- -> [(String,Int)] - -- ^ List of recipient addresses and amounts. - -> Int -- ^ Fee per 1000 bytes. - -> EitherT String m Value -- ^ Payment transaction.-cmdSendMany name dests fee = do- (tx,complete) <- dbSendTx name dests' (fromIntegral fee)- return $ object [ "Tx" .= (toJSON $ bsToHex $ encode' tx)- , "Complete" .= complete- ]- where dests' = map (\(a,b) -> (a,fromIntegral b)) dests---- | Try to sign the inputs of an existing transaction using the private keys--- of an account. This command will return an indication if the transaction is--- fully signed or if additional signatures are required. This command will--- work for both normal inputs and multisignature inputs. Signing is limited to--- the keys of one account only to allow for more control when the wallet is--- used as the backend of a web service.-cmdSignTx :: PersistUnique m- => AccountName -- ^ Account name.- -> Tx -- ^ Transaction to sign. - -> SigHash -- ^ Signature type to create. - -> EitherT String m Value -- ^ Signed transaction.-cmdSignTx name tx sh = do- (newTx,complete) <- dbSignTx name tx sh- return $ object - [ (T.pack "Tx") .= (toJSON $ bsToHex $ encode' newTx)- , (T.pack "Complete") .= complete- ]--{- Utility Commands -}---- | Decodes a transaction, providing structural information on the inputs--- and the outputs of the transaction.-cmdDecodeTx :: Monad m - => String -- ^ HEX encoded transaction- -> EitherT String m Value -- ^ Decoded transaction-cmdDecodeTx str = do- tx <- liftMaybe txErr $ decodeToMaybe =<< (hexToBS str)- return $ toJSON (tx :: Tx)- where txErr = "cmdDecodeTx: Could not decode transaction"---- | Build a raw transaction from a list of outpoints and recipients encoded--- in JSON.------ Outpoint format as JSON:------ > [ --- > { "txid": txid--- > , "vout": n--- > },...--- > ] ------ Recipient list as JSON:------ > { addr: amnt,... }----cmdBuildRawTx :: Monad m - => String -- ^ List of JSON encoded Outpoints.- -> String -- ^ List of JSON encoded Recipients.- -> EitherT String m Value -- ^ Transaction result.-cmdBuildRawTx i o = do- (RawTxOutPoints ops) <- liftMaybe opErr $ - Json.decode $ toLazyBS $ stringToBS i- (RawTxDests dests) <- liftMaybe dsErr $ - Json.decode $ toLazyBS $ stringToBS o- tx <- liftEither $ buildAddrTx ops dests- return $ object [ (T.pack "Tx") .= (bsToHex $ encode' tx) ]- where- opErr = "cmdBuildRawTx: Could not parse OutPoints"- dsErr = "cmdBuildRawTx: Could not parse recipients"----- | Sign a raw transaction by providing the signing parameters and private--- keys manually. None of the keys in the wallet will be used for signing.------ Signing data as JSON (scriptRedeem is optional):------ > [ --- > { "txid": txid--- > , "vout": n--- > , "scriptPubKey": hex--- > , "scriptRedeem": hex--- > },...--- > ]------ Private keys in JSON foramt:------ > [ WIF,... ]-cmdSignRawTx :: Monad m - => Tx -- ^ Transaction to sign.- -> String - -- ^ List of JSON encoded signing parameters.- -> String - -- ^ List of JSON encoded WIF private keys.- -> SigHash -- ^ Signature type. - -> EitherT String m Value-cmdSignRawTx tx strSigi strKeys sh = do- (RawSigInput fs) <- liftMaybe sigiErr $ - Json.decode $ toLazyBS $ stringToBS strSigi- (RawPrvKey keys) <- liftMaybe keysErr $- Json.decode $ toLazyBS $ stringToBS strKeys- let sigTx = detSignTx tx (map (\f -> f sh) fs) keys- bsTx <- liftEither $ buildToEither sigTx- return $ object [ (T.pack "Tx") .= (toJSON $ bsToHex $ encode' bsTx)- , (T.pack "Complete") .= isComplete sigTx- ]- where- sigiErr = "cmdSignRawTx: Could not parse parent transaction data"- keysErr = "cmdSignRawTx: Could not parse private keys (WIF)"--
− Network/Haskoin/Wallet/Store/CoinStatus.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Wallet.Store.CoinStatus-( CoinStatus(..)-, catStatus-) where--import Control.Monad (mzero)-import Control.Applicative ((<$>))--import Database.Persist.TH (derivePersistField)--import Data.Yaml-import qualified Data.Text as T (pack)---- |Spent if a complete transaction spends this coin--- Reserved if a partial transaction is spending these coins--- Unspent if the coins are still available--- The purpose of the Reserved status is to block this coin from being used in--- subsequent coin selection algorithms. However, Reserved coins can always be--- spent (set status to Spent) by complete transactions.-data CoinStatus = Spent String | Reserved String | Unspent- deriving (Show, Read, Eq)-derivePersistField "CoinStatus"--instance ToJSON CoinStatus where- toJSON (Spent tid) = - object [ "Status".= T.pack "Spent"- , "Txid" .= T.pack tid - ]- toJSON (Reserved tid) = - object [ "Status".= T.pack "Reserved"- , "Txid" .= T.pack tid - ]- toJSON Unspent = object [ "Status".= T.pack "Unspent" ]--instance FromJSON CoinStatus where- parseJSON (Object obj) = obj .: "Status" >>= \status -> case status of- (String "Spent") -> Spent <$> obj .: "Txid"- (String "Reserved") -> Reserved <$> obj .: "Txid"- (String "Unspent") -> return Unspent- _ -> mzero- parseJSON _ = mzero--catStatus :: [CoinStatus] -> [String]-catStatus = foldr f []- where- f (Spent str) acc = str:acc- f (Reserved str) acc = str:acc- f _ acc = acc-
− Network/Haskoin/Wallet/Store/DbAccount.hs
@@ -1,153 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.DbAccount -( dbGetAcc-, dbNewAcc-, dbNewMS-, dbAddKeys-, yamlAcc-, isMSAcc-) where--import Control.Monad (when, unless)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Either (EitherT, left)--import Data.Time (getCurrentTime)-import Data.Yaml (Value, object, (.=))-import Data.Maybe (fromJust, isJust)-import Data.List (nub)-import qualified Data.Text as T (pack)--import Database.Persist - ( PersistQuery- , PersistUnique- , PersistStore- , PersistMonadBackend- , Entity(..)- , getBy- , insert_- , update- , count- , replace- , (==.), (=.)- )--import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Manager-import Network.Haskoin.Wallet.Store.Util--yamlAcc :: DbAccountGeneric b -> Value-yamlAcc acc = object $ concat- [ [ "Name" .= dbAccountName acc- , "Tree" .= dbAccountTree acc- ]- , datType, datWarn- ]- where msReq = fromJust $ dbAccountMsRequired acc- msTot = fromJust $ dbAccountMsTotal acc- ms = unwords [show msReq,"of",show msTot]- miss = msTot - length (dbAccountMsKeys acc) - 1- datType | isMSAcc acc = ["Type" .= unwords [ "Multisig", ms ]]- | otherwise = ["Type" .= ("Regular" :: String)]- datWarn | isMSAcc acc && miss > 0 =- [ (T.pack "Warning") .= - unwords [show miss,"multisig keys missing"]- ]- | otherwise = []--isMSAcc :: DbAccountGeneric b -> Bool-isMSAcc acc = (isJust $ dbAccountMsRequired acc) && - (isJust $ dbAccountMsTotal acc) --dbGetAcc :: (PersistUnique m, PersistMonadBackend m ~ b)- => String - -> EitherT String m (Entity (DbAccountGeneric b))-dbGetAcc name = liftMaybe accErr =<< (getBy $ UniqueAccName name)- where - accErr = unwords ["dbGetAcc: Invalid account", name]--dbNewAcc :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- ) - => String -> EitherT String m (DbAccountGeneric b)-dbNewAcc name = do- time <- liftIO getCurrentTime- (Entity wk w) <- dbGetWallet "main"- let keyM = loadMasterKey =<< (xPrvImport $ dbWalletMaster w)- master <- liftMaybe keyErr keyM- let deriv = fromIntegral $ dbWalletAccIndex w + 1- (k,i) = head $ accPubKeys master deriv- acc = DbAccount name - (fromIntegral i) - (concat ["m/",show i,"'/"])- (xPubExport $ getAccPubKey k)- (-1) (-1) (-1) (-1)- Nothing Nothing [] wk time- insert_ acc- update wk [DbWalletAccIndex =. fromIntegral i]- return acc- where - keyErr = "dbNewAcc: Could not load master key"--dbNewMS :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- )- => String -> Int -> Int -> [XPubKey]- -> EitherT String m (DbAccountGeneric b)-dbNewMS name m n mskeys = do- time <- liftIO getCurrentTime- let keys = nub mskeys- unless (n >= 1 && n <= 16 && m >= 1 && m <= n) $ left- "cmdNewMS: Invalid multisig parameters"- unless (length keys < n) $ left - "cmdNewMS: Too many keys"- (Entity wk w) <- dbGetWallet "main"- let keyM = loadMasterKey =<< (xPrvImport $ dbWalletMaster w)- master <- liftMaybe keyErr keyM- let deriv = fromIntegral $ dbWalletAccIndex w + 1- (k,i) = head $ accPubKeys master deriv- acc = DbAccount name - (fromIntegral i) - (concat ["m/",show i,"'/"])- (xPubExport $ getAccPubKey k)- (-1) (-1) (-1) (-1) - (Just m) (Just n) - (map xPubExport keys)- wk time- insert_ acc- update wk [DbWalletAccIndex =. fromIntegral i]- return acc- where - keyErr = "dbNewMS: Could not load master key"--dbAddKeys :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- )- => AccountName -> [XPubKey] - -> EitherT String m (DbAccountGeneric b)-dbAddKeys name keys - | null keys = left "dbAddKeys: Keys can not be empty"- | otherwise = do- (Entity ai acc) <- dbGetAcc name- unless (isMSAcc acc) $ left $ - "dbAddKeys: Can only add keys to a multisig account"- exists <- mapM (\x -> count [DbAccountKey ==. (xPubExport x)]) keys- unless (sum exists == 0) $ left $- "dbAddKeys: Can not add your own keys to a multisig account"- prevKeys <- liftMaybe keyErr $ mapM xPubImport $ dbAccountMsKeys acc- when (length prevKeys == (fromJust $ dbAccountMsTotal acc) - 1) $ left $- "dbAddKeys: Account is complete. No more keys can be added"- let newKeys = nub $ prevKeys ++ keys- newAcc = acc{ dbAccountMsKeys = map xPubExport newKeys }- unless (length newKeys < (fromJust $ dbAccountMsTotal acc)) $ left $- "dbAddKeys: Too many keys"- replace ai newAcc- return newAcc- where - keyErr = "dbAddKeys: Invalid keys found in account"-
− Network/Haskoin/Wallet/Store/DbAddress.hs
@@ -1,199 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.DbAddress -( dbGenIntAddrs-, dbGenAddrs-, dbAdjustGap-, dbSetGap-, dbGetAddr-, yamlAddr-, yamlAddrList-) where--import Control.Applicative ((<$>),(<*>))-import Control.Monad (when, forM)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Either (EitherT, left)--import Data.Time (getCurrentTime)-import Data.Yaml (Value, object, (.=), toJSON)--import Database.Persist- ( PersistQuery- , PersistUnique- , PersistStore- , PersistMonadBackend- , Entity(..)- , get- , getBy- , selectList- , insertMany- , count- , replace- , (==.), (>.), (<=.)- , SelectOpt( Asc, Desc, LimitTo )- )--import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Manager-import Network.Haskoin.Wallet.Store.DbAccount-import Network.Haskoin.Wallet.Store.Util--yamlAddr :: DbAddressGeneric b -> Value-yamlAddr a- | null $ dbAddressLabel a = object base- | otherwise = object $ label:base- where - base = [ "Addr" .= dbAddressBase58 a- , "Key" .= dbAddressIndex a- , "Tree" .= dbAddressTree a- ]- label = "Label" .= dbAddressLabel a--yamlAddrList :: [DbAddressGeneric b] -> Int -> Int -> Int -> Value-yamlAddrList addrs pageNum resPerPage addrCount = object- [ "Addresses" .= (toJSON $ map yamlAddr addrs)- , "Page results" .= object- [ "Current page" .= pageNum- , "Results per page" .= resPerPage- , "Total pages" .= totPages- , "Total addresses" .= addrCount- ]- ]- where totPages = max 1 $ (addrCount + resPerPage - 1) `div` resPerPage--dbGetAddr :: (PersistUnique m, PersistMonadBackend m ~ b)- => String - -> EitherT String m (Entity (DbAddressGeneric b))-dbGetAddr addrStr = - liftMaybe addrErr =<< (getBy $ UniqueAddress addrStr)- where - addrErr = unwords ["dbGetAddr: Invalid address", addrStr]--dbGenIntAddrs :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- )- => AccountName -> Int - -> EitherT String m [DbAddressGeneric b]-dbGenIntAddrs name c - | c <= 0 = left "dbGenIntAddrs: Count argument must be greater than 0"- | otherwise = dbGenAddrs name (replicate c "") True--dbAdjustGap :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- )- => DbAddressGeneric b -> EitherT String m ()-dbAdjustGap a = do- acc <- liftMaybe accErr =<< (get $ dbAddressAccount a)- let fIndex | dbAddressInternal a = dbAccountIntIndex - | otherwise = dbAccountExtIndex- diff <- count [ DbAddressIndex >. fIndex acc- , DbAddressIndex <=. dbAddressIndex a- , DbAddressAccount ==. dbAddressAccount a- , DbAddressInternal ==. dbAddressInternal a- ]- when (diff > 0) $ do- _ <- dbGenAddrs (dbAccountName acc) - (replicate diff "") - (dbAddressInternal a)- return ()- where- accErr = "dbAdjustGap: Could not load address account"--dbSetGap :: ( PersistUnique m- , PersistQuery m- )- => AccountName -> Int -> Bool -> EitherT String m ()-dbSetGap name gap internal = do- (Entity ai acc) <- dbGetAcc name - diff <- count [ DbAddressIndex >. fIndex acc- , DbAddressIndex <=. fGap acc- , DbAddressAccount ==. ai- , DbAddressInternal ==. internal- ]- when (diff < gap) $ do- _ <- dbGenAddrs name (replicate (gap - diff) "") internal- return ()- res <- (map entityVal) <$> selectList - [ DbAddressAccount ==. ai- , DbAddressInternal ==. internal- ]- [ Desc DbAddressIndex- , LimitTo (gap + 1)- ]- let lastIndex | length res <= gap = (-1)- | otherwise = dbAddressIndex $ last res- lastGap = dbAddressIndex $ head res- newAcc | internal = acc{ dbAccountIntIndex = lastIndex - , dbAccountIntGap = lastGap- }- | otherwise = acc{ dbAccountExtIndex = lastIndex - , dbAccountExtGap = lastGap- }- replace ai newAcc- where - fIndex | internal = dbAccountIntIndex - | otherwise = dbAccountExtIndex- fGap | internal = dbAccountIntGap - | otherwise = dbAccountExtGap--dbGenAddrs :: ( PersistUnique m- , PersistQuery m- , PersistMonadBackend m ~ b- )- => AccountName -> [String] -> Bool - -> EitherT String m [DbAddressGeneric b]-dbGenAddrs name labels internal- | null labels = left "dbGenAddr: Labels can not be empty"- | otherwise = do- time <- liftIO getCurrentTime- (Entity ai acc) <- dbGetAcc name- let tree | internal = "1/"- | otherwise = "0/"- build (s,i) = DbAddress - s "" (fromIntegral i)- (concat [dbAccountTree acc,tree,show i,"/"])- ai internal time- ls <- liftMaybe keyErr $ f acc- let gapAddr = map build $ take (length labels) ls- _ <- insertMany gapAddr- resAddr <- selectList - [ DbAddressIndex >. fIndex acc- , DbAddressAccount ==. ai- , DbAddressInternal ==. internal- ]- [ Asc DbAddressIndex- , LimitTo $ length labels- ]- let lastGap = dbAddressIndex $ last gapAddr- lastIndex = dbAddressIndex $ entityVal $ last resAddr- newAcc | internal = acc{ dbAccountIntGap = lastGap- , dbAccountIntIndex = lastIndex- }- | otherwise = acc{ dbAccountExtGap = lastGap- , dbAccountExtIndex = lastIndex- }- replace ai newAcc- forM (zip resAddr labels) $ \(Entity idx a,l) -> do- let newAddr = a{ dbAddressLabel = l }- replace idx newAddr - return newAddr- where - keyErr = "dbGenAddr: Error decoding account keys"- f acc | isMSAcc acc = (if internal then intMulSigAddrs else extMulSigAddrs)- <$> (loadPubAcc =<< (xPubImport $ dbAccountKey acc))- <*> (mapM xPubImport $ dbAccountMsKeys acc) - <*> (dbAccountMsRequired acc)- <*> (return $ fromIntegral $ fGap acc + 1)- | otherwise = (if internal then intAddrs else extAddrs)- <$> (loadPubAcc =<< (xPubImport $ dbAccountKey acc))- <*> (return $ fromIntegral $ fGap acc + 1)- fGap | internal = dbAccountIntGap- | otherwise = dbAccountExtGap- fIndex | internal = dbAccountIntIndex- | otherwise = dbAccountExtIndex--
− Network/Haskoin/Wallet/Store/DbCoin.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.DbCoin -( dbCoins-, dbBalance-, yamlCoin-, toCoin-) where--import Control.Applicative ((<$>))-import Control.Monad.Trans.Either (EitherT)--import Data.Yaml- ( Value - , object - , (.=)- )-import Data.Maybe (isJust, fromJust)--import Database.Persist- ( PersistStore- , PersistQuery- , PersistMonadBackend- , Entity(..)- , entityVal- , selectList- , (==.)- , SelectOpt(Asc)- )-import Database.Persist.Sqlite (SqlBackend)--import Network.Haskoin.Wallet.TxBuilder-import Network.Haskoin.Wallet.Store.Util-import Network.Haskoin.Protocol-import Network.Haskoin.Util--toCoin :: DbCoinGeneric b -> Either String Coin-toCoin c = do- scp <- decodeScriptOps =<< maybeToEither scpErr (hexToBS $ dbCoinScript c)- rdm <- if isJust $ dbCoinRdmScript c- then do- bs <- maybeToEither rdmErr $ hexToBS =<< dbCoinRdmScript c- Just <$> decodeScriptOps bs- else return Nothing- h <- maybeToEither tidErr $ decodeTxid $ dbCoinTxid c- return $ Coin (TxOut (fromIntegral $ dbCoinValue c) scp)- (OutPoint h (fromIntegral $ dbCoinPos c))- rdm- where- scpErr = "toCoin: Could not decode coin script"- tidErr = "toCoin: Could not decode coin txid"- rdmErr = "toCoin: Could not decode coin redeem script"--yamlCoin :: DbCoinGeneric b -> Value-yamlCoin coin = object $ concat- [ [ "TxID" .= dbCoinTxid coin - , "Index" .= dbCoinPos coin- , "Value" .= dbCoinValue coin- , "Script" .= dbCoinScript coin- , "Address" .= dbCoinAddress coin- ] - , if isJust $ dbCoinRdmScript coin - then ["Redeem" .= fromJust (dbCoinRdmScript coin)] - else []- , if dbCoinOrphan coin then ["Orphan" .= True] else []- ]--dbBalance :: (PersistQuery m, PersistMonadBackend m ~ b)- => Entity (DbAccountGeneric b)- -> EitherT String m Int-dbBalance (Entity ai _) = do- coins <- selectList - [ DbCoinAccount ==. ai- , DbCoinStatus ==. Unspent- , DbCoinOrphan ==. False- ] []- return $ sum $ map (dbCoinValue . entityVal) coins--dbCoins :: (PersistQuery m, PersistMonadBackend m ~ SqlBackend) - => DbAccountId - -> EitherT String m [DbCoinGeneric SqlBackend]-dbCoins ai = do- coins <- selectList - [ DbCoinAccount ==. ai- , DbCoinStatus ==. Unspent- , DbCoinOrphan ==. False- ] [Asc DbCoinCreated]- return $ map entityVal coins--
− Network/Haskoin/Wallet/Store/DbTx.hs
@@ -1,441 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.DbTx-( dbImportTx-, dbRemoveTx-, dbSendTx-, dbSendSolution-, dbSendCoins-, dbSignTx-, yamlTx-, RawTxOutPoints(..)-, RawTxDests(..)-, RawSigInput(..)-, RawPrvKey(..)-) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad (forM, unless, when, mzero)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Either (EitherT, left)--import Data.Time (UTCTime, getCurrentTime)-import Data.Word (Word32, Word64)-import Data.List ((\\), nub)-import Data.Maybe (catMaybes, isNothing, isJust, fromJust)-import Data.Either (rights)-import Data.Yaml - ( Value- , object - , (.=), (.:), (.:?)- , parseJSON- , Parser- )-import qualified Data.Aeson as Json - ( FromJSON- , withObject- , withArray- )-import qualified Data.Vector as V (toList)-import qualified Data.HashMap.Strict as H (toList)-import qualified Data.Map.Strict as M - ( toList- , empty- , lookup- , insert- )-import qualified Data.Text as T (pack, unpack)--import Database.Persist - ( PersistStore- , PersistUnique- , PersistQuery- , PersistMonadBackend- , Entity(..)- , entityVal- , entityKey- , get- , getBy- , selectList- , deleteWhere- , updateWhere- , update- , insert_- , insertUnique- , replace- , (=.), (==.), (<-.)- )-import Database.Persist.Sql (SqlBackend)--import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Manager-import Network.Haskoin.Wallet.TxBuilder-import Network.Haskoin.Wallet.Store.DbAccount-import Network.Haskoin.Wallet.Store.DbAddress-import Network.Haskoin.Wallet.Store.DbCoin-import Network.Haskoin.Wallet.Store.Util-import Network.Haskoin.Script-import Network.Haskoin.Protocol-import Network.Haskoin.Crypto-import Network.Haskoin.Util-import Network.Haskoin.Util.BuildMonad--yamlTx :: DbTxGeneric b -> Value-yamlTx tx = object $ concat- [ [ "Recipients" .= dbTxRecipients tx- , "Value" .= dbTxValue tx- ]- , if dbTxOrphan tx then ["Orphan" .= True] else []- , if dbTxPartial tx then ["Partial" .= True] else []- ]---- |Remove a transaction from the database and any parent transaction-dbRemoveTx :: PersistQuery m => String -> EitherT String m [String]-dbRemoveTx tid = do- -- Find all parents of this transaction- -- Partial transactions should not have any coins. Won't check for it- coins <- selectList [ DbCoinTxid ==. tid ] []- let parents = nub $ catStatus $ map (dbCoinStatus . entityVal) coins- -- Recursively remove parents- pids <- forM parents dbRemoveTx- -- Delete output coins generated from this transaction- deleteWhere [ DbCoinTxid ==. tid ]- -- Delete account transactions- deleteWhere [ DbTxTxid ==. tid ]- -- Delete transaction blob- deleteWhere [ DbTxBlobTxid ==. tid ]- -- Delete orphaned input coins spent by this transaction- deleteWhere [ DbCoinOrphan ==. True- , DbCoinStatus <-. [Spent tid, Reserved tid]- ]- -- Unspend input coins that were previously spent by this transaction- updateWhere [ DbCoinStatus <-. [Spent tid, Reserved tid] ]- [ DbCoinStatus =. Unspent ]- return $ tid:(concat pids)- --- |Import a transaction into the database-dbImportTx :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- ) - => Tx -> EitherT String m [DbTxGeneric SqlBackend]-dbImportTx tx = do- coinsM <- mapM (getBy . f) $ map prevOutput $ txIn tx- let inCoins = catMaybes coinsM- -- Unspent coins in the wallet related to this transaction- unspent = filter ((== Unspent) . dbCoinStatus . entityVal) inCoins- -- OutPoints from this transaction with no associated coins- unknown = map snd $ filter (isNothing . fst) $ zip coinsM $ txIn tx- -- Fail if an input is spent by a transaction which is not this one- unless (isImportValid tid $ map entityVal inCoins) $ left- "dbImportTx: Double spend detected. Import failed"- let toRemove = txToRemove $ map entityVal inCoins- if length toRemove > 0- then do- -- Partial transactions need to be removed - -- before trying to re-import- _ <- mapM dbRemoveTx toRemove- dbImportTx tx- else do- time <- liftIO getCurrentTime- -- Change status of all the unspent coins- _ <- forM unspent $ \(Entity ci _) -> - update ci [DbCoinStatus =. status]- -- Insert orphaned coins- orphans <- catMaybes <$> mapM (dbImportOrphan status) unknown- -- Import new coins and update existing coins- outCoins <- catMaybes <$> - (mapM (dbImportCoin tid complete) $ zip (txOut tx) [0..])- let accTxs = buildAccTx tx ((map entityVal inCoins) ++ orphans)- outCoins (not complete) time- -- Insert transaction blob. Ignore if already exists- _ <- insertUnique $ DbTxBlob tid (encode' tx) time- -- insert account transactions into database, - -- rewriting if they exist- _ <- forM accTxs $ \accTx -> do- prev <- getBy $ UniqueTx (dbTxTxid accTx) (dbTxAccount accTx)- if isNothing prev - then insert_ accTx - else replace (entityKey $ fromJust prev) accTx- -- Re-import parent transactions (transactions spending this one)- if complete- then do- let ids = nub $ catStatus $ map dbCoinStatus outCoins- blobs <- mapM dbGetTxBlob ids- reImported <- forM blobs $ (dbImportTx =<<) . dec- return $ accTxs ++ (concat reImported)- else return accTxs- where- tid = encodeTxid $ txid tx- f (OutPoint h i) = CoinOutPoint (encodeTxid h) (fromIntegral i)- complete = isTxComplete tx- status = if complete then Spent tid else Reserved tid- dec = liftEither . decodeToEither . dbTxBlobValue . entityVal---- |A transaction can not be imported if it double spends coins in the wallet.--- Upstream code needs to remove the conflicting transaction first using--- dbTxRemove function-isImportValid :: String -> [DbCoinGeneric b] -> Bool-isImportValid tid coins = all (f . dbCoinStatus) coins- where- f (Spent parent) = parent == tid- f _ = True---- When a transaction spends coins previously spent by a partial transaction,--- we need to remove the partial transactions from the database and try to--- re-import the transaction. Coins with Reserved status are spent by a partial--- transaction.-txToRemove :: [DbCoinGeneric b] -> [String]-txToRemove coins = catMaybes $ map (f . dbCoinStatus) coins- where- f (Reserved parent) = Just parent- f _ = Nothing---- |Group input and output coins by accounts and create --- account-level transaction-buildAccTx :: Tx -> [DbCoinGeneric b] -> [DbCoinGeneric b]- -> Bool -> UTCTime -> [DbTxGeneric b]-buildAccTx tx inCoins outCoins partial time = map build $ M.toList oMap- where- iMap = foldr (f (\(i,o) x -> (x:i,o))) M.empty inCoins- oMap = foldr (f (\(i,o) x -> (i,x:o))) iMap outCoins- f g coin accMap = case M.lookup (dbCoinAccount coin) accMap of- Just tuple -> M.insert (dbCoinAccount coin) (g tuple coin) accMap- Nothing -> M.insert (dbCoinAccount coin) (g ([],[]) coin) accMap- allRecip = rights $ map toAddr $ txOut tx- toAddr = (addrToBase58 <$>) . scriptRecipient . scriptOutput- sumVal = sum . (map dbCoinValue)- build (ai,(i,o)) = - DbTx (encodeTxid $ txid tx) recips total ai orphan partial time- where- orphan = or $ map dbCoinOrphan i- total | orphan = 0- | otherwise = sumVal o - sumVal i- addrs = map dbCoinAddress o- recips | null addrs = allRecip- | orphan = allRecip \\ addrs -- assume this is an outgoing tx- | total < 0 = allRecip \\ addrs -- remove the change- | otherwise = addrs---- |Create an orphaned coin if the input spends from an address in the wallet--- but the coin doesn't exist in the wallet. This allows out-of-order tx import-dbImportOrphan :: (PersistUnique m, PersistMonadBackend m ~ SqlBackend) - => CoinStatus -> TxIn - -> EitherT String m (Maybe (DbCoinGeneric SqlBackend))-dbImportOrphan status (TxIn (OutPoint h i) s _)- | isLeft a = return Nothing- | otherwise = getBy (UniqueAddress b58) >>= \addrM -> case addrM of- Nothing -> return Nothing- Just (Entity _ add) -> do- time <- liftIO $ getCurrentTime- rdm <- dbGetRedeem add- let coin = build rdm add time- insert_ coin >> return (Just coin)- where- a = scriptSender s- b58 = addrToBase58 $ fromRight a- build rdm add time = - DbCoin (encodeTxid h) (fromIntegral i) 0 "" rdm b58 status- (dbAddressAccount add) True time---- |Create a new coin for an output if it sends coins to an --- address in the wallet. Does not actually write anything to the database--- if commit is False. This is for correctly reporting on partial transactions--- without creating coins in the database from a partial transaction-dbImportCoin :: ( PersistQuery m, PersistUnique m- , PersistMonadBackend m ~ SqlBackend- )- => String -> Bool -> (TxOut,Int) - -> EitherT String m (Maybe (DbCoinGeneric SqlBackend))-dbImportCoin tid commit ((TxOut v s), index) - | isLeft a = return Nothing- | otherwise = getBy (UniqueAddress b58) >>= \addrM -> case addrM of- Nothing -> return Nothing- Just (Entity _ add) -> do- time <- liftIO getCurrentTime- coinM <- getBy $ CoinOutPoint tid index- case coinM of- Just (Entity ci coin) -> do- -- Update existing coin with up to date information- let newCoin = coin{ dbCoinOrphan = False- , dbCoinValue = (fromIntegral v)- , dbCoinScript = scp- , dbCoinCreated = time- }- when commit $ replace ci newCoin- return $ Just newCoin- Nothing -> do- rdm <- dbGetRedeem add- let coin = build rdm add time- when commit $ insert_ coin- dbAdjustGap add -- Adjust address gap- return $ Just coin- where- a = scriptRecipient s- b58 = addrToBase58 $ fromRight a- scp = bsToHex $ encodeScriptOps s- build rdm add time = - DbCoin tid index (fromIntegral v) scp rdm b58 Unspent- (dbAddressAccount add) False time- --- |Builds a redeem script given an address. Only relevant for addresses--- linked to multisig accounts. Otherwise it returns Nothing-dbGetRedeem :: (PersistStore m, PersistMonadBackend m ~ SqlBackend) - => DbAddressGeneric SqlBackend -> EitherT String m (Maybe String)-dbGetRedeem add = do- acc <- liftMaybe accErr =<< (get $ dbAddressAccount add)- rdm <- if isMSAcc acc - then Just <$> liftMaybe rdmErr (getRdm acc)- else return Nothing- return $ bsToHex . encodeScriptOps . encodeOutput <$> rdm- where- getRdm acc = do- key <- loadPubAcc =<< (xPubImport $ dbAccountKey acc)- msKeys <- mapM xPubImport $ dbAccountMsKeys acc- addrKeys <- f key msKeys $ fromIntegral $ dbAddressIndex add- let pks = map (xPubKey . getAddrPubKey) addrKeys- sortMulSig . (PayMulSig pks) <$> dbAccountMsRequired acc- where- f = if dbAddressInternal add then intMulSigKey else extMulSigKey- accErr = "dbImportOut: Invalid address account"- rdmErr = "dbGetRedeem: Could not generate redeem script"---- |Build and sign a transactoin given a list of recipients-dbSendTx :: ( PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- )- => AccountName -> [(String,Word64)] -> Word64- -> EitherT String m (Tx, Bool)-dbSendTx name dests fee = do- (coins,recips) <- dbSendSolution name dests fee- dbSendCoins coins recips (SigAll False)---- |Given a list of recipients and a fee, finds a valid combination of coins-dbSendSolution :: ( PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- )- => AccountName -> [(String,Word64)] -> Word64- -> EitherT String m ([Coin],[(String,Word64)])-dbSendSolution name dests fee = do- (Entity ai acc) <- dbGetAcc name- unspent <- liftEither . (mapM toCoin) =<< dbCoins ai- (coins,change) <- liftEither $ if isMSAcc acc- then let msParam = ( fromJust $ dbAccountMsRequired acc- , fromJust $ dbAccountMsTotal acc- )- in chooseMSCoins tot fee msParam unspent- else chooseCoins tot fee unspent- recips <- if change < 5000 then return dests else do- cAddr <- dbGenIntAddrs name 1- return $ dests ++ [(dbAddressBase58 $ head cAddr,change)]- return (coins,recips)- where- tot = sum $ map snd dests- --- | Build and sign a transaction by providing coins and recipients-dbSendCoins :: PersistUnique m- => [Coin] -> [(String,Word64)] -> SigHash- -> EitherT String m (Tx, Bool)-dbSendCoins coins recipients sh = do- tx <- liftEither $ buildAddrTx (map coinOutPoint coins) recipients- ys <- mapM (dbGetSigData sh) coins- let sigTx = detSignTx tx (map fst ys) (map snd ys)- bsTx <- liftEither $ buildToEither sigTx- return (bsTx, isComplete sigTx)--dbSignTx :: PersistUnique m- => AccountName -> Tx -> SigHash -> EitherT String m (Tx, Bool)-dbSignTx name tx sh = do- (Entity ai _) <- dbGetAcc name- coins <- catMaybes <$> (mapM (getBy . f) $ map prevOutput $ txIn tx)- -- Filter coins for this account only- let accCoins = filter ((== ai) . dbCoinAccount . entityVal) coins- ys <- forM accCoins g- let sigTx = detSignTx tx (map fst ys) (map snd ys)- bsTx <- liftEither $ buildToEither sigTx- return (bsTx, isComplete sigTx)- where- f (OutPoint h i) = CoinOutPoint (encodeTxid h) (fromIntegral i)- g = ((dbGetSigData sh) =<<) . liftEither . toCoin . entityVal---- |Given a coin, retrieves the necessary data to sign a transaction-dbGetSigData :: PersistUnique m- => SigHash -> Coin -> EitherT String m (SigInput,PrvKey)-dbGetSigData sh coin = do- (Entity _ w) <- dbGetWallet "main"- a <- liftEither $ scriptRecipient out- (Entity _ add) <- dbGetAddr $ addrToBase58 a- acc <- liftMaybe accErr =<< get (dbAddressAccount add)- mst <- liftMaybe mstErr $ loadMasterKey =<< xPrvImport (dbWalletMaster w)- aKey <- liftMaybe prvErr $ accPrvKey mst $ fromIntegral $ dbAccountIndex acc- let g = if dbAddressInternal add then intPrvKey else extPrvKey- sigKey <- liftMaybe addErr $ g aKey $ fromIntegral $ dbAddressIndex add- return (sigi, xPrvKey $ getAddrPrvKey sigKey)- where- out = scriptOutput $ coinTxOut coin- rdm = coinRedeem coin- sigi | isJust rdm = SigInputSH out (coinOutPoint coin) (fromJust rdm) sh- | otherwise = SigInput out (coinOutPoint coin) sh- mstErr = "dbGetSigData: Could not load master key"- accErr = "dbGetSigData: Could not load address account"- prvErr = "dbGetSigData: Invalid account derivation index"- addErr = "dbGetSigData: Invalid address derivation index"--data RawTxOutPoints = RawTxOutPoints [OutPoint] - deriving (Eq, Show)--data RawTxDests = RawTxDests [(String,Word64)]- deriving (Eq, Show)--instance Json.FromJSON RawTxOutPoints where- parseJSON = Json.withArray "Expected: Array" $ \arr -> do- RawTxOutPoints <$> (mapM f $ V.toList arr)- where- f = Json.withObject "Expected: Object" $ \obj -> do- tid <- obj .: T.pack "txid" :: Parser String- vout <- obj .: T.pack "vout" :: Parser Word32- let i = maybeToEither ("Failed to decode txid" :: String)- (decodeTxid tid)- o = OutPoint <$> i <*> (return vout)- either (const mzero) return o--instance Json.FromJSON RawTxDests where- parseJSON = Json.withObject "Expected: Object" $ \obj ->- RawTxDests <$> (mapM f $ H.toList obj)- where- f (add,v) = do- amnt <- parseJSON v :: Parser Word64- return (T.unpack add, amnt)--data RawSigInput = RawSigInput [(SigHash -> SigInput)]--data RawPrvKey = RawPrvKey [PrvKey]- deriving (Eq, Show)--instance Json.FromJSON RawSigInput where- parseJSON = Json.withArray "Expected: Array" $ \arr -> do- RawSigInput <$> (mapM f $ V.toList arr)- where- f = Json.withObject "Expected: Object" $ \obj -> do- tid <- obj .: T.pack "txid" :: Parser String- vout <- obj .: T.pack "vout" :: Parser Word32- scp <- obj .: T.pack "scriptPubKey" :: Parser String- rdm <- obj .:? T.pack "scriptRedeem" :: Parser (Maybe String)- let s = decodeScriptOps =<< maybeToEither "Hex parsing failed" - (hexToBS scp)- i = maybeToEither "Failed to decode txid" (decodeTxid tid)- o = OutPoint <$> i <*> (return vout)- r = decodeScriptOps =<< maybeToEither "Hex parsing failed" - (hexToBS $ fromJust rdm)- res | isJust rdm = SigInputSH <$> s <*> o <*> r- | otherwise = SigInput <$> s <*> o- either (const mzero) return res--instance Json.FromJSON RawPrvKey where- parseJSON = Json.withArray "Expected: Array" $ \arr ->- RawPrvKey <$> (mapM f $ V.toList arr)- where- f v = do- str <- parseJSON v :: Parser String - maybe mzero return $ fromWIF str-
− Network/Haskoin/Wallet/Store/Util.hs
@@ -1,337 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.Util -( DbWalletGeneric(..)-, DbAccountGeneric(..)-, DbAddressGeneric(..)-, DbCoinGeneric(..)-, DbTxGeneric(..)-, DbTxBlobGeneric(..)-, DbWalletId-, DbAccountId-, DbAddressId-, DbCoinId-, DbTxId-, DbTxBlobId-, Unique(..)-, EntityField(..)-, AccountName-, CoinStatus(..)-, catStatus-, dbGetWallet-, dbGetTxBlob-, liftEither-, liftMaybe-, migrateAll-) where--import Control.Monad.Trans (lift)-import Control.Monad.Trans.Either (EitherT, hoistEither)--import Data.Time (UTCTime)-import Data.Yaml- ( ToJSON, toJSON- , object, (.=)- )-import qualified Data.Text as T (pack)-import qualified Data.ByteString as BS (ByteString)-import qualified Data.Conduit as C (transPipe)--import Database.Persist - ( PersistStore- , PersistUnique- , PersistQuery- , PersistMonadBackend- , Entity- , EntityField- , Unique- , get- , getBy- , insert_- , insert- , count- , selectKeys- , selectFirst- , selectSource- , updateWhere- , deleteBy- , insertUnique- , updateGet- , replace- , repsert- , insertKey- , insertMany- , delete- , deleteWhere- , update- )-import Database.Persist.TH - ( mkPersist- , sqlSettings- , mkMigrate- , persistLowerCase- , share- )--import Network.Haskoin.Wallet.Store.CoinStatus-import Network.Haskoin.Script-import Network.Haskoin.Protocol-import Network.Haskoin.Crypto-import Network.Haskoin.Util--type AccountName = String--liftEither :: Monad m => Either String a -> EitherT String m a-liftEither = hoistEither--liftMaybe :: Monad m => String -> Maybe a -> EitherT String m a-liftMaybe err = liftEither . (maybeToEither err)--share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|-DbWallet json- name String- type String- master String - accIndex Int- created UTCTime default=CURRENT_TIME- UniqueWalletName name- deriving Show--DbAccount json- name String- index Int- tree String- key String- extIndex Int- extGap Int- intIndex Int- intGap Int- msRequired Int Maybe- msTotal Int Maybe- msKeys [String] - wallet DbWalletId- created UTCTime default=CURRENT_TIME- UniqueAccName name- deriving Show--DbAddress json- base58 String- label String- index Int- tree String- account DbAccountId- internal Bool- created UTCTime default=CURRENT_TIME- UniqueAddress base58- UniqueAddressKey account index internal- deriving Show--DbCoin json- txid String- pos Int- value Int- script String- rdmScript String Maybe- address String - status CoinStatus- account DbAccountId- orphan Bool- created UTCTime default=CURRENT_TIME- CoinOutPoint txid pos- deriving Show--DbTx json- txid String- recipients [String]- value Int- account DbAccountId- orphan Bool- partial Bool- created UTCTime default=CURRENT_TIME- UniqueTx txid account- deriving Show--DbTxBlob json- txid String- value BS.ByteString - created UTCTime default=CURRENT_TIME- UniqueTxBlob txid- deriving Show--|]--dbGetWallet :: (PersistUnique m, PersistMonadBackend m ~ b)- => String -> EitherT String m (Entity (DbWalletGeneric b))-dbGetWallet name = liftMaybe walletErr =<< (getBy $ UniqueWalletName name)- where - walletErr = unwords ["dbGetWallet: Invalid wallet", name]--dbGetTxBlob :: (PersistUnique m, PersistMonadBackend m ~ b)- => String -> EitherT String m (Entity (DbTxBlobGeneric b))-dbGetTxBlob tid = liftMaybe txErr =<< (getBy $ UniqueTxBlob tid)- where- txErr = unwords ["dbGetTxBlob: Invalid txid", tid]--instance PersistStore m => PersistStore (EitherT e m) where- type PersistMonadBackend (EitherT e m) = PersistMonadBackend m- get = lift . get- insert = lift . insert- insert_ = lift . insert_- insertMany = lift . insertMany- insertKey k = lift . (insertKey k)- repsert k = lift . (repsert k)- replace k = lift . (replace k)- delete = lift . delete--instance PersistUnique m => PersistUnique (EitherT e m) where- getBy = lift . getBy- deleteBy = lift . deleteBy- insertUnique = lift . insertUnique--instance PersistQuery m => PersistQuery (EitherT e m) where- update k = lift . (update k)- updateGet k = lift . (updateGet k)- updateWhere f = lift . (updateWhere f)- deleteWhere = lift . deleteWhere- selectSource f = (C.transPipe lift) . (selectSource f)- selectFirst f = lift . (selectFirst f)- selectKeys f = (C.transPipe lift) . (selectKeys f)- count = lift . count--{- YAML templates -}--instance ToJSON OutPoint where- toJSON (OutPoint h i) = object- [ (T.pack "TxID") .= encodeTxid h- , (T.pack "Index") .= toJSON i- ]--instance ToJSON TxOut where- toJSON (TxOut v s) = object $- [ (T.pack "Value") .= toJSON v- , (T.pack "Raw Script") .= (bsToHex $ encodeScriptOps s)- , (T.pack "Script") .= toJSON s- ] ++ scptPair - where scptPair = - either (const [])- (\out -> [(T.pack "Decoded Script") .= toJSON out]) - (decodeOutput s)--instance ToJSON TxIn where- toJSON (TxIn o s i) = object $ concat- [ [ (T.pack "OutPoint") .= toJSON o- , (T.pack "Sequence") .= toJSON i- , (T.pack "Raw Script") .= (bsToHex $ encodeScriptOps s)- , (T.pack "Script") .= toJSON s- ] - , decoded - ]- where decoded = either (const $ either (const []) f $ decodeInput s) - f $ decodeScriptHash s- f inp = [(T.pack "Decoded Script") .= toJSON inp]- -instance ToJSON Tx where- toJSON tx@(Tx v is os i) = object- [ (T.pack "TxID") .= encodeTxid (txid tx)- , (T.pack "Version") .= toJSON v- , (T.pack "Inputs") .= (toJSON $ map input $ zip is [0..])- , (T.pack "Outputs") .= (toJSON $ map output $ zip os [0..])- , (T.pack "LockTime") .= toJSON i- ]- where input (x,j) = object - [(T.pack $ unwords ["Input", show (j :: Int)]) .= toJSON x]- output (x,j) = object - [(T.pack $ unwords ["Output", show (j :: Int)]) .= toJSON x]--instance ToJSON Script where- toJSON (Script ops) = toJSON $ map show ops--instance ToJSON ScriptOutput where- toJSON (PayPK p) = object - [ (T.pack "PayToPublicKey") .= object- [ (T.pack "Public Key") .= (bsToHex $ encode' p)- ]- ]- toJSON (PayPKHash a) = object - [ (T.pack "PayToPublicKeyHash") .= object- [ (T.pack "Address Hash160") .= (bsToHex $ encode' $ getAddress a)- , (T.pack "Address Base58") .= addrToBase58 a- ]- ]- toJSON (PayMulSig ks r) = object - [ (T.pack "PayToMultiSig") .= object- [ (T.pack "Required Keys (M)") .= toJSON r- , (T.pack "Public Keys") .= (toJSON $ map (bsToHex . encode') ks)- ]- ]- toJSON (PayScriptHash a) = object - [ (T.pack "PayToScriptHash") .= object- [ (T.pack "Address Hash160") .= (bsToHex $ encode' $ getAddress a)- , (T.pack "Address Base58") .= addrToBase58 a- ]- ]--instance ToJSON ScriptInput where- toJSON (SpendPK s) = object - [ (T.pack "SpendPublicKey") .= object- [ (T.pack "Signature") .= toJSON s- ]- ]- toJSON (SpendPKHash s p) = object - [ (T.pack "SpendPublicKeyHash") .= object- [ (T.pack "Signature") .= toJSON s- , (T.pack "Public Key") .= (bsToHex $ encode' p)- , (T.pack "Sender Addr") .= addrToBase58 (pubKeyAddr p)- ]- ]- toJSON (SpendMulSig sigs r) = object - [ (T.pack "SpendMultiSig") .= object- [ (T.pack "Required Keys (M)") .= toJSON r- , (T.pack "Signatures") .= (toJSON $ map toJSON sigs)- ]- ]--instance ToJSON ScriptHashInput where- toJSON (ScriptHashInput s r) = object- [ (T.pack "SpendScriptHash") .= object- [ (T.pack "ScriptInput") .= toJSON s- , (T.pack "RedeemScript") .= toJSON r- , (T.pack "Raw Redeem Script") .= - (bsToHex $ encodeScriptOps $ encodeOutput r)- , (T.pack "Sender Addr") .= (addrToBase58 $ scriptAddr r)- ]- ]--instance ToJSON TxSignature where- toJSON ts@(TxSignature _ h) = object- [ (T.pack "Raw Sig") .= (bsToHex $ encodeSig ts)- , (T.pack "SigHash") .= toJSON h- ]--instance ToJSON SigHash where- toJSON sh = case sh of- (SigAll acp) -> object- [ (T.pack "Type") .= T.pack "SigAll"- , (T.pack "AnyoneCanPay") .= acp- ]- (SigNone acp) -> object- [ (T.pack "Type") .= T.pack "SigNone"- , (T.pack "AnyoneCanPay") .= acp- ]- (SigSingle acp) -> object- [ (T.pack "Type") .= T.pack "SigSingle"- , (T.pack "AnyoneCanPay") .= acp- ]- (SigUnknown acp v) -> object- [ (T.pack "Type") .= T.pack "SigUnknown"- , (T.pack "AnyoneCanPay") .= acp- , (T.pack "Value") .= v- ]---
+ Network/Haskoin/Wallet/Transaction.hs view
@@ -0,0 +1,1306 @@+module Network.Haskoin.Wallet.Transaction+(+-- *Database transactions+ txPage+, addrTxPage+, getTx+, getAccountTx+, importTx+, importNetTx+, signKeyRingTx+, createTx+, signOfflineTx+, getOfflineTxData+, killTxs+, reviveTx+, getPendingTxs++-- *Database blocks+, importMerkles+, getBestBlock++-- *Database coins and balances+, spendableCoins+, spendableCoinsSource+, accountBalance+, addressBalances++-- *Rescan+, resetRescan++-- *Helpers+, splitSelect+, splitUpdate+, splitDelete+, join2+, InCoinData(..)+) where++import Control.Arrow (second)+import Control.Monad (forM, forM_, when, liftM, unless)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Exception (throwIO, throw)++import Data.Time (UTCTime, getCurrentTime)+import Data.Word (Word32, Word64)+import Data.Either (rights)+import Data.List ((\\), nub, nubBy, find)+import Data.List.Split (chunksOf)+import Data.Text (unpack)+import Data.Conduit (Source, mapOutput, ($$))+import Data.Maybe (isNothing, isJust, fromMaybe, listToMaybe)+import qualified Data.Map.Strict as M+ ( Map, toList, map, unionWith, fromListWith )+import Data.String.Conversions (cs)++import qualified Database.Persist as P+ ( Filter+ , selectFirst+ , deleteWhere, insertBy, insertMany_, PersistEntity+ , PersistEntityBackend+ )+import Database.Esqueleto+ ( Value(..), SqlQuery, SqlExpr, SqlBackend+ , InnerJoin(..), LeftOuterJoin(..), OrderBy, update, sum_, groupBy+ , select, from, where_, val, valList, sub_select, countRows, count+ , orderBy, limit, asc, desc, set, offset, selectSource+ , in_, unValue, not_, coalesceDefault, just, on+ , case_, when_, then_, else_, distinct+ , (^.), (=.), (==.), (&&.), (||.), (<.)+ , (<=.), (>=.), (-.), (?.), (!=.)+ -- Reexports from Database.Persist+ , SqlPersistT, Entity(..)+ , getBy, replace+ )+import qualified Database.Esqueleto as E (isNothing, delete)+import Database.Esqueleto.Internal.Sql (SqlSelect)++import Network.Haskoin.Block+import Network.Haskoin.Transaction+import Network.Haskoin.Script+import Network.Haskoin.Crypto+import Network.Haskoin.Util+import Network.Haskoin.Constants+import Network.Haskoin.Node.STM+import Network.Haskoin.Node.HeaderTree++import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Database++-- Input coin type with transaction and address information+data InCoinData = InCoinData+ { inCoinDataCoin :: !(Entity KeyRingCoin)+ , inCoinDataTx :: !KeyRingTx+ , inCoinDataAddr :: !KeyRingAddr+ }++instance Coin InCoinData where+ coinValue (InCoinData (Entity _ c) _ _) = keyRingCoinValue c++-- Output coin type with address information+data OutCoinData = OutCoinData+ { outCoinDataAddr :: !(Entity KeyRingAddr)+ , outCoinDataPos :: !KeyIndex+ , outCoinDataValue :: !Word64+ , outCoinDataScript :: !ScriptOutput+ }++{- List transaction -}++-- | Get transactions by page+txPage :: MonadIO m+ => KeyRingAccountId -- ^ Account ID+ -> PageRequest -- ^ Page request+ -> SqlPersistT m ([KeyRingTx], Word32)+ -- ^ Page result+txPage ai page@PageRequest{..}+ | validPageRequest page = do+ cntRes <- select $ from $ \t -> do+ where_ $ t ^. KeyRingTxAccount ==. val ai+ return countRows++ let cnt = maybe 0 unValue $ listToMaybe cntRes+ (d, m) = cnt `divMod` pageLen+ maxPage = max 1 $ d + min 1 m++ when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $+ unwords [ "Invalid page number", show pageNum ]++ res <- liftM (map entityVal) $ select $ from $ \t -> do+ where_ $ t ^. KeyRingTxAccount ==. val ai+ let order = if pageReverse then asc else desc+ orderBy [ order (t ^. KeyRingTxId) ]+ limit $ fromIntegral pageLen+ offset $ fromIntegral $ (pageNum - 1) * pageLen+ return t++ let f = if pageReverse then id else reverse+ return (f res, maxPage)+ | otherwise = liftIO . throwIO $ WalletException $+ concat [ "Invalid page request"+ , " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"+ ]++addrTxPage :: MonadIO m+ => Entity KeyRingAccount -- ^ Account entity+ -> KeyRingAddrId -- ^ Address Id+ -> PageRequest -- ^ Page request+ -> SqlPersistT m ([(KeyRingTx, BalanceInfo)], Word32)+addrTxPage (Entity ai _) addrI page@PageRequest{..}+ | validPageRequest page = do+ let joinSpentCoin c2 s =+ c2 ?. KeyRingCoinAccount ==. s ?. KeyRingSpentCoinAccount+ &&. c2 ?. KeyRingCoinHash ==. s ?. KeyRingSpentCoinHash+ &&. c2 ?. KeyRingCoinPos ==. s ?. KeyRingSpentCoinPos+ &&. c2 ?. KeyRingCoinAddr ==. just (val addrI)+ joinSpent s t =+ s ?. KeyRingSpentCoinSpendingTx ==. just (t ^. KeyRingTxId)+ joinCoin c t =+ c ?. KeyRingCoinTx ==. just (t ^. KeyRingTxId)+ &&. c ?. KeyRingCoinAddr ==. just (val addrI)+ joinAll t c c2 s = do+ on $ joinSpentCoin c2 s+ on $ joinSpent s t+ on $ joinCoin c t+ -- Find all the tids+ tids <- liftM (map unValue) $ select $ distinct $ from $+ \(t `LeftOuterJoin` c `LeftOuterJoin`+ s `LeftOuterJoin` c2) -> do+ joinAll t c c2 s+ where_ ( t ^. KeyRingTxAccount ==. val ai+ &&. ( not_ (E.isNothing (c ?. KeyRingCoinId))+ ||. not_ (E.isNothing (c2 ?. KeyRingCoinId))+ )+ )+ orderBy [ asc (t ^. KeyRingTxId) ]+ return $ t ^. KeyRingTxId++ let cnt = fromIntegral $ length tids+ (d, m) = cnt `divMod` pageLen+ maxPage = max 1 $ d + min 1 m++ when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $+ unwords [ "Invalid page number", show pageNum ]++ let fOrd = if pageReverse then reverse else id+ toDrop = fromIntegral $ (pageNum - 1) * pageLen+ -- We call fOrd twice to reverse the page back to ASC+ tidPage =+ fOrd $ take (fromIntegral pageLen) $ drop toDrop $ fOrd tids++ -- Use a sliptSelect query here with the exact tids to speed up the+ -- query.+ res <- splitSelect tidPage $ \tid ->+ from $ \(t `LeftOuterJoin` c `LeftOuterJoin`+ s `LeftOuterJoin` c2) -> do+ joinAll t c c2 s+ where_ $ t ^. KeyRingTxId `in_` valList tid+ groupBy $ t ^. KeyRingTxId+ orderBy [ asc (t ^. KeyRingTxId) ]+ return ( t+ -- Incoming value+ , coalesceDefault [sum_ (c ?. KeyRingCoinValue)] (val 0)+ -- Outgoing value+ , coalesceDefault [sum_ (c2 ?. KeyRingCoinValue)] (val 0)+ -- Number of new coins created+ , count $ c ?. KeyRingCoinId+ -- Number of coins spent+ , count $ c2 ?. KeyRingCoinId+ )++ let f (t, Value inVal, Value outVal, Value newCount, Value spentCount) =+ ( entityVal t+ , BalanceInfo+ { balanceInfoInBalance = floor (inVal :: Double)+ , balanceInfoOutBalance = floor (outVal :: Double)+ , balanceInfoCoins = newCount+ , balanceInfoSpentCoins = spentCount+ }+ )+ return (map f res, maxPage)+ | otherwise = liftIO . throwIO $ WalletException $+ concat [ "Invalid page request"+ , " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"+ ]+++-- Helper function to get a transaction from the wallet database. The function+-- will look across all accounts and return the first available transaction. If+-- the transaction does not exist, this function will throw a wallet exception.+getTx :: MonadIO m => TxHash -> SqlPersistT m (Maybe Tx)+getTx txid = do+ res <- select $ from $ \t -> do+ where_ $ t ^. KeyRingTxHash ==. val txid+ limit 1+ return $ t ^. KeyRingTxTx+ case res of+ (Value tx:_) -> return $ Just tx+ _ -> return Nothing++getAccountTx :: MonadIO m+ => KeyRingAccountId -> TxHash -> SqlPersistT m KeyRingTx+getAccountTx ai txid = do+ res <- select $ from $ \t -> do+ where_ ( t ^. KeyRingTxAccount ==. val ai+ &&. t ^. KeyRingTxHash ==. val txid+ )+ return t+ case res of+ (Entity _ tx:_) -> return tx+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "Transaction does not exist:", cs $ txHashToHex txid ]++-- Helper function to get all the pending transactions from the database. It is+-- used to re-broadcast pending transactions in the wallet that have not been+-- included into blocks yet.+getPendingTxs :: MonadIO m => Int -> SqlPersistT m [TxHash]+getPendingTxs i =+ liftM (map unValue) $ select $ from $ \t -> do+ where_ $ t ^. KeyRingTxConfidence ==. val TxPending+ limit $ fromIntegral i+ return $ t ^. KeyRingTxHash++{- Transaction Import -}++-- | Import a transaction into the wallet from an unknown source. If the+-- transaction is standard, valid, all inputs are known and all inputs can be+-- spent, then the transaction will be imported as a network transaction.+-- Otherwise, the transaction will be imported into the local account as an+-- offline transaction.+importTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Tx -- ^ Transaction to import+ -> KeyRingAccountId -- ^ Account ID+ -> SqlPersistT m ([KeyRingTx], [KeyRingAddr])+ -- ^ New transactions and addresses created+importTx tx ai = importTx' tx ai =<< getInCoins tx (Just ai)++importTx' :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Tx -- ^ Transaction to import+ -> KeyRingAccountId -- ^ Account ID+ -> [InCoinData] -- ^ Input coins+ -> SqlPersistT m ([KeyRingTx], [KeyRingAddr])+ -- ^ Transaction hash (after possible merges)+importTx' origTx ai origInCoins = do+ -- Merge the transaction with any previously existing transactions+ mergeResM <- mergeNoSigHashTxs ai origTx origInCoins+ let tx = fromMaybe origTx mergeResM+ origTxid = txHash origTx+ txid = txHash tx++ -- If the transaction was merged into a new transaction,+ -- update the old hashes to the new ones. This allows us to+ -- keep the spending information of our coins. It is thus possible+ -- to spend partially signed multisignature transactions (as offline+ -- transactions) even before all signatures have arrived.+ inCoins <- if origTxid == txid then return origInCoins else do+ -- Update transactions+ update $ \t -> do+ set t [ KeyRingTxHash =. val txid+ , KeyRingTxTx =. val tx+ ]+ where_ ( t ^. KeyRingTxAccount ==. val ai+ &&. t ^. KeyRingTxHash ==. val origTxid+ )+ -- Update coins+ update $ \t -> do+ set t [ KeyRingCoinHash =. val txid ]+ where_ ( t ^. KeyRingCoinAccount ==. val ai+ &&. t ^. KeyRingCoinHash ==. val origTxid+ )+ let f (InCoinData c t x) = if keyRingTxHash t == origTxid+ then InCoinData c t{ keyRingTxHash = txid, keyRingTxTx = tx } x+ else InCoinData c t x+ return $ map f origInCoins++ spendingTxs <- getSpendingTxs tx (Just ai)++ let validTx = verifyStdTx tx $ map toVerDat inCoins+ validIn = length inCoins == length (txIn tx)+ && canSpendCoins inCoins spendingTxs False+ if validIn && validTx+ then importNetTx tx+ else importOfflineTx tx ai inCoins spendingTxs+ where+ toVerDat (InCoinData (Entity _ c) t _) =+ (keyRingCoinScript c, OutPoint (keyRingTxHash t) (keyRingCoinPos c))++-- Offline transactions are usually multisignature transactions requiring+-- additional signatures. This function will merge the signatures of+-- the same offline transactions together into one single transaction.+mergeNoSigHashTxs :: MonadIO m+ => KeyRingAccountId+ -> Tx+ -> [InCoinData]+ -> SqlPersistT m (Maybe Tx)+mergeNoSigHashTxs ai tx inCoins = do+ prevM <- getBy $ UniqueAccNoSig ai $ nosigTxHash tx+ return $ case prevM of+ Just (Entity _ prev) -> case keyRingTxConfidence prev of+ TxOffline -> eitherToMaybe $+ mergeTxs [tx, keyRingTxTx prev] outPoints+ _ -> Nothing+ -- Nothing to merge. Return the original transaction.+ _ -> Nothing+ where+ buildOutpoint c t = OutPoint (keyRingTxHash t) (keyRingCoinPos c)+ f (InCoinData (Entity _ c) t _) = (keyRingCoinScript c, buildOutpoint c t)+ outPoints = map f inCoins++-- | Import an offline transaction into a specific account. Offline transactions+-- are imported either manually or from the wallet when building a partially+-- signed multisignature transaction. Offline transactions are only imported+-- into one specific account. They will not affect the input or output coins+-- of other accounts, including read-only accounts that may watch the same+-- addresses as this account.+--+-- We allow transactions to be imported manually by this function (unlike+-- `importNetTx` which imports only transactions coming from the network). This+-- means that it is possible to import completely crafted and invalid+-- transactions into the wallet. It is thus important to limit the scope of+-- those transactions to only the specific account in which it was imported.+--+-- This function will not broadcast these transactions to the network as we+-- have no idea if they are valid or not. Transactions are broadcast from the+-- transaction creation function and only if the transaction is complete.+importOfflineTx+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Tx+ -> KeyRingAccountId+ -> [InCoinData]+ -> [Entity KeyRingTx]+ -> SqlPersistT m ([KeyRingTx], [KeyRingAddr])+importOfflineTx tx ai inCoins spendingTxs = do+ -- Get all the new coins to be created by this transaction+ outCoins <- getNewCoins tx $ Just ai+ -- Only continue if the transaction is relevant to the account+ when (null inCoins && null outCoins) err+ -- Find the details of an existing transaction if it exists.+ prevM <- liftM (fmap entityVal) $ getBy $ UniqueAccTx ai txid+ -- Check if we can import the transaction+ unless (canImport $ keyRingTxConfidence <$> prevM) err+ -- Kill transactions that are spending our coins+ killTxIds $ map entityKey spendingTxs+ -- Create all the transaction records for this account.+ -- This will spend the input coins and create the output coins+ txsRes <- buildAccTxs tx TxOffline inCoins outCoins+ -- use the addresses (refill the gap addresses)+ newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $+ useAddress . entityVal+ return (txsRes, concat newAddrs)+ where+ txid = txHash tx+ canImport prevConfM =+ -- We can only re-import offline txs through this function.+ (isNothing prevConfM || prevConfM == Just TxOffline) &&+ -- Check that all coins can be spent. We allow offline+ -- coins to be spent by this function unlike importNetTx.+ canSpendCoins inCoins spendingTxs True+ sameKey e1 e2 = entityKey e1 == entityKey e2+ err = liftIO . throwIO $ WalletException+ "Could not import offline transaction"++-- | Import a transaction from the network into the wallet. This function+-- assumes transactions are imported in-order (parents first). It also assumes+-- that the confirmations always arrive after the transaction imports. This+-- function is idempotent.+--+-- When re-importing an existing transaction, this function will recompute+-- the inputs, outputs and transaction details for each account. A non-dead+-- transaction could be set to dead due to new inputs being double spent.+-- However, we do not allow dead transactions to be revived by reimporting them.+-- Transactions can only be revived if they make it into the main chain.+--+-- This function returns the network confidence of the imported transaction.+importNetTx+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Tx -- Network transaction to import+ -> SqlPersistT m ([KeyRingTx], [KeyRingAddr])+ -- ^ Returns the new transactions and addresses created+importNetTx tx = do+ -- Find all the coins spent by this transaction+ inCoins <- getInCoins tx Nothing+ -- Get all the new coins to be created by this transaction+ outCoins <- getNewCoins tx Nothing+ -- Only continue if the transaction is relevant to the wallet+ if null inCoins && null outCoins then return ([],[]) else do+ -- Update incomplete offline transactions when the completed+ -- transaction comes in from the network.+ updateNosigHash tx (nosigTxHash tx) txid+ -- Get the transaction spending our coins+ spendingTxs <- getSpendingTxs tx Nothing+ -- Compute the confidence+ let confidence | canSpendCoins inCoins spendingTxs False = TxPending+ | otherwise = TxDead+ -- Kill transactions that are spending our coins if we are not dead+ when (confidence /= TxDead) $ killTxIds $ map entityKey spendingTxs+ -- Create all the transaction records for this account.+ -- This will spend the input coins and create the output coins+ txRes <- buildAccTxs tx confidence inCoins outCoins+ -- Use up the addresses of our new coins (replenish gap addresses)+ newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $+ useAddress . entityVal+ return (txRes, concat newAddrs)+ where+ sameKey e1 e2 = entityKey e1 == entityKey e2+ txid = txHash tx++updateNosigHash :: MonadIO m => Tx -> TxHash -> TxHash -> SqlPersistT m ()+updateNosigHash tx nosig txid = do+ res <- select $ from $ \t -> do+ where_ ( t ^. KeyRingTxNosigHash ==. val nosig+ &&. t ^. KeyRingTxHash !=. val txid+ )+ return $ t ^. KeyRingTxHash+ let toUpdate = map unValue res+ unless (null toUpdate) $ do+ splitUpdate toUpdate $ \hs t -> do+ set t [ KeyRingTxHash =. val txid+ , KeyRingTxTx =. val tx+ ]+ where_ $ t ^. KeyRingTxHash `in_` valList hs+ splitUpdate toUpdate $ \hs c -> do+ set c [ KeyRingCoinHash =. val txid ]+ where_ $ c ^. KeyRingCoinHash `in_` valList hs++-- Check if the given coins can be spent.+canSpendCoins :: [InCoinData]+ -> [Entity KeyRingTx]+ -> Bool -- True for offline transactions+ -> Bool+canSpendCoins inCoins spendingTxs offline =+ all validCoin inCoins &&+ all validSpend spendingTxs+ where+ -- We can only spend pending and building coins+ validCoin (InCoinData _ t _)+ | offline = keyRingTxConfidence t /= TxDead+ | otherwise = keyRingTxConfidence t `elem` [TxPending, TxBuilding]+ -- All transactions spending the same coins as us should be offline+ validSpend = (== TxOffline) . keyRingTxConfidence . entityVal++-- Get the coins in the wallet related to the inputs of a transaction. You+-- can optionally provide an account to limit the returned coins to that+-- account only.+getInCoins :: MonadIO m+ => Tx+ -> Maybe KeyRingAccountId+ -> SqlPersistT m [InCoinData]+getInCoins tx aiM = do+ res <- splitSelect ops $ \os -> from $ \(c `InnerJoin` t `InnerJoin` x) -> do+ on $ x ^. KeyRingAddrId ==. c ^. KeyRingCoinAddr+ on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx+ where_ $ case aiM of+ Just ai ->+ c ^. KeyRingCoinAccount ==. val ai &&. limitOutPoints c os+ _ -> limitOutPoints c os+ return (c, t, x)+ return $ map (\(c, t, x) -> InCoinData c (entityVal t) (entityVal x)) res+ where+ ops = map prevOutput $ txIn tx+ limitOutPoints c os = join2 $ map (f c) os+ f c (OutPoint h i) =+ c ^. KeyRingCoinHash ==. val h &&.+ c ^. KeyRingCoinPos ==. val i++-- Find all the transactions that are spending the same coins as the given+-- transaction. You can optionally provide an account to limit the returned+-- transactions to that account only.+getSpendingTxs :: MonadIO m+ => Tx+ -> Maybe KeyRingAccountId+ -> SqlPersistT m [Entity KeyRingTx]+getSpendingTxs tx aiM+ | null txInputs = return []+ | otherwise =+ splitSelect txInputs $ \ins -> from $ \(s `InnerJoin` t) -> do+ on $ s ^. KeyRingSpentCoinSpendingTx ==. t ^. KeyRingTxId+ -- Filter out the given transaction+ let cond = t ^. KeyRingTxHash !=. val txid+ -- Limit to only the input coins of the given tx+ &&. limitSpent s ins+ where_ $ case aiM of+ Just ai -> cond &&. s ^. KeyRingSpentCoinAccount ==. val ai+ _ -> cond+ return t+ where+ txid = txHash tx+ txInputs = map prevOutput $ txIn tx+ limitSpent s ins = join2 $ map (f s) ins+ f s (OutPoint h i) =+ s ^. KeyRingSpentCoinHash ==. val h &&.+ s ^. KeyRingSpentCoinPos ==. val i++-- Returns all the new coins that need to be created from a transaction.+-- Also returns the addresses associted with those coins.+getNewCoins :: MonadIO m+ => Tx+ -> Maybe KeyRingAccountId+ -> SqlPersistT m [OutCoinData]+getNewCoins tx aiM = do+ -- Find all the addresses which are in the transaction outputs+ addrs <- splitSelect uniqueAddrs $ \as -> from $ \x -> do+ let cond = x ^. KeyRingAddrAddress `in_` valList as+ where_ $ case aiM of+ Just ai -> cond &&. x ^. KeyRingAddrAccount ==. val ai+ _ -> cond+ return x+ return $ concatMap toCoins addrs+ where+ uniqueAddrs = nub $ map (\(addr,_,_,_) -> addr) outList+ outList = rights $ map toDat txOutputs+ txOutputs = zip (txOut tx) [0..]+ toDat (out, pos) = getDataFromOutput out >>= \(addr, so) ->+ return (addr, out, pos, so)+ toCoins addrEnt@(Entity _ addr) =+ let f (a,_,_,_) = a == keyRingAddrAddress addr+ in map (toCoin addrEnt) $ filter f outList+ toCoin addrEnt (_, out, pos, so) = OutCoinData+ { outCoinDataAddr = addrEnt+ , outCoinDataPos = pos+ , outCoinDataValue = outValue out+ , outCoinDataScript = so+ }++-- Decode an output and extract an output script and a recipient address+getDataFromOutput :: TxOut -> Either String (Address, ScriptOutput)+getDataFromOutput out = do+ so <- decodeOutputBS $ scriptOutput out+ addr <- scriptRecipient $ encodeOutput so+ return (addr, so)++isCoinbaseTx :: Tx -> Bool+isCoinbaseTx (Tx _ tin _ _) =+ length tin == 1 && outPointHash (prevOutput $ head tin) ==+ "0000000000000000000000000000000000000000000000000000000000000000"++-- | Spend the given input coins. We also create dummy coins for the inputs+-- in a transaction that do not belong to us. This is to be able to detect+-- double spends when reorgs occur.+spendInputs :: MonadIO m+ => KeyRingAccountId+ -> KeyRingTxId+ -> Tx+ -> SqlPersistT m ()+spendInputs ai ti tx = do+ now <- liftIO getCurrentTime+ -- Spend the coins by inserting values in KeyRingSpentCoin+ P.insertMany_ $ map (buildSpentCoin now) txInputs+ where+ txInputs = map prevOutput $ txIn tx+ buildSpentCoin now (OutPoint h p) =+ KeyRingSpentCoin{ keyRingSpentCoinAccount = ai+ , keyRingSpentCoinHash = h+ , keyRingSpentCoinPos = p+ , keyRingSpentCoinSpendingTx = ti+ , keyRingSpentCoinCreated = now+ }++-- Build account transaction for the given input and output coins+buildAccTxs :: MonadIO m+ => Tx+ -> TxConfidence+ -> [InCoinData]+ -> [OutCoinData]+ -> SqlPersistT m [KeyRingTx]+buildAccTxs tx confidence inCoins outCoins = do+ now <- liftIO getCurrentTime+ -- Group the coins by account+ let grouped = groupCoinsByAccount inCoins outCoins+ forM (M.toList grouped) $ \(ai, (is, os)) -> do+ let atx = buildAccTx tx confidence ai is os now+ -- Insert the new transaction. If it already exists, update the+ -- information with the newly computed values. Also make sure that the+ -- confidence is set to the new value (it could have changed to TxDead).+ Entity ti newAtx <- P.insertBy atx >>= \resE -> case resE of+ Left (Entity ti prev) -> do+ let prevConf = keyRingTxConfidence prev+ newConf | confidence == TxDead = TxDead+ | prevConf == TxBuilding = TxBuilding+ | otherwise = confidence+ -- If the transaction already exists, preserve confirmation data+ let newAtx = atx+ { keyRingTxConfidence = newConf+ , keyRingTxConfirmedBy = keyRingTxConfirmedBy prev+ , keyRingTxConfirmedHeight = keyRingTxConfirmedHeight prev+ , keyRingTxConfirmedDate = keyRingTxConfirmedDate prev+ }+ replace ti newAtx+ -- Spend inputs only if the previous transaction was dead+ when (newConf /= TxDead && prevConf == TxDead) $+ spendInputs ai ti tx+ -- If the transaction changed from non-dead to dead, kill it.+ -- This will remove spent coins and child transactions.+ when (prevConf /= TxDead && newConf == TxDead) $ killTxIds [ti]+ return (Entity ti newAtx)+ Right ti -> do+ when (confidence /= TxDead) $ spendInputs ai ti tx+ return (Entity ti atx)++ -- Insert the output coins with updated accTx key+ let newOs = map (toCoin ai ti now) os+ forM_ newOs $ \c -> P.insertBy c >>= \resE -> case resE of+ Left (Entity ci _) -> replace ci c+ _ -> return ()++ -- Return the new transaction record+ return newAtx+ where+ toCoin ai accTxId now (OutCoinData addrEnt pos vl so) = KeyRingCoin+ { keyRingCoinAccount = ai+ , keyRingCoinHash = txHash tx+ , keyRingCoinPos = pos+ , keyRingCoinTx = accTxId+ , keyRingCoinValue = vl+ , keyRingCoinScript = so+ , keyRingCoinAddr = entityKey addrEnt+ , keyRingCoinCreated = now+ }++-- | Build an account transaction given the input and output coins relevant to+-- this specific account. An account transaction contains the details of how a+-- transaction affects one particular account (value sent to and from the+-- account). The first value is Maybe an existing transaction in the database+-- which is used to get the existing confirmation values.+buildAccTx :: Tx+ -> TxConfidence+ -> KeyRingAccountId+ -> [InCoinData]+ -> [OutCoinData]+ -> UTCTime+ -> KeyRingTx+buildAccTx tx confidence ai inCoins outCoins now = KeyRingTx+ { keyRingTxAccount = ai+ , keyRingTxHash = txHash tx+ -- This is a hash of the transaction excluding signatures. This allows us+ -- to track the evolution of offline transactions as we add more signatures+ -- to them.+ , keyRingTxNosigHash = nosigTxHash tx+ , keyRingTxType = txType+ , keyRingTxInValue = inVal+ , keyRingTxOutValue = outVal+ , keyRingTxInputs =+ let f h i (InCoinData (Entity _ c) t _) =+ keyRingTxHash t == h && keyRingCoinPos c == i+ toInfo (a, OutPoint h i) = case find (f h i) inCoins of+ Just (InCoinData (Entity _ c) _ _) ->+ AddressInfo a (Just $ keyRingCoinValue c) True+ _ -> AddressInfo a Nothing False+ in map toInfo allInAddrs+ , keyRingTxOutputs =+ let toInfo (a,i,v) = AddressInfo a (Just v) $ ours i+ ours i = isJust $ find ((== i) . outCoinDataPos) outCoins+ in map toInfo allOutAddrs \\ changeAddrs+ , keyRingTxChange = changeAddrs+ , keyRingTxTx = tx+ , keyRingTxIsCoinbase = isCoinbaseTx tx+ , keyRingTxConfidence = confidence+ -- Reuse the confirmation information of the existing transaction if+ -- we have it.+ , keyRingTxConfirmedBy = Nothing+ , keyRingTxConfirmedHeight = Nothing+ , keyRingTxConfirmedDate = Nothing+ , keyRingTxCreated = now+ }+ where+ -- The value going into the account is the sum of the output coins+ inVal = sum $ map outCoinDataValue outCoins+ -- The value going out of the account is the sum on the input coins+ outVal = sum $ map coinValue inCoins+ allMyCoins = length inCoins == length (txIn tx) &&+ length outCoins == length (txOut tx)+ txType+ -- If all the coins belong to the same account, it is a self+ -- transaction (even if a fee was payed).+ | allMyCoins = TxSelf+ -- This case can happen in complex transactions where the total+ -- input/output sum for a given account is 0. In this case, we count+ -- that transaction as a TxSelf. This should not happen with simple+ -- transactions.+ | inVal == outVal = TxSelf+ | inVal > outVal = TxIncoming+ | otherwise = TxOutgoing+ -- List of all the decodable input addresses in the transaction+ allInAddrs =+ let f inp = do+ addr <- scriptSender =<< decodeToEither (scriptInput inp)+ return (addr, prevOutput inp)+ in rights $ map f $ txIn tx+ -- List of all the decodable output addresses in the transaction+ allOutAddrs =+ let f op i = do+ addr <- scriptRecipient =<< decodeToEither (scriptOutput op)+ return (addr, i, outValue op)+ in rights $ zipWith f (txOut tx) [0..]+ changeAddrs+ | txType == TxIncoming = []+ | otherwise =+ let isInternal = (== AddressInternal) . keyRingAddrType+ . entityVal . outCoinDataAddr+ f = keyRingAddrAddress . entityVal . outCoinDataAddr+ toInfo c = AddressInfo (f c) (Just $ outCoinDataValue c) True+ in map toInfo $ filter isInternal outCoins++-- Group all the input and outputs coins from the same account together.+groupCoinsByAccount+ :: [InCoinData]+ -> [OutCoinData]+ -> M.Map KeyRingAccountId ([InCoinData], [OutCoinData])+groupCoinsByAccount inCoins outCoins =+ M.unionWith merge inMap outMap+ where+ -- Build a map from accounts -> (inCoins, outCoins)+ f coin@(InCoinData _ t _) = (keyRingTxAccount t, [coin])+ g coin = (keyRingAddrAccount $ entityVal $ outCoinDataAddr coin, [coin])+ merge (is, _) (_, os) = (is, os)+ inMap = M.map (\is -> (is, [])) $ M.fromListWith (++) $ map f inCoins+ outMap = M.map (\os -> ([], os)) $ M.fromListWith (++) $ map g outCoins++-- Kill transactions and their child transactions by ids.+killTxIds :: MonadIO m => [KeyRingTxId] -> SqlPersistT m ()+killTxIds txIds = do+ -- Find all the transactions spending the coins of these transactions+ -- (Find all the child transactions)+ childs <- splitSelect txIds $ \ts -> from $ \(t `InnerJoin` s) -> do+ on ( s ^. KeyRingSpentCoinAccount ==. t ^. KeyRingTxAccount+ &&. s ^. KeyRingSpentCoinHash ==. t ^. KeyRingTxHash+ )+ where_ $ t ^. KeyRingTxId `in_` valList ts+ return $ s ^. KeyRingSpentCoinSpendingTx++ -- Kill these transactions+ splitUpdate txIds $ \ts t -> do+ set t [ KeyRingTxConfidence =. val TxDead ]+ where_ $ t ^. KeyRingTxId `in_` valList ts++ -- This transaction doesn't spend any coins+ splitDelete txIds $ \ts -> from $ \s ->+ where_ $ s ^. KeyRingSpentCoinSpendingTx `in_` valList ts++ -- Recursively kill all the child transactions.+ -- (Recurse at the end in case there are closed loops)+ unless (null childs) $ killTxIds $ nub $ map unValue childs++-- Kill transactions and their child transactions by hashes.+killTxs :: MonadIO m => [TxHash] -> SqlPersistT m ()+killTxs txHashes = do+ res <- splitSelect txHashes $ \hs -> from $ \t -> do+ where_ $ t ^. KeyRingTxHash `in_` valList hs+ return $ t ^. KeyRingTxId+ killTxIds $ map unValue res++{- Confirmations -}++importMerkles :: MonadIO m+ => BlockChainAction+ -> [MerkleTxs]+ -> SqlPersistT m ()+importMerkles action expTxsLs =+ when (isBestChain action || isChainReorg action) $ do+ case action of+ ChainReorg _ os _ ->+ -- Unconfirm transactions from the old chain.+ let hs = map (Just . nodeBlockHash) os+ in splitUpdate hs $ \h t -> do+ set t [ KeyRingTxConfidence =. val TxPending+ , KeyRingTxConfirmedBy =. val Nothing+ , KeyRingTxConfirmedHeight =. val Nothing+ , KeyRingTxConfirmedDate =. val Nothing+ ]+ where_ $ t ^. KeyRingTxConfirmedBy `in_` valList h+ _ -> return ()++ -- Find all the dead transactions which need to be revived+ deadTxs <- splitSelect (concat expTxsLs) $ \ts -> from $ \t -> do+ where_ ( t ^. KeyRingTxHash `in_` valList ts+ &&. t ^. KeyRingTxConfidence ==. val TxDead+ )+ return $ t ^. KeyRingTxTx++ -- Revive dead transactions (in no particular order)+ forM_ deadTxs $ reviveTx . unValue++ -- Confirm the transactions+ forM_ (zip (actionNodes action) expTxsLs) $ \(node, hs) ->+ splitUpdate hs $ \h t -> do+ set t [ KeyRingTxConfidence =. val TxBuilding+ , KeyRingTxConfirmedBy =. val (Just (nodeBlockHash node))+ , KeyRingTxConfirmedHeight =.+ val (Just (nodeHeaderHeight node))+ , KeyRingTxConfirmedDate =.+ val (Just (blockTimestamp $ nodeHeader node))+ ]+ where_ $ t ^. KeyRingTxHash `in_` valList h++ -- Update the best height in the wallet (used to compute the number+ -- of confirmations of transactions)+ case reverse $ actionNodes action of+ (best:_) ->+ setBestBlock (nodeBlockHash best) (nodeHeaderHeight best)+ _ -> return ()++-- Helper function to set the best block and best block height in the DB.+setBestBlock :: MonadIO m => BlockHash -> Word32 -> SqlPersistT m ()+setBestBlock bid i = update $ \t -> set t [ KeyRingConfigBlock =. val bid+ , KeyRingConfigHeight =. val i+ ]++-- Helper function to get the best block and best block height from the DB+getBestBlock :: MonadIO m => SqlPersistT m (BlockHash, Word32)+getBestBlock = do+ cfgM <- liftM (fmap entityVal) $ P.selectFirst [] []+ return $ case cfgM of+ Just KeyRingConfig{..} -> (keyRingConfigBlock, keyRingConfigHeight)+ Nothing -> throw $ WalletException $ unwords+ [ "Could not get the best block."+ , "Wallet database is probably not initialized"+ ]++-- Revive a dead transaction. All transactions that are in conflict with this+-- one will be killed.+reviveTx :: MonadIO m => Tx -> SqlPersistT m ()+reviveTx tx = do+ -- Kill all transactions spending our coins+ spendingTxs <- getSpendingTxs tx Nothing+ killTxIds $ map entityKey spendingTxs++ -- Find all the KeyRingTxId that have to be revived+ ids <- select $ from $ \t -> do+ where_ ( t ^. KeyRingTxHash ==. val (txHash tx)+ &&. t ^. KeyRingTxConfidence ==. val TxDead+ )+ return (t ^. KeyRingTxAccount, t ^. KeyRingTxId)++ -- Spend the inputs for all our transactions+ forM_ ids $ \(Value ai, Value ti) -> spendInputs ai ti tx++ -- Update the transactions+ splitUpdate (map (unValue . snd) ids) $ \is t -> do+ set t [ KeyRingTxConfidence =. val TxPending+ , KeyRingTxConfirmedBy =. val Nothing+ , KeyRingTxConfirmedHeight =. val Nothing+ , KeyRingTxConfirmedDate =. val Nothing+ ]+ where_ $ t ^. KeyRingTxId `in_` valList is++{- Transaction creation and signing (local wallet functions) -}++-- | Create a transaction sending some coins to a list of recipient addresses.+createTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRing -- ^ KeyRing+ -> Entity KeyRingAccount -- ^ Account Entity+ -> [(Address,Word64)] -- ^ List of recipient addresses and amounts+ -> Word64 -- ^ Fee per 1000 bytes+ -> Word32 -- ^ Minimum confirmations+ -> Bool -- ^ Should fee be paid by recipient+ -> Bool -- ^ Should the transaction be signed+ -> SqlPersistT m (KeyRingTx, [KeyRingAddr])+ -- ^ (New transaction hash, Completed flag)+createTx keyRing accE@(Entity ai acc) dests fee minConf rcptFee sign = do+ -- Build an unsigned transaction from the given recipient values and fee+ (unsignedTx, inCoins) <- buildUnsignedTx accE dests fee minConf rcptFee+ -- Sign our new transaction if signing was requested+ let dat = map toCoinSignData inCoins+ tx | sign = signOfflineTx keyRing acc unsignedTx dat+ | otherwise = unsignedTx+ -- Import the transaction in the wallet either as a network transaction if+ -- it is complete, or as an offline transaction otherwise.+ (res, newAddrs) <- importTx' tx ai inCoins+ case res of+ (txRes:_) -> return (txRes, newAddrs)+ _ -> liftIO . throwIO $ WalletException+ "Error while importing the new transaction"++toCoinSignData :: InCoinData -> CoinSignData+toCoinSignData (InCoinData (Entity _ c) t x) =+ CoinSignData (OutPoint (keyRingTxHash t) (keyRingCoinPos c))+ (keyRingCoinScript c)+ (keyRingAddrDerivation x)++-- Build an unsigned transaction given a list of recipients and a fee. Returns+-- the unsigned transaction together with the input coins that have been+-- selected or spending.+buildUnsignedTx+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity KeyRingAccount+ -> [(Address, Word64)]+ -> Word64+ -> Word32+ -> Bool+ -> SqlPersistT m (Tx, [InCoinData])+buildUnsignedTx _ [] _ _ _ = liftIO . throwIO $ WalletException+ "buildUnsignedTx: No transaction recipients have been provided"+buildUnsignedTx accE@(Entity ai acc) origDests origFee minConf rcptFee = do+ let p = case keyRingAccountType acc of+ AccountMultisig _ m n -> (m, n)+ _ -> throw . WalletException $ "Invalid account type"+ fee = if rcptFee then 0 else origFee+ sink | isMultisigAccount acc = chooseMSCoinsSink tot fee p True+ | otherwise = chooseCoinsSink tot fee True+ -- TODO: Add more policies like confirmations or coin age+ -- Sort coins by their values in descending order+ orderPolicy c _ = [desc $ c ^. KeyRingCoinValue]++ -- Find the spendable coins in the given account with the required number+ -- of minimum confirmations.+ selectRes <- spendableCoinsSource ai minConf orderPolicy $$ sink++ -- Find a selection of spendable coins that matches our target value+ let (selected, change) = either (throw . WalletException) id selectRes+ totFee | isMultisigAccount acc = getMSFee origFee p (length selected)+ | otherwise = getFee origFee (length selected)+ -- Subtract fees from first destination if rcptFee+ value = snd $ head origDests++ -- First output must not be dust after deducting fees+ when (rcptFee && value < totFee + 5430) $ throw $ WalletException+ "First recipient cannot cover transaction fees"++ -- Subtract fees from first destination if rcptFee+ let dests | rcptFee =+ second (const $ value - totFee) (head origDests) :+ tail origDests+ | otherwise = origDests++ -- Make sure the first recipient has enough funds to cover the fee+ when (snd (head dests) <= 0) $ throw $+ WalletException "Transaction fees too high"++ -- If the change amount is not dust, we need to add a change address to+ -- our list of recipients.+ -- TODO: Put the dust value in a constant somewhere. We also need a more+ -- general way of detecting dust such as our transactions are not+ -- rejected by full nodes.+ allDests <- if change < 5430+ then return dests+ else addChangeAddr change dests++ case buildAddrTx (map toOutPoint selected) $ map toBase58 allDests of+ Right tx -> return (tx, selected)+ Left err -> liftIO . throwIO $ WalletException err+ where+ tot = sum $ map snd origDests+ toBase58 (a, v) = (addrToBase58 a, v)+ toOutPoint (InCoinData (Entity _ c) t _) =+ OutPoint (keyRingTxHash t) (keyRingCoinPos c)+ addChangeAddr change dests = do+ as <- unusedAddresses accE AddressInternal+ case as of+ (a:_) -> do+ -- Use the address to prevent reusing it again+ _ <- useAddress a+ -- TODO: Randomize the change position+ return $ (keyRingAddrAddress a, change) : dests+ _ -> liftIO . throwIO $ WalletException+ "No unused addresses available"++signKeyRingTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRing -> Entity KeyRingAccount -> TxHash+ -> SqlPersistT m ([KeyRingTx], [KeyRingAddr])+signKeyRingTx keyRing (Entity ai acc) txid = do+ (OfflineTxData tx dat, inCoins) <- getOfflineTxData ai txid+ let signedTx = signOfflineTx keyRing acc tx dat+ importTx' signedTx ai inCoins++getOfflineTxData+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingAccountId+ -> TxHash+ -> SqlPersistT m (OfflineTxData, [InCoinData])+getOfflineTxData ai txid = do+ txM <- getBy $ UniqueAccTx ai txid+ case txM of+ Just (Entity _ tx) -> do+ unless (keyRingTxConfidence tx == TxOffline) $ liftIO . throwIO $+ WalletException "Can only sign offline transactions."+ inCoins <- getInCoins (keyRingTxTx tx) $ Just ai+ return+ ( OfflineTxData (keyRingTxTx tx) $ map toCoinSignData inCoins+ , inCoins+ )+ _ -> liftIO . throwIO $ WalletException $ unwords+ [ "Invalid txid", cs $ txHashToHex txid ]++-- Sign a transaction using a list of CoinSignData. This allows an offline+-- signer without access to the coins to sign a given transaction.+signOfflineTx :: KeyRing -- ^ KeyRing+ -> KeyRingAccount -- ^ Account used for signing+ -> Tx -- ^ Transaction to sign+ -> [CoinSignData] -- ^ Input signing data+ -> Tx+signOfflineTx keyRing acc tx coinSignData+ -- Fail for read-only accounts+ | isReadAccount acc = throw $ WalletException+ "signOfflineTx is not supported on read-only accounts"+ -- Sign the transaction deterministically+ | otherwise = either (throw . WalletException) id $+ signTx tx sigData $ map (toPrvKeyG . xPrvKey) prvKeys+ where+ -- Compute all the SigInputs+ sigData = map (toSigData acc) coinSignData+ -- Compute all the private keys+ prvKeys = map (toPrvKey (keyRingMaster keyRing) acc) coinSignData+ -- Build a SigInput from a CoinSignData+ toSigData acc' (CoinSignData op so deriv) =+ -- TODO: Here we override the SigHash to be SigAll False all the time.+ -- Should we be more flexible?+ SigInput so op (SigAll False) $+ if isMultisigAccount acc+ then Just $ getPathRedeem acc' deriv+ else Nothing+ toPrvKey master acc' (CoinSignData _ _ deriv) =+ case keyRingAccountDerivation acc' of+ Just root -> derivePath (root ++| deriv) master+ _ -> throw $ WalletException $ unwords+ [ "No derivation available in account"+ , unpack $ keyRingAccountName acc'+ ]++-- Returns unspent coins that can be spent in an account that have a minimum+-- number of confirmations. Coinbase coins can only be spent after 100+-- confirmations.+spendableCoins+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingAccountId -- ^ Account key+ -> Word32 -- ^ Minimum confirmations+ -> ( SqlExpr (Entity KeyRingCoin)+ -> SqlExpr (Entity KeyRingTx)+ -> [SqlExpr OrderBy]+ )+ -- ^ Coin ordering policy+ -> SqlPersistT m [InCoinData] -- ^ Spendable coins+spendableCoins ai minConf orderPolicy =+ liftM (map f) $ select $ spendableCoinsFrom ai minConf orderPolicy+ where+ f (c, t, x) = InCoinData c (entityVal t) (entityVal x)++spendableCoinsSource+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => KeyRingAccountId -- ^ Account key+ -> Word32 -- ^ Minimum confirmations+ -> ( SqlExpr (Entity KeyRingCoin)+ -> SqlExpr (Entity KeyRingTx)+ -> [SqlExpr OrderBy]+ )+ -- ^ Coin ordering policy+ -> Source (SqlPersistT m) InCoinData+ -- ^ Spendable coins+spendableCoinsSource ai minConf orderPolicy =+ mapOutput f $ selectSource $ spendableCoinsFrom ai minConf orderPolicy+ where+ f (c, t, x) = InCoinData c (entityVal t) (entityVal x)++spendableCoinsFrom+ :: KeyRingAccountId -- ^ Account key+ -> Word32 -- ^ Minimum confirmations+ -> ( SqlExpr (Entity KeyRingCoin)+ -> SqlExpr (Entity KeyRingTx)+ -> [SqlExpr OrderBy]+ )+ -- ^ Coin ordering policy+ -> SqlQuery ( SqlExpr (Entity KeyRingCoin)+ , SqlExpr (Entity KeyRingTx)+ , SqlExpr (Entity KeyRingAddr)+ )+spendableCoinsFrom ai minConf orderPolicy =+ from $ \(c `InnerJoin` t `InnerJoin` x `LeftOuterJoin` s) -> do+ -- Joins have to be set in reverse order !+ -- Left outer join on spent coins+ on ( s ?. KeyRingSpentCoinAccount ==. just (c ^. KeyRingCoinAccount)+ &&. s ?. KeyRingSpentCoinHash ==. just (c ^. KeyRingCoinHash)+ &&. s ?. KeyRingSpentCoinPos ==. just (c ^. KeyRingCoinPos)+ )+ on $ x ^. KeyRingAddrId ==. c ^. KeyRingCoinAddr+ -- Inner join on coins and transactions+ on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx+ where_ ( c ^. KeyRingCoinAccount ==. val ai+ &&. t ^. KeyRingTxConfidence+ `in_` valList [ TxPending, TxBuilding ]+ -- We only want unspent coins+ &&. E.isNothing (s ?. KeyRingSpentCoinId)+ &&. limitConfirmations (Right t) minConf+ )+ orderBy (orderPolicy c t)+ return (c, t, x)++-- If the current height is 200 and a coin was confirmed at height 198, then it+-- has 3 confirmations. So, if we require 3 confirmations, we want coins with a+-- confirmed height of 198 or less (200 - 3 + 1).+limitConfirmations :: Either (SqlExpr (Maybe (Entity KeyRingTx)))+ (SqlExpr (Entity KeyRingTx))+ -> Word32+ -> SqlExpr (Value Bool)+limitConfirmations txE minconf+ | minconf == 0 = limitCoinbase+ | minconf < 100 = limitConfs minconf &&. limitCoinbase+ | otherwise = limitConfs minconf+ where+ limitConfs i = case txE of+ Left t -> t ?. KeyRingTxConfirmedHeight+ <=. just (just (selectHeight -. val (i - 1)))+ Right t -> t ^. KeyRingTxConfirmedHeight+ <=. just (selectHeight -. val (i - 1))+ -- Coinbase transactions require 100 confirmations+ limitCoinbase = case txE of+ Left t ->+ not_ (coalesceDefault [t ?. KeyRingTxIsCoinbase] (val False)) ||.+ limitConfs 100+ Right t ->+ not_ (t ^. KeyRingTxIsCoinbase) ||. limitConfs 100+ selectHeight :: SqlExpr (Value Word32)+ selectHeight = sub_select $ from $ \co -> do+ limit 1+ return $ co ^. KeyRingConfigHeight++{- Balances -}++accountBalance :: MonadIO m+ => KeyRingAccountId+ -> Word32+ -> Bool+ -> SqlPersistT m Word64+accountBalance ai minconf offline = do+ res <- select $ from $ \(c `InnerJoin`+ t `LeftOuterJoin` s `LeftOuterJoin` st) -> do+ on $ st ?. KeyRingTxId ==. s ?. KeyRingSpentCoinSpendingTx+ on ( s ?. KeyRingSpentCoinAccount ==. just (c ^. KeyRingCoinAccount)+ &&. s ?. KeyRingSpentCoinHash ==. just (c ^. KeyRingCoinHash)+ &&. s ?. KeyRingSpentCoinPos ==. just (c ^. KeyRingCoinPos)+ )+ on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx+ let unspent = E.isNothing ( s ?. KeyRingSpentCoinId )+ spentOffline = st ?. KeyRingTxConfidence ==. just (val TxOffline)+ cond = c ^. KeyRingCoinAccount ==. val ai+ &&. t ^. KeyRingTxConfidence `in_` valList validConfidence+ -- For non-offline balances, we have to take into account+ -- the coins which are spent by offline transactions.+ &&. if offline then unspent else unspent ||. spentOffline+ where_ $ if minconf == 0+ then cond+ else cond &&. limitConfirmations (Right t) minconf+ return $ sum_ (c ^. KeyRingCoinValue)+ case res of+ (Value (Just s):_) -> return $ floor (s :: Double)+ _ -> return 0+ where+ validConfidence = TxPending : TxBuilding : [ TxOffline | offline ]++addressBalances :: MonadIO m+ => Entity KeyRingAccount+ -> KeyIndex+ -> KeyIndex+ -> AddressType+ -> Word32+ -> Bool+ -> SqlPersistT m [(KeyIndex, BalanceInfo)]+addressBalances accE@(Entity ai _) iMin iMax addrType minconf offline = do+ -- We keep our joins flat to improve performance in SQLite.+ res <- select $ from $ \(x `LeftOuterJoin` c `LeftOuterJoin`+ t `LeftOuterJoin` s `LeftOuterJoin` st) -> do+ let joinCond = st ?. KeyRingTxId ==. s ?. KeyRingSpentCoinSpendingTx+ -- Do not join the spending information for offline transactions if we+ -- request the online balances. This will count the coin as unspent.+ on $ if offline+ then joinCond+ else joinCond &&. st ?. KeyRingTxConfidence !=. just (val TxOffline)+ on $ s ?. KeyRingSpentCoinAccount ==. c ?. KeyRingCoinAccount+ &&. s ?. KeyRingSpentCoinHash ==. c ?. KeyRingCoinHash+ &&. s ?. KeyRingSpentCoinPos ==. c ?. KeyRingCoinPos+ let txJoin = t ?. KeyRingTxId ==. c ?. KeyRingCoinTx+ &&. t ?. KeyRingTxConfidence `in_` valList validConfidence+ on $ if minconf == 0+ then txJoin+ else txJoin &&. limitConfirmations (Left t) minconf+ on $ c ?. KeyRingCoinAddr ==. just (x ^. KeyRingAddrId)+ let limitIndex+ | iMin == iMax = x ^. KeyRingAddrIndex ==. val iMin+ | otherwise = x ^. KeyRingAddrIndex >=. val iMin+ &&. x ^. KeyRingAddrIndex <=. val iMax+ where_ ( x ^. KeyRingAddrAccount ==. val ai+ &&. limitIndex+ &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType+ &&. x ^. KeyRingAddrType ==. val addrType+ )+ groupBy $ x ^. KeyRingAddrIndex+ let unspent = E.isNothing $ st ?. KeyRingTxId+ invalidTx = E.isNothing $ t ?. KeyRingTxId+ return ( x ^. KeyRingAddrIndex -- Address index+ , sum_ $ case_+ [ when_ invalidTx+ then_ (val (Just 0))+ ] (else_ $ c ?. KeyRingCoinValue) -- Out value+ , sum_ $ case_+ [ when_ (unspent ||. invalidTx)+ then_ (val (Just 0))+ ] (else_ $ c ?. KeyRingCoinValue) -- Out value+ , count $ t ?. KeyRingTxId -- New coins+ , count $ case_+ [ when_ invalidTx+ then_ (val Nothing)+ ] (else_ $ st ?. KeyRingTxId) -- Spent coins+ )+ return $ map f res+ where+ validConfidence = Just TxPending : Just TxBuilding :+ [ Just TxOffline | offline ]+ f (Value i, Value inM, Value outM, Value newC, Value spentC) =+ let b = BalanceInfo+ { balanceInfoInBalance =+ floor $ fromMaybe (0 :: Double) inM+ , balanceInfoOutBalance =+ floor $ fromMaybe (0 :: Double) outM+ , balanceInfoCoins = newC+ , balanceInfoSpentCoins = spentC+ }+ in (i, b)++{- Rescans -}++resetRescan :: MonadIO m => SqlPersistT m ()+resetRescan = do+ P.deleteWhere ([] :: [P.Filter KeyRingCoin])+ P.deleteWhere ([] :: [P.Filter KeyRingSpentCoin])+ P.deleteWhere ([] :: [P.Filter KeyRingTx])+ setBestBlock (headerHash genesisHeader) 0++{- Helpers -}++-- Join AND expressions with OR conditions in a binary way+join2 :: [SqlExpr (Value Bool)] -> SqlExpr (Value Bool)+join2 xs = case xs of+ [] -> val False+ [x] -> x+ _ -> let (ls,rs) = splitAt (length xs `div` 2) xs+ in join2 ls ||. join2 rs++splitSelect :: (SqlSelect a r, MonadIO m)+ => [t]+ -> ([t] -> SqlQuery a)+ -> SqlPersistT m [r]+splitSelect ts queryF =+ liftM concat $ forM vals $ select . queryF+ where+ vals = chunksOf paramLimit ts++splitUpdate :: ( MonadIO m+ , P.PersistEntity val+ , P.PersistEntityBackend val ~ SqlBackend+ )+ => [t]+ -> ([t] -> SqlExpr (Entity val) -> SqlQuery ())+ -> SqlPersistT m ()+splitUpdate ts updateF =+ forM_ vals $ update . updateF+ where+ vals = chunksOf paramLimit ts++splitDelete :: MonadIO m => [t] -> ([t] -> SqlQuery ()) -> SqlPersistT m ()+splitDelete ts deleteF =+ forM_ vals $ E.delete . deleteF+ where+ vals = chunksOf paramLimit ts+
− Network/Haskoin/Wallet/TxBuilder.hs
@@ -1,357 +0,0 @@-module Network.Haskoin.Wallet.TxBuilder -( Coin(..)-, buildTx-, buildAddrTx-, SigInput(..)-, signTx-, detSignTx-, verifyTx-, guessTxSize-, chooseCoins-, chooseMSCoins-, getFee-, getMSFee-, isTxComplete-) where--import Control.Monad (when, guard, liftM2)-import Control.Applicative ((<$>))-import Control.Monad.Trans (lift)--import Data.Maybe (catMaybes, maybeToList, fromMaybe)-import Data.List (sortBy, find)-import Data.Word (Word64)-import qualified Data.ByteString as BS (length, replicate)--import Network.Haskoin.Util-import Network.Haskoin.Util.BuildMonad-import Network.Haskoin.Crypto-import Network.Haskoin.Protocol-import Network.Haskoin.Script---- | A Coin is something that can be spent by a transaction and is--- represented by a transaction output, an outpoint and optionally a--- redeem script.-data Coin = - Coin { coinTxOut :: TxOut -- ^ Transaction output- , coinOutPoint :: OutPoint -- ^ Previous outpoint- , coinRedeem :: Maybe Script -- ^ Redeem script- } deriving (Eq, Show)---- | Coin selection algorithm for normal (non-multisig) transactions. This--- function returns the selected coins together with the amount of change to--- send back to yourself, taking the fee into account.-chooseCoins :: Word64 -- ^ Target price to pay.- -> Word64 -- ^ Fee price per 1000 bytes.- -> [Coin] -- ^ List of coins to choose from.- -> Either String ([Coin],Word64) - -- ^ Coin selection result and change amount.-chooseCoins target kbfee xs - | target > 0 = maybeToEither err $ greedyAdd target (getFee kbfee) xs- | otherwise = Left "chooseCoins: Target must be > 0"- where err = "chooseCoins: No solution found"---- | Coin selection algorithm for multisignature transactions. This function--- returns the selected coins together with the amount of change to send back--- to yourself, taking the fee into account. This function assumes all the --- coins are script hash outputs that send funds to a multisignature address.-chooseMSCoins :: Word64 -- ^ Target price to pay.- -> Word64 -- ^ Fee price per 1000 bytes.- -> (Int,Int) -- ^ Multisig parameters m of n (m,n).- -> [Coin] -- ^ List of coins to choose from.- -> Either String ([Coin],Word64) - -- ^ Coin selection result and change amount.-chooseMSCoins target kbfee ms xs - | target > 0 = maybeToEither err $ greedyAdd target (getMSFee kbfee ms) xs- | otherwise = Left "chooseMSCoins: Target must be > 0"- where err = "chooseMSCoins: No solution found"---- Select coins greedily by starting from an empty solution-greedyAdd :: Word64 -> (Int -> Word64) -> [Coin] -> Maybe ([Coin],Word64)-greedyAdd target fee xs = go [] 0 [] 0 $ sortBy desc xs- where desc a b = compare (outValue $ coinTxOut b) (outValue $ coinTxOut a)- goal c = target + fee c- go _ _ [] _ [] = Nothing- go _ _ ps pTot [] = return (ps,pTot - (goal $ length ps))- go acc aTot ps pTot (y:ys)- | val + aTot >= (goal $ length acc + 1) =- if aTot + val - target < pTot - target- then go [] 0 (y:acc) (aTot + val) ys- else return (ps,pTot - (goal $ length ps))- | otherwise = go (y:acc) (aTot + val) ps pTot ys- where val = outValue $ coinTxOut y--{---- Start from a solution containing all coins and greedily remove them-greedyRem :: Word64 -> (Int -> Word64) -> [Coin] -> Maybe ([Coin],Word64)-greedyRem target fee xs - | s < goal (length xs) = Nothing- | otherwise = return $ go [] s $ sortBy desc xs- where desc a b = compare (outValue $ coinTxOut b) (outValue $ coinTxOut a)- s = sum $ map (outValue . coinTxOut) xs- goal c = target + fee c- go acc tot [] = (acc,tot - (goal $ length acc))- go acc tot (y:ys) - | tot - val >= (goal $ length ys + length acc) = - go acc (tot - val) ys- | otherwise = go (y:acc) tot ys- where val = outValue $ coinTxOut y--}--getFee :: Word64 -> Int -> Word64-getFee kbfee count = kbfee*((len + 999) `div` 1000)- where len = fromIntegral $ guessTxSize count [] 2 0--getMSFee :: Word64 -> (Int,Int) -> Int -> Word64-getMSFee kbfee ms count = kbfee*((len + 999) `div` 1000)- where len = fromIntegral $ guessTxSize 0 (replicate count ms) 2 0---- | Computes an upper bound on the size of a transaction based on some known--- properties of the transaction.-guessTxSize :: Int -- ^ Number of regular transaction inputs.- -> [(Int,Int)] - -- ^ For every multisig input in the transaction, provide- -- the multisig parameters m of n (m,n) for that input.- -> Int -- ^ Number of pay to public key hash outputs.- -> Int -- ^ Number of pay to script hash outputs.- -> Int -- ^ Upper bound on the transaction size.-guessTxSize pki msi pkout msout = 8 + inpLen + inp + outLen + out- where inpLen = BS.length $ encode' $ - VarInt $ fromIntegral $ (length msi) + pki- outLen = BS.length $ encode' $ - VarInt $ fromIntegral $ pkout + msout- inp = pki*148 + (sum $ map guessMSSize msi)- -- (20: hash160) + (5: opcodes) + - -- (1: script len) + (8: Word64)- out = pkout*34 + - -- (20: hash160) + (3: opcodes) + - -- (1: script len) + (8: Word64)- msout*32---- Size of a multisig pay2sh input-guessMSSize :: (Int,Int) -> Int- -- OutPoint (36) + Sequence (4) + Script-guessMSSize (m,n) = 40 + (BS.length $ encode' $ VarInt $ fromIntegral scp) + scp- -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG- where rdm = BS.length $ encode' $ OP_PUSHDATA $ BS.replicate (n*34 + 3) 0- -- Redeem + m*sig + OP_0- scp = rdm + m*73 + 1 --{- Build a new Tx -}---- | Build a transaction by providing a list of outpoints as inputs--- and a list of recipients addresses and amounts as outputs. -buildAddrTx :: [OutPoint] -> [(String,Word64)] -> Either String Tx-buildAddrTx xs ys = buildTx xs =<< mapM f ys- where f (s,v) = case base58ToAddr s of- Just a@(PubKeyAddress _) -> return (PayPKHash a,v)- Just a@(ScriptAddress _) -> return (PayScriptHash a,v)- _ -> Left $ "buildAddrTx: Invalid address " ++ s---- | Build a transaction by providing a list of outpoints as inputs--- and a list of 'ScriptOutput' and amounts as outputs.-buildTx :: [OutPoint] -> [(ScriptOutput,Word64)] -> Either String Tx-buildTx xs ys = mapM fo ys >>= \os -> return $ Tx 1 (map fi xs) os 0- where fi outPoint = TxIn outPoint (Script []) maxBound- fo (o,v) | v <= 2100000000000000 = return $ TxOut v $ encodeOutput o- | otherwise = Left $ "buildTx: Invalid amount " ++ (show v)---- | Data type used to specify the signing parameters of a transaction input.--- To sign an input, the previous output script, outpoint and sighash are--- required. When signing a pay to script hash output, an additional redeem--- script is required.-data SigInput - -- | Parameters for signing a pay to public key hash output.- = SigInput { sigDataOut :: Script -- ^ Output script to spend.- , sigDataOP :: OutPoint - -- ^ Reference to the transaction output to spend.- , sigDataSH :: SigHash -- ^ Signature type.- } - -- | Parameters for signing a pay to script hash output.- | SigInputSH { sigDataOut :: Script - , sigDataOP :: OutPoint - , sigRedeem :: Script -- ^ Redeem script.- , sigDataSH :: SigHash - } deriving (Eq, Show)--liftSecret :: Monad m => Build a -> SecretT (BuildT m) a-liftSecret = lift . liftBuild---- | Returns True if all the inputs of a transactions are non-empty and if--- all multisignature inputs are fully signed.-isTxComplete :: Tx -> Bool-isTxComplete = isComplete . (mapM toBuildTxIn) . txIn---- | Sign a transaction by providing the 'SigInput' signing parameters and a--- list of private keys. The signature is computed within the 'SecretT' monad--- to generate the random signing nonce and within the 'BuildT' monad to add--- information on wether the result was fully or partially signed.-signTx :: Monad m - => Tx -- ^ Transaction to sign- -> [SigInput] -- ^ SigInput signing parameters- -> [PrvKey] -- ^ List of private keys to use for signing- -> SecretT (BuildT m) Tx -- ^ Signed transaction-signTx tx@(Tx _ ti _ _) sigis keys = do- liftSecret $ when (null ti) $ Broken "signTx: Transaction has no inputs"- newIn <- mapM sign $ orderSigInput ti sigis- return tx{ txIn = newIn }- where sign (maybeSI,txin,i) = case maybeSI of- Just sigi -> signTxIn txin sigi tx i keys- _ -> liftSecret $ toBuildTxIn txin--signTxIn :: Monad m => TxIn -> SigInput -> Tx -> Int -> [PrvKey] - -> SecretT (BuildT m) TxIn-signTxIn txin sigi tx i keys = do- (out,vKeys,pubs,buildf) <- liftSecret $ decodeSigInput sigi keys- let msg = txSigHash tx (encodeOutput out) i sh- sigs <- mapM (signMsg msg) vKeys- liftSecret $ buildf txin tx out i pubs $ map (flip TxSignature sh) sigs- where sh = sigDataSH sigi---- | Sign a transaction by providing the 'SigInput' signing paramters and --- a list of private keys. The signature is computed deterministically as--- defined in RFC-6979. The signature is computed within the 'Build' monad--- to add information on wether the result was fully or partially signed.-detSignTx :: Tx -- ^ Transaction to sign- -> [SigInput] -- ^ SigInput signing parameters- -> [PrvKey] -- ^ List of private keys to use for signing- -> Build Tx -- ^ Signed transaction-detSignTx tx@(Tx _ ti _ _) sigis keys = do- when (null ti) $ Broken "detSignTx: Transaction has no inputs"- newIn <- mapM sign $ orderSigInput ti sigis- return tx{ txIn = newIn }- where sign (maybeSI,txin,i) = case maybeSI of- Just sigi -> detSignTxIn txin sigi tx i keys- _ -> toBuildTxIn txin--detSignTxIn :: TxIn -> SigInput -> Tx -> Int -> [PrvKey] -> Build TxIn-detSignTxIn txin sigi tx i keys = do- (out,vKeys,pubs,buildf) <- decodeSigInput sigi keys- let msg = txSigHash tx (encodeOutput out) i sh- sigs = map (detSignMsg msg) vKeys- buildf txin tx out i pubs $ map (flip TxSignature sh) sigs- where sh = sigDataSH sigi--{- Helpers for signing transactions -}---- |Decides if a TxIn is complete. If the TxIn could not be decoded and it--- is not empty, we consider it complete.-toBuildTxIn :: TxIn -> Build TxIn-toBuildTxIn txin@(TxIn _ s _)- | null $ scriptOps s = Partial txin- | otherwise = case decodeScriptHash s of- Right (ScriptHashInput (SpendMulSig xs r) _) -> - guardPartial (length xs == r) >> return txin- Right _ -> return txin- Left _ -> case decodeInput s of- Right (SpendMulSig xs r) ->- guardPartial (length xs == r) >> return txin- _ -> return txin---orderSigInput :: [TxIn] -> [SigInput] -> [(Maybe SigInput, TxIn, Int)]-orderSigInput ti si = zip3 (matchTemplate si ti f) ti [0..]- where f s txin = sigDataOP s == prevOutput txin--type BuildFunction = TxIn -> Tx -> ScriptOutput -> Int - -> [PubKey] -> [TxSignature] -> Build TxIn--decodeSigInput :: SigInput -> [PrvKey] -> - Build (ScriptOutput, [PrvKey], [PubKey], BuildFunction)-decodeSigInput sigi keys = case sigi of- SigInput s _ _ -> do- out <- eitherToBuild $ decodeOutput s- (vKeys,pubs) <- sigKeys out keys- return (out,vKeys,pubs,buildTxIn)- SigInputSH s _ sr _ -> do- out <- eitherToBuild $ decodeOutput s- rdm <- eitherToBuild $ decodeOutput sr- (vKeys,pubs) <- sigKeysSH out rdm keys- return (rdm,vKeys,pubs,buildTxInSH)--buildTxInSH :: BuildFunction-buildTxInSH txin tx rdm i pubs sigs = do- s <- scriptInput <$> buildTxIn txin tx rdm i pubs sigs- res <- either emptyIn return $ - encodeScriptHash . (flip ScriptHashInput rdm) <$> decodeInput s- return txin{ scriptInput = res }- where emptyIn = const $ Partial $ Script []--buildTxIn :: BuildFunction-buildTxIn txin tx out i pubs sigs - | null sigs = Partial txin{ scriptInput = Script [] }- | otherwise = buildRes <$> case out of- PayPK _ -> return $ SpendPK $ head sigs- PayPKHash _ -> return $ SpendPKHash (head sigs) (head pubs)- PayMulSig msPubs r -> do- let mSigs = take r $ catMaybes $ matchTemplate aSigs msPubs f- guardPartial $ length mSigs == r- return $ SpendMulSig mSigs r- _ -> Broken "buildTxIn: Can't sign a P2SH script here"- where buildRes res = txin{ scriptInput = encodeInput res }- aSigs = concat- [ sigs - , case decodeScriptHash $ scriptInput txin of- Right (ScriptHashInput (SpendMulSig xs _) _) -> xs- _ -> case decodeInput $ scriptInput txin of- Right (SpendMulSig xs _) -> xs- _ -> []- ]- f (TxSignature sig sh) pub = - verifySig (txSigHash tx (encodeOutput out) i sh) sig pub--sigKeysSH :: ScriptOutput -> RedeemScript -> [PrvKey]- -> Build ([PrvKey],[PubKey])-sigKeysSH out rdm keys = case out of- PayScriptHash a -> if scriptAddr rdm == a- then sigKeys rdm keys- else Broken "sigKeys: Redeem script does not match P2SH script"- _ -> Broken "sigKeys: Can only decode P2SH script here"--sigKeys :: ScriptOutput -> [PrvKey] -> Build ([PrvKey],[PubKey])-sigKeys out keys = unzip <$> case out of- PayPK p -> return $ maybeToList $ - find ((== p) . snd) zipKeys- PayPKHash a -> return $ maybeToList $ - find ((== a) . pubKeyAddr . snd) zipKeys- PayMulSig ps r -> return $ take r $ - filter ((`elem` ps) . snd) zipKeys- _ -> Broken "sigKeys: Can't decode P2SH here" - where zipKeys = zip keys $ map derivePubKey keys--{- Tx verification -}--verifyTx :: Tx -> [(Script,OutPoint)] -> Bool-verifyTx tx xs = flip all z3 $ \(maybeS,txin,i) -> fromMaybe False $ do- (out,inp) <- maybeS >>= flip decodeVerifySigInput txin- let so = encodeOutput out- case (out,inp) of- (PayPK pub,SpendPK (TxSignature sig sh)) -> - return $ verifySig (txSigHash tx so i sh) sig pub- (PayPKHash a,SpendPKHash (TxSignature sig sh) pub) -> do- guard $ pubKeyAddr pub == a- return $ verifySig (txSigHash tx so i sh) sig pub- (PayMulSig pubs r,SpendMulSig sigs _) ->- (== r) <$> countMulSig tx so i pubs sigs - _ -> Nothing- where m = map (fst <$>) $ matchTemplate xs (txIn tx) f- f (_,o) txin = o == prevOutput txin- z3 = zip3 m (txIn tx) [0..]- --- Count the number of valid signatures-countMulSig :: Tx -> Script -> Int -> [PubKey] -> [TxSignature] -> Maybe Int-countMulSig _ _ _ [] _ = return 0-countMulSig _ _ _ _ [] = return 0-countMulSig tx so i (pub:pubs) sigs@(TxSignature sig sh:rest)- | verifySig (txSigHash tx so i sh) sig pub = - (+1) <$> countMulSig tx so i pubs rest- | otherwise = countMulSig tx so i pubs sigs- -decodeVerifySigInput :: Script -> TxIn -> Maybe (ScriptOutput, ScriptInput)-decodeVerifySigInput so (TxIn _ si _ ) = case decodeOutput so of- Right (PayScriptHash a) -> do- (ScriptHashInput inp rdm) <- eitherToMaybe $ decodeScriptHash si- guard $ scriptAddr rdm == a- return (rdm,inp)- out -> eitherToMaybe $ liftM2 (,) out (decodeInput si)-
+ Network/Haskoin/Wallet/Types.hs view
@@ -0,0 +1,705 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.Haskoin.Wallet.Types+( KeyRingName+, AccountName++-- JSON Types+, JsonKeyRing(..)+, JsonAccount(..)+, JsonAddr(..)+, JsonCoin(..)+, JsonTx(..)+, JsonWithKeyRing(..)+, JsonWithAccount(..)+, JsonWithAddr(..)++-- Request Types+, WalletRequest(..)+, PageRequest(..)+, validPageRequest+, NewKeyRing(..)+, NewAccount(..)+, SetAccountGap(..)+, OfflineTxData(..)+, CoinSignData(..)+, TxAction(..)+, AddressLabel(..)+, NodeAction(..)+, AccountType(..)+, AddressType(..)+, addrTypeIndex+, TxType(..)+, TxConfidence(..)+, AddressInfo(..)+, BalanceInfo(..)++-- Response Types+, WalletResponse(..)+, TxCompleteRes(..)+, AddrTx(..)+, PageRes(..)+, RescanRes(..)++-- Helper Types+, WalletException(..)+) where++import Control.Monad (mzero)+import Control.Exception (Exception)+import Control.DeepSeq (NFData(..))++import Data.Int (Int64)+import Data.Time (UTCTime)+import Data.Typeable (Typeable)+import Data.Maybe (maybeToList)+import Data.Char (toLower)+import Data.Word (Word32, Word64)+import Data.Text (Text)+import qualified Data.ByteString.Lazy as L+import Data.Aeson.Types+ ( Options(..)+ , SumEncoding(..)+ , defaultOptions+ , defaultTaggedObject+ )+import Data.String.Conversions (cs)+import Data.Aeson.TH (deriveJSON)+import Data.Aeson+ ( Value (..), FromJSON, ToJSON, encode+ , decodeStrict', withObject+ , (.=), (.:), (.:?), (.!=)+ , object, parseJSON, toJSON+ )++import Database.Persist.Class (PersistField, toPersistValue, fromPersistValue)+import Database.Persist.Types (PersistValue(..))+import Database.Persist.Sql (PersistFieldSql, SqlType(..), sqlType)++import Network.Haskoin.Block+import Network.Haskoin.Crypto+import Network.Haskoin.Script+import Network.Haskoin.Transaction+import Network.Haskoin.Node+import Network.Haskoin.Util++type KeyRingName = Text+type AccountName = Text++-- TODO: Add NFData instances for all those types++{- Request Types -}++data TxType+ = TxIncoming+ | TxOutgoing+ | TxSelf+ deriving (Eq, Show, Read)++instance NFData TxType where+ rnf x = x `seq` ()++$(deriveJSON (dropSumLabels 2 0 "") ''TxType)++data TxConfidence+ = TxOffline+ | TxDead+ | TxPending+ | TxBuilding+ deriving (Eq, Show, Read)++instance NFData TxConfidence where+ rnf x = x `seq` ()++$(deriveJSON (dropFieldLabel 2) ''TxConfidence)++data AddressInfo = AddressInfo+ { addressInfoAddress :: !Address+ , addressInfoValue :: !(Maybe Word64)+ , addressInfoIsLocal :: !Bool+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 11) ''AddressInfo)++instance NFData AddressInfo where+ rnf AddressInfo{..} =+ rnf addressInfoAddress `seq`+ rnf addressInfoValue `seq`+ rnf addressInfoIsLocal++data BalanceInfo = BalanceInfo+ { balanceInfoInBalance :: !Word64+ , balanceInfoOutBalance :: !Word64+ , balanceInfoCoins :: !Int+ , balanceInfoSpentCoins :: !Int+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 11) ''BalanceInfo)++instance NFData BalanceInfo where+ rnf BalanceInfo{..} =+ rnf balanceInfoInBalance `seq`+ rnf balanceInfoOutBalance `seq`+ rnf balanceInfoCoins `seq`+ rnf balanceInfoSpentCoins++data NewKeyRing = NewKeyRing+ { newKeyRingKeyRingName :: !KeyRingName+ , newKeyRingPassphrase :: !(Maybe Text)+ , newKeyRingMnemonic :: !(Maybe Text)+ } deriving (Eq, Read, Show)++$(deriveJSON (dropFieldLabel 10) ''NewKeyRing)++data AccountType+ = AccountRegular+ { accountTypeRead :: !Bool }+ | AccountMultisig+ { accountTypeRead :: !Bool+ , accountTypeRequiredSigs :: !Int+ , accountTypeTotalKeys :: !Int+ }+ deriving (Eq, Show, Read)++instance NFData AccountType where+ rnf t = case t of+ AccountRegular r -> rnf r+ AccountMultisig r m n -> rnf r `seq` rnf m `seq` rnf n++instance ToJSON AccountType where+ toJSON accType = case accType of+ AccountRegular r -> object+ [ "type" .= String "regular"+ , "readonly" .= r+ ]+ AccountMultisig r m n -> object+ [ "type" .= String "multisig"+ , "readonly" .= r+ , "requiredsigs" .= m+ , "totalkeys" .= n+ ]++instance FromJSON AccountType where+ parseJSON = withObject "AccountType" $ \o ->+ o .: "type" >>= \t -> case (t :: Text) of+ "regular" -> AccountRegular <$> o .: "readonly"+ "multisig" -> AccountMultisig <$> o .: "readonly"+ <*> o .: "requiredsigs"+ <*> o .: "totalkeys"+ _ -> mzero++data NewAccount = NewAccount+ { newAccountAccountName :: !AccountName+ , newAccountType :: !AccountType+ , newAccountKeys :: ![XPubKey]+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 10) ''NewAccount)++data SetAccountGap = SetAccountGap { getAccountGap :: !Word32 }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 10) ''SetAccountGap)++data PageRequest = PageRequest+ { pageNum :: !Word32+ , pageLen :: !Word32+ , pageReverse :: !Bool+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 0) ''PageRequest)++validPageRequest :: PageRequest -> Bool+validPageRequest PageRequest{..} = pageNum >= 1 && pageLen >= 1++data CoinSignData = CoinSignData+ { coinSignOutPoint :: !OutPoint+ , coinSignScriptOutput :: !ScriptOutput+ , coinSignDeriv :: !SoftPath+ }+ deriving (Eq, Show)++$(deriveJSON (dropFieldLabel 8) ''CoinSignData)++data OfflineTxData = OfflineTxData+ { offlineTxDataTx :: !Tx+ , offlineTxDataCoinData :: ![CoinSignData]+ }++$(deriveJSON (dropFieldLabel 13) ''OfflineTxData)++data TxAction+ = CreateTx+ { accTxActionRecipients :: ![(Address, Word64)]+ , accTxActionFee :: !Word64+ , accTxActionMinConf :: !Word32+ , accTxActionRcptFee :: !Bool+ , accTxActionSign :: !Bool+ }+ | ImportTx+ { accTxActionTx :: !Tx }+ | SignTx+ { accTxActionHash :: !TxHash }+ deriving (Eq, Show)++instance ToJSON TxAction where+ toJSON (CreateTx recipients fee minConf rcptFee sign) = object $+ [ "type" .= ("createtx" :: Text)+ , "recipients" .= recipients+ , "fee" .= fee+ , "minconf" .= minConf+ , "sign" .= sign+ ] ++ [ "rcptfee" .= True | rcptFee ]+ toJSON (ImportTx tx) = object+ [ "type" .= ("importtx" :: Text)+ , "tx" .= tx+ ]+ toJSON (SignTx txid) = object+ [ "type" .= ("signtx" :: Text)+ , "hash" .= txid+ ]++instance FromJSON TxAction where+ parseJSON = withObject "TxAction" $ \o -> do+ t <- o .: "type"+ case (t :: Text) of+ "createtx" -> do+ recipients <- o .: "recipients"+ fee <- o .: "fee"+ minConf <- o .: "minconf"+ sign <- o .: "sign"+ rcptFee <- o .:? "rcptfee" .!= False+ return (CreateTx recipients fee minConf rcptFee sign)+ "importtx" -> do+ tx <- o .: "tx"+ return (ImportTx tx)+ "signtx" -> do+ txid <- o .: "hash"+ return (SignTx txid)+ _ -> mzero++data AddressLabel = AddressLabel { addressLabelLabel :: !Text }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 12) ''AddressLabel)++data NodeAction+ = NodeActionRescan { nodeActionTimestamp :: !(Maybe Word32) }+ | NodeActionStatus+ deriving (Eq, Show, Read)++instance ToJSON NodeAction where+ toJSON na = case na of+ NodeActionRescan tM -> object $+ ("type" .= String "rescan") : (("timestamp" .=) <$> maybeToList tM)+ NodeActionStatus -> object [ "type" .= String "status" ]++instance FromJSON NodeAction where+ parseJSON = withObject "NodeAction" $ \o -> do+ String t <- o .: "type"+ case t of+ "rescan" -> NodeActionRescan <$> o .:? "timestamp"+ "status" -> return NodeActionStatus+ _ -> mzero++data AddressType+ = AddressInternal+ | AddressExternal+ deriving (Eq, Show, Read)++$(deriveJSON (dropSumLabels 7 0 "") ''AddressType)++instance NFData AddressType where+ rnf x = x `seq` ()++addrTypeIndex :: AddressType -> KeyIndex+addrTypeIndex AddressExternal = 0+addrTypeIndex AddressInternal = 1++data WalletRequest+ = GetKeyRingsR+ | GetKeyRingR !KeyRingName+ | PostKeyRingsR !NewKeyRing+ | GetAccountsR !KeyRingName+ | PostAccountsR !KeyRingName !NewAccount+ | GetAccountR !KeyRingName !AccountName+ | PostAccountKeysR !KeyRingName !AccountName ![XPubKey]+ | PostAccountGapR !KeyRingName !AccountName !SetAccountGap+ | GetAddressesR !KeyRingName !AccountName+ !AddressType !Word32 !Bool !PageRequest+ | GetAddressesUnusedR !KeyRingName !AccountName !AddressType+ | GetAddressR !KeyRingName !AccountName !KeyIndex !AddressType+ !Word32 !Bool+ | PutAddressR !KeyRingName !AccountName !KeyIndex !AddressType !AddressLabel+ | PostAddressesR !KeyRingName !AccountName !KeyIndex !AddressType+ | GetTxsR !KeyRingName !AccountName !PageRequest+ | GetAddrTxsR !KeyRingName !AccountName !KeyIndex !AddressType !PageRequest+ | PostTxsR !KeyRingName !AccountName !TxAction+ | GetTxR !KeyRingName !AccountName !TxHash+ | GetOfflineTxR !KeyRingName !AccountName !TxHash+ | PostOfflineTxR !KeyRingName !AccountName !Tx ![CoinSignData]+ | GetBalanceR !KeyRingName !AccountName !Word32 !Bool+ | PostNodeR !NodeAction++-- TODO: Set omitEmptyContents on aeson-0.9+$(deriveJSON+ defaultOptions+ { constructorTagModifier = map toLower . init+ , sumEncoding = defaultTaggedObject+ { tagFieldName = "method"+ , contentsFieldName = "request"+ }+ }+ ''WalletRequest+ )++{- JSON Types -}++data JsonKeyRing = JsonKeyRing+ { jsonKeyRingName :: !Text+ , jsonKeyRingMaster :: !(Maybe XPrvKey)+ , jsonKeyRingMnemonic :: !(Maybe Mnemonic)+ , jsonKeyRingCreated :: !UTCTime+ }+ deriving (Eq, Show, Read)++instance ToJSON JsonKeyRing where+ toJSON jkr = object+ [ "name" .= jsonKeyRingName jkr+ , "master" .= jsonKeyRingMaster jkr+ , "mnemonic" .= fmap (String . cs) (jsonKeyRingMnemonic jkr)+ , "created" .= jsonKeyRingCreated jkr+ ]++instance FromJSON JsonKeyRing where+ parseJSON = withObject "JsonKeyRing" $ \o -> do+ name <- o .: "name"+ master <- o .: "master"+ mnemonic <- o .:? "mnemonic" .!= Nothing+ created <- o .: "created"+ return JsonKeyRing+ { jsonKeyRingName = name+ , jsonKeyRingMaster = master+ , jsonKeyRingMnemonic = cs <$> (mnemonic :: Maybe Text)+ , jsonKeyRingCreated = created+ }++data JsonWithKeyRing a = JsonWithKeyRing+ { withKeyRingKeyRing :: !JsonKeyRing+ , withKeyRingData :: !a+ }++$(deriveJSON (dropFieldLabel 11) ''JsonWithKeyRing)++data JsonAccount = JsonAccount+ { jsonAccountName :: !Text+ , jsonAccountType :: !AccountType+ , jsonAccountDerivation :: !(Maybe HardPath)+ , jsonAccountKeys :: ![XPubKey]+ , jsonAccountGap :: !Word32+ , jsonAccountCreated :: !UTCTime+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 11) ''JsonAccount)++data JsonWithAccount a = JsonWithAccount+ { withAccountKeyRing :: !JsonKeyRing+ , withAccountAccount :: !JsonAccount+ , withAccountData :: !a+ }++$(deriveJSON (dropFieldLabel 11) ''JsonWithAccount)++data JsonAddr = JsonAddr+ { jsonAddrAddress :: !Address+ , jsonAddrIndex :: !KeyIndex+ , jsonAddrType :: !AddressType+ , jsonAddrLabel :: !Text+ , jsonAddrFullDerivation :: !(Maybe DerivPath)+ , jsonAddrDerivation :: !SoftPath+ , jsonAddrRedeem :: !(Maybe ScriptOutput)+ , jsonAddrKey :: !(Maybe PubKeyC)+ , jsonAddrCreated :: !UTCTime+ -- Optional Balance+ , jsonAddrBalance :: !(Maybe BalanceInfo)+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 8) ''JsonAddr)++data JsonWithAddr a = JsonWithAddr+ { withAddrKeyRing :: !JsonKeyRing+ , withAddrAccount :: !JsonAccount+ , withAddrAddress :: !JsonAddr+ , withAddrData :: !a+ }++$(deriveJSON (dropFieldLabel 8) ''JsonWithAddr)++data JsonTx = JsonTx+ { jsonTxHash :: !TxHash+ , jsonTxNosigHash :: !TxHash+ , jsonTxType :: !TxType+ , jsonTxInValue :: !Word64+ , jsonTxOutValue :: !Word64+ , jsonTxValue :: !Int64+ , jsonTxInputs :: ![AddressInfo]+ , jsonTxOutputs :: ![AddressInfo]+ , jsonTxChange :: ![AddressInfo]+ , jsonTxTx :: !Tx+ , jsonTxIsCoinbase :: !Bool+ , jsonTxConfidence :: !TxConfidence+ , jsonTxConfirmedBy :: !(Maybe BlockHash)+ , jsonTxConfirmedHeight :: !(Maybe Word32)+ , jsonTxConfirmedDate :: !(Maybe Word32)+ , jsonTxCreated :: !UTCTime+ -- Optional confirmation+ , jsonTxConfirmations :: !(Maybe Word32)+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 6) ''JsonTx)++data JsonCoin = JsonCoin+ { jsonCoinHash :: !TxHash+ , jsonCoinPos :: !Word32+ , jsonCoinValue :: !Word64+ , jsonCoinScript :: !ScriptOutput+ , jsonCoinCreated :: !UTCTime+ -- Optional Tx+ , jsonCoinTx :: !(Maybe JsonTx)+ -- Optional Address+ , jsonCoinAddress :: !(Maybe JsonAddr)+ -- Optional spender+ , jsonCoinSpendingTx :: !(Maybe JsonTx)+ }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 8) ''JsonCoin)++{- Response Types -}++data AddrTx = AddrTx+ { addrTxTx :: !JsonTx+ , addrTxBalance :: !BalanceInfo+ }++$(deriveJSON (dropFieldLabel 6) ''AddrTx)++data TxCompleteRes = TxCompleteRes+ { txCompleteTx :: !Tx+ , txCompleteComplete :: !Bool+ } deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 10) ''TxCompleteRes)++data PageRes a = PageRes+ { pageResPage :: ![a]+ , pageResMaxPage :: !Word32+ }++$(deriveJSON (dropFieldLabel 7) ''PageRes)++data RescanRes = RescanRes { rescanTimestamp :: !Word32 }+ deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 6) ''RescanRes)++data WalletResponse a+ = ResponseError { responseError :: !Text }+ | ResponseValid { responseResult :: !(Maybe a) }+ deriving (Eq, Show)++$(deriveJSON (dropSumLabels 8 8 "status" ) ''WalletResponse)++{- Helper Types -}++data WalletException = WalletException String+ deriving (Eq, Read, Show, Typeable)++instance Exception WalletException++{- Persistent Instances -}++instance PersistField XPrvKey where+ toPersistValue = PersistByteString . xPrvExport+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent XPrvKey" $ xPrvImport bs+ fromPersistValue _ = Left "Invalid Persistent XPrvKey"++instance PersistFieldSql XPrvKey where+ sqlType _ = SqlString++instance PersistField [XPubKey] where+ toPersistValue = PersistByteString . L.toStrict . encode+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent XPubKey" $ decodeStrict' bs+ fromPersistValue _ = Left "Invalid Persistent XPubKey"++instance PersistFieldSql [XPubKey] where+ sqlType _ = SqlString++instance PersistField DerivPath where+ toPersistValue = PersistByteString . cs . pathToStr+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent DerivPath" $ parsePath $ cs bs+ fromPersistValue _ = Left "Invalid Persistent DerivPath"++instance PersistFieldSql DerivPath where+ sqlType _ = SqlString++instance PersistField HardPath where+ toPersistValue = PersistByteString . cs . pathToStr+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent HardPath" $ parseHard $ cs bs+ fromPersistValue _ = Left "Invalid Persistent HardPath"++instance PersistFieldSql HardPath where+ sqlType _ = SqlString++instance PersistField SoftPath where+ toPersistValue = PersistByteString . cs . pathToStr+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent SoftPath" $ parseSoft $ cs bs+ fromPersistValue _ = Left "Invalid Persistent SoftPath"++instance PersistFieldSql SoftPath where+ sqlType _ = SqlString++instance PersistField AccountType where+ toPersistValue = PersistByteString . L.toStrict . encode+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent AccountType" $ decodeStrict' bs+ fromPersistValue _ = Left "Invalid Persistent AccountType"++instance PersistFieldSql AccountType where+ sqlType _ = SqlString++instance PersistField AddressType where+ toPersistValue ts = PersistInt64 $ case ts of+ AddressExternal -> 0+ AddressInternal -> 1++ fromPersistValue (PersistInt64 t) = case t of+ 0 -> return AddressExternal+ 1 -> return AddressInternal+ _ -> Left "Invalid Persistent AddressType"++ fromPersistValue _ = Left "Invalid Persistent AddressType"++instance PersistFieldSql AddressType where+ sqlType _ = SqlInt64++instance PersistField TxType where+ toPersistValue ts = PersistByteString $ case ts of+ TxIncoming -> "incoming"+ TxOutgoing -> "outgoing"+ TxSelf -> "self"++ fromPersistValue (PersistByteString bs) = case bs of+ "incoming" -> return TxIncoming+ "outgoing" -> return TxOutgoing+ "self" -> return TxSelf+ _ -> Left "Invalid Persistent TxType"++ fromPersistValue _ = Left "Invalid Persistent TxType"++instance PersistFieldSql TxType where+ sqlType _ = SqlString++instance PersistField Address where+ toPersistValue = PersistByteString . addrToBase58+ fromPersistValue (PersistByteString a) =+ maybeToEither "Invalid Persistent Address" $ base58ToAddr a+ fromPersistValue _ = Left "Invalid Persistent Address"++instance PersistFieldSql Address where+ sqlType _ = SqlString++instance PersistField BloomFilter where+ toPersistValue = PersistByteString . encode'+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent BloomFilter" $ decodeToMaybe bs+ fromPersistValue _ = Left "Invalid Persistent BloomFilter"++instance PersistFieldSql BloomFilter where+ sqlType _ = SqlBlob++instance PersistField BlockHash where+ toPersistValue = PersistByteString . blockHashToHex+ fromPersistValue (PersistByteString h) =+ maybeToEither "Could not decode BlockHash" $ hexToBlockHash h+ fromPersistValue _ = Left "Invalid Persistent BlockHash"++instance PersistFieldSql BlockHash where+ sqlType _ = SqlString++instance PersistField TxHash where+ toPersistValue = PersistByteString . txHashToHex+ fromPersistValue (PersistByteString h) =+ maybeToEither "Invalid Persistent TxHash" $ hexToTxHash h+ fromPersistValue _ = Left "Invalid Persistent TxHash"++instance PersistFieldSql TxHash where+ sqlType _ = SqlString++instance PersistField TxConfidence where+ toPersistValue tc = PersistByteString $ case tc of+ TxOffline -> "offline"+ TxDead -> "dead"+ TxPending -> "pending"+ TxBuilding -> "building"++ fromPersistValue (PersistByteString bs) = case bs of+ "offline" -> return TxOffline+ "dead" -> return TxDead+ "pending" -> return TxPending+ "building" -> return TxBuilding+ _ -> Left "Invalid Persistent TxConfidence"+ fromPersistValue _ = Left "Invalid Persistent TxConfidence"++instance PersistFieldSql TxConfidence where+ sqlType _ = SqlString++instance PersistField Tx where+ toPersistValue = PersistByteString . encode'+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent Tx" $ decodeToMaybe bs+ fromPersistValue _ = Left "Invalid Persistent Tx"++instance PersistFieldSql Tx where+ sqlType _ = SqlOther "MEDIUMBLOB"++instance PersistField PubKeyC where+ toPersistValue = PersistByteString . encodeHex . encode'+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent PubKeyC" $+ decodeToMaybe =<< decodeHex bs+ fromPersistValue _ = Left "Invalid Persistent PubKeyC"++instance PersistFieldSql PubKeyC where+ sqlType _ = SqlString++instance PersistField ScriptOutput where+ toPersistValue = PersistByteString . encodeOutputBS+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent ScriptOutput" $+ eitherToMaybe $ decodeOutputBS bs+ fromPersistValue _ = Left "Invalid Persistent ScriptOutput"++instance PersistFieldSql ScriptOutput where+ sqlType _ = SqlBlob++instance PersistField [AddressInfo] where+ toPersistValue = PersistByteString . L.toStrict . encode+ fromPersistValue (PersistByteString bs) =+ maybeToEither "Invalid Persistent AddressInfo" $ decodeStrict' bs+ fromPersistValue _ = Left "Invalid Persistent AddressInfo"++instance PersistFieldSql [AddressInfo] where+ sqlType _ = SqlString+
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Network.Haskoin.Wallet.Client++main :: IO ()+main = clientMain+
+ config/config.yml view
@@ -0,0 +1,120 @@+# ZeroMQ socket on which to listen to. Either absolute path or relative to+# work-dir/network.+bind-socket: ipc://hw.sock++# Server mode. Can be either online or offline. In offline mode, the SPV+# daemon does not start and only the local wallet is available to query.+server-mode: online++# False positive rate for the bloom filters.+bloom-false-positive: 0.00001++# Database connection information.+database:+ testnet:+ sqlite:+ database: hw-wallet.sqlite3+ poolsize: 1+ mysql:+ database: haskoin_wallet_testnet+ poolsize: 1+ user: root+ password: ""+ host: localhost+ port: 5432+ prodnet:+ sqlite:+ database: hw-wallet.sqlite3+ poolsize: 1+ mysql:+ database: haskoin_wallet+ poolsize: 1+ user: root+ password: ""+ host: localhost+ port: 5432++# List of trusted bitcoin full-nodes to connect to.+bitcoin-full-nodes:+ testnet:+ - host: testnet-seed.alexykot.me+ port: 18333+ - host: testnet-seed.bitcoin.petertodd.org+ port: 18333+ - host: testnet-seed.bluematt.me+ port: 18333+ - host: testnet-seed.bitcoin.schildbach.de+ port: 18333+ prodnet:+ - host: seed.bitcoin.sipa.be+ port: 8333+ - host: dnsseed.bluematt.me+ port: 8333+ - host: dnsseed.bitcoin.dashjr.org+ port: 8333+ - host: seed.bitcoinstats.com+ port: 8333+ - host: bitseed.xf2.org+ port: 8333+ - host: seed.bitcoin.jonasschnelli.ch+ port: 8333+++# Log file name. Either absolute path or relative to work-dir/network+log-file: hw.log++# PID file name. Either absolute path or relative to work-dir/network.+pid-file: hw.pid++# Compile time configuration value. Either absolute path or relative to+# work-dir. Can only be set as environment variable.+config-file: config.yml++# Default keyring name+keyring-name: main++# Default output size for commands such as page sizes.+output-size: 10++# Type of addresses to display. Example: external, internal+address-type: external++# Use reverse paging for diplaying addresses and txs when set to True.+reverse-paging: false++# Sign new and imported transactions.+sign-transactions: true++# Default fee to pay (in satoshi) for every 1000 bytes.+transaction-fee: 10000++# Minimum number of confirmations for spending coins and displaying balances.+minimum-confirmations: 0++# Display the balance including offline transactions+offline: false++# How command-line output should be displayed. Supported values are:+# normal, json or yaml.+display-format: normal++# Detach the SPV server from the terminal when launched+detach-server: false++# ZeroMQ socket to communicate with the server.+# Either absolute path or relative to the server work-dir/network path.+connect-uri: ipc://hw.sock++# Use Testnet3+use-testnet: false++# Haskoin working directory. Either absolute path or relative to user’s home.+# Defaults to an appropriate OS-specific value.+work-dir: ""++# Log level. Valid values are debug, info, warn and error.+log-level: info++# Print verbose+verbose: false+
+ config/help view
@@ -0,0 +1,47 @@+Server commands:+ start [--detach] Start the haskoin daemon+ stop Stop the haskoin daemon+ status [--verbose] Display node runtime information++KeyRing commands:+ newkeyring [mnemonic] [-k name] Create a new keyring+ keyring [-k name] Display keyrings by name+ keyrings List all keyrings++Account commands:+ newacc name Create a new account+ newms name M N [pubkey...] Create a new multisig account+ newread name pubkey Create a new read-only account+ newreadms name M N [pubkey...] Create a new read-only ms account+ addkeys acc {pubkey...} Add pubkeys to a multisig account+ setgap acc gap Set the address gap for an account+ accounts List all accounts in a keyring+ account acc Display an account by name++Address commands:+ list acc [page] [-c pagesize] [-r] Display addresses by page+ unused acc Display unused addresses+ label acc index label Set the label of an address+ addrtxs acc index [page] [-c pagesize] Display txs related to an address+ genaddrs acc index [--internal] Generate addresses up to this index++Transaction commands:+ txs acc [page] [-c pagesize] [-r] Display transactions by page+ send acc addr amount [-S] Send coins to an address+ sendmany acc {addr:amount...} [-S] Send coins to many addresses+ import acc tx Import a transaction (does not sign)+ sign acc txid Sign one of your offline transactions+ balance acc [--minconf] [--offline] Display account balance+ gettx acc txid Get a transaction by txid++Offline tx signing commands:+ getoffline acc txhash Get data to sign a tx offline+ signoffline acc tx coindata Sign a tx with offline signing data++Utility commands:+ decodetx tx Decode HEX transaction+ rescan [timestamp] Rescan the wallet++Other commands:+ version Display version information+ help Display this help information
+ config/models view
@@ -0,0 +1,93 @@+KeyRing+ name Text maxlen=200+ master XPrvKey maxlen=200+ created UTCTime+ UniqueKeyRing name+ deriving Show++KeyRingAccount+ keyRing KeyRingId+ name Text maxlen=200+ type AccountType maxlen=64+ derivation HardPath Maybe maxlen=200+ keys [XPubKey]+ gap Word32+ created UTCTime+ UniqueAccount keyRing name+ deriving Show++KeyRingAddr+ account KeyRingAccountId+ address Address maxlen=64+ index KeyIndex+ type AddressType maxlen=16+ label Text+ fullDerivation DerivPath Maybe maxlen=200+ derivation SoftPath maxlen=200+ redeem ScriptOutput Maybe+ key PubKeyC Maybe maxlen=66+ created UTCTime+ UniqueAddr account address+ UniqueAddrRev address account+ UniqueAddrIndex account type index+ deriving Show++KeyRingTx+ account KeyRingAccountId+ hash TxHash maxlen=64+ nosigHash TxHash maxlen=64+ type TxType maxlen=16+ inValue Word64+ outValue Word64+ inputs [AddressInfo]+ outputs [AddressInfo]+ change [AddressInfo]+ tx Tx+ isCoinbase Bool+ confidence TxConfidence maxlen=16+ confirmedBy BlockHash Maybe maxlen=64+ confirmedHeight BlockHeight Maybe+ confirmedDate Timestamp Maybe+ created UTCTime+ UniqueAccTx account hash+ UniqueAccTxRev hash account+ UniqueAccNoSig account nosigHash+ UniqueAccNoSigRev nosigHash account+ deriving Show++KeyRingCoin+ account KeyRingAccountId+ hash TxHash maxlen=64+ pos Word32+ tx KeyRingTxId+ addr KeyRingAddrId+ value Word64+ script ScriptOutput+ created UTCTime+ UniqueCoin account hash pos+ UniqueCoinRev hash pos account+ UniqueCoinTx tx pos+ UniqueCoinTxRev pos tx+ deriving Show++KeyRingSpentCoin+ account KeyRingAccountId+ hash TxHash maxlen=64+ pos Word32+ spendingTx KeyRingTxId+ created UTCTime+ UniqueSpentCoins account hash pos+ UniqueSpentCoinsRev hash pos account+ UniqueSpentTx spendingTx hash pos+ UniqueSpentTxRev hash pos spendingTx+ deriving Show++KeyRingConfig+ height BlockHeight+ block BlockHash maxlen=64+ bloomFilter BloomFilter+ bloomElems Int+ bloomFp Double+ version Int+ created UTCTime+ deriving Show
+ database/mysql/Network/Haskoin/Wallet/Database.hs view
@@ -0,0 +1,21 @@+module Network.Haskoin.Wallet.Database where++import Control.Monad.Logger (runNoLoggingT)++import Data.Text (Text)++import Database.Persist.MySQL (MySQLConf(..), createMySQLPool)+import Database.Persist.Sql (ConnectionPool)++type DatabaseConfType = MySQLConf++databaseEngine :: Text+databaseEngine = "mysql"++getDatabasePool :: DatabaseConfType -> IO ConnectionPool+getDatabasePool conf = runNoLoggingT $+ createMySQLPool (myConnInfo conf) (myPoolSize conf)++paramLimit :: Int+paramLimit = 20+
+ database/sqlite/Network/Haskoin/Wallet/Database.hs view
@@ -0,0 +1,21 @@+module Network.Haskoin.Wallet.Database where++import Control.Monad.Logger (runNoLoggingT)++import Data.Text (Text)++import Database.Persist.Sql (ConnectionPool)+import Database.Persist.Sqlite (SqliteConf(..), createSqlitePool)++type DatabaseConfType = SqliteConf++databaseEngine :: Text+databaseEngine = "sqlite"++getDatabasePool :: DatabaseConfType -> IO ConnectionPool+getDatabasePool conf = runNoLoggingT $+ createSqlitePool (sqlDatabase conf) (sqlPoolSize conf)++paramLimit :: Int+paramLimit = 20+
haskoin-wallet.cabal view
@@ -1,17 +1,15 @@ name: haskoin-wallet-version: 0.0.1-synopsis: - Implementation of a Bitcoin hierarchical deterministric wallet (BIP32).-description: - This package provides functions for generating hierarchical deterministic- keys (BIP32). It also provides functions for building and signing both- simple transactions and multisignature transactions. This package also- provides a command lines application called hw (haskoin wallet). It is a- lightweight bitcoin wallet featuring BIP32 key management, deterministic- signatures (RFC-6979) and first order support for multisignature- transactions. A library API for hw is also exposed.-homepage: http://github.com/plaprade/haskoin-wallet-bug-reports: http://github.com/plaprade/haskoin-wallet/issues+version: 0.2.0+synopsis:+ Implementation of a Bitcoin SPV Wallet with BIP32 and multisig support.+description:+ This package provides a SPV (simple payment verification) wallet+ implementation. It features BIP32 key management, deterministic signatures+ (RFC-6979) and first order support for multi-signature transactions. You+ can communicate with the wallet process through a ZeroMQ API or through a+ command-line tool called "hw" which is also provided in this package.+homepage: http://github.com/haskoin/haskoin+bug-reports: http://github.com/haskoin/haskoin/issues license: PublicDomain license-file: UNLICENSE author: Philippe Laprade@@ -19,108 +17,138 @@ category: Bitcoin, Finance, Network build-type: Simple cabal-version: >= 1.9.2+extra-source-files: database/sqlite/Network/Haskoin/Wallet/Database.hs,+ database/mysql/Network/Haskoin/Wallet/Database.hs,+ stack.yaml,+ config/help, config/config.yml, config/models source-repository head type: git- location: git://github.com/plaprade/haskoin-wallet.git+ location: git://github.com/haskoin/haskoin.git +Flag mysql+ Description: Use MySQL instead of Sqlite+ Default: False++Flag library-only+ Description: Do not build the executables+ Default: False+ library- exposed-modules: Network.Haskoin.Wallet,- Network.Haskoin.Wallet.Store,- Network.Haskoin.Wallet.Arbitrary- other-modules: Network.Haskoin.Wallet.Keys,- Network.Haskoin.Wallet.Manager,- Network.Haskoin.Wallet.TxBuilder,- Network.Haskoin.Wallet.Store.DbAccount,- Network.Haskoin.Wallet.Store.DbAddress,- Network.Haskoin.Wallet.Store.DbCoin,- Network.Haskoin.Wallet.Store.DbTx,- Network.Haskoin.Wallet.Store.CoinStatus,- Network.Haskoin.Wallet.Store.Util- build-depends: base >= 4.6 && < 4.7, - binary >= 0.7 && < 0.8, - bytestring >= 0.10 && < 0.11, - mtl >= 2.1 && < 2.2,- containers >= 0.5 && < 0.6,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.11,- either >= 4.0 && < 4.1,- text >= 0.11 && < 0.12,- yaml >= 0.8 && < 0.9,- time >= 1.4 && < 1.5,- aeson >= 0.6 && < 0.7,- aeson-pretty >= 0.7 && < 0.8,- conduit >= 1.0 && < 1.1,- persistent >= 1.2 && < 1.3,- persistent-template >= 1.2 && < 1.3,- persistent-sqlite >= 1.2 && < 1.3,- haskoin-util >= 0.0 && < 0.1, - haskoin-crypto >= 0.0 && < 0.1, - haskoin-protocol >= 0.0 && < 0.1,- haskoin-script >= 0.0 && < 0.1,- QuickCheck >= 2.6 && < 2.7- ghc-options: -Wall -fno-warn-orphans+ exposed-modules: Network.Haskoin.Wallet+ Network.Haskoin.Wallet.Model+ Network.Haskoin.Wallet.Client+ Network.Haskoin.Wallet.Server+ Network.Haskoin.Wallet.Settings+ Network.Haskoin.Wallet.Internals + other-modules: Network.Haskoin.Wallet.Types+ Network.Haskoin.Wallet.KeyRing+ Network.Haskoin.Wallet.Transaction+ Network.Haskoin.Wallet.Server.Handler+ Network.Haskoin.Wallet.Client.Commands+ Network.Haskoin.Wallet.Database++ extensions: TemplateHaskell+ QuasiQuotes+ OverloadedStrings+ MultiParamTypeClasses+ TypeFamilies+ GADTs+ FlexibleContexts+ FlexibleInstances+ EmptyDataDecls+ DeriveDataTypeable+ RecordWildCards+ GeneralizedNewtypeDeriving++ build-depends: aeson >= 0.7 && < 0.9+ , aeson-pretty >= 0.7 && < 0.8+ , base >= 4.8 && < 5+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.5 && < 0.6+ , conduit >= 1.2 && < 1.3+ , deepseq >= 1.4 && < 1.5+ , data-default >= 0.5 && < 0.6+ , directory >= 1.2 && < 1.3+ , daemons >= 0.2 && < 0.3+ , exceptions >= 0.6 && < 0.9+ , esqueleto >= 2.4 && < 2.5+ , file-embed >= 0.0 && < 0.1+ , filepath >= 1.4 && < 1.5+ , haskoin-core >= 0.2 && < 0.3+ , haskoin-node >= 0.2 && < 0.3+ , leveldb-haskell >= 0.6 && < 0.7+ , lifted-async >= 0.2 && < 0.8+ , lifted-base >= 0.2 && < 0.3+ , monad-logger >= 0.3.13 && < 0.4+ , monad-control >= 1.0 && < 1.1+ , mtl >= 2.1 && < 2.3+ , persistent >= 2.2 && < 2.3+ , persistent-template >= 2.1 && < 2.2+ , resourcet >= 1.1 && < 1.2+ , SafeSemaphore >= 0.10 && < 0.11+ , split >= 0.2 && < 0.3+ , stm >= 2.4 && < 2.5+ , stm-chans >= 3.0 && < 3.1+ , stm-conduit >= 2.6 && < 2.7+ , string-conversions >= 0.4 && < 0.5+ , text >= 0.11 && < 1.3+ , time >= 1.5 && < 1.6+ , transformers-base >= 0.4 && < 0.5+ , unix >= 2.6 && < 2.8+ , unordered-containers >= 0.2 && < 0.3+ , yaml >= 0.8 && < 0.9+ , zeromq4-haskell >= 0.6 && < 0.7++ ghc-options: -Wall++ if flag(mysql)+ build-depends: persistent-mysql >= 2.2 && < 2.3+ hs-source-dirs: . database/mysql+ else+ build-depends: persistent-sqlite >= 2.2 && < 2.3+ hs-source-dirs: . database/sqlite+ executable hw- main-is: hw.hs- build-depends: base >= 4.6 && < 4.7, - binary >= 0.7 && < 0.8, - bytestring >= 0.10 && < 0.11, - mtl >= 2.1 && < 2.2,- containers >= 0.5 && < 0.6,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.11,- directory >= 1.2 && < 1.3,- either >= 4.0 && < 4.1,- text >= 0.11 && < 0.12,- yaml >= 0.8 && < 0.9,- time >= 1.4 && < 1.5,- aeson >= 0.6 && < 0.7,- aeson-pretty >= 0.7 && < 0.8,- conduit >= 1.0 && < 1.1,- persistent >= 1.2 && < 1.3,- persistent-template >= 1.2 && < 1.3,- persistent-sqlite >= 1.2 && < 1.3,- haskoin-util >= 0.0 && < 0.1, - haskoin-crypto >= 0.0 && < 0.1, - haskoin-protocol >= 0.0 && < 0.1,- haskoin-script >= 0.0 && < 0.1- hs-source-dirs: . script- ghc-options: -Wall -fno-warn-orphans+ if flag(library-only)+ Buildable: False+ main-is: Main.hs+ build-depends: base, haskoin-wallet+ hs-source-dirs: app+ ghc-options: -Wall test-suite test-haskoin-wallet- type: exitcode-stdio-1.0- main-is: Main.hs- other-modules: Network.Haskoin.Wallet.Tests,- Network.Haskoin.Wallet.Store.Units,- QuickCheckUtils,- Units- build-depends: base >= 4.6 && < 4.7, - binary >= 0.7 && < 0.8, - bytestring >= 0.10 && < 0.11, - mtl >= 2.1 && < 2.2,- containers >= 0.5 && < 0.6,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.11,- either >= 4.0 && < 4.1,- text >= 0.11 && < 0.12,- yaml >= 0.8 && < 0.9,- time >= 1.4 && < 1.5,- aeson >= 0.6 && < 0.7,- aeson-pretty >= 0.7 && < 0.8,- conduit >= 1.0 && < 1.1,- persistent >= 1.2 && < 1.3,- persistent-template >= 1.2 && < 1.3,- persistent-sqlite >= 1.2 && < 1.3,- haskoin-util >= 0.0 && < 0.1, - haskoin-crypto >= 0.0 && < 0.1, - haskoin-protocol >= 0.0 && < 0.1,- haskoin-script >= 0.0 && < 0.1,- QuickCheck >= 2.6 && < 2.7, - test-framework >= 0.8 && < 0.9, - test-framework-quickcheck2 >= 0.3 && < 0.4, - test-framework-hunit >= 0.3 && < 0.4, - HUnit >= 1.2 && < 1.3- hs-source-dirs: . tests- ghc-options: -Wall -fno-warn-orphans+ type: exitcode-stdio-1.0+ main-is: Main.hs++ other-modules: Network.Haskoin.Wallet.Arbitrary+ , Network.Haskoin.Wallet.Tests+ , Network.Haskoin.Wallet.Units ++ extensions: RecordWildCards+ OverloadedStrings++ build-depends: aeson >= 0.7 && < 0.9+ , base >= 4.8 && < 5+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.5 && < 0.6+ , directory >= 1.2 && < 1.3+ , haskoin-core >= 0.2 && < 0.3+ , haskoin-node >= 0.2 && < 0.3+ , haskoin-wallet+ , monad-logger >= 0.3 && < 0.4+ , mtl >= 2.1 && < 2.3+ , persistent >= 2.2 && < 2.3+ , persistent-sqlite >= 2.2 && < 2.3+ , resourcet >= 1.1 && < 1.2+ , text >= 0.11 && < 1.3+ , HUnit >= 1.2 && < 1.3+ , QuickCheck >= 2.8 && < 2.9+ , test-framework >= 0.8 && < 0.9+ , test-framework-quickcheck2 >= 0.3 && < 0.4+ , test-framework-hunit >= 0.3 && < 0.4++ hs-source-dirs: tests+ ghc-options: -Wall
− script/hw.hs
@@ -1,269 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Main where--import System.Directory - ( getAppUserDataDirectory- , createDirectoryIfMissing- )-import System.IO.Error (ioeGetErrorString)-import System.Console.GetOpt - ( getOpt- , usageInfo- , OptDescr( Option )- , ArgDescr( NoArg, ReqArg )- , ArgOrder( Permute )- )-import qualified System.Environment as E (getArgs)--import Control.Monad (forM_, join)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Either (EitherT, runEitherT, left)-import Control.Exception (tryJust)--import Database.Persist- ( PersistStore- , PersistUnique- , PersistQuery- , PersistMonadBackend- )-import Database.Persist.Sql ()-import Database.Persist.Sqlite (SqlBackend, runSqlite, runMigration)--import qualified Data.Text as T (pack, unpack, splitOn)-import qualified Data.Yaml as YAML - ( Value(Null)- , encode- )-import qualified Data.Aeson.Encode.Pretty as JSON- ( encodePretty'- , defConfig- , confIndent- )--import Network.Haskoin.Wallet.Keys-import Network.Haskoin.Wallet.Store-import Network.Haskoin.Wallet.Store.Util-import Network.Haskoin.Script-import Network.Haskoin.Util-import Network.Haskoin.Util.Network--data Options = Options- { optCount :: Int- , optSigHash :: SigHash- , optFee :: Int- , optJson :: Bool- , optHelp :: Bool- , optVersion :: Bool- } deriving (Eq, Show)--defaultOptions :: Options-defaultOptions = Options- { optCount = 5- , optSigHash = SigAll False- , optFee = 10000- , optJson = False- , optHelp = False- , optVersion = False- } --options :: [OptDescr (Options -> IO Options)]-options =- [ Option ['c'] ["count"] (ReqArg parseCount "INT") $- "Count: see commands for details"- , Option ['s'] ["sighash"] (ReqArg parseSigHash "SIGHASH") $- "Signature type = ALL|NONE|SINGLE"- , Option ['a'] ["anyonecanpay"]- (NoArg $ \opts -> do- let sh = optSigHash opts- return opts{ optSigHash = sh{ anyoneCanPay = True } }- ) $ "Set signature flag AnyoneCanPay"- , Option ['f'] ["fee"] (ReqArg parseCount "INT") $- "Transaction fee (default: 10000)"- , Option ['j'] ["json"]- (NoArg $ \opts -> return opts{ optJson = True }) $- "Format result as JSON (default: YAML)"- , Option ['h'] ["help"]- (NoArg $ \opts -> return opts{ optHelp = True }) $- "Display this help message"- , Option ['v'] ["version"]- (NoArg $ \opts -> return opts{ optVersion = True }) $- "Show version information"- ]--parseCount :: String -> Options -> IO Options-parseCount s opts - | res > 0 = return opts{ optCount = res }- | otherwise = error $ unwords ["Invalid count option:", s]- where res = read s--parseSigHash :: String -> Options -> IO Options-parseSigHash s opts = return opts{ optSigHash = res }- where acp = anyoneCanPay $ optSigHash opts- res | s == "ALL" = SigAll acp- | s == "NONE" = SigNone acp- | s == "SINGLE" = SigSingle acp- | otherwise = error "SigHash must be one of ALL|NONE|SINGLE"--usageHeader :: String-usageHeader = "Usage: hw [<options>] <command> [<args>]"--cmdHelp :: [String]-cmdHelp = - [ "hw wallet commands: " - , " init seed Initialize a wallet"- , " list acc Display last page of addresses"- , " listpage acc page [-c res/page] Display addresses by page"- , " new acc {labels...} Generate address with labels"- , " genaddr acc [-c count] Generate new addresses"- , " label acc index label Add a label to an address"- , " balance acc Display account balance"- , " balances Display all balances"- , " tx acc Display transactions"- , " send acc addr amount Send coins to an address"- , " sendmany acc {addr:amount...} Send coins to many addresses"- , " newacc name Create a new account"- , " newms name M N [pubkey...] Create a new multisig account"- , " addkeys acc {pubkey...} Add pubkeys to a multisig account"- , " accinfo acc Display account information"- , " listacc List all accounts"- , " dumpkeys acc Dump account keys to stdout"- , " wif acc index Dump prvkey as WIF to stdout"- , " coins acc List coins"- , " allcoins List all coins per account"- , " signtx acc tx Sign a transaction"- , " importtx tx Import transaction"- , " removetx txid Remove transaction"- , ""- , "hw utility commands: "- , " decodetx tx Decode HEX transaction"- , " buildrawtx"- , " '[{\"txid\":txid,\"vout\":n},...]' '{addr:amnt,...}'"- , " signrawtx " - , " tx" - , " " ++ sigdata- , " '[prvkey,...]' [-s SigHash]" - ]- where - sigdata = concat- [ "'[{"- , "\"txid\":txid,"- , "\"vout\":n,"- , "\"scriptPubKey\":hex,"- , "\"scriptRedeem\":hex"- , "},...]'"- ]--warningMsg :: String-warningMsg = unwords [ "***"- , "This software is experimental."- , "Use only small amounts of Bitcoins"- , "***"- ]--versionMsg :: String-versionMsg = "haskoin wallet version 0.0.1"--usage :: String-usage = unlines $ [warningMsg, usageInfo usageHeader options] ++ cmdHelp--formatStr :: String -> IO ()-formatStr str = forM_ (lines str) putStrLn--main :: IO ()-main = E.getArgs >>= \args -> case getOpt Permute options args of- (o,xs,[]) -> do- opts <- foldl (>>=) (return defaultOptions) o- process opts xs- (_,_,msgs) -> print $ unlines $ msgs ++ [usage]---- Create and return haskoin working directory-getWorkDir :: IO FilePath-getWorkDir = do- dir <- getAppUserDataDirectory "haskoin"- createDirectoryIfMissing True dir- return $ concat [dir, "/", walletFile]--catchEx :: IOError -> Maybe String-catchEx = return . ioeGetErrorString--process :: Options -> [String] -> IO ()-process opts xs - -- -h and -v can be called without a command- | optHelp opts = formatStr usage- | optVersion opts = print versionMsg- -- otherwise require a command- | null xs = formatStr usage- | otherwise = getWorkDir >>= \dir -> do- let (cmd,args) = (head xs, tail xs)- res <- tryJust catchEx $ runSqlite (T.pack dir) $ runEitherT $ do- lift $ runMigration migrateAll- dispatchCommand cmd opts args - case join res of- Left err -> formatStr err- Right val -> if val == YAML.Null then return () else if optJson opts - then formatStr $ bsToString $ toStrictBS $ - JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } val- else formatStr $ bsToString $ YAML.encode val--type Command m = EitherT String m YAML.Value-type Args = [String]--whenArgs :: Monad m => Args -> (Int -> Bool) -> Command m -> Command m-whenArgs args f cmd = if f $ length args then cmd else argErr- where argErr = left "Invalid number of arguments"--dispatchCommand :: ( PersistStore m, PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- ) - => String -> Options -> Args -> Command m-dispatchCommand cmd opts args = case cmd of- "init" -> whenArgs args (== 1) $ cmdInit $ head args- "list" -> whenArgs args (== 1) $ cmdList (head args) 0 (optCount opts)- "listpage" -> whenArgs args (== 2) $ - cmdList (head args) (read $ args !! 1) (optCount opts)- "new" -> whenArgs args (>= 2) $ cmdGenWithLabel (head args) $ drop 1 args- "genaddr" -> whenArgs args (== 1) $ cmdGenAddrs (head args) (optCount opts)- "label" -> whenArgs args (== 3) $ - cmdLabel (head args) (read $ args !! 1) (args !! 2)- "balance" -> whenArgs args (== 1) $ cmdBalance $ head args- "balances" -> whenArgs args (== 0) cmdBalances- "tx" -> whenArgs args (== 1) $ cmdListTx $ head args- "send" -> whenArgs args (== 3) $ - cmdSend (head args) (args !! 1) (read $ args !! 2) (optFee opts)- "sendmany" -> whenArgs args (>= 2) $ do- let f [a,b] = (T.unpack a,read $ T.unpack b)- f _ = error "sendmany: Invalid format addr:amount"- dests = map (f . (T.splitOn (T.pack ":")) . T.pack) $ drop 1 args- cmdSendMany (head args) dests (optFee opts)- "newacc" -> whenArgs args (== 1) $ cmdNewAcc $ head args- "newms" -> whenArgs args (>= 3) $ do- keys <- liftMaybe "newms: Invalid keys" $ mapM xPubImport $ drop 3 args- cmdNewMS (args !! 0) (read $ args !! 1) (read $ args !! 2) keys- "addkeys" -> whenArgs args (>= 2) $ do- keys <- liftMaybe "newms: Invalid keys" $ mapM xPubImport $ drop 1 args- cmdAddKeys (head args) keys- "accinfo" -> whenArgs args (== 1) $ cmdAccInfo $ head args- "listacc" -> whenArgs args (== 0) cmdListAcc - "dumpkeys" -> whenArgs args (== 1) $ cmdDumpKeys $ head args- "wif" -> whenArgs args (== 2) $ cmdWIF (head args) (read $ args !! 1)- "coins" -> whenArgs args (== 1) $ cmdCoins $ head args- "allcoins" -> whenArgs args (== 0) cmdAllCoins- "signtx" -> whenArgs args (== 2) $ do- bs <- liftMaybe "signtx: Invalid HEX encoding" $ hexToBS $ args !! 1- tx <- liftEither $ decodeToEither bs- cmdSignTx (head args) tx (optSigHash opts)- "importtx" -> whenArgs args (== 1) $ do- bs <- liftMaybe "signtx: Invalid HEX encoding" $ hexToBS $ head args- tx <- liftEither $ decodeToEither bs- cmdImportTx tx- "removetx" -> whenArgs args (== 1) $ cmdRemoveTx $ head args- "decodetx" -> whenArgs args (== 1) $ cmdDecodeTx $ head args- "buildrawtx" -> whenArgs args (== 2) $ cmdBuildRawTx (head args) (args !! 1)- "signrawtx" -> whenArgs args (== 3) $ do - bs <- liftMaybe "signtx: Invalid HEX encoding" $ hexToBS $ head args- tx <- liftEither $ decodeToEither bs- cmdSignRawTx tx (args !! 1) (args !! 2) (optSigHash opts)- _ -> left $ unwords ["Invalid command:", cmd]-
+ stack.yaml view
@@ -0,0 +1,16 @@+flags: {}+packages:+- '.'+- '../haskoin-core'+- '../haskoin-node'+- location:+ git: https://github.com/haskoin/secp256k1.git+ commit: 5ee603061b3c1eaf2943e8d2c08e6effe85f38e7+ extra-dep: true+extra-deps:+- daemons-0.2.1+- leveldb-haskell-0.6.3+- murmur3-1.0.0+- pbkdf-1.1.1.1+- largeword-1.2.4+resolver: lts-3.4
tests/Main.hs view
@@ -2,14 +2,15 @@ import Test.Framework (defaultMain) +import qualified Network.Haskoin.Wallet.Units (tests) import qualified Network.Haskoin.Wallet.Tests (tests)-import qualified Network.Haskoin.Wallet.Store.Units (tests)-import qualified Units (tests) +import Network.Haskoin.Constants+ main :: IO ()-main = defaultMain- ( Network.Haskoin.Wallet.Tests.tests - ++ Network.Haskoin.Wallet.Store.Units.tests- ++ Units.tests - )+main | networkName == "prodnet" = defaultMain+ ( Network.Haskoin.Wallet.Tests.tests+ ++ Network.Haskoin.Wallet.Units.tests+ )+ | otherwise = error "Tests are only available on prodnet"
+ tests/Network/Haskoin/Wallet/Arbitrary.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.Haskoin.Wallet.Arbitrary where++import Test.QuickCheck (Arbitrary, arbitrary, oneof)++import Network.Haskoin.Test+import Network.Haskoin.Wallet++instance Arbitrary AccountType where+ arbitrary = oneof+ [ AccountRegular <$> arbitrary+ , do+ ArbitraryMSParam m n <- arbitrary+ r <- arbitrary+ return $ AccountMultisig r m n+ ]++instance Arbitrary NodeAction where+ arbitrary = oneof [ NodeActionRescan <$> arbitrary+ , return NodeActionStatus+ ]++instance Arbitrary TxAction where+ arbitrary = oneof+ [ do+ as' <- arbitrary+ let as = map (\(ArbitraryAddress a, x) -> (a, x)) as'+ fee <- arbitrary+ rcptFee <- arbitrary+ minConf <- arbitrary+ sign <- arbitrary+ return $ CreateTx as fee rcptFee minConf sign+ , do+ ArbitraryTx tx <- arbitrary+ return (ImportTx tx)+ , SignTx <$> (arbitrary >>= \(ArbitraryTxHash h) -> return h)+ ]+
− tests/Network/Haskoin/Wallet/Store/Units.hs
@@ -1,2548 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-module Network.Haskoin.Wallet.Store.Units (tests) where--import Test.HUnit (Assertion, assertBool, assertEqual)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)--import Control.Applicative ((<$>))-import Control.Monad.Trans (liftIO, lift)-import Control.Monad.Trans.Either (EitherT, runEitherT)--import Data.Maybe (fromJust, isJust)-import Data.Yaml as YAML- ( Value- , object - , toJSON- , (.=)- )-import qualified Data.Text as T (pack)--import Database.Persist - ( PersistStore- , PersistUnique- , PersistQuery- , PersistMonadBackend- , Entity(..)- , entityVal- , getBy- , selectList- , count- , (==.)- , Filter- , SelectOpt(Asc)- )-import Database.Persist.Sqlite (SqlBackend, runSqlite, runMigration)--import Network.Haskoin.Wallet-import Network.Haskoin.Wallet.Store-import Network.Haskoin.Wallet.Store.DbAddress-import Network.Haskoin.Wallet.Store.DbAccount-import Network.Haskoin.Wallet.Store.Util-import Network.Haskoin.Script-import Network.Haskoin.Util--tests :: [Test]-tests =- [ testGroup "Wallet persistence tests" - [ testCase "Wallet tests" runTests- ] - ]--runTests :: Assertion-runTests = do- _ <- runSqlite ":memory:" $ runEitherT $ do- lift $ runMigration migrateAll- liftIO . (assertBool "Pre init") . isRight =<< runEitherT testPreInit- liftIO . (assertBool "Init") . isRight =<< runEitherT testInit- liftIO . (assertBool "New Acc") . isRight =<< runEitherT testNewAcc- liftIO . (assertBool "New MS") . isRight =<< runEitherT testNewMS- liftIO . (assertBool "Gen Addr") . isRight =<< runEitherT testGenAddr- liftIO . (assertBool "Import Tx") . isRight =<< runEitherT testImport- liftIO . (assertBool "Orphan Tx") . isRight =<< runEitherT testOrphan- liftIO . (assertBool "Send Tx") . isRight =<< runEitherT testSend- liftIO . (assertBool "Utilities") . isRight =<< runEitherT testUtil- return ()--testPreInit :: (PersistStore m, PersistUnique m, PersistQuery m) - => EitherT String m ()-testPreInit = do - -- Creating a new account without initializing the wallet should fail- runEitherT (cmdNewAcc "default") >>= - liftIO . assertEqual "Invalid wallet" - (Left "dbGetWallet: Invalid wallet main")-- -- Listing addresses without initializing the wallet should fail- runEitherT (cmdList "default" 0 1) >>= - liftIO . assertEqual "Invalid account" - (Left "dbGetAcc: Invalid account default")-- -- Displaying page numbe -1 should fail- runEitherT (cmdList "default" (-1) 1) >>= - liftIO . assertEqual "Invalid page number" - (Left "cmdList: Invalid page number -1")-- -- Displaying 0 results per page should fail- runEitherT (cmdList "default" 0 0) >>= - liftIO . assertEqual "Invalid results per page" - (Left "cmdList: Invalid results per page 0")--testInit :: (PersistStore m, PersistUnique m, PersistQuery m) - => EitherT String m ()-testInit = do -- -- Initializing the wallet with an empty seed should fail- runEitherT (cmdInit "") >>= liftIO . assertEqual "Init empty seed" - (Left "cmdInit: seed can not be empty") -- -- Initialize wallet with seed "Hello World"- _ <- cmdInit "Hello World" -- walletE <- getBy $ UniqueWalletName "main"- - -- Get the "main" wallet from the database- liftIO $ assertBool "Wallet init" $ isJust walletE-- let (Entity _ w) = fromJust walletE- key = fromJust $ makeMasterKey $ stringToBS "Hello World"- keystr = xPrvExport $ masterKey key-- -- Check wallet master key- liftIO $ assertEqual "Wallet master key" keystr $ dbWalletMaster w-- -- Check wallet name- liftIO $ assertEqual "Wallet name" "main" $ dbWalletName w-- -- Generate addresses on an invalid account should fail- runEitherT (cmdGenAddrs "default" 5) >>= liftIO . - assertEqual "Invalid account" - (Left "dbGetAcc: Invalid account default") -- -- Address count in the database should be 0 at this point- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Address count" 0--testNewAcc :: (PersistStore m, PersistUnique m, PersistQuery m) - => EitherT String m ()-testNewAcc = do -- -- Create a new account with empty name ""- cmdNewAcc "" >>= liftIO . assertEqual "New acc 1"- ( object - [ "Name" .= T.pack ""- , "Tree" .= T.pack "m/0'/"- , "Type" .= T.pack "Regular"- ] - )-- -- Check the wallet account index- (dbWalletAccIndex . entityVal <$> dbGetWallet "main") >>= - liftIO . assertEqual "acc index 0" 0-- -- Create a new account named "acc1"- cmdNewAcc "acc1" >>= liftIO . assertEqual "New acc 2"- ( object - [ "Name" .= T.pack "acc1"- , "Tree" .= T.pack "m/1'/"- , "Type" .= T.pack "Regular"- ] - )-- -- Check the wallet account index- (dbWalletAccIndex . entityVal <$> dbGetWallet "main") >>= - liftIO . assertEqual "acc index 1" 1-- -- Create a new account named "acc2"- cmdNewAcc "acc2" >>= liftIO . assertEqual "New acc 3"- ( object - [ "Name" .= T.pack "acc2"- , "Tree" .= T.pack "m/2'/"- , "Type" .= T.pack "Regular"- ] - )-- -- Check the wallet account index- (dbWalletAccIndex . entityVal <$> dbGetWallet "main") >>= - liftIO . assertEqual "acc index 2" 2-- -- List all accounts created up to now- cmdListAcc >>= liftIO . assertEqual "List accs"- ( toJSON- [ object - [ "Name" .= T.pack ""- , "Tree" .= T.pack "m/0'/"- , "Type" .= T.pack "Regular"- ] - , object - [ "Name" .= T.pack "acc1"- , "Tree" .= T.pack "m/1'/"- , "Type" .= T.pack "Regular"- ] - , object - [ "Name" .= T.pack "acc2"- , "Tree" .= T.pack "m/2'/"- , "Type" .= T.pack "Regular"- ] - ]- )-- -- Initialize some keys for future tests- let mstKey = fromJust $ makeMasterKey $ stringToBS "Hello World"- prvKey = getAccPrvKey $ fromJust $ accPrvKey mstKey 1- pubKey = deriveXPubKey prvKey- - -- Dump keys for account "acc1"- cmdDumpKeys "acc1" >>= liftIO . assertEqual "Dump keys"- ( object - [ "Account" .= object - [ "Name" .= T.pack "acc1"- , "Tree" .= T.pack "m/1'/"- , "Type" .= T.pack "Regular"- ] - , "PubKey" .= xPubExport pubKey- , "PrvKey" .= xPrvExport prvKey- ]- )-- -- Display account information for account "acc2"- cmdAccInfo "acc2" >>= liftIO . assertEqual "Acc info" - ( object - [ "Name" .= T.pack "acc2"- , "Tree" .= T.pack "m/2'/"- , "Type" .= T.pack "Regular"- ] - )-- -- Count accounts in the database created up to now- count ([] :: [Filter (DbAccountGeneric b)]) >>= - liftIO . assertEqual "Acc count" 3-- -- Check that address-related data and gaps are correct- (Entity a1 acc1) <- dbGetAcc ""- (Entity a2 acc2) <- dbGetAcc "acc1"- (Entity a3 acc3) <- dbGetAcc "acc2"-- count [DbAddressAccount ==. a1, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count" 30-- count [DbAddressAccount ==. a1, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count" 30-- count [DbAddressAccount ==. a2, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count 2" 30-- count [DbAddressAccount ==. a2, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count 2" 30-- count [DbAddressAccount ==. a3, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count 3" 30-- count [DbAddressAccount ==. a3, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count 3" 30-- liftIO $ assertEqual "ExtIndex acc 1" (-1) (dbAccountExtIndex acc1)- liftIO $ assertEqual "IntIndex acc 1" (-1) (dbAccountIntIndex acc1)- liftIO $ assertEqual "ExtGap acc 1" 29 (dbAccountExtGap acc1)- liftIO $ assertEqual "IntGap acc 1" 29 (dbAccountIntGap acc1)-- liftIO $ assertEqual "ExtIndex acc 2" (-1) (dbAccountExtIndex acc2)- liftIO $ assertEqual "IntIndex acc 2" (-1) (dbAccountIntIndex acc2)- liftIO $ assertEqual "ExtGap acc 2" 29 (dbAccountExtGap acc2)- liftIO $ assertEqual "IntGap acc 2" 29 (dbAccountIntGap acc2)-- liftIO $ assertEqual "ExtIndex acc 3" (-1) (dbAccountExtIndex acc3)- liftIO $ assertEqual "IntIndex acc 3" (-1) (dbAccountIntIndex acc3)- liftIO $ assertEqual "ExtGap acc 3" 29 (dbAccountExtGap acc3)- liftIO $ assertEqual "IntGap acc 3" 29 (dbAccountIntGap acc3)-- cmdList "" 0 5 >>= liftIO . assertEqual "check empty addrs 1"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- cmdList "acc1" 0 5 >>= liftIO . assertEqual "check empty addrs 2"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- cmdList "acc2" 0 5 >>= liftIO . assertEqual "check empty addrs 3"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )- --testNewMS :: (PersistStore m, PersistUnique m, PersistQuery m) - => EitherT String m ()-testNewMS = do -- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" (-1) 0 []) >>= liftIO . assertEqual "Invalid ms 1"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 0 (-1) []) >>= liftIO . assertEqual "Invalid ms 2"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 0 0 []) >>= liftIO . assertEqual "Invalid ms 3"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 0 3 []) >>= liftIO . assertEqual "Invalid ms 4"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 3 0 []) >>= liftIO . assertEqual "Invalid ms 5"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 3 17 []) >>= liftIO . assertEqual "Invalid ms 6"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 17 3 []) >>= liftIO . assertEqual "Invalid ms 7"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Creating invalid multisig accounts should fail- runEitherT (cmdNewMS "ms1" 3 2 []) >>= liftIO . assertEqual "Invalid ms 8"- (Left "cmdNewMS: Invalid multisig parameters")-- -- Create a new 2 of 3 multisig account name "ms1"- cmdNewMS "ms1" 2 3 [] >>= liftIO . assertEqual "New ms 1" - ( object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "2 multisig keys missing"- ] - )-- -- Check the wallet account index- (dbWalletAccIndex . entityVal <$> dbGetWallet "main") >>= - liftIO . assertEqual "acc index 3" 3-- -- Display account information for account "ms1"- cmdAccInfo "ms1" >>= liftIO . assertEqual "MS info"- ( object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "2 multisig keys missing"- ] - )-- -- List all accounts created up to now (include the "ms1")- cmdListAcc >>= liftIO . assertEqual "List accs"- ( toJSON- [ object - [ "Name" .= T.pack ""- , "Tree" .= T.pack "m/0'/"- , "Type" .= T.pack "Regular"- ] - , object - [ "Name" .= T.pack "acc1"- , "Tree" .= T.pack "m/1'/"- , "Type" .= T.pack "Regular"- ] - , object - [ "Name" .= T.pack "acc2"- , "Tree" .= T.pack "m/2'/"- , "Type" .= T.pack "Regular"- ] - , object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "2 multisig keys missing"- ] - ]- )-- -- Initialize some keys for the next tests- let mstKey = fromJust $ makeMasterKey $ stringToBS "Hello World"- mstKey2 = fromJust $ makeMasterKey $ stringToBS "Hello World 2"- prvs = map (getAccPrvKey . fst) $ accPrvKeys mstKey 0- pubs = map deriveXPubKey prvs- prvs2 = map (getAccPrvKey . fst) $ accPrvKeys mstKey2 0- pubs2 = map deriveXPubKey prvs2-- -- Count the number of accounts in the database- count ([] :: [Filter (DbAccountGeneric b)]) >>= - liftIO . assertEqual "MS count" 4-- -- Adding empty key list should fail- runEitherT (cmdAddKeys "ms1" []) >>= liftIO . assertEqual "Empty addKey"- (Left "dbAddKeys: Keys can not be empty")-- -- Adding keys to a non-multisig account should fail- runEitherT (cmdAddKeys "acc1" [pubs !! 0]) >>= - liftIO . assertEqual "Invalid addKey 1" - (Left "dbAddKeys: Can only add keys to a multisig account")-- -- Adding your own keys to a multisig account should fail- runEitherT (cmdAddKeys "ms1" [pubs !! 0]) >>=- liftIO . assertEqual "Invalid addKey 2" - (Left "dbAddKeys: Can not add your own keys to a multisig account")-- -- Adding your own keys to a multisig account should fail- runEitherT (cmdAddKeys "ms1" [pubs2 !! 0,pubs !! 1]) >>=- liftIO . assertEqual "Invalid addKey 3" - (Left "dbAddKeys: Can not add your own keys to a multisig account")- - -- Adding too many keys to a multisig account should fail- runEitherT (cmdAddKeys "ms1" $ take 4 pubs2) >>=- liftIO . assertEqual "Invalid addKey 4" - (Left "dbAddKeys: Too many keys")-- -- Display account information for account "ms1". Shold not have changed- cmdAccInfo "ms1" >>= liftIO . assertEqual "MS info 2"- ( object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "2 multisig keys missing"- ] - )- - -- Check that address-related data and gaps are correct- (Entity a1 acc1) <- dbGetAcc "ms1"-- count [DbAddressAccount ==. a1, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count MS 1" 0-- count [DbAddressAccount ==. a1, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count MS 1" 0-- liftIO $ assertEqual "ExtIndex acc MS" (-1) (dbAccountExtIndex acc1)- liftIO $ assertEqual "IntIndex acc MS" (-1) (dbAccountIntIndex acc1)- liftIO $ assertEqual "ExtGap acc MS" (-1) (dbAccountExtGap acc1)- liftIO $ assertEqual "IntGap acc MS" (-1) (dbAccountIntGap acc1)-- cmdList "ms1" 0 5 >>= liftIO . assertEqual "check empty addrs MS 1"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- -- Adding a key to the multisig account "ms1". One should still be missing- cmdAddKeys "ms1" [pubs2 !! 0] >>= liftIO . assertEqual "MS addkey 1"- ( object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "1 multisig keys missing"- ] - )-- -- Dump the keys of account "ms1". One account should be listed under MSKeys- cmdDumpKeys "ms1" >>= liftIO . assertEqual "MS dumpkey 2" - ( object - [ "Account" .= object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- , "Warning" .= T.pack "1 multisig keys missing"- ] - , "PubKey" .= (xPubExport $ pubs !! 3)- , "PrvKey" .= (xPrvExport $ prvs !! 3)- , "MSKeys" .= toJSON [xPubExport $ pubs2 !! 0]- ]- )-- -- Check that address-related data and gaps are correct- (Entity a2 acc2) <- dbGetAcc "ms1"-- count [DbAddressAccount ==. a2, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count MS 2" 0-- count [DbAddressAccount ==. a2, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count MS 2" 0-- liftIO $ assertEqual "ExtIndex acc MS 2" (-1) (dbAccountExtIndex acc2)- liftIO $ assertEqual "IntIndex acc MS 2" (-1) (dbAccountIntIndex acc2)- liftIO $ assertEqual "ExtGap acc MS 2" (-1) (dbAccountExtGap acc2)- liftIO $ assertEqual "IntGap acc MS 2" (-1) (dbAccountIntGap acc2)-- cmdList "ms1" 0 5 >>= liftIO . assertEqual "check empty addrs MS 2"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- -- Add second key to account "ms1". Account should be complete now- cmdAddKeys "ms1" [pubs2 !! 1] >>= liftIO . assertEqual "MS addkey 2" - ( object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- ] - )-- -- Dumping "ms1" keys should now display all keys- cmdDumpKeys "ms1" >>= liftIO . assertEqual "MS dumpkey 2" - ( object - [ "Account" .= object - [ "Name" .= T.pack "ms1"- , "Tree" .= T.pack "m/3'/"- , "Type" .= T.pack "Multisig 2 of 3"- ] - , "PubKey" .= (xPubExport $ pubs !! 3)- , "PrvKey" .= (xPrvExport $ prvs !! 3)- , "MSKeys" .= toJSON [ xPubExport $ pubs2 !! 0- , xPubExport $ pubs2 !! 1- ]- ]- )-- -- Check that address-related data and gaps are correct- (Entity a3 acc3) <- dbGetAcc "ms1"-- count [DbAddressAccount ==. a3, DbAddressInternal ==. True] >>=- liftIO . assertEqual "Int gap address count MS 3" 30-- count [DbAddressAccount ==. a3, DbAddressInternal ==. False] >>=- liftIO . assertEqual "Ext gap address count MS 3" 30-- liftIO $ assertEqual "ExtIndex acc MS 3" (-1) (dbAccountExtIndex acc3)- liftIO $ assertEqual "IntIndex acc MS 3" (-1) (dbAccountIntIndex acc3)- liftIO $ assertEqual "ExtGap acc MS 3" 29 (dbAccountExtGap acc3)- liftIO $ assertEqual "IntGap acc MS 3" 29 (dbAccountIntGap acc3)-- cmdList "ms1" 0 5 >>= liftIO . assertEqual "check empty addrs MS 3"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- -- Adding another key now should fail as the account "ms1" is complete- runEitherT (cmdAddKeys "ms1" [pubs2 !! 2]) >>=- liftIO . assertEqual "Invalid addKey 5" - (Left "dbAddKeys: Account is complete. No more keys can be added")--testGenAddr :: (PersistStore m, PersistUnique m, PersistQuery m) - => EitherT String m ()-testGenAddr = do -- -- List addresses from an empty account- cmdList "" 0 5 >>= liftIO . assertEqual "list empty addr" - ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- -- Generate 5 addresses on the account "" (empty string)- cmdGenAddrs "" 5 >>= liftIO . assertEqual "gen addr"- ( toJSON - [ object [ "Addr" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , "Key" .= (0 :: Int)- , "Tree" .= T.pack "m/0'/0/0/"- ]- , object [ "Addr" .= T.pack "1NkXvbrHPGC2vjtmL2mup1sWi2TU8LW6XB"- , "Key" .= (1 :: Int)- , "Tree" .= T.pack "m/0'/0/1/"- ]- , object [ "Addr" .= T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- , "Key" .= (2 :: Int)- , "Tree" .= T.pack "m/0'/0/2/"- ]- , object [ "Addr" .= T.pack "1Erwcuqn1dHm8r6fNxogGmCHYuNfwKNwer"- , "Key" .= (3 :: Int)- , "Tree" .= T.pack "m/0'/0/3/"- ]- , object [ "Addr" .= T.pack "18aT8MJ15VV26nx29xmbu5fzvqE6sqh6i9"- , "Key" .= (4 :: Int)- , "Tree" .= T.pack "m/0'/0/4/"- ]- ]- )-- -- Check account external index- (dbAccountExtIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext index" 4-- -- Check account internal index- (dbAccountIntIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int index" (-1)-- -- Check account external gap- (dbAccountExtGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext gap" 34-- -- Check account internal gap- (dbAccountIntGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int gap" 29-- -- Count all addresses in the Address table- -- 60*4 + 5- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Count addr" 245-- let f x = (dbAddressBase58 x,dbAddressTree x,dbAddressIndex x)- (map f <$> dbGenIntAddrs "" 4) >>= liftIO . assertEqual "Internal addr"- [ ("19RtLtmuuxscgg5TXkCsSJ7bCdEzci5XTm","m/0'/1/0/",0)- , ("1E75f3kuDanTHeTa8nvJCxYF8MXaud4QPE","m/0'/1/1/",1)- , ("1NXkqUpqM23p6u44nAhoP1wVd2BdCEr4Zm","m/0'/1/2/",2)- , ("1AjBQfprusZGGnD4jCmexizJxKBcAw4cdc","m/0'/1/3/",3)- ]-- -- Check account external index- (dbAccountExtIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext index 2" 4-- -- Check account internal index- (dbAccountIntIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int index" 3-- -- Check account external gap- (dbAccountExtGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext gap" 34-- -- Check account internal gap- (dbAccountIntGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int gap" 33-- -- Count all addresses in the Address table- -- 60*4 + 5- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Count addr" 249-- -- List addresses from the ms1 account. Should be empty- cmdList "ms1" 0 5 >>= liftIO . assertEqual "list empty addr 2"- ( object- [ "Addresses" .= toJSON ([] :: [Value])- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (0 :: Int)- ]- ]- )-- -- List page 1 with 1 result per page- cmdList "" 1 1 >>= liftIO . assertEqual "list addr 1"- ( object - [ "Addresses" .= toJSON - [ object [ "Addr" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , "Key" .= (0 :: Int)- , "Tree" .= T.pack "m/0'/0/0/"- ]- ]- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (1 :: Int)- , "Total pages" .= (5 :: Int)- , "Total addresses" .= (5 :: Int)- ]- ]- )-- -- List page 2 with 1 result per page- cmdList "" 2 1 >>= liftIO . assertEqual "list addr 2"- ( object - [ "Addresses" .= toJSON - [ object [ "Addr" .= T.pack "1NkXvbrHPGC2vjtmL2mup1sWi2TU8LW6XB"- , "Key" .= (1 :: Int)- , "Tree" .= T.pack "m/0'/0/1/"- ]- ]- , "Page results" .= object- [ "Current page" .= (2 :: Int)- , "Results per page" .= (1 :: Int)- , "Total pages" .= (5 :: Int)- , "Total addresses" .= (5 :: Int)- ]- ]- )-- -- List page 0 (last page) with 1 result per page- cmdList "" 0 1 >>= liftIO . assertEqual "list addr 2"- ( object - [ "Addresses" .= toJSON - [ object [ "Addr" .= T.pack "18aT8MJ15VV26nx29xmbu5fzvqE6sqh6i9"- , "Key" .= (4 :: Int)- , "Tree" .= T.pack "m/0'/0/4/"- ]- ]- , "Page results" .= object- [ "Current page" .= (5 :: Int)- , "Results per page" .= (1 :: Int)- , "Total pages" .= (5 :: Int)- , "Total addresses" .= (5 :: Int)- ]- ]- )-- -- Listing page > maxpage should fail- runEitherT (cmdList "" 6 1) >>= liftIO . assertEqual "list addr 2"- (Left "cmdList: Page number too high")-- -- List page 0 (last page) with 3 result per page- cmdList "" 0 3 >>= liftIO . assertEqual "list addr 2"- ( object - [ "Addresses" .= toJSON - [ object [ "Addr" .= T.pack "1Erwcuqn1dHm8r6fNxogGmCHYuNfwKNwer"- , "Key" .= (3 :: Int)- , "Tree" .= T.pack "m/0'/0/3/"- ]- , object [ "Addr" .= T.pack "18aT8MJ15VV26nx29xmbu5fzvqE6sqh6i9"- , "Key" .= (4 :: Int)- , "Tree" .= T.pack "m/0'/0/4/"- ]- ]- , "Page results" .= object- [ "Current page" .= (2 :: Int)- , "Results per page" .= (3 :: Int)- , "Total pages" .= (2 :: Int)- , "Total addresses" .= (5 :: Int)- ]- ]- )-- -- Generating multisig addresses with labels- cmdGenWithLabel "ms1" ["","addr1","addr2","Two Words"] >>= - liftIO . assertEqual "gen ms addr" - ( toJSON - [ object [ "Addr" .= T.pack "32VCGK4pbvVsFvSGfmLpmNTu4JjhuR3WmM"- , "Key" .= (0 :: Int)- , "Tree" .= T.pack "m/3'/0/0/"- ]- , object [ "Addr" .= T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , "Key" .= (1 :: Int)- , "Tree" .= T.pack "m/3'/0/1/"- , "Label" .= T.pack "addr1"- ]- , object [ "Addr" .= T.pack "3E3qvGPki6sypXdyL6CMxBQwzFkY7iKrGW"- , "Key" .= (2 :: Int)- , "Tree" .= T.pack "m/3'/0/2/"- , "Label" .= T.pack "addr2"- ]- , object [ "Addr" .= T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- , "Key" .= (3 :: Int)- , "Tree" .= T.pack "m/3'/0/3/"- , "Label" .= T.pack "Two Words"- ]- ]- )-- -- Check account external index- (dbAccountExtIndex . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc ext index 3" 3-- -- Check account internal index- (dbAccountIntIndex . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc int index 3" (-1)-- -- Check account external gap- (dbAccountExtGap . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc ext gap 3" 33-- -- Check account internal gap- (dbAccountIntGap . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc int gap 3" 29-- -- Count addresses- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Count addr 3" 253-- let h x = (dbAddressBase58 x,dbAddressTree x,dbAddressIndex x)- (map h <$> dbGenIntAddrs "ms1" 6) >>= liftIO . assertEqual "Internal addr 2"- [ ("34rWmp9DmxFbqXLHvzhMGATWDfsnLF8wiR","m/3'/1/0/",0)- , ("3As9nWqHcWavv3MxSeZKYjMQ9SgE8zVaJ1","m/3'/1/1/",1)- , ("3QYVvQrjtK5w8s6uE8T8ZLeXBEe7aTtVdj","m/3'/1/2/",2)- , ("3GS2h9uZ3akS9GQbXDGZtWgAvzLFnjWrsS","m/3'/1/3/",3)- , ("3CAF8PpJirGsqTxzK2aPao2MQSGkiC3gPN","m/3'/1/4/",4)- , ("3Kcd2Nz1XYv25U6xUzjAycVBz9rp6r2Tf2","m/3'/1/5/",5)- ]-- -- Check account external index- (dbAccountExtIndex . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc ext index 4" 3-- -- Check account internal index- (dbAccountIntIndex . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc int index 4" 5-- -- Check account external gap- (dbAccountExtGap . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc ext gap 4" 33-- -- Check account internal gap- (dbAccountIntGap . entityVal <$> dbGetAcc "ms1") >>= - liftIO . assertEqual "acc int gap 4" 35-- -- Count addresses- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Count addr 4" 259-- -- Rename the first multisig address label- cmdLabel "ms1" 0 "alpha" >>= liftIO . assertEqual "label ms"- ( object - [ "Addr" .= T.pack "32VCGK4pbvVsFvSGfmLpmNTu4JjhuR3WmM"- , "Key" .= (0 :: Int)- , "Tree" .= T.pack "m/3'/0/0/"- , "Label" .= T.pack "alpha"- ]- )-- -- Rename the last multisig address label- _ <- cmdLabel "ms1" 3 "beta"-- -- Setting a label on an invalid address should fail- runEitherT (cmdLabel "ms1" (-1) "theta") >>= - liftIO . assertEqual "set label fail"- (Left "cmdLabel: Key -1 does not exist")-- -- Setting a label on an invalid address should fail- runEitherT (cmdLabel "ms1" 4 "theta") >>= - liftIO . assertEqual "set label fail 2"- (Left "cmdLabel: Key 4 does not exist")-- -- Setting a label on an invalid address should fail- runEitherT (cmdLabel "ms1" 100 "theta") >>= - liftIO . assertEqual "set label fail 3"- (Left "cmdLabel: Key 100 does not exist")-- -- List page 1 with 5 result per page- cmdList "ms1" 1 5 >>= liftIO . assertEqual "list ms"- ( object - [ "Addresses" .= toJSON - [ object [ "Addr" .= T.pack "32VCGK4pbvVsFvSGfmLpmNTu4JjhuR3WmM"- , "Key" .= (0 :: Int)- , "Tree" .= T.pack "m/3'/0/0/"- , "Label" .= T.pack "alpha"- ]- , object [ "Addr" .= T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , "Key" .= (1 :: Int)- , "Tree" .= T.pack "m/3'/0/1/"- , "Label" .= T.pack "addr1"- ]- , object [ "Addr" .= T.pack "3E3qvGPki6sypXdyL6CMxBQwzFkY7iKrGW"- , "Key" .= (2 :: Int)- , "Tree" .= T.pack "m/3'/0/2/"- , "Label" .= T.pack "addr2"- ]- , object [ "Addr" .= T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- , "Key" .= (3 :: Int)- , "Tree" .= T.pack "m/3'/0/3/"- , "Label" .= T.pack "beta"- ]- ]- , "Page results" .= object- [ "Current page" .= (1 :: Int)- , "Results per page" .= (5 :: Int)- , "Total pages" .= (1 :: Int)- , "Total addresses" .= (4 :: Int)- ]- ]- )--{- Payments sent to:- - 1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi:100000 (in wallet)- - 1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY:200000 (in wallet)- - 1Azso1Fz77buNc8p7sm3myVXZxqwQopMtp:240000 (not in wallet)- - 1L1ryKs82ucjNmGwKT9kAsxeSVX1mhJyo5:122000 (not in wallet)- - 38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki:150000 (in wallet)- - 3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q:400000 (in wallet)- -}---- ID: a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996-tx1 :: String-tx1 = "01000000010000000000000000000000000000000000000000000000000000000000000001010000006b483045022100bf1c6e0720284bcefa2e104b5eea27fb3f11a8ebce1d7c06a99567473f9524a202201ed0baafcac25f9aa3c81fb26a3476f559169f4c7f5a64e43a2eebb6b0a1aae001210290a14bce9d363667574a29da1b2e38d106968969f449588713bb271e28a9a4a0ffffffff06a0860100000000001976a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac400d0300000000001976a91468e94ed1e88f7e942bf4aaa25fcf5930f517730888ac80a90300000000001976a9146dab3dec58a7ab13267c4ec8c60b516cbe7a3c9f88ac90dc0100000000001976a914d0941a8b2ce829d8692bf6af24f67c485ff9a20b88acf04902000000000017a9144d769c08d79eed22532e044213bef3174f05158487801a06000000000017a914fdf1e3c1a936ab1dde0d7a305d28df396949ffd08700000000"---- ID: 319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785-tx2 :: String-tx2 = "01000000010000000000000000000000000000000000000000000000000000000000000002010000006b483045022100bf1c6e0720284bcefa2e104b5eea27fb3f11a8ebce1d7c06a99567473f9524a202201ed0baafcac25f9aa3c81fb26a3476f559169f4c7f5a64e43a2eebb6b0a1aae001210290a14bce9d363667574a29da1b2e38d106968969f449588713bb271e28a9a4a0ffffffff06a0860100000000001976a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac400d0300000000001976a91468e94ed1e88f7e942bf4aaa25fcf5930f517730888ac80a90300000000001976a9146dab3dec58a7ab13267c4ec8c60b516cbe7a3c9f88ac90dc0100000000001976a914d0941a8b2ce829d8692bf6af24f67c485ff9a20b88acf04902000000000017a9144d769c08d79eed22532e044213bef3174f05158487801a06000000000017a914fdf1e3c1a936ab1dde0d7a305d28df396949ffd08700000000"--testImport :: ( PersistStore m, PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- ) - => EitherT String m ()-testImport = do -- -- Importin transaction sending funds to two different accounts- cmdImportTx (decode' $ fromJust $ hexToBS tx1) >>= - liftIO . assertEqual "Import tx 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- , "Value" .= (550000 :: Int)- ]- ]- )-- -- Importin similar transaction sending funds to two different accounts- cmdImportTx (decode' $ fromJust $ hexToBS tx2) >>= - liftIO . assertEqual "Import tx 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- , "Value" .= (550000 :: Int)- ]- ]- )-- -- List transactions of account ""- cmdListTx "" >>= liftIO . assertEqual "List tx 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- ]- )-- -- List transactions of account "ms1"- cmdListTx "ms1" >>= liftIO . assertEqual "List tx 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- , "Value" .= (550000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- , "Value" .= (550000 :: Int)- ]- ]- )-- -- Verify the balance of account ""- cmdBalance "" >>= liftIO . assertEqual "Balance 1" - (object ["Balance" .= (600000 :: Int)])-- -- Verify the balance of account "ms1"- cmdBalance "ms1" >>= liftIO . assertEqual "Balance 2" - (object ["Balance" .= (1100000 :: Int)])-- -- Get coins of account ""- cmdCoins "" >>= liftIO . assertEqual "Get coins 1"- ( toJSON- [ object- [ "TxID" .= T.pack "a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac"- , "Address" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- ]- , object- [ "TxID" .= T.pack "a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996"- , "Index" .= (1 :: Int)- , "Value" .= (200000 :: Int)- , "Script" .= T.pack "76a91468e94ed1e88f7e942bf4aaa25fcf5930f517730888ac"- , "Address" .= T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , object- [ "TxID" .= T.pack "319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac"- , "Address" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- ]- , object- [ "TxID" .= T.pack "319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785"- , "Index" .= (1 :: Int)- , "Value" .= (200000 :: Int)- , "Script" .= T.pack "76a91468e94ed1e88f7e942bf4aaa25fcf5930f517730888ac"- , "Address" .= T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- ]- )-- -- Get coins of account "ms1"- cmdCoins "ms1" >>= liftIO . assertEqual "Get coins 2"- ( toJSON- [ object- [ "TxID" .= T.pack "a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996"- , "Index" .= (4 :: Int)- , "Value" .= (150000 :: Int)- , "Script" .= T.pack "a9144d769c08d79eed22532e044213bef3174f05158487"- , "Redeem" .= T.pack "5221026e294fcecdcbae12a0aba1685db35c54ddfc1375d48f96ff1b8805a4bb57bfc921028bc8d8377f44de8ac8beff0dc9ccefde4cd5dded7b8cd8babe02c7147a90ba6c21039cf5d06e79871043c420fabc652f8082e702e0094f91ec14c020e9fcf48fa4d853ae"- , "Address" .= T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- ]- , object- [ "TxID" .= T.pack "a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996"- , "Index" .= (5 :: Int)- , "Value" .= (400000 :: Int)- , "Script" .= T.pack "a914fdf1e3c1a936ab1dde0d7a305d28df396949ffd087"- , "Redeem" .= T.pack "5221020f7ead178316e8414d128712a23cde2e843d1a0f66afc0bfa600ab90deefd5f321023182b240cb2607ed03f76c9dca37c4b9fcb3b763b776223cc94808f7e67fb03a2102648dbcbc9f44fb55a992efe7b3ab214306cc72cdcae2a7cf6f9d44262a53c3b353ae"- , "Address" .= T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- , object- [ "TxID" .= T.pack "319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785"- , "Index" .= (4 :: Int)- , "Value" .= (150000 :: Int)- , "Script" .= T.pack "a9144d769c08d79eed22532e044213bef3174f05158487"- , "Redeem" .= T.pack "5221026e294fcecdcbae12a0aba1685db35c54ddfc1375d48f96ff1b8805a4bb57bfc921028bc8d8377f44de8ac8beff0dc9ccefde4cd5dded7b8cd8babe02c7147a90ba6c21039cf5d06e79871043c420fabc652f8082e702e0094f91ec14c020e9fcf48fa4d853ae"- , "Address" .= T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- ]- , object- [ "TxID" .= T.pack "319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785"- , "Index" .= (5 :: Int)- , "Value" .= (400000 :: Int)- , "Script" .= T.pack "a914fdf1e3c1a936ab1dde0d7a305d28df396949ffd087"- , "Redeem" .= T.pack "5221020f7ead178316e8414d128712a23cde2e843d1a0f66afc0bfa600ab90deefd5f321023182b240cb2607ed03f76c9dca37c4b9fcb3b763b776223cc94808f7e67fb03a2102648dbcbc9f44fb55a992efe7b3ab214306cc72cdcae2a7cf6f9d44262a53c3b353ae"- , "Address" .= T.pack "3QqkesBZx7WBSLcdy5e1PmRU1QLdYTG49Q"- ]- ]- )-- -- ID: 9062c5ae9a4e84e37e712387a111f2dba6be57de4235df8dd1fae67cc2071771- -- Input: 200000 and 200000 = 400000- -- Output = 340000 + 50000 change = 390000- -- Fee = 10000-- let txRes = "010000000285e7fcc7399ef68c3277ab4be6aecfa7f77781a99d3a8e0038f03846fb269f31010000006a47304402200f4bc4dba8e47e810362d48502329a75624d8863d8bd22618bd47c5fff8bd9e402200531318470a60b4d898b2061c3eef96ad9129ca758e7f55bd120a81569a7196201210250f4e42bb94ed8b27c6c8b728c0bd02828af1d4ebf8e3f0a6e7da3f53369c104ffffffff96a9342b5d88583a607e8cc43a4fd844a9dfc3ef9f72982db4dac3b708f356a1010000006a4730440220566d57667786d93551976f2bf890de9d623820c02c2e6d4476a71c27b771eae6022004227d27972a1f0933bf50472d85644cc5dbbc277f1370c171f80e95ed834ca401210250f4e42bb94ed8b27c6c8b728c0bd02828af1d4ebf8e3f0a6e7da3f53369c104ffffffff04c0d401000000000017a9144d769c08d79eed22532e044213bef3174f0515848780380100000000001976a914980b9c708958bbe4cc05d0b302d4f12625a5d88c88ace0220200000000001976a9147f77d7a91f8e53a387530c58139290211579dd2b88ac50c30000000000001976a914bb498fb0f0d0639193660b40a9a91e1b3eb60bab88ac00000000"-- cmdSendMany "" - [ ("38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki",120000) -- In wallet- , ("1Erwcuqn1dHm8r6fNxogGmCHYuNfwKNwer", 80000) -- In wallet- , ("1CczPAHXrwyiCeJfx5Bifaoo4NBQr3TPpJ",140000) -- Not in wallet- ] 10000 >>= liftIO . assertEqual "sendMany tx"- (object - [ "Tx" .= T.pack txRes- , "Complete" .= True- ]- )-- -- Check that the internal change address was correctly generated- (dbAddressIndex . entityVal) <$> - (dbGetAddr "1J5HV12wGbPj5SUryku2zFoaxnC1AngqcH") >>= - liftIO . assertEqual "check internal address" 4-- (dbAddressTree . entityVal) <$> - (dbGetAddr "1J5HV12wGbPj5SUryku2zFoaxnC1AngqcH") >>= - liftIO . assertEqual "check internal address tree" "m/0'/1/4/"-- (dbAddressInternal . entityVal) <$> - (dbGetAddr "1J5HV12wGbPj5SUryku2zFoaxnC1AngqcH") >>= - liftIO . assertEqual "check internal address tree" True-- -- Check account external index- (dbAccountExtIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext index 5" 4-- -- Check account internal index- (dbAccountIntIndex . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int index 5" 4-- -- Check account external gap- (dbAccountExtGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc ext gap 5" 34-- -- Check account internal gap- (dbAccountIntGap . entityVal <$> dbGetAcc "") >>= - liftIO . assertEqual "acc int gap 5" 34-- -- Count addresses- count ([] :: [Filter (DbAddressGeneric b)]) >>= - liftIO . assertEqual "Count addr 5" 260--- (cmdImportTx $ decode' $ fromJust $ hexToBS txRes) >>=- liftIO . assertEqual "import send tx"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "1CczPAHXrwyiCeJfx5Bifaoo4NBQr3TPpJ"- ]- , "Value" .= (-270000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki" ]- , "Value" .= (120000 :: Int)- ]- ]- )-- -- Get coins of account ""- cmdCoins "" >>= liftIO . assertEqual "Get coins 2"- ( toJSON- [ object- [ "TxID" .= T.pack "a156f308b7c3dab42d98729fefc3dfa944d84f3ac48c7e603a58885d2b34a996"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac"- , "Address" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- ]- , object- [ "TxID" .= T.pack "319f26fb4638f038008e3a9da98177f7a7cfaee64bab77328cf69e39c7fce785"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914d6baf45f52b4cccc7ac1ba3a35dd739497f8e98988ac"- , "Address" .= T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- ]- , object- [ "TxID" .= T.pack "9062c5ae9a4e84e37e712387a111f2dba6be57de4235df8dd1fae67cc2071771"- , "Index" .= (1 :: Int)- , "Value" .= (80000 :: Int)- , "Script" .= T.pack "76a914980b9c708958bbe4cc05d0b302d4f12625a5d88c88ac"- , "Address" .= T.pack "1Erwcuqn1dHm8r6fNxogGmCHYuNfwKNwer"- ]- , object- [ "TxID" .= T.pack "9062c5ae9a4e84e37e712387a111f2dba6be57de4235df8dd1fae67cc2071771"- , "Index" .= (3 :: Int)- , "Value" .= (50000 :: Int)- , "Script" .= T.pack "76a914bb498fb0f0d0639193660b40a9a91e1b3eb60bab88ac"- , "Address" .= T.pack "1J5HV12wGbPj5SUryku2zFoaxnC1AngqcH"- ]- ]- )-- -- List transactions of account ""- cmdListTx "" >>= liftIO . assertEqual "List tx 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "1LaPZtFWAWRP8eLNZRLLPGaB3dn19Nb6wi"- , T.pack "1AZimU5FfTQyF4GMsEKLZ32773TtPKczdY"- ]- , "Value" .= (300000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "38kc3Sw4fwkvXMyGPmjQqp7WXMdGQG3Lki"- , T.pack "1CczPAHXrwyiCeJfx5Bifaoo4NBQr3TPpJ"- ]- , "Value" .= (-270000 :: Int)- ]- ]- )- - -- Verify the balance of account ""- cmdBalance "" >>= liftIO . assertEqual "Balance 3" - (object ["Balance" .= (330000 :: Int)])-- -- Verify the balance of account "ms1"- cmdBalance "ms1" >>= liftIO . assertEqual "Balance 4" - (object ["Balance" .= (1220000 :: Int)])---- Building tx link:--- txA : outside => acc1--- txB : acc1 => (acc1,acc2,outside)--- txC : acc2 => (acc1,outside) --- tcD : acc1 => outside--- import order: txC, tcB, txA--{- TxID: 23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd- - Payments sent to:- - 1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL : 100000 (acc1)- - 1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw : 200000 (acc1)- - 17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG : 300000 (acc1)- -}--txA :: String-txA = "01000000010000000000000000000000000000000000000000000000000000000000000001090000006a4730440220464686ba44f82d76bc3687399f971fe86661241b9698308711e099fab785ef140220074de9e525ae379fc7ab676fbeb475e7c8aa7268afb0c3f48ea18137bf069f7d01210290a14bce9d363667574a29da1b2e38d106968969f449588713bb271e28a9a4a0ffffffff03a0860100000000001976a9148062ab5c3fdf5f8f0d41fccacbb3ea8058b911ae88ac400d0300000000001976a9148727e4552058a555d0ce269d8cf8c850785666f688ace0930400000000001976a9144c769509bb3e22c2275cd025fcb55ebc5dc1e39f88ac00000000"--{- TxID: 53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0- - inputs: acc1 (index 1 and index 2 = 500000)- - Payments sent to:- - 14JcRDidCbYFBwWjP9PGJL1MRKCzUWCmaS : 100000 (acc1)- - 16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M : 200000 (acc2)- - 1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86 : 150000 (outside)- - 1Baez98Lapiu7mQLfXuUCjBreEAwFrWNd2 : 40000 (change to acc1)- -}--txB :: String-txB = "0100000002bd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc523010000006b4830450221009c061ca53ccfdd379f883857466103308f54c764e7acd94f5eb23d40bb5ce1cc022074f40ed51bbdc295307db177c15679939e104bcc8944b54eb3ac681992f27a10012103a40f6bd1d59440a007aa8ec93875d07f234ffebe76df311c1b610fc1c0d22dd9ffffffffbd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc523020000006a47304402204e3c85a423066ef44a7d25d0ee0352d8dd5e7628e989aa9f0833abe681405610022030638452839cbb210bf7589e16beb0a737ecbc4a6560e28cd3b11517c83ff225012103a0d2cdf936eca39cfd6407393f8f0f2af932bdea6271d559308075b77d2ec080ffffffff04a0860100000000001976a914243d03889d49470ee721d44596fd146440e1167c88ac400d0300000000001976a9143f53fba59a1c17f17cf3c4b5cfcf15fa0087f1c188acf0490200000000001976a9149d3e18f3cd8edf442c31cb5cc5b0acf8e4e96a1e88ac409c0000000000001976a914740eb168ae243882a73f5467b9024431443ef12988ac00000000"--{- TxID: 2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150- - inputs: acc2 (index 1 = 200000)- - Payments sent to:- - 14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb : 120000 (acc1)- - 13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n : 40000 (outside)- - 13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J : 30000 (change to acc2)- -}--txC :: String-txC = "0100000001d0a3cbf9246be9519374c96b551545050b01d53c9d33e2ff3af59e571411fe53010000006b483045022100ff41f0cb1ce0f7f6d07b93c9f3c43480f843092a14618b2b20c2fad90d003216022049069460cbf2355f03ed31ac25cc086057aa752bd53f9de558f33e565369d11e012103b4b925d5967a00d2540115f035aa10290853d39e3c20591d711680cac5e2b4efffffffff03c0d40100000000001976a91424cba659aad4563de9199f3fe273bac07f170eb088ac409c0000000000001976a91418dc74eb38930493ce81b8f1d3fd0f15e43e96b288ac30750000000000001976a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac00000000"--{- TxID: 03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582- - inputs: acc1 (index 0 = 120000)- - Payments sent to:- - 13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf : 110000 (outside)- -}--txD :: String-txD = "010000000150b18a410fdc69cf463134a357c6ef0c5b0651723dda6164c300ffe356db5522000000006b483045022100f9a43bc03aa44ea2e97873d73f522680a7967f71ad9406de380aafd8f1afc1260220790f82a126d2a5a5404ea2632c99e90e55484e1d16dba1842884bc740add3f23012103a104bc20b43f7f10f89f0519b12bd828dfb7c7969e4c833eadfc6badda334bc0ffffffff01b0ad0100000000001976a9141f69921a4f95254ee2aaa181381439bbc8b2645788ac00000000"--testOrphan :: ( PersistStore m, PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- ) - => EitherT String m ()-testOrphan = do -- -- import transaction D- cmdImportTx (decode' $ fromJust $ hexToBS txD) >>= - liftIO . assertEqual "import txD"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- ]- )-- -- import transaction D a second time. Operation should be idempotent- cmdImportTx (decode' $ fromJust $ hexToBS txD) >>= - liftIO . assertEqual "import txD 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- ]- )-- (Entity ai1 _) <- dbGetAcc "acc1"- (Entity ai2 _) <- dbGetAcc "acc2"-- let f (Entity _ c) = ( dbCoinTxid c, dbCoinPos c- , dbCoinValue c, dbCoinScript c- , dbCoinRdmScript c, dbCoinAddress c- , dbCoinStatus c, dbCoinOrphan c- )- g (Entity _ t) = ( dbTxTxid t, dbTxRecipients t- , dbTxValue t, dbTxOrphan t, dbTxPartial t- )-- ((map f) <$> selectList [DbCoinAccount ==. ai1] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check import txD coins"- [ ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 0, 0, "", Nothing - , "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , Spent "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , True- )- ]-- ((map g) <$> selectList [DbTxAccount ==. ai1] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check import txD tx"- [ ( "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , ["13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"]- , 0, True, False- )- ]-- cmdCoins "acc1" >>= liftIO . assertEqual "Check empty coins txD" - (toJSON ([] :: [DbCoinGeneric b]))-- cmdListTx "acc1" >>= liftIO . assertEqual "Check listTx txD"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- ]- )-- cmdBalance "acc1" >>= liftIO . assertEqual "Check 0 balance txD" - (object ["Balance" .= (0 :: Int)])-- -- import transaction C- cmdImportTx (decode' $ fromJust $ hexToBS txC) >>= - liftIO . assertEqual "import txC"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- import transaction C again (operation should be idempotent)- cmdImportTx (decode' $ fromJust $ hexToBS txC) >>= - liftIO . assertEqual "import txC 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- The previous orphaned coin should be un-orphaned now- ((map f) <$> selectList [DbCoinAccount ==. ai1] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check import txC coins 2"- [ ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 0, 120000- , "76a91424cba659aad4563de9199f3fe273bac07f170eb088ac", Nothing - , "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , Spent "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , False- )- ]-- -- The creation time of the transactions should reflect their dependencies- ((map g) <$> selectList [DbTxAccount ==. ai1] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check import txC tx"- [ ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , ["14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"]- , 120000, False, False- )- , ( "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , ["13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"]- , -120000, False, False- )- ]-- -- Check coins of account 2- ((map f) <$> selectList [DbCoinAccount ==. ai2] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check import txC coins 3"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 1, 0- , "", Nothing - , "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , Spent "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150" - , True- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 2, 30000- , "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac", Nothing - , "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- , Unspent , False- )- ]-- -- Check transactions of account 2- ((map g) <$> selectList [DbTxAccount ==. ai2] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check import txC tx 2"- [ ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , [ "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , 0, True, False- )- ]-- -- list cmdCoins of acc 1 (should be empty)- cmdCoins "acc1" >>= liftIO . assertEqual "Check cmdCoins txC 1" - (toJSON ([] :: [DbCoinGeneric b]))-- -- list cmdCoins of acc 2- cmdCoins "acc2" >>= liftIO . assertEqual "Check cmdCoins txC 2" - (toJSON - [ object [ "TxID" .= T.pack "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , "Index" .= (2 :: Int)- , "Value" .= (30000 :: Int)- , "Script" .= T.pack "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac"- , "Address" .= T.pack "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- ] - ]- )-- -- list cmdListTx of acc1- cmdListTx "acc1" >>= liftIO . assertEqual "Check listTx txC 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- list cmdListTx of acc2- cmdListTx "acc2" >>= liftIO . assertEqual "Check listTx txC 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- ]- )-- -- Check balance of acc1- cmdBalance "acc1" >>= liftIO . assertEqual "Check balance txC 1" - (object ["Balance" .= (0 :: Int)])-- -- Balance of acc2 is 30000 but pending orphaned coins- cmdBalance "acc2" >>= liftIO . assertEqual "Check balance txC 2" - (object ["Balance" .= (30000 :: Int)])-- -- Importing txB- cmdImportTx (decode' $ fromJust $ hexToBS txB) >>= - liftIO . assertEqual "import txB 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- Importing txB again. Import is idempotent so this should work fine- cmdImportTx (decode' $ fromJust $ hexToBS txB) >>= - liftIO . assertEqual "import txB 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- List coins of account 1 after importing txB- ((map f) <$> selectList [DbCoinAccount ==. ai1] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check import txB coins"- [ ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , 1, 0- , "", Nothing - , "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , Spent "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , True- )- , ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , 2, 0- , "", Nothing - , "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- , Spent "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , True- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 0, 100000- , "76a914243d03889d49470ee721d44596fd146440e1167c88ac", Nothing - , "14JcRDidCbYFBwWjP9PGJL1MRKCzUWCmaS"- , Unspent- , False- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 3, 40000- , "76a914740eb168ae243882a73f5467b9024431443ef12988ac", Nothing - , "1Baez98Lapiu7mQLfXuUCjBreEAwFrWNd2"- , Unspent- , False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 0, 120000- , "76a91424cba659aad4563de9199f3fe273bac07f170eb088ac", Nothing - , "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , Spent "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , False- )- ]-- -- List of transactions for account 1- ((map g) <$> selectList [DbTxAccount ==. ai1] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check transactions import txB"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , 0, True, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , ["14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"]- , 120000, False, False- )- , ( "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , ["13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"]- , -120000, False, False- )- ]-- -- List coins of account 2. The first coin is not orphaned anymore- ((map f) <$> selectList [DbCoinAccount ==. ai2] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check coins txB 2"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 1, 200000- , "76a9143f53fba59a1c17f17cf3c4b5cfcf15fa0087f1c188ac", Nothing - , "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , Spent "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150" - , False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 2, 30000- , "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac", Nothing - , "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- , Unspent , False- )- ]-- -- Check transactions of account 2- ((map g) <$> selectList [DbTxAccount ==. ai2] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check transactions import txB 2"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , 200000, False, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , [ "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , -170000, False, False- )- ]-- -- list cmdCoins of acc 1- cmdCoins "acc1" >>= liftIO . assertEqual "Check cmdCoins txB 1" - (toJSON - [ object [ "TxID" .= T.pack "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914243d03889d49470ee721d44596fd146440e1167c88ac"- , "Address" .= T.pack "14JcRDidCbYFBwWjP9PGJL1MRKCzUWCmaS"- ] - , object [ "TxID" .= T.pack "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , "Index" .= (3 :: Int)- , "Value" .= (40000 :: Int)- , "Script" .= T.pack "76a914740eb168ae243882a73f5467b9024431443ef12988ac"- , "Address" .= T.pack "1Baez98Lapiu7mQLfXuUCjBreEAwFrWNd2"- ] - ]- )-- -- list cmdCoins of acc 2- cmdCoins "acc2" >>= liftIO . assertEqual "Check cmdCoins txB 2" - (toJSON - [ object [ "TxID" .= T.pack "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , "Index" .= (2 :: Int)- , "Value" .= (30000 :: Int)- , "Script" .= T.pack "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac"- , "Address" .= T.pack "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- ] - ]- )-- -- list cmdListTx of acc1- cmdListTx "acc1" >>= liftIO . assertEqual "Check listTx txB 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (0 :: Int)- , "Orphan" .= True- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- list cmdListTx of acc2- cmdListTx "acc2" >>= liftIO . assertEqual "Check listTx txB 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- ]- )-- -- Check balance of acc1- cmdBalance "acc1" >>= liftIO . assertEqual "Check balance txB 1" - (object ["Balance" .= (140000 :: Int)])-- -- Balance of acc2 - cmdBalance "acc2" >>= liftIO . assertEqual "Check balance txB 2" - (object ["Balance" .= (30000 :: Int)])-- -- Importing txA (Partial)- cmdImportTx (decode' $ fromJust $ hexToBS txA) >>= - liftIO . assertEqual "import txA 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , T.pack "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , T.pack "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- ]- , "Value" .= (600000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (-360000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf" ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- Importing txA a second time- cmdImportTx (decode' $ fromJust $ hexToBS txA) >>= - liftIO . assertEqual "import txA 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , T.pack "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , T.pack "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- ]- , "Value" .= (600000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (-360000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf" ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- List coins of account 1 after importing txA- ((map f) <$> selectList [DbCoinAccount ==. ai1] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check import txB coins"- [ ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , 0, 100000- , "76a9148062ab5c3fdf5f8f0d41fccacbb3ea8058b911ae88ac", Nothing - , "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , Unspent, False- )- , ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , 1, 200000- , "76a9148727e4552058a555d0ce269d8cf8c850785666f688ac", Nothing - , "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , Spent "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , False- )- , ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , 2, 300000- , "76a9144c769509bb3e22c2275cd025fcb55ebc5dc1e39f88ac", Nothing - , "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- , Spent "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , False- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 0, 100000- , "76a914243d03889d49470ee721d44596fd146440e1167c88ac", Nothing - , "14JcRDidCbYFBwWjP9PGJL1MRKCzUWCmaS"- , Unspent, False- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 3, 40000- , "76a914740eb168ae243882a73f5467b9024431443ef12988ac", Nothing - , "1Baez98Lapiu7mQLfXuUCjBreEAwFrWNd2"- , Unspent, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 0, 120000- , "76a91424cba659aad4563de9199f3fe273bac07f170eb088ac", Nothing - , "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , Spent "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , False- )- ]-- -- List of transactions for account 1- ((map g) <$> selectList [DbTxAccount ==. ai1] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check transactions import txA"- [ ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , [ "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- ]- , 600000, False, False- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , -360000, False, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , ["14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"]- , 120000, False, False- )- , ( "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , ["13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"]- , -120000, False, False- )- ]-- -- List coins of account 2- ((map f) <$> selectList [DbCoinAccount ==. ai2] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check coins txA 2"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , 1, 200000- , "76a9143f53fba59a1c17f17cf3c4b5cfcf15fa0087f1c188ac", Nothing - , "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , Spent "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150" - , False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , 2, 30000- , "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac", Nothing - , "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- , Unspent , False- )- ]-- -- Check transactions of account 2- ((map g) <$> selectList [DbTxAccount ==. ai2] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check transactions import txA 2"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , 200000, False, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , [ "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , -170000, False, False- )- ]-- -- list cmdCoins of acc 1- cmdCoins "acc1" >>= liftIO . assertEqual "Check cmdCoins txA 1" - (toJSON - [ object [ "TxID" .= T.pack "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a9148062ab5c3fdf5f8f0d41fccacbb3ea8058b911ae88ac"- , "Address" .= T.pack "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- ] - , object [ "TxID" .= T.pack "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "76a914243d03889d49470ee721d44596fd146440e1167c88ac"- , "Address" .= T.pack "14JcRDidCbYFBwWjP9PGJL1MRKCzUWCmaS"- ] - , object [ "TxID" .= T.pack "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , "Index" .= (3 :: Int)- , "Value" .= (40000 :: Int)- , "Script" .= T.pack "76a914740eb168ae243882a73f5467b9024431443ef12988ac"- , "Address" .= T.pack "1Baez98Lapiu7mQLfXuUCjBreEAwFrWNd2"- ] - ]- )-- -- list cmdCoins of acc 2- cmdCoins "acc2" >>= liftIO . assertEqual "Check cmdCoins txA 2" - (toJSON - [ object [ "TxID" .= T.pack "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , "Index" .= (2 :: Int)- , "Value" .= (30000 :: Int)- , "Script" .= T.pack "76a9142030bc3fec2b3783acd9e83f6e24d57568be69a988ac"- , "Address" .= T.pack "13wD1L9PvEgBytP5X6ykiuhB8gRP58CB5J"- ] - ]- )-- -- list cmdListTx of acc1- cmdListTx "acc1" >>= liftIO . assertEqual "Check listTx txA 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , T.pack "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , T.pack "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- ]- , "Value" .= (600000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , T.pack "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , "Value" .= (-360000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- list cmdListTx of acc2- cmdListTx "acc2" >>= liftIO . assertEqual "Check listTx txA 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , "Value" .= (200000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- ]- )-- -- Check balance of acc1- cmdBalance "acc1" >>= liftIO . assertEqual "Check balance txA 1" - (object ["Balance" .= (240000 :: Int)])-- -- Balance of acc2 - cmdBalance "acc2" >>= liftIO . assertEqual "Check balance txA 2" - (object ["Balance" .= (30000 :: Int)])-- -- Re-Importing a transaction in the middle of the chain- cmdImportTx (decode' $ fromJust $ hexToBS txC) >>= - liftIO . assertEqual "import txC BIS"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- ]- , "Value" .= (120000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , T.pack "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , "Value" .= (-170000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"- ]- , "Value" .= (-120000 :: Int)- ]- ]- )-- -- Verify that the transaction orders haven't changed- ((map g) <$> selectList [DbTxAccount ==. ai1] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Last order verification"- [ ( "23c5dcac6ef51d36ca63cf7f3dc30163939bb208eb8e12b92183ccc1333c20bd"- , [ "1ChqhDvLVx5bjRHbdUweCsd4mgwD4fvdGL"- , "1DKe1dvRznGqmBFsHY7MmvJy3DtcfBDZbw"- , "17yJQpBHpWyVHNshgGpCK876Nb8qqvp3rG"- ]- , 600000, False, False- )- , ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M"- , "1FLRUj4iGRZHpr9WJq3RG64cL2vEbccQ86"- ]- , -360000, False, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , ["14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"]- , 120000, False, False- )- , ( "03e0ce2206a300bfc718afd25e1d34bc3a0b61e570913c4ab94884219b031582"- , ["13s6R8TRWTk5DZaSQ2pKn3hfdugvEZEdZf"]- , -120000, False, False- )- ]-- -- Verify that the transaction order haven't changed- ((map g) <$> selectList [DbTxAccount ==. ai2] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Last order verification 2"- [ ( "53fe1114579ef53affe2339d3cd5010b054515556bc9749351e96b24f9cba3d0"- , [ "16mrBKvB9DV5YAYw7a8kYDvqwh1tJGMR5M" ]- , 200000, False, False- )- , ( "2255db56e3ff00c36461da3d7251065b0cefc657a3343146cf69dc0f418ab150"- , [ "14MZHk4dkM3ZM7bBcET4ELuyozXqCCsQpb"- , "13GTKCtWbpRpPGca3uhTjwZWiQcqAMPh6n"- ]- , -170000, False, False- )- ]---testSend :: ( PersistStore m, PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- ) - => EitherT String m ()-testSend = do -- -- Send some money to an outside address- cmdSendMany "acc1" - [ ("19w9Btacp9tYgbhWE9d8yEdhR15XcjE9XZ", 20000) -- outside- , ("1D8KWhk1x2EGqEUXi1GMJmqmRRWebH8XmT", 30000) -- outside- ] 10000 >>= liftIO . assertEqual "send normal tx"- ( object [ "Tx" .= T.pack "0100000001bd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc523000000006b483045022100b45842dae5f62c6564c9133891bab410ec8b9129580bf98762fc66ae6be45b6c02207cf90bdc82e2d538a46e3580a7b639737c2d334cdd74df65ee24770d2ac8fb940121020ab91e1cdcaf0d13ca13f1b0b975184882a90ee369f4ac6eab00caacca36b423ffffffff03204e0000000000001976a91461fe4d90fbb250c29e24aaff95f14218c0d39f3388ac30750000000000001976a9148503dfd0281b679af0770d5894cdf0402047befa88ac409c0000000000001976a9146d1523de2ac60a29e60f6584956032054302e73a88ac00000000"- , "Complete" .= True- ]- )-- -- Same as before but set the amount such that the change would- -- result in dust. The dust should be donated as tx fee- cmdSendMany "acc1" - [ ("19w9Btacp9tYgbhWE9d8yEdhR15XcjE9XZ", 44000) -- outside- , ("1D8KWhk1x2EGqEUXi1GMJmqmRRWebH8XmT", 44000) -- outside- ] 10000 >>= liftIO . assertEqual "send normal tx no change"- ( object [ "Tx" .= T.pack "0100000001bd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc523000000006a47304402207a68a43941c387787a611b7775e487dced559f7331f00aa143d87bf4c6dc447802203d56aa3c9e3b209da4396e771c734d68b6b99c52528c8255dc552fe42a7d67be0121020ab91e1cdcaf0d13ca13f1b0b975184882a90ee369f4ac6eab00caacca36b423ffffffff02e0ab0000000000001976a91461fe4d90fbb250c29e24aaff95f14218c0d39f3388ace0ab0000000000001976a9148503dfd0281b679af0770d5894cdf0402047befa88ac00000000"- , "Complete" .= True- ]- )-- let emptyTx = "0100000001bd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc5230000000000ffffffff02e0ab0000000000001976a91461fe4d90fbb250c29e24aaff95f14218c0d39f3388ace0ab0000000000001976a9148503dfd0281b679af0770d5894cdf0402047befa88ac00000000"-- -- Sign an empty shell transaction with cmdSignTx- cmdSignTx "acc1" (decode' $ fromJust $ hexToBS emptyTx) (SigAll False) >>= - liftIO . assertEqual "sign empty transaction"- ( object [ "Tx" .= T.pack "0100000001bd203c33c1cc8321b9128eeb08b29b936301c33d7fcf63ca361df56eacdcc523000000006a47304402207a68a43941c387787a611b7775e487dced559f7331f00aa143d87bf4c6dc447802203d56aa3c9e3b209da4396e771c734d68b6b99c52528c8255dc552fe42a7d67be0121020ab91e1cdcaf0d13ca13f1b0b975184882a90ee369f4ac6eab00caacca36b423ffffffff02e0ab0000000000001976a91461fe4d90fbb250c29e24aaff95f14218c0d39f3388ace0ab0000000000001976a9148503dfd0281b679af0770d5894cdf0402047befa88ac00000000"- , "Complete" .= True- ]- )-- -- Sign an empty shell transaction with cmdSignTx. Should fail as- -- acc2 does not have any of the inputs- cmdSignTx "acc2" (decode' $ fromJust $ hexToBS emptyTx) (SigAll False) >>= - liftIO . assertEqual "sign empty transaction 2"- ( object [ "Tx" .= T.pack emptyTx- , "Complete" .= False- ]- )-- -- Sending more coins than you have should fail- (runEitherT $ cmdSendMany "acc1" - [ ("15WAh7HRms3HDFLEAtMuBM4aUcwvN7B2QY", 300000) -- outside- , ("1CzjVJfn1RmNes4ZEKGRA8VJcpCB1xfNvp", 110000) -- outside- ] 10000) >>= liftIO . assertEqual "Send too many coins"- (Left "chooseCoins: No solution found")-- -- Spending coins from a multisignature account- cmdSendMany "ms1" - [ ("15WAh7HRms3HDFLEAtMuBM4aUcwvN7B2QY", 300000) -- outside- , ("1CzjVJfn1RmNes4ZEKGRA8VJcpCB1xfNvp", 110000) -- outside- ] 10000 >>= liftIO . assertEqual "Send coins from multisig coins"- ( object [ "Tx" .= T.pack "0100000003711707c27ce6fad18ddf3542de57bea6dbf211a18723717ee3844e9aaec5629000000000b50047304402206fa37ea2fcc6467c788b321be6c8db6b52c1c328dfe3397c1d0c3f06b13ef1bc02203afdcca94843391019cf0a38331a85f7ae5b24df28c397adb4ebecbd5390db2901004c695221026e294fcecdcbae12a0aba1685db35c54ddfc1375d48f96ff1b8805a4bb57bfc921028bc8d8377f44de8ac8beff0dc9ccefde4cd5dded7b8cd8babe02c7147a90ba6c21039cf5d06e79871043c420fabc652f8082e702e0094f91ec14c020e9fcf48fa4d853aeffffffff85e7fcc7399ef68c3277ab4be6aecfa7f77781a99d3a8e0038f03846fb269f3104000000b600483045022100caeda000f0a7144721439020edee8c9f20f41afc63288ea732b2483f1f3b77a202207d727f06e2a5661eff977a7f29bf563a9e3fc11bc3e191a246a722cfc9ab9a6601004c695221026e294fcecdcbae12a0aba1685db35c54ddfc1375d48f96ff1b8805a4bb57bfc921028bc8d8377f44de8ac8beff0dc9ccefde4cd5dded7b8cd8babe02c7147a90ba6c21039cf5d06e79871043c420fabc652f8082e702e0094f91ec14c020e9fcf48fa4d853aeffffffff96a9342b5d88583a607e8cc43a4fd844a9dfc3ef9f72982db4dac3b708f356a104000000b500473044022070bdccc43981a4a341f27b4e8ed146301ce82c1c571f483b7d457f20bc754b4402201deefab82e52a0235c336fd24e7ccf1ec47b5751f4b8a472b0a23543d9b7e42401004c695221026e294fcecdcbae12a0aba1685db35c54ddfc1375d48f96ff1b8805a4bb57bfc921028bc8d8377f44de8ac8beff0dc9ccefde4cd5dded7b8cd8babe02c7147a90ba6c21039cf5d06e79871043c420fabc652f8082e702e0094f91ec14c020e9fcf48fa4d853aeffffffff02e0930400000000001976a9143164a7f65ce9d354a8ded150547a9523df056b3588acb0ad0100000000001976a91483948f86afa40df4836e88f402aff1e540469ba588ac00000000"- , "Complete" .= False- ]- )-- _ <- cmdNewMS "signms" 2 3 []- - _ <- cmdAddKeys "signms" [fromJust $ xPubImport "xpub69QmF5x2m5duxo856Dg622vDjsxtDCwMAaLyhVjBZDDTaKbenBfMByNJVMYKAVTEpGPDePdgjDpDyPvBPx4WpFV8zmNEa6Cx7Lk4Bn9PDcE"]-- _ <- cmdAddKeys "signms" [fromJust $ xPubImport "xpub69QmF5x2m5dv1r2xNBLTq6HGKjFDyE4iAhxhdL4FgVR8vQprruLcauxJNdASANJaZc65bmoD1snK4db9DDYAuEBo3ANZik9SHnTAKQZLDt1"]---- cmdNewMS "test2" 2 3 []--- cmdNewMS "test3" 2 3 []------ deleteBy $ UniqueAccName "signms"--- deleteBy $ UniqueAccName "test2"------ cmdAddKeys "test3" [fromJust $ xPubImport "xpub69QmF5x2m5duvyfWu3DjU9r9CkTKp5poGCnVLBmRBgJaye7LQ9yPs55z7zPZDpp6X4BHru9EpF8hqQGNa2ipEmBx9rYq6LdvNht6M2qqxUm"]------ cmdAddKeys "test3" [fromJust $ xPubImport "xpub69QmF5x2m5duxo856Dg622vDjsxtDCwMAaLyhVjBZDDTaKbenBfMByNJVMYKAVTEpGPDePdgjDpDyPvBPx4WpFV8zmNEa6Cx7Lk4Bn9PDcE"]--{- TxID: 62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589- - Input: 03-01- - Outputs:- - 3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E : 100000- - 3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW : 200000- - 3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR : 150000- - 3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp : 180000 - -}-- let fundingTx = decode' $ fromJust $ hexToBS "01000000010000000000000000000000000000000000000000000000000000000000000001030000006a47304402206992bec0f95102a9994dd77e0b910af0b19b0b94d94423c68bb49ed57890238402203b15cbb6e1edcb686891138b057acac4cb67247f6bf693f38bd35d8c6605bca201210290a14bce9d363667574a29da1b2e38d106968969f449588713bb271e28a9a4a0ffffffff04a08601000000000017a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87400d03000000000017a91488fb2eb63c1f992d801f538340180527510464c787f04902000000000017a9148c0ad01947abab4985837a24be0d2141dcba06398720bf02000000000017a91460c1eb9034130684ece4594384e984325d1280ad8700000000"--{- TxID: 74ea8680000dd5e4f0122e47c73de7b0b02aae478a03930c5f547f67ed3dabcb- - Inputs: 1,2,3- - Outputs: - - 13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3 : 300000- - 1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d : 140000- - 3CDgiQ2TnKvy1AovxwFy2jsDqURN8bq856 : 80000 (Change)- -}- let partialTx = "01000000038935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76202000000b6004830450221009d876833374da1714aa42945b73fe2af9ee37fdf32b4db9dd10297c0a9a18257022065618d04ead4ba5e4201bf15f149f1429e83173d42e31246d3164f2072e6605901004c69522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76203000000b600483045022100f8f9274fcf04200031578f5bfa0ecd108f5c945d7efef5f4fe519943d945594502200941f22088458750894005366a74857b72fb59197405bd2298947d96456d165b01004c6952210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76201000000b50047304402200469180f9e94bf6d1d03ce07411bfd107b78f2fb1b1a862fc39dfeece417d14b02206696f963f97d3a6aaddc295c8eaf1846fef07f44c46d3aa97f09a4c0b72476c101004c695221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853aeffffffff03e0930400000000001976a91419abd2efb4cd44b132ffd6206aa35e60f9d3e4b988ace0220200000000001976a914decc77b87d2199a51532034ad63f59cae6e6c4f588ac803801000000000017a914737e1e10bbf4290c82681745b5a54449ca83d1848700000000"---- ID: a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3-- let finalTx = "01000000038935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76202000000fdfd00004830450221009d876833374da1714aa42945b73fe2af9ee37fdf32b4db9dd10297c0a9a18257022065618d04ead4ba5e4201bf15f149f1429e83173d42e31246d3164f2072e6605901473044022065316243de4edd6e1741580a11489a5445b4fc35efcb13aa6189f1a524f6745a022003fdf5273c90ac7d906cba33f42661dcac45e80aab9aecd4fcd5ed5e9595c239014c69522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76203000000fdfd000047304402205c1bd8303745cbcc3f3412ee6f19090519ef2b72a03c799325ebd2188783bc670220298b8b13cf726beccf0909c83016a22c8429df4a2982f7ea54b24f40dd6a27ac01483045022100f8f9274fcf04200031578f5bfa0ecd108f5c945d7efef5f4fe519943d945594502200941f22088458750894005366a74857b72fb59197405bd2298947d96456d165b014c6952210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76201000000fdfd000047304402200469180f9e94bf6d1d03ce07411bfd107b78f2fb1b1a862fc39dfeece417d14b02206696f963f97d3a6aaddc295c8eaf1846fef07f44c46d3aa97f09a4c0b72476c101483045022100e865ba910c96823cc9ddf6b65d62f6d107ca5589a866f3814d048ada70a01b3102201025101604ccf2f639a7f7176517665656b04c9a531d3e542eb495095148b802014c695221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853aeffffffff03e0930400000000001976a91419abd2efb4cd44b132ffd6206aa35e60f9d3e4b988ace0220200000000001976a914decc77b87d2199a51532034ad63f59cae6e6c4f588ac803801000000000017a914737e1e10bbf4290c82681745b5a54449ca83d1848700000000"-- liftIO $ assertBool "Partial transaction not complete" $ - not $ isTxComplete (decode' $ fromJust $ hexToBS partialTx)-- liftIO $ assertBool "Final transaction complete" $ - isTxComplete (decode' $ fromJust $ hexToBS finalTx)-- -- trying to sign the multisig transaction before importing the transaction- -- funding the account. This should return the original transaction- cmdSignTx "signms" (decode' $ fromJust $ hexToBS partialTx) (SigAll False)- >>= liftIO . assertEqual "Sign partial multisig without coins" - ( object [ "Tx" .= T.pack partialTx- , "Complete" .= False- ]- )-- -- Import the funding transaction into the wallet- cmdImportTx fundingTx >>= liftIO . assertEqual "Importing funding tx"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , T.pack "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , T.pack "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , T.pack "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , "Value" .= (630000:: Int)- ]- ]- )-- -- Import the funding transaction again. The process should be idempotent- cmdImportTx fundingTx >>= liftIO . assertEqual "Importing funding tx"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , T.pack "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , T.pack "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , T.pack "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , "Value" .= (630000:: Int)- ]- ]- )-- -- We should have 4 coins in the database- cmdCoins "signms" >>= liftIO . assertEqual "Check coins after funding tx import" - (toJSON - [ object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87"- , "Redeem" .= T.pack "522102690c830a595721558e2bf6c58f6ed269c3b9fa194523326bb26d9a20b0cf49532102c98a1bde30c9fd0b71e88792b512963ce8b956f8735dbb0b1a2d6da7f1385e8d2102e7166192bf2bb2433daad4ab396fc2dc09785df716ca992f8bf76ff0aed6695053ae"- , "Address" .= T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- ] - , object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (1 :: Int)- , "Value" .= (200000 :: Int)- , "Script" .= T.pack "a91488fb2eb63c1f992d801f538340180527510464c787"- , "Redeem" .= T.pack "5221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853ae"- , "Address" .= T.pack "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- ] - , object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (2 :: Int)- , "Value" .= (150000 :: Int)- , "Script" .= T.pack "a9148c0ad01947abab4985837a24be0d2141dcba063987"- , "Redeem" .= T.pack "522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253ae"- , "Address" .= T.pack "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- ] - , object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (3 :: Int)- , "Value" .= (180000 :: Int)- , "Script" .= T.pack "a91460c1eb9034130684ece4594384e984325d1280ad87"- , "Redeem" .= T.pack "52210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953ae"- , "Address" .= T.pack "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ] - ]- )-- -- Import the partially signed transaction into the wallet- -- This should yield a partial transaction and no output coins- cmdImportTx (decode' $ fromJust $ hexToBS $ partialTx) >>= - liftIO . assertEqual "Importing partial tx 1"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- , "Partial" .= True- ]- ]- )-- -- Re-importing the partial transaction should be an idempotent process- cmdImportTx (decode' $ fromJust $ hexToBS $ partialTx) >>= - liftIO . assertEqual "Importing partial tx 2"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- , "Partial" .= True- ]- ]- )-- -- After importing the partially signed transaction in the wallet, we should- -- have some of the coins in "reserved" status. Additionally, the change- -- coin should not be displayed here as importing partial transactions does- -- not produce coins (would not make sense as TxID is wrong)- cmdCoins "signms" >>= liftIO . assertEqual "Check coins after importing partial tx" - (toJSON - [ object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87"- , "Redeem" .= T.pack "522102690c830a595721558e2bf6c58f6ed269c3b9fa194523326bb26d9a20b0cf49532102c98a1bde30c9fd0b71e88792b512963ce8b956f8735dbb0b1a2d6da7f1385e8d2102e7166192bf2bb2433daad4ab396fc2dc09785df716ca992f8bf76ff0aed6695053ae"- , "Address" .= T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- ] - ]- )-- -- Now we should have the funding transaction followed by a- -- a partially signed multisig transaction- cmdListTx "signms" >>= liftIO . assertEqual "Final tx check MS"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , T.pack "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , T.pack "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , T.pack "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , "Value" .= (630000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- , "Partial" .= True- ]- ]- )--- let f (Entity _ c) = ( dbCoinTxid c, dbCoinPos c- , dbCoinValue c, dbCoinScript c- , dbCoinRdmScript c, dbCoinAddress c- , dbCoinStatus c, dbCoinOrphan c- )- g (Entity _ t) = ( dbTxTxid t, dbTxRecipients t- , dbTxValue t, dbTxOrphan t, dbTxPartial t- )-- (Entity msi _) <- dbGetAcc "signms"-- -- Checking the coins directly in the database- ((map f) <$> selectList [DbCoinAccount ==. msi] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check DB coins after importing Partial tx"- [ ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 0, 100000, "a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87"- , Just "522102690c830a595721558e2bf6c58f6ed269c3b9fa194523326bb26d9a20b0cf49532102c98a1bde30c9fd0b71e88792b512963ce8b956f8735dbb0b1a2d6da7f1385e8d2102e7166192bf2bb2433daad4ab396fc2dc09785df716ca992f8bf76ff0aed6695053ae"- , "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , Unspent- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 1, 200000, "a91488fb2eb63c1f992d801f538340180527510464c787"- , Just "5221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853ae"- , "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , Reserved "74ea8680000dd5e4f0122e47c73de7b0b02aae478a03930c5f547f67ed3dabcb"- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 2, 150000, "a9148c0ad01947abab4985837a24be0d2141dcba063987"- , Just "522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253ae"- , "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , Reserved "74ea8680000dd5e4f0122e47c73de7b0b02aae478a03930c5f547f67ed3dabcb"- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 3, 180000, "a91460c1eb9034130684ece4594384e984325d1280ad87"- , Just "52210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953ae"- , "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- , Reserved "74ea8680000dd5e4f0122e47c73de7b0b02aae478a03930c5f547f67ed3dabcb"- , False- )- ]-- -- Checking the transactions directly in the database- ((map g) <$> selectList [DbTxAccount ==. msi] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check DB transactions after importing Partial tx"- [ ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , [ "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , 630000 , False, False- )- , ( "74ea8680000dd5e4f0122e47c73de7b0b02aae478a03930c5f547f67ed3dabcb"- , [ "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , -450000, False, True- )- ]-- -- Completing a multisig transaction- cmdSignTx "signms" (decode' $ fromJust $ hexToBS partialTx) (SigAll False) - >>= liftIO . assertEqual "Sign partial multisig" - ( object [ "Tx" .= T.pack finalTx- , "Complete" .= True- ]- )-- -- this should return the partial signature as the account is wrong- cmdSignTx "ms1" (decode' $ fromJust $ hexToBS partialTx) (SigAll False) - >>= liftIO . assertEqual "Sign partial multisig bad acc" - ( object [ "Tx" .= T.pack partialTx- , "Complete" .= False- ]- )-- -- Importing the full transaction into the wallet- cmdImportTx (decode' $ fromJust $ hexToBS finalTx) >>= - liftIO . assertEqual "Final tx import"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- ]- ]- )-- -- Importing the full transaction into the wallet (again)- cmdImportTx (decode' $ fromJust $ hexToBS finalTx) >>= - liftIO . assertEqual "Final tx import again"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- ]- ]- )-- -- The change coin should now be there- cmdCoins "signms" >>= liftIO . assertEqual "Check coins after importing final tx" - (toJSON - [ object [ "TxID" .= T.pack "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , "Index" .= (0 :: Int)- , "Value" .= (100000 :: Int)- , "Script" .= T.pack "a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87"- , "Redeem" .= T.pack "522102690c830a595721558e2bf6c58f6ed269c3b9fa194523326bb26d9a20b0cf49532102c98a1bde30c9fd0b71e88792b512963ce8b956f8735dbb0b1a2d6da7f1385e8d2102e7166192bf2bb2433daad4ab396fc2dc09785df716ca992f8bf76ff0aed6695053ae"- , "Address" .= T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- ] - , object [ "TxID" .= T.pack "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , "Index" .= (2 :: Int)- , "Value" .= (80000 :: Int)- , "Script" .= T.pack "a914737e1e10bbf4290c82681745b5a54449ca83d18487"- , "Redeem" .= T.pack "5221021190e8331245f9455d0b027cd9f53e2e5f530ffa48aaa4f6b9fc7657c8cd5ebe21030e08ad2233845f90e958988768b42f8e53d358efc371149049a5399ae0d3b334210380f8240eb12a1bbe20c2f441d6c2216d5eb84bbb4b926aa801180de13dbdf7c553ae"- , "Address" .= T.pack "3CDgiQ2TnKvy1AovxwFy2jsDqURN8bq856"- ] - ]- )-- -- The transaction list should be the funding transaction followed by- -- the multisig spending transaction- cmdListTx "signms" >>= liftIO . assertEqual "Check tx after importing final tx"- ( toJSON- [ object [ "Recipients" .= toJSON- [ T.pack "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , T.pack "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , T.pack "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , T.pack "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , "Value" .= (630000 :: Int)- ]- , object [ "Recipients" .= toJSON- [ T.pack "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , T.pack "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , "Value" .= (-450000 :: Int)- ]- ]- )-- -- Checking the coins directly in the database- ((map f) <$> selectList [DbCoinAccount ==. msi] [Asc DbCoinCreated]) >>= - liftIO . assertEqual "Check DB coins after importing Final tx"- [ ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 0, 100000, "a91491b00b8d4d4b8909d5d17fe8da3b09fbd64e003c87"- , Just "522102690c830a595721558e2bf6c58f6ed269c3b9fa194523326bb26d9a20b0cf49532102c98a1bde30c9fd0b71e88792b512963ce8b956f8735dbb0b1a2d6da7f1385e8d2102e7166192bf2bb2433daad4ab396fc2dc09785df716ca992f8bf76ff0aed6695053ae"- , "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , Unspent- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 1, 200000, "a91488fb2eb63c1f992d801f538340180527510464c787"- , Just "5221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853ae"- , "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , Spent "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 2, 150000, "a9148c0ad01947abab4985837a24be0d2141dcba063987"- , Just "522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253ae"- , "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , Spent "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , False- )- , ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , 3, 180000, "a91460c1eb9034130684ece4594384e984325d1280ad87"- , Just "52210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953ae"- , "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- , Spent "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , False- )- , ( "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , 2, 80000, "a914737e1e10bbf4290c82681745b5a54449ca83d18487"- , Just "5221021190e8331245f9455d0b027cd9f53e2e5f530ffa48aaa4f6b9fc7657c8cd5ebe21030e08ad2233845f90e958988768b42f8e53d358efc371149049a5399ae0d3b334210380f8240eb12a1bbe20c2f441d6c2216d5eb84bbb4b926aa801180de13dbdf7c553ae"- , "3CDgiQ2TnKvy1AovxwFy2jsDqURN8bq856"- , Unspent- , False- )- ]-- -- Checking the transactions directly in the database- ((map g) <$> selectList [DbTxAccount ==. msi] [Asc DbTxCreated]) >>=- liftIO . assertEqual "Check DB transactions after importing Final tx"- [ ( "62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589"- , [ "3EyLoBudu2fNY7hnQDX7iZ3kn1d9wyPc2E"- , "3EBJj6Z2FrrGUytJabTrJRD6mxCgF3d7JW"- , "3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR"- , "3AWd6mZHrvMbocVRp752ExTGnUhh1huWQp"- ]- , 630000 , False, False- )- , ( "a7274a15719099c5de37741bfd70efa15bb22a9de5507d966ccdf528a4f8f4c3"- , [ "13LjjLQGGiTL8AYMbYqBmQVyAMyQnjPZK3"- , "1MK3xFQSekQPuety1oaVTmvLRusFYsTq3d"- ]- , -450000, False, False- )- ]--testUtil :: ( PersistStore m, PersistUnique m, PersistQuery m- , PersistMonadBackend m ~ SqlBackend- ) - => EitherT String m ()-testUtil = do -- cmdBuildRawTx "[{\"txid\":\"0100000000000000000000000000000000000000000000000000000000000000\",\"vout\":10},{\"txid\":\"0200000000000000000000000000000000000000000000000000000000000000\",\"vout\":11}]" "{\"1EWdRnLVsncoJjrfShHQxPDJPZNGNGFKgx\":100000,\"3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR\":200000}" >>= liftIO . assertEqual "Build Raw Tx"- (toJSON $ object ["Tx" .= T.pack "010000000200000000000000000000000000000000000000000000000000000000000000010a00000000ffffffff00000000000000000000000000000000000000000000000000000000000000020b00000000ffffffff02a0860100000000001976a91494341b2515efda20f26d37a2f4f5abd424cf71f688ac400d03000000000017a9148c0ad01947abab4985837a24be0d2141dcba06398700000000"])-- let partialTx = "01000000038935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76202000000b6004830450221009d876833374da1714aa42945b73fe2af9ee37fdf32b4db9dd10297c0a9a18257022065618d04ead4ba5e4201bf15f149f1429e83173d42e31246d3164f2072e6605901004c69522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76203000000b600483045022100f8f9274fcf04200031578f5bfa0ecd108f5c945d7efef5f4fe519943d945594502200941f22088458750894005366a74857b72fb59197405bd2298947d96456d165b01004c6952210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76201000000b50047304402200469180f9e94bf6d1d03ce07411bfd107b78f2fb1b1a862fc39dfeece417d14b02206696f963f97d3a6aaddc295c8eaf1846fef07f44c46d3aa97f09a4c0b72476c101004c695221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853aeffffffff03e0930400000000001976a91419abd2efb4cd44b132ffd6206aa35e60f9d3e4b988ace0220200000000001976a914decc77b87d2199a51532034ad63f59cae6e6c4f588ac803801000000000017a914737e1e10bbf4290c82681745b5a54449ca83d1848700000000"-- let resultTx = "01000000038935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76202000000fdfd00004830450221009d876833374da1714aa42945b73fe2af9ee37fdf32b4db9dd10297c0a9a18257022065618d04ead4ba5e4201bf15f149f1429e83173d42e31246d3164f2072e6605901473044022065316243de4edd6e1741580a11489a5445b4fc35efcb13aa6189f1a524f6745a022003fdf5273c90ac7d906cba33f42661dcac45e80aab9aecd4fcd5ed5e9595c239014c69522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76203000000b600483045022100f8f9274fcf04200031578f5bfa0ecd108f5c945d7efef5f4fe519943d945594502200941f22088458750894005366a74857b72fb59197405bd2298947d96456d165b01004c6952210285bd8161363c6e2d2c075e08ed8a956c4706ccd77497a31327bf92b2208c3587210286e3177a8ca61d2d9426b4230735631e8552cc4d6e87e1277960461b0d26aac42103e2e138589e064f347238c2ca46c1d7deb8dd9472d065d7c5cb0f91aa5cc210a953aeffffffff8935da5b1084b96a26d931aa9a6e9c844191c014c190d7981979eb977c89e76201000000fdfd000047304402200469180f9e94bf6d1d03ce07411bfd107b78f2fb1b1a862fc39dfeece417d14b02206696f963f97d3a6aaddc295c8eaf1846fef07f44c46d3aa97f09a4c0b72476c101483045022100e865ba910c96823cc9ddf6b65d62f6d107ca5589a866f3814d048ada70a01b3102201025101604ccf2f639a7f7176517665656b04c9a531d3e542eb495095148b802014c695221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853aeffffffff03e0930400000000001976a91419abd2efb4cd44b132ffd6206aa35e60f9d3e4b988ace0220200000000001976a914decc77b87d2199a51532034ad63f59cae6e6c4f588ac803801000000000017a914737e1e10bbf4290c82681745b5a54449ca83d1848700000000"-- let sigi = concat- [ "[{"- , "\"txid\":\"62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589\","- , "\"vout\":2,"- , "\"scriptPubKey\":\"a9148c0ad01947abab4985837a24be0d2141dcba063987\","- , "\"scriptRedeem\":\"522102779d361a5d534dfca9d480eb60a1b14741a98d29f5c984fc1afd68a8c50981232102f579364c0d0971ec9ae52f2fc870204bce00438be1b6fa695d27c9d01cfb0956210383787221b68f601aa4695c27e7eebb0d15de2ed7ef7b9981fba8cad71ae2d84253ae\""- , "},{"- , "\"txid\":\"62e7897c97eb791998d790c114c09141849c6e9aaa31d9266ab984105bda3589\","- , "\"vout\":1,"- , "\"scriptPubKey\":\"a91488fb2eb63c1f992d801f538340180527510464c787\","- , "\"scriptRedeem\":\"5221023206a385544defd500a54d3d3fd8982d35fa7f877fa721beb59e440186183e8a210352b7c1f82593abebcb4ad0bbf28a4317b49efc1cc3e647453c09c6375122e8f621035c9ca1f7825d2cf025f42e636f57f193dbaae5c18b08dca10bf996ddb58eb8e853ae\""- , "}]"- ]-- -- WIF for 3ETVUh7mn1sSiLrhUQYMByfuo32DauHKdR (input 0)- let prv = concat- [ "["- , "\"L4rxfXmwUDpmkpfmUAaJo7ChfPgAAj18pdpF8GTVkJRheJZaFikf\","- , "\"L5ZencGKZqtiDk2DjFn23PjMdzGo9ZNpDw5wpcgN2cX1Qzjg6zzr\""- , "]"- ]- tx = decode' $ fromJust $ hexToBS partialTx-- cmdSignRawTx tx sigi prv (SigAll False) >>=- liftIO . assertEqual "Sign raw transaction"- ( object [ (T.pack "Tx") .= T.pack resultTx- , (T.pack "Complete") .= False- ]- )-
tests/Network/Haskoin/Wallet/Tests.hs view
@@ -3,154 +3,20 @@ import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Control.Monad (liftM2)-import Control.Applicative ((<$>))--import Data.Word (Word32, Word64)-import Data.Bits ((.&.))-import Data.Maybe (fromJust)-import qualified Data.ByteString as BS (length)--import QuickCheckUtils-import Network.Haskoin.Wallet.Arbitrary+import Data.Aeson (FromJSON, ToJSON, encode, decode) +import Network.Haskoin.Wallet.Arbitrary () import Network.Haskoin.Wallet-import Network.Haskoin.Wallet.TxBuilder-import Network.Haskoin.Script-import Network.Haskoin.Crypto-import Network.Haskoin.Protocol-import Network.Haskoin.Util-import Network.Haskoin.Util.BuildMonad tests :: [Test]-tests = - [ testGroup "HDW Extended Keys"- [ testProperty "prvSubKey(k,c)*G = pubSubKey(k*G,c)" subkeyTest- , testProperty "decode . encode prvKey" binXPrvKey- , testProperty "decode . encode pubKey" binXPubKey- , testProperty "fromB58 . toB58 prvKey" b58PrvKey- , testProperty "fromB58 . toB58 pubKey" b58PubKey- ]- , testGroup "HDW Extended Key Manager"- [ testProperty "decode . encode masterKey" decEncMaster- , testProperty "decode . encode prvAccKey" decEncPrvAcc- , testProperty "decode . encode pubAccKey" decEncPubAcc- ]- , testGroup "Building Transactions"- [ testProperty "building address tx" testBuildAddrTx- , testProperty "testing guessTxSize function" testGuessSize- , testProperty "testing chooseCoins function" testChooseCoins- , testProperty "testing chooseMSCoins function" testChooseMSCoins- ]- , testGroup "Signing Transactions"- [ testProperty "Check signed transaction status" testSignTxBuild- , testProperty "Sign and validate transactions" testSignTxValidate+tests =+ [ testGroup "Serialize & de-serialize types to JSON"+ [ testProperty "AccountType" (metaID :: AccountType -> Bool)+ , testProperty "TxAction" (metaID :: TxAction -> Bool)+ , testProperty "NodeAction" (metaID :: NodeAction -> Bool) ] ] -{- HDW Extended Keys -}--subkeyTest :: XPrvKey -> Word32 -> Bool-subkeyTest k i = fromJust $ liftM2 (==) - (deriveXPubKey <$> prvSubKey k i') (pubSubKey (deriveXPubKey k) i')- where i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation--binXPrvKey :: XPrvKey -> Bool-binXPrvKey k = (decode' $ encode' k) == k--binXPubKey :: XPubKey -> Bool-binXPubKey k = (decode' $ encode' k) == k--b58PrvKey :: XPrvKey -> Bool-b58PrvKey k = (fromJust $ xPrvImport $ xPrvExport k) == k--b58PubKey :: XPubKey -> Bool-b58PubKey k = (fromJust $ xPubImport $ xPubExport k) == k--{- HDW Extended Key Manager -}--decEncMaster :: MasterKey -> Bool-decEncMaster k = (fromJust $ loadMasterKey $ decode' bs) == k- where bs = encode' $ masterKey k--decEncPrvAcc :: AccPrvKey -> Bool-decEncPrvAcc k = (fromJust $ loadPrvAcc $ decode' bs) == k- where bs = encode' $ getAccPrvKey k--decEncPubAcc :: AccPubKey -> Bool-decEncPubAcc k = (fromJust $ loadPubAcc $ decode' bs) == k- where bs = encode' $ getAccPubKey k--{- Building Transactions -}--testBuildAddrTx :: [OutPoint] -> Address -> Word64 -> Bool-testBuildAddrTx os a v - | v <= 2100000000000000 = isRight tx && case a of- x@(PubKeyAddress _) -> Right (PayPKHash x) == out- x@(ScriptAddress _) -> Right (PayScriptHash x) == out- | otherwise = isLeft tx- where tx = buildAddrTx os [(addrToBase58 a,v)]- out = decodeOutput $ scriptOutput $ txOut (fromRight tx) !! 0--testGuessSize :: RegularTx -> Bool-testGuessSize (RegularTx tx) =- -- We compute an upper bound but it should be close enough to the real size- -- We give 3 bytes of slack on every signature (1 on r and 2 on s)- guess >= len && guess - 3*delta <= len- where delta = pki + (sum $ map fst msi)- guess = guessTxSize pki msi pkout msout- len = BS.length $ encode' tx- rIns = map (decodeInput . scriptInput) $ txIn tx- mIns = map (decodeScriptHash . scriptInput) $ txIn tx- pki = length $ filter (isSpendPKHash . fromRight) $ - filter isRight rIns- msi = concat $ map (shData . fromRight) $ filter isRight mIns- shData (ScriptHashInput _ (PayMulSig keys r)) = [(r,length keys)]- shData _ = []- out = map (fromRight . decodeOutput . scriptOutput) $ txOut tx- pkout = length $ filter isPayPKHash out- msout = length $ filter isPayScriptHash out--testChooseCoins :: Word64 -> Word64 -> [Coin] -> Bool-testChooseCoins target kbfee xs = case chooseCoins target kbfee xs of- Right (chosen,change) ->- let outSum = sum $ map (outValue . coinTxOut) chosen- fee = getFee kbfee (length chosen) - in outSum == target + change + fee- Left _ -> - let fee = getFee kbfee (length xs) - in target == 0 || s < target || s < target + fee- where s = sum $ map (outValue . coinTxOut) xs--testChooseMSCoins :: Word64 -> Word64 -> MSParam -> [Coin] -> Bool-testChooseMSCoins target kbfee (MSParam m n) xs = - case chooseMSCoins target kbfee (m,n) xs of- Right (chosen,change) ->- let outSum = sum $ map (outValue . coinTxOut) chosen- fee = getMSFee kbfee (m,n) (length chosen) - in outSum == target + change + fee- Left _ -> - let fee = getMSFee kbfee (m,n) (length xs) - in target == 0 || s < target + fee- where s = sum $ map (outValue . coinTxOut) xs--{- Signing Transactions -}--testSignTxBuild :: PKHashSigTemplate -> Bool-testSignTxBuild (PKHashSigTemplate tx sigi prv)- | null $ txIn tx = isBroken txSig && isBroken txSigP- | otherwise = isComplete txSig && isPartial txSigP- where txSig = detSignTx tx sigi prv- txSigP = detSignTx tx (tail sigi) (tail prv)- -testSignTxValidate :: PKHashSigTemplate -> Bool-testSignTxValidate (PKHashSigTemplate tx sigi prv) =- case detSignTx tx sigi prv of- (Broken _) -> True- (Partial btx) -> not $ verifyTx btx $ map f sigi- (Complete btx) -> verifyTx btx $ map f sigi- where f si = (sigDataOut si, sigDataOP si)---- todo: test p2sh transactions-+metaID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool+metaID x = (decode . encode) [x] == Just [x]
+ tests/Network/Haskoin/Wallet/Units.hs view
@@ -0,0 +1,1602 @@+module Network.Haskoin.Wallet.Units (tests) where++import Test.HUnit (Assertion, assertEqual, assertFailure)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)++import Control.Monad (liftM, guard)+import Control.Monad.Trans (liftIO)+import Control.Exception (Exception, handleJust)+import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Logger (NoLoggingT)++import Data.Word (Word32, Word64)+import Data.Maybe (fromJust)+import qualified Data.ByteString as BS+ ( ByteString+ , empty+ , pack+ )++import Database.Persist (Entity(..), entityVal, getBy)+import Database.Persist.Sqlite+ ( runSqlite+ , runMigrationSilent+ , SqlPersistT+ )++import Network.Haskoin.Wallet.Internals+import Network.Haskoin.Node.HeaderTree++import Network.Haskoin.Block+import Network.Haskoin.Transaction+import Network.Haskoin.Script+import Network.Haskoin.Crypto+import Network.Haskoin.Util++type App = SqlPersistT (NoLoggingT (ResourceT IO))++tests :: [Test]+tests =+ [ testGroup "KeyRing creation"+ [ testCase "Calling newKeyRing with an empty seed should fail" $+ assertException+ (WalletException "The seed is empty")+ (newKeyRing "main" BS.empty)++ , testCase "Creating two KeyRings with the same name should fail" $+ assertException+ (WalletException "KeyRing main already exists") $ do+ _ <- newKeyRing "main" $ BS.pack [0]+ newKeyRing "main" $ BS.pack [1]+ ]+ , testGroup "Account tests"+ [ testCase "Creating two accounts with the same name should fail" $+ assertException (WalletException "Account acc already exists") $ do+ keyE <- newKeyRing "main" $ BS.pack [1]+ _ <- newAccount keyE "acc" (AccountRegular False) []+ newAccount keyE "acc" (AccountRegular False) []++ , testCase "Invalid multisig parameters (0 of 1)" $+ assertException (WalletException "Invalid account type") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ newAccount keyE "ms" (AccountMultisig False 0 1) []++ , testCase "Invalid multisig parameters (2 of 1)" $+ assertException (WalletException "Invalid account type") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ newAccount keyE "ms" (AccountMultisig False 2 1) []++ , testCase "Invalid multisig parameters (15 of 16)" $+ assertException (WalletException "Invalid account type") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ newAccount keyE "ms" (AccountMultisig False 15 16) []++ , testCase "To many multisig keys (2 keys for 1 of 2)" $+ assertException+ (WalletException "Invalid account keys") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ newAccount keyE "ms" (AccountMultisig False 1 2)+ [ deriveXPubKey $ makeXPrvKey (BS.pack [1])+ , deriveXPubKey $ makeXPrvKey (BS.pack [2])+ ]++ , testCase "Calling addAccountKeys with an empty key list should fail" $+ assertException+ (WalletException "Invalid account keys") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular True) []+ addAccountKeys accE []++ , testCase "Calling addAccountKeys on a non-multisig account should fail" $+ assertException+ (WalletException "The account is already complete") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ _ <- newAccount keyE "default" (AccountRegular False) []+ (_, accE) <- getAccount "main" "default"+ addAccountKeys accE [ deriveXPubKey $ makeXPrvKey (BS.pack [1]) ]++ , testCase "Adding keys to a complete multisig account should fail" $+ assertException+ (WalletException "The account is already complete") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ _ <- newAccount keyE "ms" (AccountMultisig False 2 3)+ [ deriveXPubKey $ makeXPrvKey (BS.pack [1])+ , deriveXPubKey $ makeXPrvKey (BS.pack [2])+ ]+ (_, accE) <- getAccount "main" "ms"+ addAccountKeys accE [deriveXPubKey $ makeXPrvKey (BS.pack [3])]++ , testCase "Getting a non-existing account should fail" $+ assertException+ (WalletException "Account default does not exist") $ do+ _ <- newKeyRing "main" $ BS.pack [0]+ getAccount "main" "default"++ ]+ , testGroup "Address tests"+ [ testCase "Displaying page 0 should fail" $+ assertException+ (WalletException "Invalid page request (Page: 0, Page size: 1)" ) $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular False) []+ addressPage accE AddressExternal $ PageRequest 0 1 False++ , testCase "Displaying 0 results per page should fail" $+ assertException+ (WalletException "Invalid page request (Page: 1, Page size: 0)" ) $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular False) []+ addressPage accE AddressExternal $ PageRequest 1 0 False++ , testCase "Displaying a page number that is too high should fail" $+ assertException+ (WalletException "Invalid page number 5") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular False) []+ addressPage accE AddressExternal $ PageRequest 5 3 False++ , testCase "Decreasing the address gap should fail" $+ assertException (WalletException "The gap of an account can only be increased") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ _ <- newAccount keyE "default" (AccountRegular False) []+ (_, acc1E) <- getAccount "main" "default"+ _ <- setAccountGap acc1E 15+ (_, acc2E) <- getAccount "main" "default"+ setAccountGap acc2E 14++ , testCase "Setting a label on a hidden address key should fail" $+ assertException (WalletException "Invalid address index 10") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular False) []+ setAddrLabel accE 10 AddressExternal "Gym membership"++ , testCase "Setting a label on an invalid address key should fail" $+ assertException (WalletException "Invalid address index 20") $ do+ keyE <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular False) []+ setAddrLabel accE 20 AddressExternal "Gym membership"++ , testCase "Requesting an address prvkey on a read-only account should fail" $+ assertException+ (WalletException "Invalid address") $ do+ keyE@(Entity _ kr) <- newKeyRing "main" $ BS.pack [0]+ accE <- newAccount keyE "default" (AccountRegular True)+ [deriveXPubKey $ makeXPrvKey $ BS.pack [1]]+ addressPrvKey kr accE 2 AddressExternal+ ]+ , testGroup "Wallet tests"+ [ testCase "Verify address derivations" $ runUnit testDerivations+ , testCase "Verify balances" $ runUnit testBalances+ , testCase "Verify balances in conflict" $ runUnit testConflictBalances+ , testCase "Offline transactions" $ runUnit testOffline+ , testCase "Kill an offline tx by spending his coins" $ runUnit testKillOffline+ , testCase "Offline transaction exceptions" testOfflineExceptions+ , testCase "Multisig test 1" $ runUnit testImportMultisig+ , testCase "Kill Tx" $ runUnit testKillTx+ ]+ ]++assertException :: (Exception e, Eq e) => e -> App a -> Assertion+assertException ex action =+ handleJust matchEx (const $ return ()) $ do+ runUnit action+ assertFailure $ "Expecting exception: " ++ show ex+ where+ matchEx = guard . (== ex)++runUnit :: App a -> Assertion+runUnit action = do+ _ <- runSqlite ":memory:" $ do+ _ <- runMigrationSilent migrateWallet+ initWallet 0.0001+ action+ return ()++bs1 :: BS.ByteString+bs1 = fromRight $ mnemonicToSeed pass+ "mass coast dance birth online various renew alert crunch middle absurd health"++pass :: BS.ByteString+pass = "passw0rd"++tid1 :: TxHash+tid1 = "0000000000000000000000000000000000000000000000000000000000000001"++bid0 :: BlockHash+bid0 = "0000000000000000000000000000000000000000000000000000000000000000"++bid1 :: BlockHash+bid1 = "0000000000000000000000000000000000000000000000000000000000000001"++bid2 :: BlockHash+bid2 = "0000000000000000000000000000000000000000000000000000000000000002"++bid3 :: BlockHash+bid3 = "0000000000000000000000000000000000000000000000000000000000000003"++bid4 :: BlockHash+bid4 = "0000000000000000000000000000000000000000000000000000000000000004"++bid5 :: BlockHash+bid5 = "0000000000000000000000000000000000000000000000000000000000000005"++bid6 :: BlockHash+bid6 = "0000000000000000000000000000000000000000000000000000000000000006"++bid7 :: BlockHash+bid7 = "0000000000000000000000000000000000000000000000000000000000000007"++-- Creates fake testing blocks+fakeNode :: Word32 -> BlockHash -> BlockHeaderNode+fakeNode i h = BlockHeaderNode+ { nodeBlockHash = h+ , nodeHeader = BlockHeader 1 z1 z2 0 0 0+ , nodeHeaderHeight = i+ , nodeChainWork = 0+ , nodeChild = Nothing+ , nodeMedianTimes = []+ , nodeMinWork = 0+ }+ where+ z1 = "0000000000000000000000000000000000000000000000000000000000000000"+ z2 = "0000000000000000000000000000000000000000000000000000000000000000"++fakeTx :: [(TxHash, Word32)] -> [(BS.ByteString, Word64)] -> Tx+fakeTx xs ys =+ Tx 1 txi txo 0+ where+ txi = map (\(h,p) -> TxIn (OutPoint h p) (BS.pack [1]) maxBound) xs+ f = encodeOutputBS . PayPKHash . fromJust . base58ToAddr+ txo = map (\(a,v) -> TxOut v $ f a ) ys++testDerivations :: App ()+testDerivations = do+ keyE <- newKeyRing "test" bs1+ accE <- newAccount keyE "acc1" (AccountRegular False) []++ unusedAddresses accE AddressExternal+ >>= liftIO . assertEqual "Generated external addresses do not match"+ [ "13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR"+ , "1BECmeSVxBYCwL493wt9Vqx8mvaWozTF4r"+ , "1J7n7Lz1VKYdemEDWfyFoGQpSByK9doqeZ"+ , "184p3tofVNgFXfA7Ry3VU1uTPyr5dGCiUF"+ , "1FkBfN2P6RdvSE6M4k1BGZqFYRLXMXyJen"+ , "1MQRM1Luzq4rkrKV8ii7BiukjCa63wt91D"+ , "14zzWHCS5969DL4ZqphMrsG7p2gCSJnCV7"+ , "1FFCS3SzGduAv2MBM9Ak9tALT5snVySST"+ , "18VNX8vQre2hGneuCrXtXwB5D1NVTBUB46"+ , "17mE4ZUaWETvjyLXbTcgoyqTc3A1f7eWVs"+ ] . map (addrToBase58 . keyRingAddrAddress)++ unusedAddresses accE AddressInternal+ >>= liftIO . assertEqual "Generated internal addresses do not match"+ [ "1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd"+ , "16wQCfrqW5QegVe5pXpczHaxDmqTAn4ieM"+ , "1PZjbfPbGzvB7jvoRSkCQZfne154mjU3sY"+ , "152Nc7WrB24foAydrHJ7Sie954NgXCx5Tn"+ , "1HojKLGEQb9bZMMckXgujnv9HGCNxtowCP"+ , "13X9ds52rRYGvLwfbAvQDVU7K13j9cU7BR"+ , "1LSBEYAcmsZuxyPVpF1GqxXTRxpg4CaJPF"+ , "1MUcLFqrYhkSHjYcQdfZJRwnkEi9xWaGZU"+ , "12vgEgi8ExgCo7EBPG1kxwJGR5FCXmZpoB"+ , "1K14RjZ3he6erLHFNrPWwvmxm4nbr1MEYC"+ ] . map (addrToBase58 . keyRingAddrAddress)++testBalances :: App ()+testBalances = do+ keyE <- newKeyRing "test" bs1+ accE@(Entity ai _) <- newAccount keyE "acc1" (AccountRegular False) []+ let fundingTx = fakeTx+ [ (tid1, 0) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000)+ , ("1BECmeSVxBYCwL493wt9Vqx8mvaWozTF4r", 20000000)+ ]+ let tx1 = fakeTx+ [ (txHash fundingTx, 0)+ , (txHash fundingTx, 1)+ ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 30000000) ] -- external+ tx2 = fakeTx+ [ (txHash fundingTx, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 5000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 5000000) -- change+ ]++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ -- Import funding transaction twice. This operation should be idempotent+ importNetTx fundingTx+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 2))+ . testTx+ importNetTx fundingTx+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 0))+ . testTx++ spendableCoins ai 0 (const . const []) >>=+ liftIO . (assertEqual "0-conf spendable coins is not 2" 2) . length+ spendableCoins ai 1 (const . const []) >>=+ liftIO . (assertEqual "1-conf spendable coins is not 0" 0) . length++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 30000000") 30000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 0, 1, 0)")+ [(1, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 1 1 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 1 1-conf balance is not (0, 0, 0, 0)")+ [(1, BalanceInfo 0 0 0 0)]++ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 1 1 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 1 1-conf balance is not (0, 0, 0, 0)")+ [(1, BalanceInfo 0 0 0 0)]++ -- We re-import tx1. This operation has to be idempotent with respect to+ -- balances.+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 1 1 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 1 1-conf balance is not (0, 0, 0, 0)")+ [(1, BalanceInfo 0 0 0 0)]++ -- Importing tx2 twice. This operation has to be idempotent.+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not dead"+ ([(ai, TxDead)], 1))+ . testTx+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not dead"+ ([(ai, TxDead)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ -- Confirm the funding transaction at height 1+ importMerkles ((BestChain [fakeNode 1 bid1])) [[txHash fundingTx]]++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 1 1-conf balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ -- Confirm tx1 at height 2+ importMerkles ((BestChain [fakeNode 2 bid2])) [[txHash tx1]]++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 1 2-conf balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 3-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 1 1 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 1 3-conf balance is not (0, 0, 0, 0)")+ [(1, BalanceInfo 0 0 0 0)]++ -- Reorg on tx2+ let s = fakeNode 1 bid1+ o = [fakeNode 2 bid2]+ n = [fakeNode 2 bid3, fakeNode 3 bid4]+ importMerkles (ChainReorg s o n) [[], [txHash tx2]]++ getBy (UniqueAccTx ai (txHash tx1))+ >>= liftIO+ . (assertEqual "Confidence is not dead" TxDead)+ . keyRingTxConfidence . entityVal . fromJust++ getBy (UniqueAccTx ai (txHash tx2))+ >>= liftIO+ . (assertEqual "Confidence is not building" TxBuilding)+ . keyRingTxConfidence . entityVal . fromJust++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 25000000") 25000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 25000000") 25000000+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 4 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 0, 1, 0)")+ [(1, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 3-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 1 3-conf balance is not (20000000, 0, 1, 0)")+ [(1, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (5000000, 0, 1, 0)")+ [(0, BalanceInfo 5000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (5000000, 0, 1, 0)")+ [(0, BalanceInfo 5000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Reimporting tx2 should be idempotent and return TxBuilding+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not building"+ ([(ai, TxBuilding)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 25000000") 25000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 25000000") 25000000+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 4 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 0, 1, 0)")+ [(1, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 3-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 1 3-conf balance is not (20000000, 0, 1, 0)")+ [(1, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (5000000, 0, 1, 0)")+ [(0, BalanceInfo 5000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (5000000, 0, 1, 0)")+ [(0, BalanceInfo 5000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Reorg back onto tx1+ let s2 = fakeNode 1 bid1+ o2 = [fakeNode 2 bid3, fakeNode 3 bid4]+ n2 = [fakeNode 2 bid2, fakeNode 3 bid5, fakeNode 4 bid6]+ importMerkles (ChainReorg s2 o2 n2) [[txHash tx1], [], []]++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 4 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 5 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 1 balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 4 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 1 1 AddressExternal 4 False+ >>= liftIO+ . (assertEqual "Address 1 2-conf balance is not (20000000, 20000000, 1, 1)")+ [(1, BalanceInfo 20000000 20000000 1 1)]++ addressBalances accE 0 0 AddressExternal 5 False+ >>= liftIO+ . (assertEqual "Address 0 4-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 1 1 AddressExternal 5 False+ >>= liftIO+ . (assertEqual "Address 1 4-conf balance is not (0, 0, 0, 0)")+ [(1, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++-- tx1, tx2 and tx3 form a chain, and tx4 is in conflict with tx1+testConflictBalances :: App ()+testConflictBalances = do+ keyE <- newKeyRing "test" bs1+ accE@(Entity ai _) <- newAccount keyE "acc1" (AccountRegular False) []+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 20000000) ]++ -- Import first transaction+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import second transaction+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx++ accountBalance ai 0 False+ >>= liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 1 False+ >>= liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Let's confirm these two transactions+ importMerkles+ (BestChain [fakeNode 1 bid1, fakeNode 2 bid2 ])+ [[txHash tx1], [txHash tx2]]++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Import third transaction+ importNetTx tx3+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ addressBalances accE 0 0 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Now let's add tx4 which is in conflict with tx1+ importNetTx tx4+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxDead)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ addressBalances accE 0 0 AddressExternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 1 False+ >>= liftIO+ . (assertEqual "Address 0 1-conf balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ addressBalances accE 0 0 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Now we trigger a reorg that validates tx4. tx1, tx2 and tx3 should be dead+ let s = fakeNode 0 bid0+ o = [fakeNode 1 bid1, fakeNode 2 bid2]+ n = [fakeNode 1 bid3, fakeNode 2 bid4, fakeNode 3 bid5]+ importMerkles (ChainReorg s o n) [[], [txHash tx4], []]++ getBy (UniqueAccTx ai $ txHash tx1) >>=+ liftIO . (assertEqual "tx1 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx2) >>=+ liftIO . (assertEqual "tx2 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx3) >>=+ liftIO . (assertEqual "tx3 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (20000000, 0, 1, 0)")+ [(0, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 2 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (20000000, 0, 1, 0)")+ [(0, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 2-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Reorg back to tx1, tx2 and tx3+ let s2 = fakeNode 0 bid0+ o2 = [ fakeNode 1 bid3, fakeNode 2 bid4, fakeNode 3 bid5 ]+ n2 = [ fakeNode 1 bid1, fakeNode 2 bid2+ , fakeNode 3 bid6, fakeNode 4 bid7+ ]+ importMerkles (ChainReorg s2 o2 n2) [[txHash tx1], [txHash tx2], [], []]++ getBy (UniqueAccTx ai $ txHash tx1)+ >>= liftIO+ . (assertEqual "tx1 confidence is not building") (Just TxBuilding)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx2)+ >>= liftIO+ . (assertEqual "tx2 confidence is not building") (Just TxBuilding)+ . fmap (keyRingTxConfidence . entityVal)++ -- Tx3 remains dead until it is included into a block. Dead transaction are+ -- only revived upon confirmations. They are not revived if they are not+ -- confirmed even if they have no conflicts anymore.+ getBy (UniqueAccTx ai $ txHash tx3) >>=+ liftIO . (assertEqual "tx3 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx4) >>=+ liftIO . (assertEqual "tx4 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 2 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 3 False >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000+ accountBalance ai 4 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 5 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 3-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 3 False+ >>= liftIO+ . (assertEqual "Address 0 3-conf balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 4 False+ >>= liftIO+ . (assertEqual "Address 0 4-conf balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 4 False+ >>= liftIO+ . (assertEqual "Address 0 4-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 5 False+ >>= liftIO+ . (assertEqual "Address 0 5-conf balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++testOffline :: App ()+testOffline = do+ keyE <- newKeyRing "test" bs1+ accE@(Entity ai _) <- newAccount keyE "acc1" (AccountRegular False) []+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 20000000) ]++ -- Import first transaction+ importTx tx1 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 1))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Reimporting a transaction should me idempotent+ importTx tx1 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import tx2+ importTx tx2 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 1))+ . testTx++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Import tx3+ importTx tx3 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 0))+ . testTx++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ -- Import tx4+ importTx tx4 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 0))+ . testTx++ getBy (UniqueAccTx ai $ txHash tx1) >>=+ liftIO . (assertEqual "tx1 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx2) >>=+ liftIO . (assertEqual "tx2 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ getBy (UniqueAccTx ai $ txHash tx3) >>=+ liftIO . (assertEqual "tx3 confidence is not dead") (Just TxDead)+ . fmap (keyRingTxConfidence . entityVal)++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (20000000, 0, 1, 0)")+ [(0, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- importTx should be idempotent+ importTx tx4 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 0))+ . testTx++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 20000000") 20000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (20000000, 0, 1, 0)")+ [(0, BalanceInfo 20000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++testKillOffline :: App ()+testKillOffline = do+ keyE <- newKeyRing "test" bs1+ accE@(Entity ai _) <- newAccount keyE "acc1" (AccountRegular False) []+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 2000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 3000000) -- change+ , ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 5000000) -- more change+ ]++ -- Import tx1 as a network transaction+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import tx2 as offline+ importTx tx2 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 1))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Offline balance is not 4000000") 4000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "1-conf Balance is not 0") 0+ accountBalance ai 1 True >>=+ liftIO . (assertEqual "1-conf Offline balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Import tx3 as offline+ importTx tx3 ai+ >>= liftIO+ . (assertEqual "Confidence is not offline"+ ([(ai, TxOffline)], 0))+ . testTx++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Offline balance is not 0") 0+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "1-conf Balance is not 0") 0+ accountBalance ai 1 True >>=+ liftIO . (assertEqual "1-conf Offline balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ addressBalances accE 0 0 AddressExternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (10000000, 10000000, 1 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ -- Import tx4 as a network transaction. It should override tx2 and tx3.+ importNetTx tx4+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 0))+ . testTx++ getBy (UniqueAccTx ai (txHash tx2))+ >>= liftIO+ . (assertEqual "Confidence is not dead" TxDead)+ . keyRingTxConfidence . entityVal . fromJust++ getBy (UniqueAccTx ai (txHash tx3))+ >>= liftIO+ . (assertEqual "Confidence is not dead" TxDead)+ . keyRingTxConfidence . entityVal . fromJust++ accountBalance ai 0 False >>=+ liftIO . (assertEqual "Balance is not 8000000") 8000000+ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Offline balance is not 8000000") 8000000+ accountBalance ai 1 False >>=+ liftIO . (assertEqual "1-conf Balance is not 0") 0+ accountBalance ai 1 True >>=+ liftIO . (assertEqual "1-conf Offline balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (15000000, 10000000, 2, 1)")+ [(0, BalanceInfo 15000000 10000000 2 1)]++ addressBalances accE 0 0 AddressInternal 0 False+ >>= liftIO+ . (assertEqual "Address 0 balance is not (3000000, 0, 1, 0)")+ [(0, BalanceInfo 3000000 0 1 0)]++ addressBalances accE 0 0 AddressExternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (15000000, 10000000, 2 1)")+ [(0, BalanceInfo 15000000 10000000 2 1)]++ addressBalances accE 0 0 AddressInternal 0 True+ >>= liftIO+ . (assertEqual "Address 0 balance is not (3000000, 0, 1, 0)")+ [(0, BalanceInfo 3000000 0 1 0)]++testOfflineExceptions :: Assertion+testOfflineExceptions = do+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 20000000) ]++ assertException (WalletException "Could not import offline transaction") $ do+ keyE <- newKeyRing "test" bs1+ _ <- newAccount keyE "acc1" (AccountRegular False) []+ (_, Entity ai _) <- getAccount "test" "acc1"+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx+ importTx tx4 ai++ assertException (WalletException "Could not import offline transaction") $ do+ keyE <- newKeyRing "test" bs1+ _ <- newAccount keyE "acc1" (AccountRegular False) []+ (_, Entity ai _) <- getAccount "test" "acc1"+ importNetTx tx4+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not dead"+ ([(ai, TxDead)], 0))+ . testTx+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not dead"+ ([(ai, TxDead)], 1))+ . testTx+ importTx tx3 ai++ assertException (WalletException "Could not import offline transaction") $ do+ keyE <- newKeyRing "test" bs1+ _ <- newAccount keyE "acc1" (AccountRegular False) []+ (_, Entity ai _) <- getAccount "test" "acc1"+ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai, TxPending)], 1))+ . testTx+ importTx tx1 ai++-- This test create a multisig account with the key of testImportMultisig2+testImportMultisig :: App ()+testImportMultisig = do+ keyE <- newKeyRing "test" bs1+ _ <- newAccount keyE "ms1" (AccountMultisig False 2 2)+ [fromJust $ xPubImport "xpub69iinth3CTrfkmijzhQXi3kwhGQjba31fncrBgA9vM9T9tv69qSwp525yDVYmX2BTAdeuYSZqkcWhkrqD5Xbsz5YHJZL6CzYGL2WACorpdS"]+ _ <- newAccount keyE "ms2" (AccountMultisig False 2 2)+ [fromJust $ xPubImport "xpub69iinth3CTrfh5efv7baTWwk9hHi4zqcQEsNFgVwEJvdaZVEPytZzmNxjYTnF5F5x2CamLXvmD1T4RhpsuaXSFPo2MnLN5VqWqrWb82U7ED"]+ Entity _ keyRing <- getKeyRing "test"+ (_, accE1@(Entity ai1 _)) <- getAccount "test" "ms1"+ (_, accE2@(Entity ai2 _)) <- getAccount "test" "ms2"++ let fundingTx =+ Tx 1 [ TxIn (OutPoint tid1 0) (BS.pack [1]) maxBound ] -- dummy input+ [ TxOut 10000000 $+ encodeOutputBS $ PayScriptHash $ fromJust $+ base58ToAddr "3Dgz9gqsAMPr7i9qocLMNHU8wuoKqtUNoM"+ ] 0++ importNetTx fundingTx+ >>= liftIO+ . (assertEqual "Confidence is not pending"+ ([(ai1, TxPending), (ai2, TxPending)], 2))+ . testTx++ -- Create a transaction which has 0 signatures in ms1+ (tx1, _) <- createTx keyRing accE1+ [ ( fromJust $ base58ToAddr "3C9fz8kDwX2rV25YeWC7YcDNHtTreAV52m"+ , 5000000+ )+ ] 10000 0 False True+ liftIO $ assertEqual "Confidence is not offline" TxOffline $+ keyRingTxConfidence tx1+ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . (assertEqual "Wrong txhash in coins" [])+ . map (keyRingCoinHash . entityVal . inCoinDataCoin)+ txPage ai1 (PageRequest 1 10 False)+ >>= liftIO+ . (assertEqual "Wrong txhash in tx list"+ [txHash fundingTx, keyRingTxHash tx1])+ . (map keyRingTxHash) . fst+ accountBalance ai1 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai1 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai1 0 True >>=+ liftIO . (assertEqual "Offline balance is not 9990000") 9990000++ -- Import the empty transaction in ms2+ (tx2:_, _) <- importTx (keyRingTxTx tx1) ai2+ -- This second import should be idempotent+ _ <- importTx (keyRingTxTx tx1) ai2+ liftIO $ assertEqual "Txid do not match"+ (keyRingTxHash tx1) (keyRingTxHash tx2)+ liftIO $ assertEqual "Confidence is not offline" TxOffline $+ keyRingTxConfidence tx2+ spendableCoins ai2 0 (const . const [])+ >>= liftIO+ . (assertEqual "Wrong txhash in coins" [])+ . map (keyRingCoinHash . entityVal . inCoinDataCoin)+ txPage ai2 (PageRequest 1 10 False)+ >>= liftIO+ . (assertEqual "Wrong txhash in tx list"+ [txHash fundingTx, keyRingTxHash tx2])+ . (map keyRingTxHash) . fst+ accountBalance ai2 0 False >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000+ accountBalance ai2 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai2 0 True >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000++ -- Sign the transaction in ms2+ (tx3:_, _) <- signKeyRingTx keyRing accE2 $ keyRingTxHash tx2+ liftIO $ assertEqual "Confidence is not pending" TxPending $+ keyRingTxConfidence tx3+ spendableCoins ai2 0 (const . const [])+ >>= liftIO+ . (assertEqual "Wrong txhash in coins"+ [keyRingTxHash tx3, keyRingTxHash tx3])+ . map (keyRingCoinHash . entityVal . inCoinDataCoin)+ txPage ai2 (PageRequest 1 10 False)+ >>= liftIO+ . (assertEqual "Wrong txhash in tx list"+ [txHash fundingTx, keyRingTxHash tx3])+ . (map keyRingTxHash) . fst+ accountBalance ai2 0 False >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000+ accountBalance ai2 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai2 0 True >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000++ tx4 <- liftM (entityVal . fromJust) $+ getBy $ UniqueAccTx ai1 $ keyRingTxHash tx3+ liftIO $ assertEqual "Confidence is not pending" TxPending $+ keyRingTxConfidence tx4+ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . (assertEqual "Wrong txhash in coins"+ [keyRingTxHash tx3, keyRingTxHash tx3])+ . map (keyRingCoinHash . entityVal . inCoinDataCoin)+ txPage ai1 (PageRequest 1 10 False)+ >>= liftIO+ . (assertEqual "Wrong txhash in tx list"+ [txHash fundingTx, keyRingTxHash tx3])+ . (map keyRingTxHash ) . fst+ accountBalance ai1 0 False >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000+ accountBalance ai1 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai1 0 True >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000++ -- Importing the transaction should have no effect as it was globally+ -- imported already in the previous step.+ (tx5:_, _) <- importTx (keyRingTxTx tx3) ai1+ liftIO $ assertEqual "Confidence is not pending" TxPending $+ keyRingTxConfidence tx5+ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . (assertEqual "Wrong txhash in coins"+ [keyRingTxHash tx5, keyRingTxHash tx5])+ . map (keyRingCoinHash . entityVal . inCoinDataCoin)+ txPage ai1 (PageRequest 1 10 False)+ >>= liftIO+ . (assertEqual "Wrong txhash in tx list"+ [txHash fundingTx, keyRingTxHash tx5])+ . (map keyRingTxHash) . fst+ accountBalance ai1 0 False >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000+ accountBalance ai1 1 False >>=+ liftIO . (assertEqual "Balance is not 0") 0+ accountBalance ai1 0 True >>=+ liftIO . (assertEqual "Balance is not 9990000") 9990000++testKillTx :: App ()+testKillTx = do+ keyE <- newKeyRing "test" bs1+ _ <- newAccount keyE "acc1" (AccountRegular False) []+ (_, accE@(Entity ai _)) <- getAccount "test" "acc1"+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("13XaDQvvE4rqiVKMi4MApsaZwTcDNiwfuR", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1BwbQ8Wp7YUfaYeiQPgXu6br5e4ogKjuKd", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external++ importNetTx tx1+ >>= liftIO+ . (assertEqual "Confidence is not pending" ([(ai, TxPending)], 1))+ . testTx+ importNetTx tx2+ >>= liftIO+ . (assertEqual "Confidence is not pending" ([(ai, TxPending)], 1))+ . testTx+ importNetTx tx3+ >>= liftIO+ . (assertEqual "Confidence is not pending" ([(ai, TxPending)], 0))+ . testTx++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 0") 0++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (4000000, 4000000, 1, 1)")+ [(0, BalanceInfo 4000000 4000000 1 1)]++ killTxs [txHash tx2]++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ -- Killing a transaction should be idempotent+ killTxs [txHash tx2]++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ killTxs [txHash tx3]++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 10000000") 10000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 0, 1, 0)")+ [(0, BalanceInfo 10000000 0 1 0)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (0, 0, 0, 0)")+ [(0, BalanceInfo 0 0 0 0)]++ reviveTx tx2++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Reviving a transaction should be idempotent+ reviveTx tx2++ accountBalance ai 0 True >>=+ liftIO . (assertEqual "Balance is not 4000000") 4000000++ addressBalances accE 0 0 AddressExternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (10000000, 10000000, 1, 1)")+ [(0, BalanceInfo 10000000 10000000 1 1)]++ addressBalances accE 0 0 AddressInternal 0 True >>=+ liftIO . (assertEqual "Address 0 balance is not (4000000, 0, 1, 0)")+ [(0, BalanceInfo 4000000 0 1 0)]++testTx :: ([KeyRingTx], [KeyRingAddr])+ -> ([(KeyRingAccountId, TxConfidence)], Int)+testTx (txs, addrs) = (map f txs, length addrs)+ where+ f tx = (keyRingTxAccount tx, keyRingTxConfidence tx)+
− tests/QuickCheckUtils.hs
@@ -1,44 +0,0 @@-module QuickCheckUtils where--import Test.QuickCheck - ( Arbitrary- , arbitrary- , vectorOf- , choose- )--import Control.Applicative ((<$>))-import Data.List (permutations)--import Network.Haskoin.Wallet-import Network.Haskoin.Wallet.Arbitrary ()-import Network.Haskoin.Script-import Network.Haskoin.Crypto-import Network.Haskoin.Protocol-import Network.Haskoin.Util--data PKHashSigTemplate = PKHashSigTemplate Tx [SigInput] [PrvKey]- deriving (Eq, Show)---- Generates data for signing a PKHash transaction-instance Arbitrary PKHashSigTemplate where- arbitrary = do- inCount <- choose (0,10)- perm <- choose (0,max 0 $ inCount-1)- outPoints <- vectorOf inCount arbitrary- prvKeys <- vectorOf inCount arbitrary- sigHashes <- vectorOf inCount arbitrary- payTo <- choose (0,10) >>= \n -> do- h <- (map (addrToBase58 . PubKeyAddress)) <$> vectorOf n arbitrary - v <- vectorOf n $ choose (1,2100000000000000)- return $ zip h v- let pubKeys = map derivePubKey prvKeys- scriptOut = map (PayPKHash . pubKeyAddr) pubKeys- scripts = map encodeOutput scriptOut- sigInputs = map (\(s,o,h) -> SigInput s o h) - (zip3 scripts outPoints sigHashes)- perInputs = (permutations sigInputs) !! perm- perKeys = (permutations prvKeys) !! perm- tx = fromRight $ buildAddrTx outPoints payTo- return $ PKHashSigTemplate tx perInputs perKeys-
− tests/Units.hs
@@ -1,452 +0,0 @@-module Units (tests) where--import Test.HUnit (Assertion, assertBool)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)--import Data.Word (Word32, Word64)-import Data.Maybe (fromJust, catMaybes)-import Data.Binary.Get (getWord32le)-import qualified Data.ByteString as BS (reverse)--import Network.Haskoin.Wallet-import Network.Haskoin.Wallet.TxBuilder-import Network.Haskoin.Protocol-import Network.Haskoin.Crypto-import Network.Haskoin.Util--tests :: [Test]-tests =- [ testGroup "BIP32 derivation vector 1" - [ testCase "Chain m" $ runXKeyVec (xKeyVec !! 0)- , testCase "Chain m/0'" $ runXKeyVec (xKeyVec !! 1)- , testCase "Chain m/0'/1" $ runXKeyVec (xKeyVec !! 2)- , testCase "Chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3)- , testCase "Chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4)- , testCase "Chain m/0'/1/2'/2/1000000000" $ - runXKeyVec (xKeyVec !! 5)- ] - , testGroup "BIP32 subkey derivation vector 2" - [ testCase "Chain m" $ runXKeyVec (xKeyVec2 !! 0)- , testCase "Chain m/0" $ runXKeyVec (xKeyVec2 !! 1)- , testCase "Chain m/0/2147483647'" $ - runXKeyVec (xKeyVec2 !! 2)- , testCase "Chain m/0/2147483647'/1" $ - runXKeyVec (xKeyVec2 !! 3)- , testCase "Chain m/0/2147483647'/1/2147483646'" $ - runXKeyVec (xKeyVec2 !! 4)- , testCase "Chain m/0/2147483647'/1/2147483646'/2" $ - runXKeyVec (xKeyVec2 !! 5)- ] - , testGroup "Build PKHash Transaction (generated from bitcoind)" - ( map mapPKHashVec $ zip pkHashVec [0..] )- , testGroup "Verify transaction (bitcoind /test/data/tx_valid.json)" - ( map mapVerifyVec $ zip verifyVec [0..] )- ]---runXKeyVec :: ([String],XPrvKey) -> Assertion-runXKeyVec (v,m) = do- assertBool "xPrvID" $ (bsToHex $ encode' $ xPrvID m) == v !! 0- assertBool "xPrvFP" $ (bsToHex $ encode' $ xPrvFP m) == v !! 1- assertBool "xPrvAddr" $ - (addrToBase58 $ xPubAddr $ deriveXPubKey m) == v !! 2- assertBool "prvKey" $ (bsToHex $ runPut' $ putPrvKey $ xPrvKey m) == v !! 3- assertBool "xPrvWIF" $ xPrvWIF m == v !! 4- assertBool "pubKey" $ - (bsToHex $ encode' $ xPubKey $ deriveXPubKey m) == v !! 5- assertBool "chain code" $ (bsToHex $ encode' $ xPrvChain m) == v !! 6- assertBool "Hex PubKey" $ (bsToHex $ encode' $ deriveXPubKey m) == v !! 7- assertBool "Hex PrvKey" $ (bsToHex $ encode' m) == v !! 8- assertBool "Base58 PubKey" $ (xPubExport $ deriveXPubKey m) == v !! 9- assertBool "Base58 PrvKey" $ xPrvExport m == v !! 10--mapPKHashVec :: (([(String,Word32)],[(String,Word64)],String),Int)- -> Test.Framework.Test-mapPKHashVec (v,i) = testCase name $ runPKHashVec v- where name = "Build PKHash Tx " ++ (show i)--runPKHashVec :: ([(String,Word32)],[(String,Word64)],String) -> Assertion-runPKHashVec (xs,ys,res) = - assertBool "Build PKHash Tx" $ (bsToHex $ encode' tx) == res- where tx = fromRight $ buildAddrTx (map f xs) ys- f (tid,ix) = OutPoint (fromJust $ decodeTxid tid) ix---mapVerifyVec :: (([(String,String,String)],String),Int) - -> Test.Framework.Test-mapVerifyVec (v,i) = testCase name $ runVerifyVec v i- where name = "Verify Tx " ++ (show i)--runVerifyVec :: ([(String,String,String)],String) -> Int -> Assertion-runVerifyVec (is,bsTx) i = - assertBool name $ verifyTx tx $ map f is- where name = " > Verify transaction " ++ (show i)- tx = decode' (fromJust $ hexToBS bsTx)- f (o1,o2,bsScript) = - let ops = runGet' getScriptOps (fromJust $ hexToBS bsScript)- op = OutPoint (decode' $ BS.reverse $ fromJust $ hexToBS o1) - (runGet' getWord32le $ fromJust $ hexToBS o2)- in (Script ops,op)---- BIP 0032 Test Vectors--- https://en.bitcoin.it/wiki/BIP_0032_TestVectors--xKeyVec :: [([String],XPrvKey)]-xKeyVec = zip xKeyResVec $ catMaybes $ foldl f [m] der- where f acc d = acc ++ [d =<< last acc]- m = makeXPrvKey $ fromJust $ hexToBS m0- der = [ flip primeSubKey 0- , flip prvSubKey 1- , flip primeSubKey 2- , flip prvSubKey 2- , flip prvSubKey 1000000000- ]--xKeyVec2 :: [([String],XPrvKey)]-xKeyVec2 = zip xKeyResVec2 $ catMaybes $ foldl f [m] der- where f acc d = acc ++ [d =<< last acc]- m = makeXPrvKey $ fromJust $ hexToBS m1- der = [ flip prvSubKey 0- , flip primeSubKey 2147483647- , flip prvSubKey 1- , flip primeSubKey 2147483646- , flip prvSubKey 2- ]--m0 :: String-m0 = "000102030405060708090a0b0c0d0e0f"--xKeyResVec :: [[String]]-xKeyResVec =- [- -- m- [ "3442193e1bb70916e914552172cd4e2dbc9df811"- , "3442193e"- , "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma"- , "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35"- , "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW"- , "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2"- , "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508"- , "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2"- , "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35"- , "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8"- , "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi"- ]- -- m/0'- , [ "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7"- , "5c1bd648"- , "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh"- , "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea"- , "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT"- , "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56"- , "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141"- , "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56"- , "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea"- , "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw"- , "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7"- ]- -- m/0'/1- , [ "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe"- , "bef5a2f9"- , "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj"- , "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368"- , "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM"- , "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c"- , "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19"- , "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c"- , "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368"- , "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ"- , "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs"- ]- -- m/0'/1/2'- , [ "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72"- , "ee7ab90c"- , "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x"- , "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca"- , "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU"- , "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2"- , "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f"- , "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2"- , "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca"- , "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5"- , "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM"- ]- -- m/0'/1/2'/2- , [ "d880d7d893848509a62d8fb74e32148dac68412f"- , "d880d7d8"- , "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt"- , "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4"- , "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR"- , "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29"- , "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd"- , "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29"- , "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4"- , "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV"- , "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334"- ]- -- m/0'/1/2'/2/1000000000- , [ "d69aa102255fed74378278c7812701ea641fdf32"- , "d69aa102"- , "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam"- , "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8"- , "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs"- , "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011"- , "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e"- , "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011"- , "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8"- , "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy"- , "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76"- ]- ]--m1 :: String-m1 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542"--xKeyResVec2 :: [[String]]-xKeyResVec2 =- [- -- m- [ "bd16bee53961a47d6ad888e29545434a89bdfe95"- , "bd16bee5"- , "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg"- , "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e"- , "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy"- , "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7"- , "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689"- , "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7"- , "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e"- , "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB"- , "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U"- ]- -- m/0- , [ "5a61ff8eb7aaca3010db97ebda76121610b78096"- , "5a61ff8e"- , "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ"- , "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e"- , "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj"- , "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea"- , "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c"- , "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea"- , "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e"- , "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH"- , "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt"- ]- -- m/0/2147483647'- , [ "d8ab493736da02f11ed682f88339e720fb0379d1"- , "d8ab4937"- , "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk"- , "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93"- , "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr"- , "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b"- , "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9"- , "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b"- , "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93"- , "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a"- , "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9"- ]- -- m/0/2147483647'/1- , [ "78412e3a2296a40de124307b6485bd19833e2e34"- , "78412e3a"- , "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW"- , "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7"- , "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2"- , "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9"- , "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb"- , "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9"- , "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7"- , "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon"- , "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef"- ]- -- m/0/2147483647'/1/2147483646'- , [ "31a507b815593dfc51ffc7245ae7e5aee304246e"- , "31a507b8"- , "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R"- , "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d"- , "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF"- , "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0"- , "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29"- , "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0"- , "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d"- , "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL"- , "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc"- ]- -- m/0/2147483647'/1/2147483646'/2- , [ "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220"- , "26132fdb"- , "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt"- , "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23"- , "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK"- , "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c"- , "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271"- , "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c"- , "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23"- , "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt"- , "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j"- ]- ]---- These test vectors have been generated from bitcoind raw transaction api--pkHashVec :: [([(String,Word32)],[(String,Word64)],String)]-pkHashVec =- [- ( [("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",14)]- , [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",90000000)]- , "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac00000000"- )- , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0)- , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647)- ]- , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1)- , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000)- ]- , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"- )- , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0)- , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647)- ]- , []- , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0000000000"- )- , ( []- , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1)- , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000)- ]- , "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"- )- ]--{- Test vectors from bitcoind -}--- github.com/bitcoin/bitcoin/blob/master/src/test/data/tx_valid.json---verifyVec :: [([(String,String,String)],String)]-verifyVec = - [- -- It is of particular interest because it contains an invalidly-encoded signature which OpenSSL accepts- ( [ - ( "60a20bd93aa49ab4b28d514ec10b06e1829ce6818ec06cd3aabd013ebcdc4bb1"- , "00000000"- , "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae"- )- ]- , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"- )- -- It has an arbitrary extra byte stuffed into the signature at pos length - 2- , ( [- ( "60a20bd93aa49ab4b28d514ec10b06e1829ce6818ec06cd3aabd013ebcdc4bb1"- , "00000000"- , "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae"- )- ]- , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba260000000004A0048304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2bab01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"- )- -- it is of interest because it contains a 0-sequence as well as a signature of SIGHASH type 0 (which is not a real type)- , ( [- ( "406b2b06bcd34d3c8733e6b79f7a394c8a431fbf4ff5ac705c93f4076bb77602"- , "00000000"- , "76a914dc44b1164188067c3a32d4780f5996fa14a4f2d988ac"- )- ]- , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000"- )- -- It caught a bug in the workaround for 23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63 in an overly simple implementation- , ( [- ( "b464e85df2a238416f8bdae11d120add610380ea07f4ef19c5f9dfd472f96c3d"- , "00000000"- , "76a914bef80ecf3a44500fda1bc92176e442891662aed288ac"- )- , ( "b7978cc96e59a8b13e0865d3f95657561a7f725be952438637475920bac9eb21"- , "01000000"- , "76a914bef80ecf3a44500fda1bc92176e442891662aed288ac"- )- ]- , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000"- )- -- It results in signing the constant 1, instead of something generated based on the transaction,- -- when the input doing the signing has an index greater than the maximum output index- , ( [ - ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "76a914e52b482f2faa8ecbf0db344f93c84ac908557f3388ac"- )- , ( "0000000000000000000000000000000000000000000000000000000000000200"- , "00000000"- , "76a914751e76e8199196d454941c45d1b3a323f1433bd688ac"- )- ]- , "01000000020002000000000000000000000000000000000000000000000000000000000000000000006a47304402200469f169b8091cd18a2770136be7411f079b3ac2b5c199885eb66a80aa3ed75002201fa89f3e6f80974e1b3474e70a0fbe907c766137ff231e4dd05a555d8544536701210279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798ffffffff0001000000000000000000000000000000000000000000000000000000000000000000006b483045022100c9cdd08798a28af9d1baf44a6c77bcc7e279f47dc487c8c899911bc48feaffcc0220503c5c50ae3998a733263c5c0f7061b483e2b56c4c41b456e7d2f5a78a74c077032102d5c25adb51b61339d2b05315791e21bbe80ea470a49db0135720983c905aace0ffffffff010000000000000000015100000000"- )- -- A valid P2SH Transaction using the standard transaction type put forth in BIP 16- , ( [- ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "a9148febbed40483661de6958d957412f82deed8e2f787"- )- ]- , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006e493046022100c66c9cdf4c43609586d15424c54707156e316d88b0a1534c9e6b0d4f311406310221009c0fe51dbc9c4ab7cc25d3fdbeccf6679fe6827f08edf2b4a9f16ee3eb0e438a0123210338e8034509af564c62644c07691942e0c056752008a173c89f60ab2a88ac2ebfacffffffff010000000000000000015100000000"- )- -- MAX_MONEY output- , ( [- ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "a91432afac281462b822adbec5094b8d4d337dd5bd6a87"- )- ]- , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006e493046022100e1eadba00d9296c743cb6ecc703fd9ddc9b3cd12906176a226ae4c18d6b00796022100a71aef7d2874deff681ba6080f1b278bac7bb99c61b08a85f4311970ffe7f63f012321030c0588dc44d92bdcbf8e72093466766fdc265ead8db64517b0c542275b70fffbacffffffff010040075af0750700015100000000"- )- -- MAX_MONEY output + 0 output- , ( [- ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "a914b558cbf4930954aa6a344363a15668d7477ae71687"- )- ]- , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006d483045022027deccc14aa6668e78a8c9da3484fbcd4f9dcc9bb7d1b85146314b21b9ae4d86022100d0b43dece8cfb07348de0ca8bc5b86276fa88f7f2138381128b7c36ab2e42264012321029bb13463ddd5d2cc05da6e84e37536cb9525703cfd8f43afdb414988987a92f6acffffffff020040075af075070001510000000000000000015100000000"- )- -- Simple transaction with first input is signed with SIGHASH_ALL, second with SIGHASH_ANYONECANPAY- , ( [- ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac"- )- , ( "0000000000000000000000000000000000000000000000000000000000000200"- , "00000000"- , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac"- )- ]- , "010000000200010000000000000000000000000000000000000000000000000000000000000000000049483045022100d180fd2eb9140aeb4210c9204d3f358766eb53842b2a9473db687fa24b12a3cc022079781799cd4f038b85135bbe49ec2b57f306b2bb17101b17f71f000fcab2b6fb01ffffffff0002000000000000000000000000000000000000000000000000000000000000000000004847304402205f7530653eea9b38699e476320ab135b74771e1c48b81a5d041e2ca84b9be7a802200ac8d1f40fb026674fe5a5edd3dea715c27baa9baca51ed45ea750ac9dc0a55e81ffffffff010100000000000000015100000000"- )- -- Same as above, but we change the sequence number of the first input to check that SIGHASH_ANYONECANPAY is being followed- , ( [- ( "0000000000000000000000000000000000000000000000000000000000000100"- , "00000000"- , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac"- )- , ( "0000000000000000000000000000000000000000000000000000000000000200"- , "00000000"- , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac"- )- ]- , "01000000020001000000000000000000000000000000000000000000000000000000000000000000004948304502203a0f5f0e1f2bdbcd04db3061d18f3af70e07f4f467cbc1b8116f267025f5360b022100c792b6e215afc5afc721a351ec413e714305cb749aae3d7fee76621313418df101010000000002000000000000000000000000000000000000000000000000000000000000000000004847304402205f7530653eea9b38699e476320ab135b74771e1c48b81a5d041e2ca84b9be7a802200ac8d1f40fb026674fe5a5edd3dea715c27baa9baca51ed45ea750ac9dc0a55e81ffffffff010100000000000000015100000000"- )- -- several SIGHASH_SINGLE signatures- , ( [- ( "63cfa5a09dc540bf63e53713b82d9ea3692ca97cd608c384f2aa88e51a0aac70"- , "00000000"- , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac"- )- , ( "04e8d0fcf3846c6734477b98f0f3d4badfb78f020ee097a0be5fe347645b817d"- , "01000000"- , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac"- )- , ( "ee1377aff5d0579909e11782e1d2f5f7b84d26537be7f5516dd4e43373091f3f"- , "01000000"- , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac"- )- ]- , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000"- )- ]-