diff --git a/Network/Haskoin/Wallet.hs b/Network/Haskoin/Wallet.hs --- a/Network/Haskoin/Wallet.hs +++ b/Network/Haskoin/Wallet.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Arbitrary.hs b/Network/Haskoin/Wallet/Arbitrary.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Arbitrary.hs +++ /dev/null @@ -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 - diff --git a/Network/Haskoin/Wallet/Client.hs b/Network/Haskoin/Wallet/Client.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Client.hs @@ -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 [] []" + +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 "." + diff --git a/Network/Haskoin/Wallet/Client/Commands.hs b/Network/Haskoin/Wallet/Client/Commands.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Client/Commands.hs @@ -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] + + diff --git a/Network/Haskoin/Wallet/Internals.hs b/Network/Haskoin/Wallet/Internals.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Internals.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/KeyRing.hs b/Network/Haskoin/Wallet/KeyRing.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/KeyRing.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Keys.hs b/Network/Haskoin/Wallet/Keys.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Keys.hs +++ /dev/null @@ -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 - diff --git a/Network/Haskoin/Wallet/Manager.hs b/Network/Haskoin/Wallet/Manager.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Manager.hs +++ /dev/null @@ -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) - diff --git a/Network/Haskoin/Wallet/Model.hs b/Network/Haskoin/Wallet/Model.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Model.hs @@ -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 + } + diff --git a/Network/Haskoin/Wallet/Server.hs b/Network/Haskoin/Wallet/Server.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Server.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Server/Handler.hs b/Network/Haskoin/Wallet/Server/Handler.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Server/Handler.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Settings.hs b/Network/Haskoin/Wallet/Settings.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Settings.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Store.hs b/Network/Haskoin/Wallet/Store.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store.hs +++ /dev/null @@ -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: - - --} -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)" - - diff --git a/Network/Haskoin/Wallet/Store/CoinStatus.hs b/Network/Haskoin/Wallet/Store/CoinStatus.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/CoinStatus.hs +++ /dev/null @@ -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 - diff --git a/Network/Haskoin/Wallet/Store/DbAccount.hs b/Network/Haskoin/Wallet/Store/DbAccount.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/DbAccount.hs +++ /dev/null @@ -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" - diff --git a/Network/Haskoin/Wallet/Store/DbAddress.hs b/Network/Haskoin/Wallet/Store/DbAddress.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/DbAddress.hs +++ /dev/null @@ -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 - - diff --git a/Network/Haskoin/Wallet/Store/DbCoin.hs b/Network/Haskoin/Wallet/Store/DbCoin.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/DbCoin.hs +++ /dev/null @@ -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 - - diff --git a/Network/Haskoin/Wallet/Store/DbTx.hs b/Network/Haskoin/Wallet/Store/DbTx.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/DbTx.hs +++ /dev/null @@ -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 - diff --git a/Network/Haskoin/Wallet/Store/Util.hs b/Network/Haskoin/Wallet/Store/Util.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Store/Util.hs +++ /dev/null @@ -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 - ] - - - diff --git a/Network/Haskoin/Wallet/Transaction.hs b/Network/Haskoin/Wallet/Transaction.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Transaction.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/TxBuilder.hs b/Network/Haskoin/Wallet/TxBuilder.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/TxBuilder.hs +++ /dev/null @@ -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) - diff --git a/Network/Haskoin/Wallet/Types.hs b/Network/Haskoin/Wallet/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Types.hs @@ -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 + diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Network.Haskoin.Wallet.Client + +main :: IO () +main = clientMain + diff --git a/config/config.yml b/config/config.yml new file mode 100644 --- /dev/null +++ b/config/config.yml @@ -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 + diff --git a/config/help b/config/help new file mode 100644 --- /dev/null +++ b/config/help @@ -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 diff --git a/config/models b/config/models new file mode 100644 --- /dev/null +++ b/config/models @@ -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 diff --git a/database/mysql/Network/Haskoin/Wallet/Database.hs b/database/mysql/Network/Haskoin/Wallet/Database.hs new file mode 100644 --- /dev/null +++ b/database/mysql/Network/Haskoin/Wallet/Database.hs @@ -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 + diff --git a/database/sqlite/Network/Haskoin/Wallet/Database.hs b/database/sqlite/Network/Haskoin/Wallet/Database.hs new file mode 100644 --- /dev/null +++ b/database/sqlite/Network/Haskoin/Wallet/Database.hs @@ -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 + diff --git a/haskoin-wallet.cabal b/haskoin-wallet.cabal --- a/haskoin-wallet.cabal +++ b/haskoin-wallet.cabal @@ -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 diff --git a/script/hw.hs b/script/hw.hs deleted file mode 100644 --- a/script/hw.hs +++ /dev/null @@ -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 [] []" - -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] - diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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" diff --git a/tests/Network/Haskoin/Wallet/Arbitrary.hs b/tests/Network/Haskoin/Wallet/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Wallet/Arbitrary.hs @@ -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) + ] + diff --git a/tests/Network/Haskoin/Wallet/Store/Units.hs b/tests/Network/Haskoin/Wallet/Store/Units.hs deleted file mode 100644 --- a/tests/Network/Haskoin/Wallet/Store/Units.hs +++ /dev/null @@ -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 - ] - ) - diff --git a/tests/Network/Haskoin/Wallet/Tests.hs b/tests/Network/Haskoin/Wallet/Tests.hs --- a/tests/Network/Haskoin/Wallet/Tests.hs +++ b/tests/Network/Haskoin/Wallet/Tests.hs @@ -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] diff --git a/tests/Network/Haskoin/Wallet/Units.hs b/tests/Network/Haskoin/Wallet/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Wallet/Units.hs @@ -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) + diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs deleted file mode 100644 --- a/tests/QuickCheckUtils.hs +++ /dev/null @@ -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 - diff --git a/tests/Units.hs b/tests/Units.hs deleted file mode 100644 --- a/tests/Units.hs +++ /dev/null @@ -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" - ) - ] -