haskoin-wallet 0.2.0 → 0.3.0
raw patch · 24 files changed
+5320/−5144 lines, 24 filesdep +binarydep +haskelinedep +semigroupsdep −SafeSemaphoredep −leveldb-haskelldep −persistent-mysqldep ~HUnitdep ~aesondep ~haskoin-corenew-uploader
Dependencies added: binary, haskeline, semigroups
Dependencies removed: SafeSemaphore, leveldb-haskell, persistent-mysql
Dependency ranges changed: HUnit, aeson, haskoin-core, haskoin-node, lifted-async, stm-conduit, time
Files
- Network/Haskoin/Wallet.hs +11/−26
- Network/Haskoin/Wallet/Accounts.hs +694/−0
- Network/Haskoin/Wallet/Block.hs +59/−0
- Network/Haskoin/Wallet/Client.hs +68/−49
- Network/Haskoin/Wallet/Client/Commands.hs +476/−285
- Network/Haskoin/Wallet/Database.hs +17/−0
- Network/Haskoin/Wallet/Internals.hs +2/−2
- Network/Haskoin/Wallet/KeyRing.hs +0/−720
- Network/Haskoin/Wallet/Model.hs +68/−153
- Network/Haskoin/Wallet/Server.hs +246/−164
- Network/Haskoin/Wallet/Server/Handler.hs +297/−351
- Network/Haskoin/Wallet/Settings.hs +116/−93
- Network/Haskoin/Wallet/Transaction.hs +1355/−1305
- Network/Haskoin/Wallet/Types.hs +282/−218
- config/config.yml +26/−28
- config/help +36/−34
- config/models +15/−24
- database/mysql/Network/Haskoin/Wallet/Database.hs +0/−21
- database/sqlite/Network/Haskoin/Wallet/Database.hs +0/−21
- haskoin-wallet.cabal +27/−29
- stack.yaml +0/−16
- tests/Network/Haskoin/Wallet/Arbitrary.hs +2/−3
- tests/Network/Haskoin/Wallet/Tests.hs +3/−1
- tests/Network/Haskoin/Wallet/Units.hs +1520/−1601
Network/Haskoin/Wallet.hs view
@@ -17,20 +17,14 @@ , SPVMode(..) -- *API JSON Types-, JsonKeyRing(..) , JsonAccount(..) , JsonAddr(..) , JsonCoin(..) , JsonTx(..)-, JsonWithKeyRing(..)-, JsonWithAccount(..)-, JsonWithAddr(..) -- *API Request Types , WalletRequest(..)-, PageRequest(..)-, validPageRequest-, NewKeyRing(..)+, ListRequest(..) , NewAccount(..) , SetAccountGap(..) , OfflineTxData(..)@@ -49,20 +43,12 @@ -- *API Response Types , WalletResponse(..) , TxCompleteRes(..)-, AddrTx(..)-, PageRes(..)+, ListResult(..) , RescanRes(..) --- *Database KeyRings-, initWallet-, newKeyRing-, keyRings-, keyRingSource-, getKeyRing- -- *Database Accounts+, initWallet , accounts-, accountSource , newAccount , addAccountKeys , getAccount@@ -72,9 +58,9 @@ -- *Database Addresses , getAddress-, addressSourceAll-, addressSource-, addressPage+, addressesAll+, addresses+, addressList , unusedAddresses , addressCount , setAddrLabel@@ -89,24 +75,23 @@ , getBloomFilter -- *Database transactions-, txPage-, addrTxPage+, txs+, addrTxs , getTx , getAccountTx , importTx , importNetTx-, signKeyRingTx+, signAccountTx , createTx , signOfflineTx , getOfflineTxData -- *Database blocks , importMerkles-, getBestBlock+, walletBestBlock -- *Database coins and balances , spendableCoins-, spendableCoinsSource , accountBalance , addressBalances @@ -118,6 +103,6 @@ import Network.Haskoin.Wallet.Server import Network.Haskoin.Wallet.Settings import Network.Haskoin.Wallet.Types-import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Accounts import Network.Haskoin.Wallet.Transaction
+ Network/Haskoin/Wallet/Accounts.hs view
@@ -0,0 +1,694 @@+module Network.Haskoin.Wallet.Accounts+(+-- *Database Wallet+ initWallet++-- *Database Accounts+, accounts+, newAccount+, renameAccount+, addAccountKeys+, getAccount+, isMultisigAccount+, isReadAccount+, isCompleteAccount++-- *Database Addresses+, getAddress+, addressesAll+, addresses+, addressList+, unusedAddresses+, addressCount+, setAddrLabel+, addressPrvKey+, useAddress+, generateAddrs+, setAccountGap+, firstAddrTime+, getPathRedeem+, getPathPubKey++-- *Database Bloom Filter+, getBloomFilter++-- * Helpers+, subSelectAddrCount+) where++import Control.Applicative ((<|>))+import Control.Monad (unless, void, when)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Exception (throw)++import Data.Text (Text, unpack)+import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing)+import Data.Time.Clock (getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.List (nub)+import Data.Word (Word32)+import Data.String.Conversions (cs)++import qualified Database.Persist as P (updateWhere, update , (=.))+import Database.Esqueleto+ ( Value(..), SqlExpr+ , select, from, where_, val, sub_select, countRows, count, unValue+ , orderBy, limit, asc, desc, offset, get, countDistinct+ , max_, case_, when_, then_, else_+ , (^.), (==.), (&&.), (>.), (-.), (<.)+ -- Reexports from Database.Persist+ , SqlPersistT, Entity(..)+ , insertUnique, 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 ^. WalletStateId+ let cnt = maybe 0 unValue $ listToMaybe prevConfigRes+ when (cnt == (0 :: Int)) $ do+ time <- liftIO getCurrentTime+ -- Create an initial bloom filter+ -- TODO: Compute a random nonce+ let bloom = bloomCreate (filterLen 0) fpRate 0 BloomUpdateNone+ insert_ WalletState+ { walletStateHeight = 0+ , walletStateBlock = headerHash genesisHeader+ , walletStateBloomFilter = bloom+ , walletStateBloomElems = 0+ , walletStateBloomFp = fpRate+ , walletStateVersion = 1+ , walletStateCreated = time+ }++{- Account -}++-- | Fetch all accounts+accounts :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => ListRequest -> SqlPersistT m ([Account], Word32)+accounts ListRequest{..} = do+ cntRes <- select $ from $ \acc ->+ return $ countDistinct $ acc ^. AccountId++ let cnt = maybe 0 unValue $ listToMaybe cntRes++ when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException+ "Offset beyond end of data set"++ res <- fmap (map entityVal) $ select $ from $ \acc -> do+ limitOffset listLimit listOffset+ return acc++ return (res, cnt)++initGap :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity Account -> SqlPersistT m ()+initGap accE = do+ void $ createAddrs accE AddressExternal 20+ void $ createAddrs accE AddressInternal 20++-- | Create a new account+newAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => NewAccount+ -> SqlPersistT m (Entity Account, Maybe Mnemonic)+newAccount NewAccount{..} = do+ unless (validAccountType newAccountType) $+ throwM $ WalletException "Invalid account type"+ let gen = isNothing newAccountMnemonic &&+ isNothing newAccountMaster &&+ null newAccountKeys+ (mnemonicM, masterM, keys) <- if gen+ then do+ when (isJust newAccountMaster || isJust newAccountMnemonic) $+ throwM $ WalletException+ "Master key or mnemonic not allowed for generate"+ ent <- liftIO $ getEntropy 16+ let ms = fromRight $ toMnemonic ent+ root = makeXPrvKey $ fromRight $ mnemonicToSeed "" ms+ master = case newAccountDeriv of+ Nothing -> root+ Just d -> derivePath d root+ keys = deriveXPubKey master : newAccountKeys+ return (Just ms, Just master, keys)+ else case newAccountMnemonic of+ Just ms -> do+ when (isJust newAccountMaster) $ throwM $ WalletException+ "Cannot provide both master key and mnemonic"+ root <- case mnemonicToSeed "" (cs ms) of+ Right s -> return $ makeXPrvKey s+ Left _ -> throwM $ WalletException+ "Mnemonic sentence invalid"+ let master = case newAccountDeriv of+ Nothing -> root+ Just d -> derivePath d root+ keys = deriveXPubKey master : newAccountKeys+ return (Nothing, Just master, keys)+ Nothing -> case newAccountMaster of+ Just master -> do+ let keys = deriveXPubKey master : newAccountKeys+ return (Nothing, newAccountMaster, keys)+ Nothing -> return (Nothing, newAccountMaster, newAccountKeys)++ -- Build the account+ now <- liftIO getCurrentTime+ let acc = Account+ { accountName = newAccountName+ , accountType = newAccountType+ , accountMaster = if newAccountReadOnly+ then Nothing+ else masterM+ , accountDerivation = newAccountDeriv+ , accountKeys = nub keys+ , accountGap = 0+ , accountCreated = now+ }++ -- Check if all the keys are valid+ unless (isValidAccKeys acc) $+ throwM $ WalletException "Invalid account keys"++ -- Insert our account in the database+ let canSetGap = isCompleteAccount acc+ newAcc = acc{ accountGap = 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 $ initGap accE+ return (accE, mnemonicM)+ -- The account already exists+ Nothing -> throwM $ WalletException "Account already exists"++renameAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity Account+ -> AccountName+ -> SqlPersistT m Account+renameAccount (Entity ai acc) name = do+ P.update ai [ AccountName P.=. name ]+ return $ acc{ accountName = name }++-- | 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 Account -- ^ Account Entity+ -> [XPubKey] -- ^ Thirdparty public keys to add+ -> SqlPersistT m Account -- ^ Account information+addAccountKeys (Entity ai acc) keys+ -- We can only add keys on incomplete accounts+ | isCompleteAccount acc = throwM $+ WalletException "The account is already complete"+ | null keys || not (isValidAccKeys accKeys) = throwM $+ WalletException "Invalid account keys"+ | otherwise = do+ let canSetGap = isCompleteAccount accKeys+ updGap = [ AccountGap P.=. 10 | canSetGap]+ newAcc = accKeys{ accountGap = if canSetGap then 10 else 0 }+ -- Update the account with the keys and the new gap if it is complete+ P.update ai $ (AccountKeys P.=. newKeys) : updGap+ -- If we can set the gap, create the gap addresses+ when canSetGap $ initGap $ Entity ai newAcc+ return newAcc+ where+ newKeys = accountKeys acc ++ keys+ accKeys = acc{ accountKeys = newKeys }++isValidAccKeys :: Account -> Bool+isValidAccKeys Account{..} = testMaster && case accountType of+ AccountRegular -> length accountKeys == 1+ AccountMultisig _ n -> goMultisig n+ where+ goMultisig n =+ length accountKeys == length (nub accountKeys) &&+ length accountKeys <= n && not (null accountKeys)+ testMaster = case accountMaster of+ Just m -> deriveXPubKey m `elem` accountKeys+ Nothing -> True++-- Helper functions to get an Account if it exists, or throw an exception+-- otherwise.+getAccount :: (MonadIO m, MonadThrow m) => AccountName+ -> SqlPersistT m (Entity Account)+getAccount accountName = do+ as <- select $ from $ \a -> do+ where_ $ a ^. AccountName ==. val accountName+ return a+ case as of+ (accEnt:_) -> return accEnt+ _ -> throwM $ 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, MonadThrow m)+ => Entity Account -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> KeyIndex -- ^ Derivation index (key)+ -> SqlPersistT m (Entity WalletAddr) -- ^ Address+getAddress accE@(Entity ai _) addrType index = do+ res <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ &&. x ^. WalletAddrIndex ==. val index+ &&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType+ )+ limit 1+ return x+ case res of+ (addrE:_) -> return addrE+ _ -> throwM $ WalletException $ unwords+ [ "Invalid address index", show index ]++-- | All addresses in the wallet, including hidden gap addresses. This is useful+-- for building a bloom filter.+addressesAll :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => SqlPersistT m [WalletAddr]+addressesAll = fmap (map entityVal) $ select $ from return++-- | All addresses in one account excluding hidden gap.+addresses :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity Account -- ^ Account Entity+ -> AddressType -- ^ Address Type+ -> SqlPersistT m [WalletAddr] -- ^ Addresses+addresses accE@(Entity ai _) addrType = fmap (map entityVal) $+ select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ &&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType+ )+ return x++-- | Get address list.+addressList :: MonadIO m+ => Entity Account -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> ListRequest -- ^ List request+ -> SqlPersistT m ([WalletAddr], Word32)+ -- ^ List result+addressList accE@(Entity ai _) addrType ListRequest{..} = do+ cnt <- addressCount accE addrType++ when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException+ "Offset beyond end of data set"++ res <- fmap (map entityVal) $ select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ &&. x ^. WalletAddrIndex <. val cnt+ )+ let order = if listReverse then asc else desc+ orderBy [ order (x ^. WalletAddrIndex) ]+ when (listLimit > 0) $ limit $ fromIntegral listLimit+ when (listOffset > 0) $ offset $ fromIntegral listOffset+ return x++ return (res, cnt)++-- | Get a count of all the addresses in an account+addressCount :: MonadIO m+ => Entity Account -- ^ Account Entity+ -> AddressType -- ^ Address type+ -> SqlPersistT m Word32 -- ^ Address Count+addressCount (Entity ai acc) addrType = do+ res <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ )+ return countRows+ let cnt = maybe 0 unValue $ listToMaybe res+ return $ if cnt > accountGap acc then cnt - accountGap acc else 0++-- | Get a list of all unused addresses.+unusedAddresses :: MonadIO m+ => Entity Account -- ^ Account ID+ -> AddressType -- ^ Address type+ -> ListRequest+ -> SqlPersistT m ([WalletAddr], Word32) -- ^ Unused addresses+unusedAddresses (Entity ai acc) addrType ListRequest{..} = do+ cntRes <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ )+ return countRows++ let cnt = maybe 0 unValue $ listToMaybe cntRes++ when (listOffset > 0 && listOffset >= gap) $ throw $ WalletException+ "Offset beyond end of data set"++ res <- fmap (map entityVal) $ select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ )+ orderBy [ order $ x ^. WalletAddrIndex ]+ limit $ fromIntegral $ lim cnt+ offset $ fromIntegral $ off cnt+ return x+ return (res, gap)+ where+ gap = accountGap acc+ lim' = if listLimit > 0 then listLimit else gap+ off cnt | listReverse = listOffset + gap+ | otherwise = cnt - 2 * gap + listOffset+ lim cnt | listReverse = min lim' (gap - listOffset)+ | otherwise = min lim' (cnt - off cnt - gap)+ order = if listReverse then desc else asc++-- | Add a label to an address.+setAddrLabel :: (MonadIO m, MonadThrow m)+ => Entity Account -- ^ Account ID+ -> KeyIndex -- ^ Derivation index+ -> AddressType -- ^ Address type+ -> Text -- ^ New label+ -> SqlPersistT m WalletAddr+setAddrLabel accE i addrType label = do+ Entity addrI addr <- getAddress accE addrType i+ P.update addrI [ WalletAddrLabel P.=. label ]+ return $ addr{ walletAddrLabel = label }++-- | Returns the private key of an address.+addressPrvKey :: (MonadIO m, MonadThrow m)+ => Entity Account -- ^ Account Entity+ -> Maybe XPrvKey -- ^ If not in account+ -> KeyIndex -- ^ Derivation index of the address+ -> AddressType -- ^ Address type+ -> SqlPersistT m PrvKeyC -- ^ Private key+addressPrvKey accE@(Entity ai acc) masterM index addrType = do+ ret <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ &&. x ^. WalletAddrIndex ==. val index+ &&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType+ )+ return $ x ^. WalletAddrIndex+ case ret of+ (Value idx:_) -> do+ accKey <- case accountMaster acc <|> masterM of+ Just key -> return key+ Nothing -> throwM $ WalletException "Could not get private key"+ let addrKey =+ prvSubKey (prvSubKey accKey (addrTypeIndex addrType)) idx+ return $ xPrvKey addrKey+ _ -> throwM $ 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 Account+ -> AddressType+ -> Word32+ -> SqlPersistT m [WalletAddr]+createAddrs (Entity ai acc) addrType n+ | n == 0 = throwM $ WalletException $+ unwords [ "Invalid value", show n ]+ | not (isCompleteAccount acc) =+ throwM $ WalletException $ unwords+ [ "Keys are still missing from the incomplete account"+ , unpack $ accountName acc+ ]+ | otherwise = do+ now <- liftIO getCurrentTime+ -- Find the next derivation index from the last address+ lastRes <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ )+ return $ max_ (x ^. WalletAddrIndex)+ let nextI = case lastRes of+ (Value (Just lastI):_) -> lastI + 1+ _ -> 0+ build (addr, keyM, rdmM, i) = WalletAddr+ { walletAddrAccount = ai+ , walletAddrAddress = addr+ , walletAddrIndex = i+ , walletAddrType = addrType+ , walletAddrLabel = ""+ , walletAddrRedeem = rdmM+ , walletAddrKey = keyM+ , walletAddrCreated = now+ }+ res = map build $ take (fromIntegral n) $ deriveFrom nextI++ -- Save the addresses and increment the bloom filter+ splitInsertMany_ res+ incrementFilter res+ return res+ where+ -- Branch type (external = 0, internal = 1)+ branchType = addrTypeIndex addrType+ deriveFrom = case accountType acc of+ AccountMultisig m _ ->+ let f (a, r, i) = (a, Nothing, Just r, i)+ deriv = Deriv :/ branchType+ in map f . derivePathMSAddrs (accountKeys acc) deriv m+ AccountRegular -> case accountKeys 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 in regular account (corrupt database)"+ , unpack $ accountName acc+ ]++-- | Generate all the addresses up to certain index.+generateAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity Account+ -> AddressType+ -> KeyIndex+ -> SqlPersistT m Int+generateAddrs accE addrType genIndex = do+ cnt <- addressCount accE addrType+ let toGen = fromIntegral genIndex - fromIntegral cnt + 1+ if toGen > 0+ then do+ void $ 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)+ => WalletAddr -> SqlPersistT m [WalletAddr]+useAddress WalletAddr{..} = do+ res <- select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val walletAddrAccount+ &&. x ^. WalletAddrType ==. val walletAddrType+ &&. x ^. WalletAddrIndex >. val walletAddrIndex+ )+ return countRows+ case res of+ (Value cnt:_) -> get walletAddrAccount >>= \accM -> case accM of+ Just acc -> do+ let accE = Entity walletAddrAccount acc+ gap = fromIntegral (accountGap acc) :: Int+ missing = 2*gap - cnt+ if missing > 0+ then createAddrs accE walletAddrType $ 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 Account -- ^ Account Entity+ -> Word32 -- ^ New gap value+ -> SqlPersistT m (Entity Account)+setAccountGap accE@(Entity ai acc) gap+ | not (isCompleteAccount acc) =+ throwM $ WalletException $ unwords+ [ "Keys are still missing from the incomplete account"+ , unpack $ accountName acc+ ]+ | missing <= 0 = throwM $ 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 [ AccountGap P.=. gap ]+ return $ Entity ai acc{ accountGap = gap }+ where+ missing = toInteger gap - toInteger (accountGap 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 ^. WalletAddrId) ]+ limit 1+ return $ x ^. WalletAddrCreated+ 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)+ => [WalletAddr]+ -> 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 ^. WalletAddrId+ let elems = maybe 0 unValue $ listToMaybe cntRes+ newBloom = bloomCreate (filterLen elems) fpRate 0 BloomUpdateNone+ addrs <- addressesAll+ let bloom = addToFilter newBloom addrs+ setBloomFilter bloom elems++-- 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 -> [WalletAddr] -> BloomFilter+addToFilter bloom addrs =+ bloom3+ where+ pks = mapMaybe walletAddrKey addrs+ rdms = mapMaybe walletAddrRedeem addrs+ -- Add the Hash160 of the addresses+ f1 b a = bloomInsert b $ encode' $ getAddrHash a+ bloom1 = foldl f1 bloom $ map walletAddrAddress 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, MonadThrow m)+ => SqlPersistT m (BloomFilter, Int, Double)+getBloomFilter = do+ res <- select $ from $ \c -> do+ limit 1+ return ( c ^. WalletStateBloomFilter+ , c ^. WalletStateBloomElems+ , c ^. WalletStateBloomFp+ )+ case res of+ ((Value b, Value n, Value fp):_) -> return (b, n, fp)+ _ -> throwM $+ 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 [] [ WalletStateBloomFilter P.=. bloom+ , WalletStateBloomElems P.=. elems+ ]++-- Helper function to compute the redeem script of a given derivation path+-- for a given multisig account.+getPathRedeem :: Account -> SoftPath -> RedeemScript+getPathRedeem acc@Account{..} deriv = case accountType of+ AccountMultisig m _ -> if isCompleteAccount acc+ then sortMulSig $ PayMulSig pubKeys m+ else throw $ WalletException $ unwords+ [ "getPathRedeem: Incomplete multisig account"+ , unpack accountName+ ]+ _ -> throw $ WalletException $ unwords+ [ "getPathRedeem: Account", unpack accountName+ , "is not a multisig account"+ ]+ where+ f = toPubKeyG . xPubKey . derivePubPath deriv+ pubKeys = map f accountKeys++-- Helper function to compute the public key of a given derivation path for+-- a given non-multisig account.+getPathPubKey :: Account -> SoftPath -> PubKeyC+getPathPubKey acc@Account{..} deriv+ | isMultisigAccount acc = throw $ WalletException $+ unwords [ "getPathPubKey: Account", unpack accountName+ , "is not a regular non-multisig account"+ ]+ | otherwise = case accountKeys of+ (key:_) -> xPubKey $ derivePubPath deriv key+ _ -> throw $ WalletException $ unwords+ [ "getPathPubKey: No keys are available in account"+ , unpack accountName+ ]++{- Helpers -}++subSelectAddrCount :: Entity Account+ -> AddressType+ -> SqlExpr (Value KeyIndex)+subSelectAddrCount (Entity ai acc) addrType =+ sub_select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ )+ let gap = val $ accountGap 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 :: Account -> Bool+isMultisigAccount acc = case accountType acc of+ AccountRegular -> False+ AccountMultisig{} -> True++isReadAccount :: Account -> Bool+isReadAccount = isNothing . accountMaster++isCompleteAccount :: Account -> Bool+isCompleteAccount acc = case accountType acc of+ AccountRegular -> length (accountKeys acc) == 1+ AccountMultisig _ n -> length (accountKeys acc) == n+
+ Network/Haskoin/Wallet/Block.hs view
@@ -0,0 +1,59 @@+module Network.Haskoin.Wallet.Block where++import Control.Exception (throw)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Trans (MonadIO)+import Data.Maybe (fromMaybe)+import Database.Persist.Sql (SqlPersistT)+import Network.Haskoin.Block+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Types++mainChain :: (MonadIO m, MonadThrow m)+ => Either BlockHeight BlockHash+ -> ListRequest+ -> SqlPersistT m (ListResult NodeBlock)+mainChain blockE ListRequest{..} = do+ bestHash <- fst <$> walletBestBlock+ bestM <- getBlockByHash bestHash+ best <- maybe (throwM $ WalletException "Could not find wallet best block")+ return bestM+ remoteNode <- case blockE of+ Right h -> do+ remoteNodeM <- getBlockByHash h+ maybe (throwM $ WalletException "Colud not get remote node")+ return remoteNodeM+ Left h -> do+ heightNodeM <- getBlockByHeight best h+ maybe (throwM $ WalletException "Could not find bock height")+ return heightNodeM+ frst <- (+1) . nodeBlockHeight <$> splitBlock best remoteNode+ if nodeBlockHeight best < frst+ then return $ ListResult [] 0+ else do+ let cnt = nodeBlockHeight best - frst+ limit = min listLimit (cnt - listOffset)+ offset =+ if listReverse+ then cnt - listOffset - limit+ else listOffset+ nodes <- getBlocksFromHeight best limit (frst + offset)+ return $ ListResult nodes cnt++blockTxs :: [NodeBlock] -> [WalletTx] -> [(NodeBlock, [WalletTx])]+blockTxs blocks transactions = reverse $ go [] blocks transactions+ where+ go bs [] _ = bs+ go bs (n:ns) [] = go ((n,[]):bs) ns []+ go [] (n:ns) xs = go [(n,[])] ns xs+ go (b:bs) (n:ns) (x:xs)+ | nodeHash (fst b) == blockHashOf x =+ go ((fst b, x : snd b) : bs) (n:ns) xs+ | nodeHash n == blockHashOf x =+ go ((n, [x]) : b : bs) ns xs+ | otherwise = go ((n, []) : b : bs) ns (x:xs)+ blockHashOf t = fromMaybe+ (throw $ WalletException "Unexpected unconfirmed transaction")+ (walletTxConfirmedBy t)
Network/Haskoin/Wallet/Client.hs view
@@ -28,15 +28,17 @@ 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.Crypto import Network.Haskoin.Wallet.Settings import Network.Haskoin.Wallet.Client.Commands import Network.Haskoin.Wallet.Types +import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr) import System.FilePath.Posix (isAbsolute) usageHeader :: String@@ -54,21 +56,30 @@ usage :: [String] usage = warningMsg : usageInfo usageHeader options : cmdHelp +read' :: Read x => String -> String -> x+read' e s = case reads s of+ [(x, "")] -> x+ _ -> error e+ 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 "c" ["count"]+ ( ReqArg+ (\s cfg -> cfg { configCount = read' "Could not parse count" s })+ "INT"+ ) $ "Items per page. Default: " ++ show (configCount def) , Option "m" ["minconf"]- (ReqArg (\s cfg -> cfg { configMinConf = read s }) "INT") $- "Minimum confirmations. Default: "+ ( ReqArg+ (\s cfg ->+ cfg { configMinConf = read' "Colud not parse minconf" 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)+ ( ReqArg+ (\s cfg -> cfg { configFee = read' "Could not parse fee" s })+ "INT"+ ) $ "Fee per kilobyte. Default: " ++ show (configFee def) , Option "R" ["rcptfee"] (NoArg $ \cfg -> cfg { configRcptFee = True }) $ "Recipient pays fee. Default: " ++ show (configRcptFee def)@@ -86,9 +97,13 @@ (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 "p" ["path"]+ ( ReqArg ( \s cfg -> case parseHard s of+ Just p -> cfg { configPath = Just p }+ Nothing -> error "Could not parse derivation path"+ ) "PATH"+ )+ "Derivation path (e.g. m/44'/3')" , Option "j" ["json"] (NoArg $ \cfg -> cfg { configFormat = OutputJSON }) "Output JSON"@@ -163,41 +178,45 @@ 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-+ "start" : [] -> cmdStart+ "stop" : [] -> cmdStop+ "newacc" : name : [] -> cmdNewAcc False name []+ "newread" : name : [] -> cmdNewAcc True name []+ "newms" : name : m : n : [] -> cmdNewAcc False name [m, n]+ "newreadms" : name : m : n : [] -> cmdNewAcc True name [m, n]+ "addkey" : name : [] -> cmdAddKey name+ "setgap" : name : gap : [] -> cmdSetGap name gap+ "account" : name : [] -> cmdAccount name+ "accounts" : page -> cmdAccounts page+ "rename" : name : new : [] -> cmdRenameAcc name new+ "list" : name : page -> cmdList name page+ "unused" : name : page -> cmdUnused name page+ "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 : [] -> cmdImport name+ "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+ "deletetx" : txid : [] -> cmdDeleteTx txid+ "sync" : name : block : page -> cmdSync name block page+ "pending" : name : page -> cmdPending name page+ "dead" : name : page -> cmdDead name page+ "monitor" : name -> cmdMonitor name+ "decodetx" : [] -> cmdDecodeTx+ "status" : [] -> cmdStatus+ "keypair" : [] -> cmdKeyPair+ "version" : [] -> cmdVersion+ "help" : [] -> liftIO $ forM_ usage (hPutStrLn stderr)+ [] -> liftIO $ forM_ usage (hPutStrLn stderr)+ _ -> liftIO $+ forM_ ("Invalid command" : usage) (hPutStrLn stderr) >> exitFailure appDir :: IO FilePath appDir = case os of "mingw" -> windows
Network/Haskoin/Wallet/Client/Commands.hs view
@@ -1,15 +1,11 @@ module Network.Haskoin.Wallet.Client.Commands ( cmdStart , cmdStop-, cmdNewKeyRing-, cmdKeyRing-, cmdKeyRings , cmdNewAcc-, cmdNewMS-, cmdNewRead-, cmdAddKeys+, cmdAddKey , cmdSetGap , cmdAccount+, cmdRenameAcc , cmdAccounts , cmdList , cmdUnused@@ -29,61 +25,67 @@ , cmdDecodeTx , cmdVersion , cmdStatus+, cmdMonitor+, cmdSync+, cmdKeyPair+, cmdDeleteTx+, cmdPending+, cmdDead ) 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+import Control.Applicative ((<|>))+import Control.Concurrent.Async.Lifted (async, wait)+import Control.Monad (forM_, forever, liftM2,+ unless, when)+import qualified Control.Monad.Reader as R (ReaderT, ask, asks)+import Control.Monad.Trans (liftIO)+import Data.Aeson (FromJSON, ToJSON, Value (..),+ decode, eitherDecode, encode,+ object, toJSON, (.=))+import qualified Data.Aeson.Encode.Pretty as JSON (Config (..),+ defConfig,+ encodePretty')+import qualified Data.ByteString.Char8 as B8 (hPutStrLn, putStrLn,+ unwords)+import Data.List (intercalate, intersperse)+import Data.Maybe (fromMaybe, isJust, isNothing,+ listToMaybe, maybeToList)+import Data.Monoid ((<>))+import Data.Restricted (rvalue)+import Data.String.Conversions (cs)+import Data.Text (Text, pack, splitOn, unpack)+import Data.Word (Word32, Word64)+import qualified Data.Yaml as YAML (encode)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Crypto+import Network.Haskoin.Node.STM+import Network.Haskoin.Script+import Network.Haskoin.Transaction+import Network.Haskoin.Util+import Network.Haskoin.Wallet.Server+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Types+import qualified System.Console.Haskeline as Haskeline+import System.IO (stderr)+import System.ZMQ4 (KeyFormat (..), Req (..),+ Socket, SocketType, Sub (..),+ connect, curveKeyPair,+ receive, receiveMulti,+ restrict, send,+ setCurvePublicKey,+ setCurveSecretKey,+ setCurveServerKey, setLinger,+ subscribe, withContext,+ withSocket)+import Text.Read (readMaybe) type Handler = R.ReaderT Config IO +defaultDeriv :: HardPath+defaultDeriv = Deriv :| 0+ -- hw start [config] [--detach] cmdStart :: Handler () cmdStart = do@@ -97,158 +99,257 @@ 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+getSigningKeys :: String+ -> Handler (Maybe XPrvKey)+getSigningKeys name = do+ derivM <- R.asks configPath+ kM <- masterKey+ case kM of+ Just _ -> return Nothing+ Nothing -> do+ keyOrMnemonic <-+ liftIO . Haskeline.runInputT+ Haskeline.defaultSettings $+ Haskeline.getPassword (Just '*')+ "Mnemonic or private extended key: "+ case keyOrMnemonic of+ Just ms -> return $ go (cs ms) derivM+ Nothing -> error "No action due to EOF"+ where+ masterKey = do+ resE <- sendZmq $ GetAccountR $ pack name+ case resE of+ Right (ResponseValid (Just acc)) ->+ return $ jsonAccountMaster acc+ Right (ResponseError e) -> error $ cs e+ Left e -> error e+ _ -> error "You find yourself in a strange place"+ go "" _ = error "Need key to sign"+ go str derivM = case xPrvImport str of+ Just k -> case derivM of+ Just d -> Just $ derivePath d k+ Nothing -> Just k+ Nothing -> case mnemonicToSeed "" str of+ Right s -> Just (makeXPrvKey s)+ Left _ -> error "Could not parse key" -cmdKeyRings :: Handler ()-cmdKeyRings = sendZmq GetKeyRingsR $ \ks -> do- let xs = map (putStr . printKeyRing) ks- sequence_ $ intersperse (putStrLn "-") xs+checkExists :: String -> Handler Bool+checkExists name = do+ resE <- sendZmq $ GetAccountR $ pack name+ case (resE :: Either String (WalletResponse JsonAccount)) of+ Right (ResponseValid _) -> return True+ Right (ResponseError _) -> return False+ Left e -> error e -cmdNewAcc :: String -> Handler ()-cmdNewAcc name = do- k <- R.asks configKeyRing- sendZmq (PostAccountsR k newAcc) $- \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+getKey :: Handler (Maybe Mnemonic, Maybe XPrvKey, Maybe HardPath, Maybe XPubKey)+getKey = do+ derivM <- R.asks configPath+ i <- liftIO . Haskeline.runInputT Haskeline.defaultSettings $+ Haskeline.getPassword (Just '*')+ "Type mnemonic, extended key or leave empty to generate: "+ case i of+ Just s -> go (cs s) derivM+ Nothing -> error "No action due to EOF" where- newAcc = NewAccount (pack name) (AccountRegular False) []+ go "" derivM = return+ ( Nothing+ , Nothing+ , derivM <|> Just defaultDeriv+ , Nothing+ )+ go str' derivM = case xPrvImport str' of+ Just k -> return+ ( Nothing+ , Just $ maybe k (`derivePath` k) derivM+ , derivM+ , Nothing+ )+ Nothing -> case xPubImport str' of+ Just p -> return+ ( Nothing+ , Nothing+ , derivM+ , Just p+ )+ Nothing -> return+ ( Just $ cs str'+ , Nothing+ , derivM <|> Just defaultDeriv+ , Nothing+ ) -- 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"+cmdNewAcc :: Bool -> String -> [String] -> Handler ()+cmdNewAcc r name ls = do+ _ <- return $! typ+ e <- checkExists name+ when e $ error "Account exists"+ (mnemonicM, masterM, derivM, keyM) <- getKey+ let newAcc = NewAccount+ { newAccountName = pack name+ , newAccountType = typ+ , newAccountMnemonic = cs <$> mnemonicM+ , newAccountMaster = masterM+ , newAccountDeriv = derivM+ , newAccountKeys = maybeToList keyM+ , newAccountReadOnly = r+ }+ resE <- sendZmq $ PostAccountsR newAcc+ handleResponse resE $ liftIO . putStr . printAccount where- keyM = xPubImport $ cs keyStr+ typ = case ls of+ [] -> AccountRegular+ [mS, nS] -> fromMaybe (error "Account information incorrect") $ do+ m <- readMaybe mS+ n <- readMaybe nS+ return $ AccountMultisig m n+ _ -> error "Number of parametres incorrect" -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+cmdAddKey :: String -> Handler ()+cmdAddKey name = do+ e <- checkExists name+ unless e $ error "Account does not exist"+ (mnemonicM, masterM, derivM, pubM) <- getKey+ let key = case mnemonicM of+ Just ms -> case mnemonicToSeed "" (cs ms) of+ Right s -> deriveXPubKey $+ derivePath (fromMaybe defaultDeriv derivM) $+ makeXPrvKey s+ Left _ -> error "Could not decode mnemonic sentence"+ Nothing -> case masterM of+ Just m -> deriveXPubKey $ maybe m (`derivePath` m) derivM+ Nothing -> fromMaybe (error "No keys provided") pubM+ resE <- sendZmq (PostAccountKeysR (pack name) [key])+ handleResponse resE $ liftIO . putStr . printAccount cmdSetGap :: String -> String -> Handler () cmdSetGap name gap = do- k <- R.asks configKeyRing- sendZmq (PostAccountGapR k (pack name) setGap) $- \(JsonWithKeyRing _ acc) -> putStr $ printAccount acc+ resE <- sendZmq (PostAccountGapR (pack name) setGap)+ handleResponse resE $ liftIO . putStr . printAccount 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+ resE <- sendZmq (GetAccountR $ pack name)+ handleResponse resE $ liftIO . putStr . printAccount -cmdAccounts :: Handler ()-cmdAccounts = do- k <- R.asks configKeyRing- sendZmq (GetAccountsR k) $ \(JsonWithKeyRing _ as) -> do- let xs = map (putStr . printAccount) as- sequence_ $ intersperse (putStrLn "-") xs+cmdAccounts :: [String] -> Handler ()+cmdAccounts ls = do+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ listAction page GetAccountsR $ \ts -> do+ let xs = map (liftIO . putStr . printAccount) ts+ sequence_ $ intersperse (liftIO $ putStrLn "-") xs -pagedAction :: (FromJSON a, ToJSON a)- => [String]- -> (PageRequest -> WalletRequest)- -> ([a] -> IO ())+cmdRenameAcc :: String -> String -> Handler ()+cmdRenameAcc oldName newName = do+ resE <- sendZmq $ PostAccountRenameR (pack oldName) (pack newName)+ handleResponse resE $ liftIO . putStr . printAccount++listAction :: (FromJSON a, ToJSON a)+ => Word32+ -> (ListRequest -> WalletRequest)+ -> ([a] -> Handler ()) -> Handler ()-pagedAction pageLs requestBuilder action = do+listAction page 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+ case c of+ 0 -> do+ let listReq = ListRequest 0 0 r+ resE <- sendZmq (requestBuilder listReq)+ handleResponse resE $ \(ListResult a _) -> action a+ _ -> do+ when (page < 1) $ error "Page cannot be less than 1"+ let listReq = ListRequest ((page - 1) * c) c r+ resE <- sendZmq (requestBuilder listReq)+ handleResponse resE $ \(ListResult a m) -> case m of+ 0 -> liftIO . putStrLn $ "No elements"+ _ -> do+ liftIO . putStrLn $+ "Page " ++ show page ++ " of " ++ show (pages m c) +++ " (" ++ show m ++ " elements)"+ action a where- page = fromMaybe 1 (read <$> listToMaybe pageLs)+ pages m c | m `mod` c == 0 = m `div` c+ | otherwise = m `div` c + 1 cmdList :: String -> [String] -> Handler ()-cmdList name pageLs = do- k <- R.asks configKeyRing+cmdList name ls = do 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)+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ f = GetAddressesR (pack name) t m o+ listAction page f $ \as -> forM_ as (liftIO . putStrLn . printAddress) -cmdUnused :: String -> Handler ()-cmdUnused name = do- k <- R.asks configKeyRing+cmdUnused :: String -> [String] -> Handler ()+cmdUnused name ls = do t <- R.asks configAddrType- sendZmq (GetAddressesUnusedR k (pack name) t) $- \(JsonWithAccount _ _ as) -> forM_ (as :: [JsonAddr]) $ putStrLn . printAddress+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ f = GetAddressesUnusedR (pack name) t+ listAction page f $ \as -> forM_ (as :: [JsonAddr]) $+ liftIO . 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+ resE <- sendZmq (PutAddressR (pack name) i t addrLabel)+ handleResponse resE $ liftIO . putStrLn . printAddress 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+cmdTxs name ls = do+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ r <- R.asks configReversePaging+ listAction page (GetTxsR (pack name)) $ \ts -> do+ let xs = map (liftIO . putStr . printTx Nothing) ts+ xs' = if r then xs else reverse xs+ sequence_ $ intersperse (liftIO $ putStrLn "-") xs' +cmdPending :: String -> [String] -> Handler ()+cmdPending name ls = do+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ r <- R.asks configReversePaging+ listAction page (GetPendingR (pack name)) $ \ts -> do+ let xs = map (liftIO . putStr . printTx Nothing) ts+ xs' = if r then xs else reverse xs+ sequence_ $ intersperse (liftIO $ putStrLn "-") xs'++cmdDead :: String -> [String] -> Handler ()+cmdDead name ls = do+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ r <- R.asks configReversePaging+ listAction page (GetDeadR (pack name)) $ \ts -> do+ let xs = map (liftIO . putStr . printTx Nothing) ts+ xs' = if r then xs else reverse xs+ sequence_ $ intersperse (liftIO $ putStrLn "-") xs'+ cmdAddrTxs :: String -> String -> [String] -> Handler ()-cmdAddrTxs name i pageLs = do- k <- R.asks configKeyRing+cmdAddrTxs name i ls = do t <- R.asks configAddrType- c <- R.asks configCount+ m <- R.asks configMinConf+ o <- R.asks configOffline 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+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ f = GetAddrTxsR (pack name) index t+ resE <- sendZmq (GetAddressR (pack name) index t m o)+ handleResponse resE $ \JsonAddr{..} -> listAction page f $ \ts -> do+ let xs = map (liftIO . putStr . printTx (Just jsonAddrAddress)) ts+ xs' = if r then xs else reverse xs+ sequence_ $ intersperse (liftIO $ putStrLn "-") xs' where- page = fromMaybe 1 (read <$> listToMaybe pageLs)- index = read i+ index = fromMaybe (error "Could not read index") $ readMaybe 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" ]+ let req = PostAddressesR (pack name) index t+ resE <- sendZmq req+ handleResponse resE $ \cnt -> liftIO . putStrLn $+ unwords [ "Generated", show (cnt :: Int), "addresses" ] where index = read i @@ -258,39 +359,46 @@ 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+ masterM <- if sign then getSigningKeys name else return Nothing let action = CreateTx rcps fee minconf rcptFee sign- sendZmq (PostTxsR k (pack name) action) $- \(JsonWithAccount _ _ tx) -> putStr $ printTx tx+ resE <- sendZmq (PostTxsR (pack name) masterM action)+ handleResponse resE $ liftIO . putStr . printTx Nothing _ -> 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 [a,v] = liftM2 (,) (base58ToAddr a) (readMaybe $ 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)+getHexTx :: Handler Tx+getHexTx = do+ hexM <- Haskeline.runInputT Haskeline.defaultSettings $+ Haskeline.getInputLine ""+ let txM = case hexM of+ Nothing -> error "No action due to EOF"+ Just hex -> decodeToMaybe =<< decodeHex (cs hex)+ case txM of+ Just tx -> return tx+ Nothing -> error "Could not parse transaction" +cmdImport :: String -> Handler ()+cmdImport name = do+ tx <- getHexTx+ let action = ImportTx tx+ resE <- sendZmq (PostTxsR (pack name) Nothing action)+ handleResponse resE $ liftIO . putStr . printTx Nothing+ cmdSign :: String -> String -> Handler () cmdSign name txidStr = case txidM of Just txid -> do- k <- R.asks configKeyRing+ masterM <- getSigningKeys name let action = SignTx txid- sendZmq (PostTxsR k (pack name) action) $- \(JsonWithAccount _ _ tx) -> putStr $ printTx tx+ resE <- sendZmq (PostTxsR (pack name) masterM action)+ handleResponse resE $ liftIO . putStr . printTx Nothing _ -> error "Could not parse txid" where txidM = hexToTxHash $ cs txidStr@@ -298,13 +406,12 @@ 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 ]+ resE <- sendZmq (GetOfflineTxR (pack name) tid)+ handleResponse resE $ \(OfflineTxData tx dat) -> do+ liftIO $ putStrLn $ unwords+ [ "Tx :", cs $ encodeHex $ encode' tx ]+ liftIO $ putStrLn $ unwords+ [ "CoinData:", cs $ encodeHex $ cs $ encode dat ] _ -> error "Could not parse txid" where tidM = hexToTxHash $ cs tidStr@@ -312,11 +419,13 @@ 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" ]+ masterM <- getSigningKeys name+ resE <- sendZmq (PostOfflineTxR (pack name) masterM tx dat)+ handleResponse resE $ \(TxCompleteRes tx' c) -> do+ liftIO $ putStrLn $ unwords+ [ "Tx :", cs $ encodeHex $ encode' tx' ]+ liftIO $ putStrLn $ unwords+ [ "Complete:", if c then "Yes" else "No" ] _ -> error "Could not decode input data" where datM = decode . cs =<< decodeHex (cs datStr)@@ -324,77 +433,167 @@ 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) ]+ resE <- sendZmq (GetBalanceR (pack name) m o)+ handleResponse resE $ \bal ->+ liftIO $ 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+ resE <- sendZmq (GetTxR (pack name) tid)+ handleResponse resE $ liftIO . putStr . printTx Nothing _ -> 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]+cmdRescan timeLs = do+ let timeM = case timeLs of+ [] -> Nothing+ str:_ -> case readMaybe str of+ Nothing -> error "Could not decode time"+ Just t -> Just t+ resE <- sendZmq (PostNodeR $ NodeActionRescan timeM)+ handleResponse resE $ \(RescanRes ts) ->+ liftIO $ putStrLn $ unwords [ "Timestamp:", show ts]++cmdDeleteTx :: String -> Handler ()+cmdDeleteTx tidStr = case tidM of+ Just tid -> do+ resE <- sendZmq (DeleteTxIdR tid)+ handleResponse resE $ \() -> return ()+ Nothing -> error "Could not parse txid" where- timeM = read <$> listToMaybe timeLs+ tidM = hexToTxHash $ cs tidStr -cmdDecodeTx :: String -> Handler ()-cmdDecodeTx txStr = do- when (isNothing txM) $ error "Could not parse transaction"+cmdMonitor :: [String] -> Handler ()+cmdMonitor ls = do+ cfg@Config{..} <- R.ask+ -- TODO: I can do this in the same thread without ^C twice (see sendZmq)+ liftIO $ withContext $ \ctx -> withSocket ctx Sub $ \sock -> do+ setLinger (restrict (0 :: Int)) sock+ setupAuth cfg sock+ connect sock configConnectNotif+ subscribe sock "[block]"+ forM_ ls $ \name -> subscribe sock $ "{" <> cs name <> "}"+ forever $ do+ [_,m] <- receiveMulti sock+ handleNotif configFormat $ eitherDecode $ cs m++cmdSync :: String -> String -> [String] -> Handler ()+cmdSync acc block ls = do+ let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe+ f = case length block of+ 64 -> GetSyncR (cs acc) $+ fromMaybe (error "Could not decode block id") $+ hexToBlockHash $ cs block+ _ -> GetSyncHeightR (cs acc) $+ fromMaybe (error "Could not decode block height") $+ readMaybe block+ r <- R.asks configReversePaging+ listAction page f $ \blocks -> do+ let blocks' = if r then reverse blocks else blocks+ forM_ (blocks' :: [JsonSyncBlock]) $ liftIO . putStrLn . printSyncBlock++cmdDecodeTx :: Handler ()+cmdDecodeTx = do+ tx <- getHexTx format <- R.asks configFormat liftIO $ formatStr $ cs $ case format of- OutputJSON -> cs jsn- _ -> YAML.encode val+ OutputJSON -> cs $ jsn tx+ _ -> YAML.encode $ val tx where- txM = decodeToMaybe =<< decodeHex (cs txStr)- val = encodeTxJSON $ fromJust txM- jsn = JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } val+ val = encodeTxJSON+ 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+ resE <- sendZmq (PostNodeR NodeActionStatus)+ handleResponse resE $ mapM_ (liftIO . putStrLn) . printNodeStatus v +cmdKeyPair :: Handler ()+cmdKeyPair = do+ (pub, sec) <- curveKeyPair+ liftIO $ do+ B8.putStrLn $ B8.unwords [ "public :", rvalue pub ]+ B8.putStrLn $ B8.unwords [ "private:", rvalue sec ]+ {- 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+handleNotif :: OutputFormat -> Either String Notif -> IO ()+handleNotif _ (Left e) = error e+handleNotif fmt (Right notif) = case fmt of+ OutputJSON -> formatStr $ cs $+ JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } notif+ OutputYAML -> do+ putStrLn "---"+ formatStr $ cs $ YAML.encode notif+ putStrLn "..."+ OutputNormal ->+ putStrLn $ printNotif notif++handleResponse+ :: (FromJSON a, ToJSON a)+ => Either String (WalletResponse a)+ -> (a -> Handler ())+ -> Handler ()+handleResponse resE handle = 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 $+ formatOutput a format = case format of+ OutputJSON -> liftIO . formatStr $ cs $ JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } a- OutputYAML -> formatStr $- cs $ YAML.encode a+ OutputYAML -> liftIO . formatStr $ cs $ YAML.encode a OutputNormal -> handle a +sendZmq :: (FromJSON a, ToJSON a)+ => WalletRequest+ -> Handler (Either String (WalletResponse a))+sendZmq req = do+ cfg <- R.ask+ let msg = cs $ encode req+ when (configVerbose cfg) $ liftIO $+ B8.hPutStrLn stderr $ "Outgoing JSON: " `mappend` msg+ -- TODO: If I do this in the same thread I have to ^C twice to exit+ a <- async $ liftIO $ withContext $ \ctx ->+ withSocket ctx Req $ \sock -> do+ setLinger (restrict (0 :: Int)) sock+ setupAuth cfg sock+ connect sock (configConnect cfg)+ send sock [] (cs $ encode req)+ eitherDecode . cs <$> receive sock+ wait a++setupAuth :: (SocketType t)+ => Config+ -> Socket t+ -> IO ()+setupAuth cfg sock = do+ let clientKeyM = configClientKey cfg+ clientKeyPubM = configClientKeyPub cfg+ serverKeyPubM = configServerKeyPub cfg+ forM_ clientKeyM $ \clientKey -> do+ let serverKeyPub = fromMaybe+ (error "Server public key not provided")+ serverKeyPubM+ clientKeyPub = fromMaybe+ (error "Client public key not provided")+ clientKeyPubM+ setCurveServerKey TextFormat serverKeyPub sock+ setCurvePublicKey TextFormat clientKeyPub sock+ setCurveSecretKey TextFormat clientKey sock+ formatStr :: String -> IO () formatStr str = forM_ (lines str) putStrLn @@ -402,15 +601,10 @@ 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..]+ , "inputs" .= map encodeTxInJSON is+ , "outputs" .= map encodeTxOutJSON os , "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 $@@ -526,38 +720,32 @@ {- 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+ [ "Account : " ++ unpack jsonAccountName+ , "Type : " ++ showType+ , "Gap : " ++ show jsonAccountGap ] ++- [ "Deriv : " ++ pathToStr d+ [ "Deriv : " ++ pathToStr d | d <- maybeToList jsonAccountDerivation ] +++ [ "Mnemonic: " ++ cs ms+ | ms <- maybeToList jsonAccountMnemonic+ ]+ ++ concat [ printKeys | not (null jsonAccountKeys) ] where printKeys =- ("Keys : " ++ cs (xPubExport (head jsonAccountKeys))) :- map ((" " ++) . cs . xPubExport) (tail jsonAccountKeys)+ ("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"+ AccountRegular -> if isNothing jsonAccountMaster+ then "Read-Only" else "Regular"+ AccountMultisig m n -> unwords+ [ if isNothing jsonAccountMaster+ then "Read-Only Multisig" else "Multisig" , show m, "of", show n ] @@ -567,17 +755,23 @@ ++ [ "(" ++ 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+ [ [ "[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 $+printNotif :: Notif -> String+printNotif (NotifTx tx) = printTx Nothing tx+printNotif (NotifBlock b) = printBlock b++printTx :: Maybe Address -> JsonTx -> String+printTx aM tx@JsonTx{..} = unlines $+ [ "Id : " ++ cs (txHashToHex jsonTxHash) ]+ ++ [ "Value : " ++ printTxType jsonTxType ++ " " ++ show jsonTxValue ] ++ [ "Confidence : " ++ printTxConfidence tx ]@@ -601,22 +795,7 @@ 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 ]+ [ "<-" | maybe local (== addr) aM ] printTxConfidence :: JsonTx -> String printTxConfidence JsonTx{..} = case jsonTxConfidence of@@ -635,12 +814,28 @@ TxOutgoing -> "Outgoing" TxSelf -> "Self" +printBlock :: JsonBlock -> String+printBlock JsonBlock{..} = unlines+ [ "Block Hash : " ++ cs (blockHashToHex jsonBlockHash)+ , "Block Height : " ++ show jsonBlockHeight+ , "Previous block : " ++ cs (blockHashToHex jsonBlockPrev)+ ]++printSyncBlock :: JsonSyncBlock -> String+printSyncBlock JsonSyncBlock{..} = unlines+ [ "Block Hash : " ++ cs (blockHashToHex jsonSyncBlockHash)+ , "Block Height : " ++ show jsonSyncBlockHeight+ , "Previous block : " ++ cs (blockHashToHex jsonSyncBlockPrev)+ , "Transactions : " ++ show (length jsonSyncBlockTxs)+ ]+ 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)+ , "Best Block Height : " ++ show nodeStatusBestBlockHeight , "Bloom Filter Size : " ++ show nodeStatusBloomSize ] ++ [ "Header Peer : " ++ show h@@ -660,7 +855,6 @@ ] ++ [ "Synced Mempool : " ++ show nodeStatusMempool | verbose ] ++ [ "HeaderSync Lock : " ++ show nodeStatusSyncLock | verbose ] ++- [ "LevelDB Lock : " ++ show nodeStatusLevelDBLock | verbose ] ++ [ "Peers: " ] ++ intercalate ["-"] (map (printPeerStatus verbose) nodeStatusPeers) @@ -679,7 +873,6 @@ ] ++ [ " DoS Score: " ++ show d | d <- maybeToList peerStatusDoSScore ] ++- [ " ThreadId : " ++ peerStatusThreadId | verbose ] ++ [ " Merkles : " ++ show peerStatusHaveMerkles | verbose ] ++ [ " Messages : " ++ show peerStatusHaveMessage | verbose ] ++ [ " Nonces : " ++ show peerStatusPingNonces | verbose ] ++@@ -687,6 +880,4 @@ | t <- maybeToList peerStatusReconnectTimer, verbose ] ++ [ " Logs : " | verbose ] ++- [ " - " ++ msg | msg <- maybe [] id peerStatusLog, verbose]--+ [ " - " ++ msg | msg <- fromMaybe [] peerStatusLog, verbose]
+ Network/Haskoin/Wallet/Database.hs view
@@ -0,0 +1,17 @@+module Network.Haskoin.Wallet.Database where++import Control.Monad.Logger (MonadLoggerIO)+import Control.Monad.Trans.Control (MonadBaseControl)++import Database.Persist.Sql (ConnectionPool)+import Database.Persist.Sqlite (SqliteConf(..), createSqlitePool)++type DatabaseConfType = SqliteConf++getDatabasePool :: (MonadLoggerIO m, MonadBaseControl IO m)+ => DatabaseConfType -> m ConnectionPool+getDatabasePool conf = createSqlitePool (sqlDatabase conf) (sqlPoolSize conf)++paramLimit :: Int+paramLimit = 20+
Network/Haskoin/Wallet/Internals.hs view
@@ -5,7 +5,7 @@ module Network.Haskoin.Wallet.Internals ( module Network.Haskoin.Wallet-, module Network.Haskoin.Wallet.KeyRing+, module Network.Haskoin.Wallet.Accounts , module Network.Haskoin.Wallet.Transaction , module Network.Haskoin.Wallet.Client , module Network.Haskoin.Wallet.Client.Commands@@ -18,7 +18,7 @@ ) where import Network.Haskoin.Wallet-import Network.Haskoin.Wallet.KeyRing+import Network.Haskoin.Wallet.Accounts import Network.Haskoin.Wallet.Transaction import Network.Haskoin.Wallet.Client import Network.Haskoin.Wallet.Client.Commands
− Network/Haskoin/Wallet/KeyRing.hs
@@ -1,720 +0,0 @@-module Network.Haskoin.Wallet.KeyRing-(--- *Database KeyRings- initWallet-, newKeyRing-, keyRings-, keyRingSource-, getKeyRing---- *Database Accounts-, accounts-, accountSource-, newAccount-, addAccountKeys-, getAccount-, isMultisigAccount-, isReadAccount-, isCompleteAccount---- *Database Addresses-, getAddress-, addressSourceAll-, addressSource-, addressPage-, unusedAddresses-, addressCount-, setAddrLabel-, addressPrvKey-, useAddress-, generateAddrs-, setAccountGap-, firstAddrTime-, getPathRedeem-, getPathPubKey---- *Database Bloom Filter-, getBloomFilter---- * Helpers-, subSelectAddrCount-) where--import Control.Monad (unless, when, liftM)-import Control.Monad.Trans (MonadIO, liftIO)-import Control.Monad.Base (MonadBase)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.Trans.Resource (MonadResource)-import Control.Exception (throwIO, throw)--import Data.Text (Text, unpack)-import Data.Maybe (mapMaybe, listToMaybe)-import Data.Time.Clock (getCurrentTime)-import Data.Conduit (Source, mapOutput, await, ($$))-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)-import Data.List (nub)-import Data.Word (Word32)-import qualified Data.ByteString as BS (ByteString, null)--import qualified Database.Persist as P (updateWhere, update , (=.))-import Database.Esqueleto- ( Value(..), SqlExpr, SqlQuery- , InnerJoin(..), on- , select, from, where_, val, sub_select, countRows, count, unValue- , orderBy, limit, asc, desc, offset, selectSource, get- , max_, not_, isNothing, case_, when_, then_, else_- , (^.), (==.), (&&.), (>.), (-.), (<.)- -- Reexports from Database.Persist- , SqlPersistT, Entity(..)- , getBy, insertUnique, insertMany_, insert_- )--import Network.Haskoin.Crypto-import Network.Haskoin.Block-import Network.Haskoin.Script-import Network.Haskoin.Node-import Network.Haskoin.Util-import Network.Haskoin.Constants-import Network.Haskoin.Node.HeaderTree--import Network.Haskoin.Wallet.Types-import Network.Haskoin.Wallet.Model--{- Initialization -}--initWallet :: MonadIO m => Double -> SqlPersistT m ()-initWallet fpRate = do- prevConfigRes <- select $ from $ \c -> return $ count $ c ^. KeyRingConfigId- let cnt = maybe 0 unValue $ listToMaybe prevConfigRes- if cnt == (0 :: Int)- then do- time <- liftIO getCurrentTime- -- Create an initial bloom filter- -- TODO: Compute a random nonce- let bloom = bloomCreate (filterLen 0) fpRate 0 BloomUpdateNone- insert_ $ KeyRingConfig- { keyRingConfigHeight = 0- , keyRingConfigBlock = headerHash genesisHeader- , keyRingConfigBloomFilter = bloom- , keyRingConfigBloomElems = 0- , keyRingConfigBloomFp = fpRate- , keyRingConfigVersion = 1- , keyRingConfigCreated = time- }- else return () -- Nothing to do--{- KeyRing -}---- | Create a new KeyRing from a seed-newKeyRing :: MonadIO m- => KeyRingName- -> BS.ByteString- -> SqlPersistT m (Entity KeyRing)-newKeyRing name seed- | BS.null seed = liftIO . throwIO $ WalletException "The seed is empty"- | otherwise = do- now <- liftIO getCurrentTime- let keyRing = KeyRing- { keyRingName = name- , keyRingMaster = makeXPrvKey seed- , keyRingCreated = now- }- insertUnique keyRing >>= \resM -> case resM of- Just ki -> return (Entity ki keyRing)- _ -> liftIO . throwIO $ WalletException $ unwords- [ "KeyRing", unpack name, "already exists" ]--keyRings :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => SqlPersistT m [KeyRing]-keyRings = liftM (map entityVal) $ select $ from return---- | Stream all KeyRings-keyRingSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Source (SqlPersistT m) KeyRing-keyRingSource = mapOutput entityVal $ selectSource $ from return---- Helper functions to get a KeyRing if it exists, or throw an exception--- otherwise.-getKeyRing :: MonadIO m => KeyRingName -> SqlPersistT m (Entity KeyRing)-getKeyRing name = getBy (UniqueKeyRing name) >>= \resM -> case resM of- Just keyRingEnt -> return keyRingEnt- _ -> liftIO . throwIO $ WalletException $ unwords- [ "KeyRing", unpack name, "does not exist." ]--{- Account -}---- | Fetch all the accounts in a keyring-accounts :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => KeyRingId -> SqlPersistT m [KeyRingAccount]-accounts ki = liftM (map entityVal) $ select $ accountsFrom ki---- | Stream all accounts in a keyring-accountSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => KeyRingId -> Source (SqlPersistT m) KeyRingAccount-accountSource ki = mapOutput entityVal $ selectSource $ accountsFrom ki--accountsFrom :: KeyRingId -> SqlQuery (SqlExpr (Entity KeyRingAccount))-accountsFrom ki =- from $ \a -> do- where_ $ a ^. KeyRingAccountKeyRing ==. val ki- return a---- | Create a new account-newAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRing- -> AccountName- -> AccountType- -> [XPubKey]- -> SqlPersistT m (Entity KeyRingAccount)-newAccount (Entity ki keyRing) accountName accountType extraKeys = do- unless (validAccountType accountType) $- liftIO . throwIO $ WalletException "Invalid account type"-- -- Get the next account derivation- derivM <- if accountTypeRead accountType then return Nothing else- liftM Just $ nextAccountDeriv ki-- -- Derive the next account key- let f d = [ deriveXPubKey (derivePath d $ keyRingMaster keyRing) ]- keys = (maybe [] f derivM) ++ extraKeys-- -- Build the account- now <- liftIO getCurrentTime- let acc = KeyRingAccount- { keyRingAccountKeyRing = ki- , keyRingAccountName = accountName- , keyRingAccountType = accountType- , keyRingAccountDerivation = derivM- , keyRingAccountKeys = keys- , keyRingAccountGap = 0- , keyRingAccountCreated = now- }-- -- Check if all the keys are valid- unless (isValidAccKeys acc) $- liftIO . throwIO $ WalletException "Invalid account keys"-- -- Insert our account in the database- let canSetGap = isCompleteAccount acc- newAcc = acc{ keyRingAccountGap = if canSetGap then 10 else 0 }-- insertUnique newAcc >>= \resM -> case resM of- -- The account got created.- Just ai -> do- let accE = Entity ai newAcc- -- If we can set the gap, create the gap addresses- when canSetGap $ do- _ <- createAddrs accE AddressExternal 20- _ <- createAddrs accE AddressInternal 20- return ()- return accE- -- The account already exists- Nothing -> liftIO . throwIO $ WalletException $ unwords- [ "Account", unpack accountName, "already exists" ]---- | Add new thirdparty keys to a multisignature account. This function can--- fail if the multisignature account already has all required keys.-addAccountKeys :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRingAccount -- ^ Account Entity- -> [XPubKey] -- ^ Thirdparty public keys to add- -> SqlPersistT m KeyRingAccount -- ^ Account information-addAccountKeys (Entity ai acc) keys- -- We can only add keys on incomplete accounts- | isCompleteAccount acc = liftIO . throwIO $- WalletException "The account is already complete"- | null keys || (not $ isValidAccKeys accKeys) = liftIO . throwIO $- WalletException "Invalid account keys"- | otherwise = do- let canSetGap = isCompleteAccount accKeys- updGap = if canSetGap then [ KeyRingAccountGap P.=. 10 ] else []- newAcc = accKeys{ keyRingAccountGap = if canSetGap then 10 else 0 }- -- Update the account with the keys and the new gap if it is complete- P.update ai $ (KeyRingAccountKeys P.=. newKeys) : updGap- -- If we can set the gap, create the gap addresses- when canSetGap $ do- let accE = Entity ai newAcc- _ <- createAddrs accE AddressExternal 20- _ <- createAddrs accE AddressInternal 20- return ()- return newAcc- where- newKeys = keyRingAccountKeys acc ++ keys- accKeys = acc{ keyRingAccountKeys = newKeys }--isValidAccKeys :: KeyRingAccount -> Bool-isValidAccKeys KeyRingAccount{..} = case keyRingAccountType of- AccountRegular _ -> length keyRingAccountKeys == 1- -- read-only accounts can have 0 keys. Otherwise 1 key is required.- AccountMultisig r _ n -> goMultisig n (if r then 0 else 1)- where- goMultisig n minLen =- length keyRingAccountKeys == length (nub keyRingAccountKeys) &&- length keyRingAccountKeys <= n &&- length keyRingAccountKeys >= minLen---- | Compute the next derivation path for a new account-nextAccountDeriv :: MonadIO m => KeyRingId -> SqlPersistT m HardPath-nextAccountDeriv ki = do- lastRes <- select $ from $ \a -> do- where_ ( a ^. KeyRingAccountKeyRing ==. val ki- &&. not_ (isNothing (a ^. KeyRingAccountDerivation))- )- orderBy [ desc (a ^. KeyRingAccountId) ]- limit 1- return $ a ^. KeyRingAccountDerivation- return $ case lastRes of- (Value (Just (prev :| i)):_) -> prev :| (i + 1)- _ -> Deriv :| 0---- Helper functions to get an Account if it exists, or throw an exception--- otherwise.-getAccount :: MonadIO m => KeyRingName -> AccountName- -> SqlPersistT m (KeyRing, Entity KeyRingAccount)-getAccount keyRingName accountName = do- as <- select $ from $ \(k `InnerJoin` a) -> do- on $ a ^. KeyRingAccountKeyRing ==. k ^. KeyRingId- where_ ( k ^. KeyRingName ==. val keyRingName- &&. a ^. KeyRingAccountName ==. val accountName- )- return (k, a)- case as of- ((Entity _ k, accEnt):_) -> return (k, accEnt)- _ -> liftIO . throwIO $ WalletException $ unwords- [ "Account", unpack accountName, "does not exist" ]--{- Addresses -}---- | Get an address if it exists, or throw an exception otherwise. Fetching--- addresses in the hidden gap will also throw an exception.-getAddress :: MonadIO m- => Entity KeyRingAccount -- ^ Account Entity- -> AddressType -- ^ Address type- -> KeyIndex -- ^ Derivation index (key)- -> SqlPersistT m (Entity KeyRingAddr) -- ^ Address-getAddress accE@(Entity ai _) addrType index = do- res <- select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- &&. x ^. KeyRingAddrIndex ==. val index- &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType- )- limit 1- return x- case res of- (addrE:_) -> return addrE- _ -> liftIO . throwIO $ WalletException $ unwords- [ "Invalid address index", show index ]---- | Stream all addresses in the wallet, including hidden gap addresses. This--- is useful for building a bloom filter.-addressSourceAll :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Source (SqlPersistT m) KeyRingAddr-addressSourceAll = mapOutput entityVal $ selectSource $ from return---- | Stream all addresses in one account. Hidden gap addresses are not included.-addressSource :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRingAccount -- ^ Account Entity- -> AddressType -- ^ Address Type- -> Source (SqlPersistT m) KeyRingAddr -- ^ Source of addresses-addressSource accE@(Entity ai _) addrType = mapOutput entityVal $- selectSource $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType- )- return x---- | Get addresses by pages.-addressPage :: MonadIO m- => Entity KeyRingAccount -- ^ Account Entity- -> AddressType -- ^ Address type- -> PageRequest -- ^ Page request- -> SqlPersistT m ([KeyRingAddr], Word32)- -- ^ Page result-addressPage accE@(Entity ai _) addrType page@PageRequest{..}- | validPageRequest page = do- cnt <- addressCount accE addrType-- let (d, m) = cnt `divMod` pageLen- maxPage = max 1 $ d + min 1 m-- when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $- unwords [ "Invalid page number", show pageNum ]-- if cnt == 0 then return ([], maxPage) else do- res <- liftM (map entityVal) $ select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- &&. x ^. KeyRingAddrIndex <. val cnt- )- let order = if pageReverse then asc else desc- orderBy [ order (x ^. KeyRingAddrIndex) ]- limit $ fromIntegral pageLen- offset $ fromIntegral $ (pageNum - 1) * pageLen- return x-- -- Flip the order back to ASC if we had it DEC- let f = if pageReverse then id else reverse- return (f res, maxPage)-- | otherwise = liftIO . throwIO $ WalletException $- concat [ "Invalid page request"- , " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"- ]---- | Get a count of all the addresses in an account-addressCount :: MonadIO m- => Entity KeyRingAccount -- ^ Account Entity- -> AddressType -- ^ Address type- -> SqlPersistT m Word32 -- ^ Address Count-addressCount (Entity ai acc) addrType = do- res <- select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- )- return countRows- let cnt = maybe 0 unValue $ listToMaybe res- return $ if cnt > keyRingAccountGap acc- then cnt - keyRingAccountGap acc- else 0---- | Get a list of all unused addresses.-unusedAddresses :: MonadIO m- => Entity KeyRingAccount -- ^ Account ID- -> AddressType -- ^ Address type- -> SqlPersistT m [KeyRingAddr] -- ^ Unused addresses-unusedAddresses (Entity ai acc) addrType = do- liftM (reverse . map entityVal) $ select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- )- orderBy [ desc $ x ^. KeyRingAddrIndex ]- limit $ fromIntegral $ keyRingAccountGap acc- offset $ fromIntegral $ keyRingAccountGap acc- return x---- | Add a label to an address.-setAddrLabel :: MonadIO m- => Entity KeyRingAccount -- ^ Account ID- -> KeyIndex -- ^ Derivation index- -> AddressType -- ^ Address type- -> Text -- ^ New label- -> SqlPersistT m KeyRingAddr-setAddrLabel accE i addrType label = do- Entity addrI addr <- getAddress accE addrType i- P.update addrI [ KeyRingAddrLabel P.=. label ]- return $ addr{ keyRingAddrLabel = label }---- | Returns the private key of an address.-addressPrvKey :: MonadIO m- => KeyRing -- ^ KeyRing- -> Entity KeyRingAccount -- ^ Account Entity- -> KeyIndex -- ^ Derivation index of the address- -> AddressType -- ^ Address type- -> SqlPersistT m PrvKeyC -- ^ Private key-addressPrvKey keyRing accE@(Entity ai _) index addrType = do- res <- select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- &&. x ^. KeyRingAddrIndex ==. val index- &&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType- )- return (x ^. KeyRingAddrFullDerivation)- case res of- (Value (Just deriv):_) ->- return $ xPrvKey $ derivePath deriv $ keyRingMaster keyRing- _ -> liftIO . throwIO $ WalletException "Invalid address"---- | Create new addresses in an account and increment the internal bloom filter.--- This is a low-level function that simply creates the desired amount of new--- addresses in an account, disregarding visible and hidden address gaps. You--- should use the function `setAccountGap` if you want to control the gap of an--- account instead.-createAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRingAccount- -> AddressType- -> Word32- -> SqlPersistT m [KeyRingAddr]-createAddrs (Entity ai acc) addrType n- | n == 0 = liftIO . throwIO $ WalletException $- unwords [ "Invalid value", show n ]- | not (isCompleteAccount acc) =- liftIO . throwIO $ WalletException $ unwords- [ "Keys are still missing from the incomplete account"- , unpack $ keyRingAccountName acc- ]- | otherwise = do- now <- liftIO getCurrentTime- -- Find the next derivation index from the last address- lastRes <- select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- )- return $ max_ (x ^. KeyRingAddrIndex)- let nextI = case lastRes of- (Value (Just lastI):_) -> lastI + 1- _ -> 0- build (addr, keyM, rdmM, i) = KeyRingAddr- { keyRingAddrAccount = ai- , keyRingAddrAddress = addr- , keyRingAddrIndex = i- , keyRingAddrType = addrType- , keyRingAddrLabel = ""- -- Full derivation from the master key- , keyRingAddrFullDerivation =- let f d = toMixed d :/ branchType :/ i- in f <$> keyRingAccountDerivation acc- -- Partial derivation under the account derivation- , keyRingAddrDerivation = Deriv :/ branchType :/ i- , keyRingAddrRedeem = rdmM- , keyRingAddrKey = keyM- , keyRingAddrCreated = now- }- res = map build $ take (fromIntegral n) $ deriveFrom nextI-- -- Save the addresses and increment the bloom filter- insertMany_ res- incrementFilter res- return res- where- -- Branch type (external = 0, internal = 1)- branchType = addrTypeIndex addrType- deriveFrom = case keyRingAccountType acc of- AccountMultisig _ m _ ->- let f (a, r, i) = (a, Nothing, Just r, i)- deriv = Deriv :/ branchType- in map f . derivePathMSAddrs (keyRingAccountKeys acc) deriv m- AccountRegular _ -> case keyRingAccountKeys acc of- (key:_) -> let f (a, k, i) = (a, Just k, Nothing, i)- in map f . derivePathAddrs key (Deriv :/ branchType)- [] -> throw $ WalletException $ unwords- [ "createAddrs: No key available in regular account"- , unpack $ keyRingAccountName acc- ]---- | Generate all the addresses up to a certain index-generateAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRingAccount- -> AddressType- -> KeyIndex- -> SqlPersistT m Int-generateAddrs accE@(Entity _ _) addrType genIndex = do- cnt <- addressCount accE addrType- let toGen = (fromIntegral genIndex) - (fromIntegral cnt) + 1- if toGen > 0- then do- _ <- createAddrs accE addrType $ fromIntegral toGen- return toGen- else return 0---- | Use an address and make sure we have enough gap addresses after it.--- Returns the new addresses that have been created.-useAddress :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => KeyRingAddr -> SqlPersistT m [KeyRingAddr]-useAddress KeyRingAddr{..} = do- res <- select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val keyRingAddrAccount- &&. x ^. KeyRingAddrType ==. val keyRingAddrType- &&. x ^. KeyRingAddrIndex >. val keyRingAddrIndex- )- return countRows- case res of- ((Value cnt):_) -> get keyRingAddrAccount >>= \accM -> case accM of- Just acc -> do- let accE = Entity keyRingAddrAccount acc- gap = fromIntegral (keyRingAccountGap acc) :: Int- missing = 2*gap - cnt- if missing > 0- then createAddrs accE keyRingAddrType $ fromIntegral missing- else return []- _ -> return [] -- Should not happen- _ -> return [] -- Should not happen---- | Set the address gap of an account to a new value. This will create new--- internal and external addresses as required. The gap can only be increased,--- not decreased in size.-setAccountGap :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => Entity KeyRingAccount -- ^ Account Entity- -> Word32 -- ^ New gap value- -> SqlPersistT m KeyRingAccount-setAccountGap accE@(Entity ai acc) gap- | not (isCompleteAccount acc) =- liftIO . throwIO $ WalletException $ unwords- [ "Keys are still missing from the incomplete account"- , unpack $ keyRingAccountName acc- ]- | missing <= 0 = liftIO . throwIO $ WalletException- "The gap of an account can only be increased"- | otherwise = do- _ <- createAddrs accE AddressExternal $ fromInteger $ missing*2- _ <- createAddrs accE AddressInternal $ fromInteger $ missing*2- P.update ai [ KeyRingAccountGap P.=. gap ]- return $ acc{ keyRingAccountGap = gap }- where- missing = toInteger gap - toInteger (keyRingAccountGap acc)---- Return the creation time of the first address in the wallet.-firstAddrTime :: MonadIO m => SqlPersistT m (Maybe Timestamp)-firstAddrTime = do- res <- select $ from $ \x -> do- orderBy [ asc (x ^. KeyRingAddrId) ]- limit 1- return $ x ^. KeyRingAddrCreated- return $ case res of- (Value d:_) -> Just $ toPOSIX d- _ -> Nothing- where- toPOSIX = fromInteger . round . utcTimeToPOSIXSeconds--{- Bloom filters -}---- | Add the given addresses to the bloom filter. If the number of elements--- becomes too large, a new bloom filter is computed from scratch.-incrementFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => [KeyRingAddr]- -> SqlPersistT m ()-incrementFilter addrs = do- (bloom, elems, _) <- getBloomFilter- let newElems = elems + (length addrs * 2)- if filterLen newElems > filterLen elems- then computeNewFilter- else setBloomFilter (addToFilter bloom addrs) newElems---- | Generate a new bloom filter from the data in the database-computeNewFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)- => SqlPersistT m ()-computeNewFilter = do- (_, _, fpRate) <- getBloomFilter- -- Create a new empty bloom filter- -- TODO: Choose a random nonce for the bloom filter- -- TODO: Check global bloom filter length limits- cntRes <- select $ from $ \x -> return $ count $ x ^. KeyRingAddrId- let elems = maybe 0 unValue $ listToMaybe cntRes- newBloom = bloomCreate (filterLen elems) fpRate 0 BloomUpdateNone- bloom <- addressSourceAll $$ bloomSink newBloom- setBloomFilter bloom elems- where- bloomSink bloom = await >>= \addrM -> case addrM of- Just addr -> bloomSink $ addToFilter bloom [addr]- _ -> return bloom---- Compute the size of a filter given a number of elements. Scale--- the filter length by powers of 2.-filterLen :: Int -> Int-filterLen = round . pow2 . ceiling . log2- where- pow2 x = (2 :: Double) ** fromInteger x- log2 x = logBase (2 :: Double) (fromIntegral x)---- | Add elements to a bloom filter-addToFilter :: BloomFilter -> [KeyRingAddr] -> BloomFilter-addToFilter bloom addrs =- bloom3- where- pks = mapMaybe keyRingAddrKey addrs- rdms = mapMaybe keyRingAddrRedeem addrs- -- Add the Hash160 of the addresses- f1 b a = bloomInsert b $ encode' $ getAddrHash a- bloom1 = foldl f1 bloom $ map keyRingAddrAddress addrs- -- Add the redeem scripts- f2 b r = bloomInsert b $ encodeOutputBS r- bloom2 = foldl f2 bloom1 rdms- -- Add the public keys- f3 b p = bloomInsert b $ encode' p- bloom3 = foldl f3 bloom2 pks---- | Returns a bloom filter containing all the addresses in this wallet. This--- includes internal and external addresses. The bloom filter can be set on a--- peer connection to filter the transactions received by that peer.-getBloomFilter :: MonadIO m => SqlPersistT m (BloomFilter, Int, Double)-getBloomFilter = do- res <- select $ from $ \c -> do- limit 1- return ( c ^. KeyRingConfigBloomFilter- , c ^. KeyRingConfigBloomElems- , c ^. KeyRingConfigBloomFp- )- case res of- ((Value b, Value n, Value fp):_) -> return (b, n, fp)- _ -> liftIO . throwIO $- WalletException "getBloomFilter: Database not initialized"---- | Save a bloom filter and the number of elements it contains-setBloomFilter :: MonadIO m => BloomFilter -> Int -> SqlPersistT m ()-setBloomFilter bloom elems =- P.updateWhere [] [ KeyRingConfigBloomFilter P.=. bloom- , KeyRingConfigBloomElems P.=. elems- ]---- Helper function to compute the redeem script of a given derivation path--- for a given multisig account.-getPathRedeem :: KeyRingAccount -> SoftPath -> RedeemScript-getPathRedeem acc@KeyRingAccount{..} deriv = case keyRingAccountType of- AccountMultisig _ m _ -> if isCompleteAccount acc- then sortMulSig $ PayMulSig pubKeys m- else throw $ WalletException $ unwords- [ "getPathRedeem: Incomplete multisig account"- , unpack keyRingAccountName- ]- _ -> throw $ WalletException $ unwords- [ "getPathRedeem: Account", unpack keyRingAccountName- , "is not a multisig account"- ]- where- f = toPubKeyG . xPubKey . derivePubPath deriv- pubKeys = map f keyRingAccountKeys---- Helper function to compute the public key of a given derivation path for--- a given non-multisig account.-getPathPubKey :: KeyRingAccount -> SoftPath -> PubKeyC-getPathPubKey acc@KeyRingAccount{..} deriv- | isMultisigAccount acc = throw $ WalletException $- unwords [ "getPathPubKey: Account", unpack keyRingAccountName- , "is not a regular non-multisig account"- ]- | otherwise = case keyRingAccountKeys of- (key:_) -> xPubKey $ derivePubPath deriv key- _ -> throw $ WalletException $ unwords- [ "getPathPubKey: No keys are available in account"- , unpack keyRingAccountName- ]--{- Helpers -}--subSelectAddrCount :: Entity KeyRingAccount- -> AddressType- -> SqlExpr (Value KeyIndex)-subSelectAddrCount (Entity ai acc) addrType =- sub_select $ from $ \x -> do- where_ ( x ^. KeyRingAddrAccount ==. val ai- &&. x ^. KeyRingAddrType ==. val addrType- )- let gap = val $ keyRingAccountGap acc- return $ case_- [ when_ (countRows >. gap)- then_ (countRows -. gap)- ] (else_ $ val 0)--validMultisigParams :: Int -> Int -> Bool-validMultisigParams m n = n >= 1 && n <= 15 && m >= 1 && m <= n--validAccountType :: AccountType -> Bool-validAccountType t = case t of- AccountRegular _ -> True- AccountMultisig _ m n -> validMultisigParams m n--isMultisigAccount :: KeyRingAccount -> Bool-isMultisigAccount acc = case keyRingAccountType acc of- AccountRegular _ -> False- AccountMultisig _ _ _ -> True--isReadAccount :: KeyRingAccount -> Bool-isReadAccount acc = case keyRingAccountType acc of- AccountRegular r -> r- AccountMultisig r _ _ -> r--isCompleteAccount :: KeyRingAccount -> Bool-isCompleteAccount acc = case keyRingAccountType acc of- AccountRegular _ -> length (keyRingAccountKeys acc) == 1- AccountMultisig _ _ n -> length (keyRingAccountKeys acc) == n-
Network/Haskoin/Wallet/Model.hs view
@@ -1,25 +1,22 @@ module Network.Haskoin.Wallet.Model ( -- Database types- KeyRing(..)-, KeyRingId-, KeyRingAccount(..)-, KeyRingAccountId-, KeyRingAddr(..)-, KeyRingAddrId-, KeyRingConfig(..)-, KeyRingConfigId-, KeyRingCoin(..)-, KeyRingCoinId-, KeyRingSpentCoin(..)-, KeyRingSpentCoinId-, KeyRingTx(..)-, KeyRingTxId+ Account(..)+, AccountId+, WalletAddr(..)+, WalletAddrId+, WalletState(..)+, WalletStateId+, WalletCoin(..)+, WalletCoinId+, SpentCoin(..)+, SpentCoinId+, WalletTx(..)+, WalletTxId , EntityField(..) , Unique(..) , migrateWallet -- JSON conversion-, toJsonKeyRing , toJsonAccount , toJsonAddr , toJsonCoin@@ -27,11 +24,10 @@ ) where -import Control.DeepSeq (NFData(..))- import Data.Word (Word32, Word64) import Data.Time (UTCTime) import Data.Text (Text)+import Data.String.Conversions (cs) import Database.Persist (EntityField, Unique) import Database.Persist.Quasi (lowerCaseSettings)@@ -56,159 +52,78 @@ ] $(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+toJsonAccount :: Maybe Mnemonic -> Account -> JsonAccount+toJsonAccount msM acc = JsonAccount+ { jsonAccountName = accountName acc+ , jsonAccountType = accountType acc+ , jsonAccountMnemonic = fmap cs msM+ , jsonAccountMaster = accountMaster acc+ , jsonAccountDerivation = accountDerivation acc+ , jsonAccountKeys = accountKeys acc+ , jsonAccountGap = accountGap acc+ , jsonAccountCreated = accountCreated acc } -toJsonAddr :: KeyRingAddr -- ^ The address- -> Maybe BalanceInfo -- ^ The addresses balance+toJsonAddr :: WalletAddr+ -> Maybe BalanceInfo -> 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+ { jsonAddrAddress = walletAddrAddress addr+ , jsonAddrIndex = walletAddrIndex addr+ , jsonAddrType = walletAddrType addr+ , jsonAddrLabel = walletAddrLabel addr+ , jsonAddrRedeem = walletAddrRedeem addr+ , jsonAddrKey = walletAddrKey addr+ , jsonAddrCreated = walletAddrCreated addr , jsonAddrBalance = balM } -toJsonTx :: KeyRingTx -- ^ The transaction- -> Maybe BlockHeight -- ^ The current best block height+toJsonTx :: AccountName+ -> Maybe (BlockHash, BlockHeight) -- ^ Current best block+ -> WalletTx -> 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+toJsonTx acc bbM tx = JsonTx+ { jsonTxHash = walletTxHash tx+ , jsonTxNosigHash = walletTxNosigHash tx+ , jsonTxType = walletTxType tx+ , jsonTxInValue = walletTxInValue tx+ , jsonTxOutValue = walletTxOutValue tx+ , jsonTxValue = fromIntegral (walletTxInValue tx) -+ fromIntegral (walletTxOutValue tx)+ , jsonTxInputs = walletTxInputs tx+ , jsonTxOutputs = walletTxOutputs tx+ , jsonTxChange = walletTxChange tx+ , jsonTxTx = walletTxTx tx+ , jsonTxIsCoinbase = walletTxIsCoinbase tx+ , jsonTxConfidence = walletTxConfidence tx+ , jsonTxConfirmedBy = walletTxConfirmedBy tx+ , jsonTxConfirmedHeight = walletTxConfirmedHeight tx+ , jsonTxConfirmedDate = walletTxConfirmedDate tx+ , jsonTxCreated = walletTxCreated tx+ , jsonTxAccount = acc+ , jsonTxConfirmations = f =<< walletTxConfirmedHeight tx+ , jsonTxBestBlock = fst <$> bbM+ , jsonTxBestBlockHeight = snd <$> bbM } where- f confirmedHeight = case currentHeightM of- Just h -> return $ fromInteger $+ f confirmedHeight = case bbM 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+toJsonCoin :: WalletCoin+ -> Maybe JsonTx -- ^ Coin’s transaction+ -> Maybe JsonAddr -- ^ Coin’s address+ -> Maybe JsonTx -- ^ Coin’s spending transaction -> JsonCoin toJsonCoin coin txM addrM spendM = JsonCoin- { jsonCoinHash = keyRingCoinHash coin- , jsonCoinPos = keyRingCoinPos coin- , jsonCoinValue = keyRingCoinValue coin- , jsonCoinScript = keyRingCoinScript coin- , jsonCoinCreated = keyRingCoinCreated coin+ { jsonCoinHash = walletCoinHash coin+ , jsonCoinPos = walletCoinPos coin+ , jsonCoinValue = walletCoinValue coin+ , jsonCoinScript = walletCoinScript coin+ , jsonCoinCreated = walletCoinCreated coin -- Optional tx , jsonCoinTx = txM -- Optional address
Network/Haskoin/Wallet/Server.hs view
@@ -1,71 +1,87 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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+import Control.Concurrent.Async.Lifted (async, link,+ waitAnyCancel)+import Control.Concurrent.STM (atomically, retry)+import Control.Concurrent.STM.TBMChan (TBMChan, newTBMChan,+ readTBMChan)+import Control.DeepSeq (NFData (..))+import Control.Exception.Lifted (ErrorCall (..),+ SomeException (..),+ catches)+import qualified Control.Exception.Lifted as E (Handler (..))+import Control.Monad (forM_, forever, unless,+ void, when)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Logger (MonadLoggerIO,+ filterLogger, logDebug,+ logError, logInfo,+ logWarn,+ runStdoutLoggingT)+import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl,+ liftBaseOpDiscard)+import Control.Monad.Trans.Resource (MonadResource,+ runResourceT)+import Data.Aeson (Value, decode, encode)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL (fromStrict,+ toStrict)+import Data.Conduit (await, awaitForever,+ ($$))+import qualified Data.HashMap.Strict as H (lookup)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Map.Strict as M (Map, assocs, elems,+ empty,+ fromListWith, null,+ unionWith)+import Data.Maybe (fromJust, fromMaybe,+ isJust)+import Data.Monoid ((<>))+import Data.String.Conversions (cs)+import Data.Text (pack)+import Data.Word (Word32)+import Database.Esqueleto (from, val, where_,+ (&&.), (<=.), (==.),+ (^.))+import Database.Persist.Sql (ConnectionPool,+ runMigration)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Node.BlockChain+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.Peer+import Network.Haskoin.Node.STM+import Network.Haskoin.Transaction+import Network.Haskoin.Wallet.Accounts+import Network.Haskoin.Wallet.Database+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Server.Handler+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Types+import System.Posix.Daemon (Redirection (ToFile),+ killAndWait,+ runDetached)+import System.ZMQ4 (Context, KeyFormat (..),+ Pub (..), Rep (..),+ Socket, bind, receive,+ receiveMulti, restrict,+ send, sendMulti,+ setCurveSecretKey,+ setCurveServer,+ setLinger, withContext,+ withSocket, z85Decode) data EventSession = EventSession { eventBatchSize :: !Int- , eventNewAddrs :: !(M.Map KeyRingAccountId Word32)+ , eventNewAddrs :: !(M.Map AccountId Word32) } deriving (Eq, Show, Read) @@ -75,125 +91,122 @@ rnf (M.elems eventNewAddrs) runSPVServer :: Config -> IO ()-runSPVServer cfg = maybeDetach cfg $ do -- start the server process+runSPVServer cfg = maybeDetach cfg $ run $ do -- start the server process -- Initialize the database- (sem, pool) <- initDatabase cfg -- Check the operation mode of the server.- run $ case configMode cfg of+ pool <- initDatabase cfg+ -- Notification channel+ notif <- liftIO $ atomically $ newTBMChan 1000+ 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+ SPVOffline ->+ runWalletApp $ HandlerSession cfg pool Nothing notif -- 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+ node <- getNodeState (Right pool) -- Spin up the node threads+ let session = HandlerSession cfg pool (Just node) notif as <- mapM async -- Start the SPV node- [ runNodeT nodeState $ do- -- Get our bloom filter- (bloom, elems, _) <- runDBPool sem pool getBloomFilter- startSPVNode hosts bloom elems+ [ runNodeT (spv pool) node -- Merkle block synchronization- , runMerkleSync nodeState sem pool+ , runNodeT (runMerkleSync pool notif) node -- Import solo transactions as they arrive from peers- , runNodeT nodeState $ txSource $$ processTx sem pool+ , runNodeT (txSource $$ processTx pool notif) node -- Respond to transaction GetData requests- , runNodeT nodeState $- handleGetData $ runDBPool sem pool . getTx+ , runNodeT (handleGetData $ (`runDBPool` pool) . getTx) node -- Re-broadcast pending transactions- , broadcastPendingTxs nodeState sem pool+ , runNodeT (broadcastPendingTxs pool) node -- Run the ZMQ API server- , runWalletApp $ HandlerSession cfg pool (Just nodeState) sem+ , runWalletApp session ]+ mapM_ link as _ <- waitAnyCancel as return () where+ spv pool = do+ -- Get our bloom filter+ (bloom, elems, _) <- runDBPool getBloomFilter pool+ startSPVNode hosts bloom elems -- Setup logging monads- run = runResourceT . runLogging- runLogging = runStdoutLoggingT . filterLogger logFilter+ 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- }+ hosts = map (\x -> PeerHost (btcNodeHost x) (btcNodePort x)) nodes -- Run the merkle syncing thread- runMerkleSync nodeState sem pool = runNodeT nodeState $ do+ runMerkleSync pool notif = 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+ fcM <- fmap (fmap adjustFCTime) $ (`runDBPool` pool) $ do+ (_, h) <- walletBestBlock if h == 0 then firstAddrTime else return Nothing maybe (return ()) (atomicallyNodeT . rescanTs) fcM -- Start the merkle sync- merkleSync sem pool 500+ merkleSync pool 500 notif -- Run a thread that will re-broadcast pending transactions- broadcastPendingTxs nodeState sem pool = runNodeT nodeState $ forever $ do+ broadcastPendingTxs pool = 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)+ broadcastTxs =<< runDBPool (getPendingTxs 0) pool -- 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+ processTx pool notif = awaitForever $ \tx -> lift $ do+ (_, newAddrs) <- runDBPool (importNetTx tx (Just notif)) pool 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+ (bloom, elems, _) <- runDBPool getBloomFilter pool atomicallyNodeT $ sendBloomFilter bloom elems -initDatabase :: Config -> IO (Sem.MSem Int, ConnectionPool)+initDatabase :: (MonadBaseControl IO m, MonadLoggerIO m)+ => Config -> m 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+ flip runDBPool pool $ do _ <- runMigration migrateWallet+ _ <- runMigration migrateHeaderTree initWallet $ configBloomFP cfg -- Return the semaphrone and the connection pool- return (sem, pool)+ return pool merkleSync- :: ( MonadLogger m- , MonadIO m- , MonadBaseControl IO m- , MonadThrow m- , MonadResource m- )- => Sem.MSem Int- -> ConnectionPool- -> Int+ :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m, MonadResource m)+ => ConnectionPool+ -> Word32+ -> TBMChan Notif -> NodeT m ()-merkleSync sem pool bSize = do+merkleSync pool bSize notif = do -- Get our best block- best <- fst <$> runDBPool sem pool getBestBlock+ (hash, _) <- runDBPool walletBestBlock pool $(logDebug) "Starting merkle batch download" -- Wait for a new block or a rescan+ bestM <- runSqlNodeT $ getBlockByHash hash+ let best = fromMaybe (error "Best wallet block not found") bestM (action, source) <- merkleDownload best bSize $(logDebug) "Received a merkle action and source. Processing the source..." @@ -208,12 +221,12 @@ , "new addresses while importing the merkle block." , "Sending our bloom filter." ]- (bloom, elems, _) <- runDBPool sem pool getBloomFilter+ (bloom, elems, _) <- runDBPool getBloomFilter pool 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+ rescan <- 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@@ -224,7 +237,7 @@ -- Did we receive all the merkles that we asked for ? let missing = (headerHash <$> lastMerkleM) /=- Just (nodeBlockHash $ last $ actionNodes action)+ Just (nodeHash $ last $ actionNodes action) when missing $ $(logWarn) $ pack $ unwords [ "Merkle block stream closed prematurely"@@ -235,17 +248,17 @@ unless (rescan || missing) $ do $(logDebug) "Importing merkles into the wallet..." -- Confirm the transactions- runDBPool sem pool $ importMerkles action mTxsAcc+ runDBPool (importMerkles action mTxsAcc (Just notif)) pool $(logDebug) "Done importing merkles into the wallet" logBlockChainAction action - merkleSync sem pool newBSize+ merkleSync pool newBSize notif 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+ (_, newAddrs) <- lift $ runDBPool (importNetTx tx Nothing) pool $(logDebug) $ pack $ unwords [ "Generated", show $ length newAddrs , "new addresses while importing tx"@@ -263,43 +276,44 @@ -- prepending new values to it. _ -> return (lastMerkleM, reverse mTxsAcc, aMap) groupByAcc addrs =- let xs = map (\a -> (keyRingAddrAccount a, 1)) addrs+ let xs = map (\a -> (walletAddrAccount 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 ->+ res <- (`runDBPool` pool) $ splitSelect (M.assocs aMap) $ \ks -> from $ \a -> do let andCond (ai, cnt) =- a ^. KeyRingAccountId ==. val ai &&.- a ^. KeyRingAccountGap <=. val cnt+ a ^. AccountId ==. val ai &&.+ a ^. AccountGap <=. val cnt where_ $ join2 $ map andCond ks- return $ a ^. KeyRingAccountId+ return $ a ^. AccountId 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, ")"+ , show $ nodeBlockHeight $ last nodes+ , "(", cs $ blockHashToHex $ nodeHash $ last nodes+ , ")" ] ChainReorg _ o n -> $(logInfo) $ pack $ unlines $ [ "Chain reorg." , "Orphaned blocks:" ]- ++ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) o+ ++ map ((" " ++) . cs . blockHashToHex . nodeHash) o ++ [ "New blocks:" ]- ++ map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n+ ++ map ((" " ++) . cs . blockHashToHex . nodeHash) n ++ [ unwords [ "Best merkle chain height"- , show $ nodeHeaderHeight $ last n+ , show $ nodeBlockHeight $ last n ] ] SideChain n -> $(logWarn) $ pack $ unlines $ "Side chain:" :- map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n+ map ((" " ++) . cs . blockHashToHex . nodeHash) n KnownChain n -> $(logWarn) $ pack $ unlines $ "Known chain:" :- map ((" " ++) . cs . blockHashToHex . nodeBlockHash) n+ map ((" " ++) . cs . blockHashToHex . nodeHash) n maybeDetach :: Config -> IO () -> IO () maybeDetach cfg action =@@ -316,63 +330,131 @@ -- Run the main ZeroMQ loop -- TODO: Support concurrent requests using DEALER socket when we can do -- concurrent MySQL requests.-runWalletApp :: ( MonadIO m- , MonadLogger m+runWalletApp :: ( MonadLoggerIO m , MonadBaseControl IO m , MonadBase IO m , MonadThrow m , MonadResource m ) => HandlerSession -> m ()-runWalletApp session =+runWalletApp session = do+ na <- async $ liftBaseOpDiscard withContext $ \ctx ->+ liftBaseOpDiscard (withSocket ctx Pub) $ \sock -> do+ liftIO $ setLinger (restrict (0 :: Int)) sock+ setupCrypto ctx sock+ liftIO $ bind sock $ configBindNotif $ handlerConfig session+ forever $ do+ xM <- liftIO $ atomically $ readTBMChan $ handlerNotifChan session+ forM_ xM $ \x ->+ let (typ, pay) = case x of+ NotifBlock _ ->+ ("[block]", cs $ encode x)+ NotifTx JsonTx{..} ->+ ("{" <> cs jsonTxAccount <> "}", cs $ encode x)+ in liftIO $ sendMulti sock $ typ :| [pay]+ link na 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+ liftIO $ setLinger (restrict (0 :: Int)) sock+ setupCrypto ctx sock+ liftIO $ bind sock $ configBind $ handlerConfig session+ forever $ do+ bs <- liftIO $ receive sock+ res <- case decode $ BL.fromStrict bs of+ Just r -> catchErrors $+ runHandler (dispatchRequest r) session+ Nothing -> return $ ResponseError "Could not decode request"+ liftIO $ send sock [] $ BL.toStrict $ encode res where+ setupCrypto :: (MonadLoggerIO m, MonadBaseControl IO m)+ => Context -> Socket a -> m ()+ setupCrypto ctx sock = do+ when (isJust serverKeyM) $ liftIO $ do+ let k = fromJust $ configServerKey $ handlerConfig session+ setCurveServer True sock+ setCurveSecretKey TextFormat k sock+ when (isJust clientKeyPubM) $ do+ k <- z85Decode (fromJust clientKeyPubM)+ void $ async $ runZapAuth ctx k+ cfg = handlerConfig session+ serverKeyM = configServerKey cfg+ clientKeyPubM = configClientKeyPub cfg catchErrors m = catches m- [ E.Handler $ \(WalletException err) ->+ [ E.Handler $ \(WalletException err) -> do+ $(logError) $ pack err return $ ResponseError $ pack err- , E.Handler $ \(ErrorCall err) ->+ , E.Handler $ \(ErrorCall err) -> do+ $(logError) $ pack err return $ ResponseError $ pack err- , E.Handler $ \(SomeException exc) ->+ , E.Handler $ \(SomeException exc) -> do+ $(logError) $ pack $ show exc return $ ResponseError $ pack $ show exc ] -dispatchRequest :: ( MonadLogger m+runZapAuth :: ( MonadLoggerIO m+ , MonadBaseControl IO m+ , MonadBase IO m+ )+ => Context -> ByteString -> m ()+runZapAuth ctx k = do+ $(logDebug) $ "Starting ØMQ authentication thread"+ liftBaseOpDiscard (withSocket ctx Rep) $ \zap -> do+ liftIO $ setLinger (restrict (0 :: Int)) zap+ liftIO $ bind zap "inproc://zeromq.zap.01"+ forever $ do+ buffer <- liftIO $ receiveMulti zap+ let actionE =+ case buffer of+ v:q:_:_:_:m:p:_ -> do+ when (v /= "1.0") $+ Left (q, "500", "Version number not valid")+ when (m /= "CURVE") $+ Left (q, "400", "Mechanism not supported")+ when (p /= k) $+ Left (q, "400", "Invalid client public key")+ return q+ _ -> Left ("", "500", "Malformed request")+ case actionE of+ Right q -> do+ $(logInfo) "Authenticated client successfully"+ liftIO $ sendMulti zap $+ "1.0" :| [q, "200", "OK", "client", ""]+ Left (q, c, m) -> do+ $(logError) $ pack $ unwords+ [ "Failed to authenticate client:" , cs c, cs m ]+ liftIO $ sendMulti zap $+ "1.0" :| [q, c, m, "", ""]+++dispatchRequest :: ( MonadLoggerIO 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+dispatchRequest req = fmap ResponseValid $ case req of+ GetAccountsR p -> getAccountsR p+ PostAccountsR na -> postAccountsR na+ PostAccountRenameR n n' -> postAccountRenameR n n'+ GetAccountR n -> getAccountR n+ PostAccountKeysR n ks -> postAccountKeysR n ks+ PostAccountGapR n g -> postAccountGapR n g+ GetAddressesR n t m o p -> getAddressesR n t m o p+ GetAddressesUnusedR n t p -> getAddressesUnusedR n t p+ GetAddressR n i t m o -> getAddressR n i t m o+ PutAddressR n i t l -> putAddressR n i t l+ PostAddressesR n i t -> postAddressesR n i t+ GetTxsR n p -> getTxsR n p+ GetAddrTxsR n i t p -> getAddrTxsR n i t p+ PostTxsR n k a -> postTxsR n k a+ GetTxR n h -> getTxR n h+ GetOfflineTxR n h -> getOfflineTxR n h+ PostOfflineTxR n k t c -> postOfflineTxR n k t c+ GetBalanceR n mc o -> getBalanceR n mc o PostNodeR na -> postNodeR na-+ DeleteTxIdR t -> deleteTxIdR t+ GetSyncR a n b -> getSyncR a (Right n) b+ GetSyncHeightR a n b -> getSyncR a (Left n) b+ GetPendingR a p -> getPendingR a p+ GetDeadR a p -> getDeadR a p
Network/Haskoin/Wallet/Server/Handler.hs view
@@ -1,71 +1,68 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} 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+import Control.Arrow (first)+import Control.Concurrent.STM.TBMChan (TBMChan)+import Control.Exception (SomeException (..),+ tryJust)+import Control.Monad (liftM, unless, when)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Logger (MonadLoggerIO, logError,+ logInfo)+import Control.Monad.Reader (ReaderT, asks, runReaderT)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Resource (MonadResource)+import Data.Aeson (Value (..), toJSON)+import qualified Data.Map.Strict as M (elems, fromList,+ intersectionWith)+import Data.String.Conversions (cs)+import Data.Text (Text, pack, unpack)+import Data.Word (Word32)+import Database.Esqueleto (Entity (..), SqlPersistT)+import Database.Persist.Sql (ConnectionPool,+ SqlPersistM,+ runSqlPersistMPool,+ runSqlPool)+import Network.Haskoin.Block+import Network.Haskoin.Crypto+import Network.Haskoin.Node.BlockChain+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.Peer+import Network.Haskoin.Node.STM+import Network.Haskoin.Transaction+import Network.Haskoin.Wallet.Accounts+import Network.Haskoin.Wallet.Block+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Settings+import Network.Haskoin.Wallet.Transaction+import Network.Haskoin.Wallet.Types -type Handler m = S.StateT HandlerSession m+type Handler m = ReaderT HandlerSession m data HandlerSession = HandlerSession { handlerConfig :: !Config , handlerPool :: !ConnectionPool , handlerNodeState :: !(Maybe SharedNodeState)- , handlerSem :: !(Sem.MSem Int)+ , handlerNotifChan :: !(TBMChan Notif) } -runHandler :: Monad m => HandlerSession -> Handler m a -> m a-runHandler = flip S.evalStateT+runHandler :: Monad m => Handler m a -> HandlerSession -> m a+runHandler = runReaderT 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+runDB action = asks handlerPool >>= lift . runDBPool 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+runDBPool :: MonadBaseControl IO m => SqlPersistT m a -> ConnectionPool -> m a+runDBPool = runSqlPool -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+tryDBPool :: MonadLoggerIO m => ConnectionPool -> SqlPersistM a -> m (Maybe a)+tryDBPool pool action = do+ resE <- liftIO $ tryJust f $ runSqlPersistMPool action pool case resE of Right res -> return $ Just res Left err -> do@@ -76,386 +73,308 @@ runNode :: MonadIO m => NodeT m a -> Handler m a runNode action = do- nodeStateM <- S.gets handlerNodeState+ nodeStateM <- asks handlerNodeState case nodeStateM of- Just nodeState -> lift $ runNodeT nodeState action+ Just nodeState -> lift $ runNodeT action nodeState _ -> 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+getAccountsR :: ( MonadLoggerIO 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- }+ => ListRequest+ -> Handler m (Maybe Value)+getAccountsR lq@ListRequest{..} = do+ $(logInfo) $ format $ unlines+ [ "GetAccountsR"+ , " Offset : " ++ show listOffset+ , " Limit : " ++ show listLimit+ , " Reversed : " ++ show listReverse+ ]+ (accs, cnt) <- runDB $ accounts lq+ return $ Just $ toJSON $ ListResult (map (toJsonAccount Nothing) accs) cnt postAccountsR- :: ( MonadResource m, MonadThrow m, MonadLogger m- , MonadBaseControl IO m, MonadIO m- )- => KeyRingName -> NewAccount -> Handler m (Maybe Value)-postAccountsR keyRingName NewAccount{..} = do+ :: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)+ => NewAccount -> Handler m (Maybe Value)+postAccountsR newAcc@NewAccount{..} = do $(logInfo) $ format $ unlines [ "PostAccountsR"- , " KeyRing name: " ++ unpack keyRingName+ , " Account name: " ++ unpack newAccountName , " 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)+ (Entity _ newAcc', mnemonicM) <- runDB $ newAccount 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- }+ whenOnline $ when (isCompleteAccount newAcc') updateNodeFilter+ return $ Just $ toJSON $ toJsonAccount mnemonicM newAcc' -getAccountR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName -> Handler m (Maybe Value)-getAccountR keyRingName name = do+postAccountRenameR+ :: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)+ => AccountName -> AccountName -> Handler m (Maybe Value)+postAccountRenameR oldName newName = do $(logInfo) $ format $ unlines+ [ "PostAccountRenameR"+ , " Account name: " ++ unpack oldName+ , " New name : " ++ unpack newName+ ]+ newAcc <- runDB $ do+ accE <- getAccount oldName+ renameAccount accE newName+ return $ Just $ toJSON $ toJsonAccount Nothing newAcc++getAccountR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> Handler m (Maybe Value)+getAccountR 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- }+ Entity _ acc <- runDB $ getAccount name+ return $ Just $ toJSON $ toJsonAccount Nothing 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+ :: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)+ => AccountName -> [XPubKey] -> Handler m (Maybe Value)+postAccountKeysR 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)+ newAcc <- runDB $ do+ accE <- getAccount name+ addAccountKeys accE keys -- 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- }+ return $ Just $ toJSON $ toJsonAccount Nothing newAcc -postAccountGapR :: ( MonadLogger m+postAccountGapR :: ( MonadLoggerIO m , MonadBaseControl IO m , MonadBase IO m- , MonadIO m , MonadThrow m , MonadResource m )- => KeyRingName -> AccountName -> SetAccountGap+ => AccountName -> SetAccountGap -> Handler m (Maybe Value)-postAccountGapR keyRingName name (SetAccountGap gap) = do+postAccountGapR 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)+ Entity _ newAcc <- runDB $ do+ accE <- getAccount name+ setAccountGap accE gap -- Update the bloom filter whenOnline updateNodeFilter- return $ Just $ toJSON JsonWithKeyRing- { withKeyRingKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withKeyRingData = toJsonAccount newAcc- }+ return $ Just $ toJSON $ toJsonAccount Nothing newAcc -getAddressesR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName- -> AccountName+getAddressesR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> AddressType -> Word32 -> Bool- -> PageRequest+ -> ListRequest -> Handler m (Maybe Value)-getAddressesR keyRingName name addrType minConf offline page = do+getAddressesR name addrType minConf offline listReq = 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)+ , " Start index : " ++ show (listOffset listReq)+ , " Reversed : " ++ show (listReverse listReq) , " 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+ (res, bals, cnt) <- runDB $ do+ accE <- getAccount name+ (res, cnt) <- addressList accE addrType listReq case res of- [] -> return (keyRing, acc, res, [], maxPage)+ [] -> return (res, [], cnt) _ -> do- let is = map keyRingAddrIndex res+ let is = map walletAddrIndex res (iMin, iMax) = (minimum is, maximum is) bals <- addressBalances accE iMin iMax addrType minConf offline- return (keyRing, acc, res, bals, maxPage)+ return (res, bals, cnt) -- 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- }+ return $ Just $ toJSON $ ListResult addrBals cnt where joinAddrs addrs bals =- let f addr = (keyRingAddrIndex addr, addr)+ let f addr = (walletAddrIndex 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+getAddressesUnusedR+ :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> AddressType -> ListRequest -> Handler m (Maybe Value)+getAddressesUnusedR name addrType lq@ListRequest{..} = do $(logInfo) $ format $ unlines [ "GetAddressesUnusedR"- , " KeyRing name: " ++ unpack keyRingName , " Account name: " ++ unpack name , " Address type: " ++ show addrType+ , " Offset : " ++ show listOffset+ , " Limit : " ++ show listLimit+ , " Reversed : " ++ show listReverse ] - (keyRing, acc, addrs) <- runDB $ do- (keyRing, accE@(Entity _ acc)) <- getAccount keyRingName name- addrs <- unusedAddresses accE addrType- return (keyRing, acc, addrs)+ (addrs, cnt) <- runDB $ do+ accE <- getAccount name+ unusedAddresses accE addrType lq - return $ Just $ toJSON JsonWithAccount- { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withAccountAccount = toJsonAccount acc- , withAccountData = map (`toJsonAddr` Nothing) addrs- }+ return $ Just $ toJSON $ ListResult (map (`toJsonAddr` Nothing) addrs) cnt -getAddressR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName -> KeyIndex -> AddressType+getAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> KeyIndex -> AddressType -> Word32 -> Bool -> Handler m (Maybe Value)-getAddressR keyRingName name i addrType minConf offline = do+getAddressR 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+ (addr, balM) <- runDB $ do+ accE <- getAccount 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- }+ ((_,bal):_) -> (entityVal addrE, Just bal)+ _ -> (entityVal addrE, Nothing)+ return $ Just $ toJSON $ toJsonAddr addr balM -putAddressR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName- -> AccountName+putAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> KeyIndex -> AddressType -> AddressLabel -> Handler m (Maybe Value)-putAddressR keyRingName name i addrType (AddressLabel label) = do+putAddressR 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)+ newAddr <- runDB $ do+ accE <- getAccount name+ setAddrLabel accE i addrType label - return $ Just $ toJSON JsonWithAccount- { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withAccountAccount = toJsonAccount acc- , withAccountData = toJsonAddr newAddr Nothing- }+ return $ Just $ toJSON $ toJsonAddr newAddr Nothing -postAddressesR :: ( MonadLogger m+postAddressesR :: ( MonadLoggerIO m , MonadBaseControl IO m- , MonadIO m , MonadThrow m , MonadBase IO m , MonadResource m )- => KeyRingName- -> AccountName+ => AccountName -> KeyIndex -> AddressType -> Handler m (Maybe Value)-postAddressesR keyRingName name i addrType = do+postAddressesR 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)+ cnt <- runDB $ do+ accE <- getAccount name+ generateAddrs accE addrType i -- Update the bloom filter whenOnline updateNodeFilter - return $ Just $ toJSON JsonWithAccount- { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withAccountAccount = toJsonAccount acc- , withAccountData = cnt- }+ return $ Just $ toJSON cnt -getTxsR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName -> PageRequest -> Handler m (Maybe Value)-getTxsR keyRingName name page = do+getTxs :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName+ -> ListRequest+ -> String+ -> (AccountId -> ListRequest -> SqlPersistT m ([WalletTx], Word32))+ -> Handler m (Maybe Value)+getTxs name lq@ListRequest{..} cmd f = do $(logInfo) $ format $ unlines- [ "GetTxsR"- , " KeyRing name: " ++ unpack keyRingName+ [ cmd , " Account name: " ++ unpack name- , " Page number : " ++ show (pageNum page)- , " Page size : " ++ show (pageLen page)- , " Page reverse: " ++ show (pageReverse page)+ , " Offset : " ++ show listOffset+ , " Limit : " ++ show listLimit+ , " Reversed : " ++ show listReverse ] - (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)+ (res, cnt, bb) <- runDB $ do+ Entity ai _ <- getAccount name+ bb <- walletBestBlock+ (res, cnt) <- f ai lq+ return (res, cnt, bb) - return $ Just $ toJSON JsonWithAccount- { withAccountKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withAccountAccount = toJsonAccount acc- , withAccountData =- PageRes (map (`toJsonTx` Just height) res) maxPage- }+ return $ Just $ toJSON $ ListResult (map (g bb) res) cnt+ where+ g bb = toJsonTx name (Just bb) -getAddrTxsR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName- -> KeyIndex -> AddressType -> PageRequest+getTxsR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> ListRequest -> Handler m (Maybe Value)+getTxsR name lq = getTxs name lq "GetTxsR" (txs Nothing)++getPendingR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> ListRequest -> Handler m (Maybe Value)+getPendingR name lq = getTxs name lq "GetPendingR" (txs (Just TxPending))++getDeadR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> ListRequest -> Handler m (Maybe Value)+getDeadR name lq = getTxs name lq "GetDeadR" (txs (Just TxDead))++getAddrTxsR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> KeyIndex -> AddressType -> ListRequest -> Handler m (Maybe Value)-getAddrTxsR keyRingName name index addrType page = do+getAddrTxsR name index addrType lq@ListRequest{..} = 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)+ , " Offset : " ++ show listOffset+ , " Limit : " ++ show listLimit+ , " Reversed : " ++ show listReverse ] - (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)+ (res, cnt, bb) <- runDB $ do+ accE <- getAccount name+ addrE <- getAddress accE addrType index+ bb <- walletBestBlock+ (res, cnt) <- addrTxs accE addrE lq+ return (res, cnt, bb) - return $ Just $ toJSON JsonWithAddr- { withAddrKeyRing = toJsonKeyRing keyRing Nothing Nothing- , withAddrAccount = toJsonAccount acc- , withAddrAddress = toJsonAddr addr Nothing- , withAddrData = PageRes (map (f height) res) maxPage- }+ return $ Just $ toJSON $ ListResult (map (f bb) res) cnt where- f height (tx, bal) = AddrTx (toJsonTx tx (Just height)) bal+ f bb = toJsonTx name (Just bb) -postTxsR :: ( MonadLogger m, MonadBaseControl IO m, MonadBase IO m- , MonadIO m, MonadThrow m, MonadResource m+postTxsR :: ( MonadLoggerIO m, MonadBaseControl IO m, MonadBase IO 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)+ => AccountName -> Maybe XPrvKey -> TxAction -> Handler m (Maybe Value)+postTxsR name masterM action = do+ (accE@(Entity ai _), bb) <- runDB $ do+ accE <- getAccount name+ bb <- walletBestBlock+ return (accE, bb) + notif <- asks handlerNotifChan (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@@ -463,124 +382,116 @@ , " Rcpt. Fee : " ++ show rcptFee , " Sign : " ++ show sign ]- runDB $ createTx keyRing accE rs fee minconf rcptFee sign+ runDB $ createTx+ accE (Just notif) masterM 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))+ , " TxId : " ++ cs (txHashToHex (txHash tx)) ] runDB $ do- (res, newAddrs) <- importTx tx ai- case filter ((== ai) . keyRingTxAccount) res of+ (res, newAddrs) <- importTx tx (Just notif) ai+ case filter ((== ai) . walletTxAccount) res of (txRes:_) -> return (txRes, newAddrs)- _ -> liftIO . throwIO $ WalletException+ _ -> throwM $ 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)+ , " TxId : " ++ cs (txHashToHex txid) ] runDB $ do- (res, newAddrs) <- signKeyRingTx keyRing accE txid- case filter ((== ai) . keyRingTxAccount) res of+ (res, newAddrs) <- signAccountTx accE (Just notif) masterM txid+ case filter ((== ai) . walletTxAccount) res of (txRes:_) -> return (txRes, newAddrs)- _ -> liftIO . throwIO $ WalletException+ _ -> throwM $ 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)- }+ when (walletTxConfidence txRes == TxPending) $+ runNode $ broadcastTxs [walletTxHash txRes]+ return $ Just $ toJSON $ toJsonTx name (Just bb) txRes -getTxR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName -> TxHash -> Handler m (Maybe Value)-getTxR keyRingName name txid = do+getTxR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> TxHash -> Handler m (Maybe Value)+getTxR name txid = do $(logInfo) $ format $ unlines [ "GetTxR"- , " KeyRing name: " ++ unpack keyRingName , " Account name: " ++ unpack name- , " Txid : " ++ cs (txHashToHex txid)+ , " TxId : " ++ cs (txHashToHex txid) ]- (keyRing, acc, res, height) <- runDB $ do- (keyRing, Entity ai acc) <- getAccount keyRingName name- (_, height) <- getBestBlock+ (res, bb) <- runDB $ do+ Entity ai _ <- getAccount name+ bb <- walletBestBlock 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)- }+ return (res, bb)+ return $ Just $ toJSON $ toJsonTx name (Just bb) res -getBalanceR :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)- => KeyRingName -> AccountName -> Word32 -> Bool+deleteTxIdR :: (MonadLoggerIO m, MonadThrow m, MonadBaseControl IO m)+ => TxHash -> Handler m (Maybe Value)+deleteTxIdR txid = do+ $(logInfo) $ format $ unlines+ [ "DeleteTxR"+ , " TxId: " ++ cs (txHashToHex txid)+ ]+ runDB $ deleteTx txid+ return Nothing++getBalanceR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName -> Word32 -> Bool -> Handler m (Maybe Value)-getBalanceR keyRingName name minconf offline = do+getBalanceR 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- }+ bal <- runDB $ do+ Entity ai _ <- getAccount name+ accountBalance ai minconf offline+ return $ Just $ toJSON bal -getOfflineTxR :: ( MonadLogger m, MonadIO m, MonadBaseControl IO m+getOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m , MonadBase IO m, MonadThrow m, MonadResource m )- => KeyRingName -> AccountName -> TxHash -> Handler m (Maybe Value)-getOfflineTxR keyRingName accountName txid = do+ => AccountName -> TxHash -> Handler m (Maybe Value)+getOfflineTxR accountName txid = do $(logInfo) $ format $ unlines [ "GetOfflineTxR"- , " KeyRing name: " ++ unpack keyRingName , " Account name: " ++ unpack accountName- , " Txid : " ++ cs (txHashToHex txid)+ , " TxId : " ++ cs (txHashToHex txid) ] (dat, _) <- runDB $ do- (_, Entity ai _) <- getAccount keyRingName accountName+ Entity ai _ <- getAccount accountName getOfflineTxData ai txid return $ Just $ toJSON dat -postOfflineTxR :: ( MonadLogger m, MonadIO m, MonadBaseControl IO m+postOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m , MonadBase IO m, MonadThrow m, MonadResource m )- => KeyRingName- -> AccountName+ => AccountName+ -> Maybe XPrvKey -> Tx -> [CoinSignData] -> Handler m (Maybe Value)-postOfflineTxR keyRingName accountName tx signData = do+postOfflineTxR accountName masterM tx signData = do $(logInfo) $ format $ unlines [ "PostTxsR SignOfflineTx"- , " KeyRing name: " ++ unpack keyRingName , " Account name: " ++ unpack accountName- , " Txid : " ++ cs (txHashToHex (txHash tx))+ , " TxId : " ++ cs (txHashToHex (txHash tx)) ]- (keyRing, Entity _ acc) <- runDB $ getAccount keyRingName accountName- let signedTx = signOfflineTx keyRing acc tx signData+ Entity _ acc <- runDB $ getAccount accountName+ let signedTx = signOfflineTx acc masterM 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)+postNodeR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) => NodeAction -> Handler m (Maybe Value) postNodeR action = case action of NodeActionRescan tM -> do@@ -601,18 +512,53 @@ status <- runNode $ atomicallyNodeT nodeStatus return $ Just $ toJSON status where- err = liftIO . throwIO $ WalletException+ err = throwM $ WalletException "No keys have been generated in the wallet" +getSyncR :: (MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)+ => AccountName+ -> Either BlockHeight BlockHash+ -> ListRequest+ -> Handler m (Maybe Value)+getSyncR acc blockE lq@ListRequest{..} = runDB $ do+ $(logInfo) $ format $ unlines+ [ "GetSyncR"+ , " Account name: " ++ cs acc+ , " Block : " ++ showBlock+ , " Offset : " ++ show listOffset+ , " Limit : " ++ show listLimit+ , " Reversed : " ++ show listReverse+ ]+ ListResult nodes cnt <- mainChain blockE lq+ case nodes of+ [] -> return $ Just $ toJSON $ ListResult ([] :: [()]) cnt+ b:_ -> do+ Entity ai _ <- getAccount acc+ ts <- accTxsFromBlock ai (nodeBlockHeight b)+ (fromIntegral $ length nodes)+ let bts = blockTxs nodes ts+ return $ Just $ toJSON $ ListResult (map f bts) cnt+ where+ f (block, txs') = JsonSyncBlock+ { jsonSyncBlockHash = nodeHash block+ , jsonSyncBlockHeight = nodeBlockHeight block+ , jsonSyncBlockPrev = nodePrev block+ , jsonSyncBlockTxs = map (toJsonTx acc Nothing) txs'+ }+ showBlock = case blockE of+ Left e -> show e+ Right b -> cs $ blockHashToHex b+ {- Helpers -} whenOnline :: Monad m => Handler m () -> Handler m () whenOnline handler = do- mode <- configMode `liftM` S.gets handlerConfig+ mode <- configMode `liftM` asks handlerConfig when (mode == SPVOnline) handler -updateNodeFilter :: (MonadBaseControl IO m, MonadIO m, MonadLogger m)- => Handler m ()+updateNodeFilter+ :: (MonadBaseControl IO m, MonadLoggerIO m, MonadThrow m)+ => Handler m () updateNodeFilter = do $(logInfo) $ format "Sending a new bloom filter" (bloom, elems, _) <- runDB getBloomFilter
Network/Haskoin/Wallet/Settings.hs view
@@ -4,7 +4,7 @@ , Config(..) ) where -import Control.Monad (forM, mzero)+import Control.Monad (mzero) import Control.Exception (throw) import Control.Monad.Logger (LogLevel(..)) @@ -12,33 +12,37 @@ 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.HashMap.Strict (HashMap, unionWith)+import Data.String.Conversions (cs)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8) import Data.Aeson- ( Value(..)- , FromJSON- , parseJSON- , withObject- , (.:), (.:?), (.!=)+ ( Value(..), FromJSON, ToJSON+ , parseJSON, toJSON, withObject+ , (.:) ) +import Network.Haskoin.Crypto import Network.Haskoin.Wallet.Database import Network.Haskoin.Wallet.Types +import Data.Restricted (Restricted, Div5)+import System.ZMQ4 (toRestricted)+ data SPVMode = SPVOnline | SPVOffline deriving (Eq, Show, Read) +newtype LogLevelJSON = LogLevelJSON LogLevel+ deriving (Eq, Show, Read)+ data OutputFormat = OutputNormal | OutputJSON | OutputYAML data Config = Config- { configKeyRing :: !T.Text- -- ^ Keyring to use in commands- , configCount :: !Word32+ { configCount :: !Word32 -- ^ Output size of commands , configMinConf :: !Word32 -- ^ Minimum number of confirmations@@ -54,12 +58,14 @@ -- ^ 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)+ , configPath :: !(Maybe HardPath)+ -- ^ Derivation path when creating account , configFormat :: !OutputFormat -- ^ How to format the command-line results , configConnect :: !String -- ^ ZeroMQ socket to connect to (location of the server)+ , configConnectNotif :: !String+ -- ^ ZeroMQ socket to connect for notifications , configDetach :: !Bool -- ^ Detach server when launched from command-line , configFile :: !FilePath@@ -69,14 +75,16 @@ , configDir :: !FilePath -- ^ Working directory , configBind :: !String- -- ^ Bind address for the zeromq socket- , configBTCNodes :: !(HashMap T.Text [(String, Int)])+ -- ^ Bind address for the ZeroMQ socket+ , configBindNotif :: !String+ -- ^ Bind address for ZeroMQ notifications+ , configBTCNodes :: !(HashMap Text [BTCNode]) -- ^ 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)+ , configDatabase :: !(HashMap Text DatabaseConfType) -- ^ Database configuration , configLogFile :: !FilePath -- ^ Log file@@ -86,88 +94,103 @@ -- ^ Log level , configVerbose :: !Bool -- ^ Verbose+ , configServerKey :: !(Maybe (Restricted Div5 ByteString))+ -- ^ Server key for authentication and encryption (server config)+ , configServerKeyPub :: !(Maybe (Restricted Div5 ByteString))+ -- ^ Server public key for authentication and encryption (client config)+ , configClientKey :: !(Maybe (Restricted Div5 ByteString))+ -- ^ Client key for authentication and encryption (client config)+ , configClientKeyPub :: !(Maybe (Restricted Div5 ByteString))+ -- ^ Client public key for authentication and encryption+ -- (client + server config) } -configBS :: BS.ByteString+configBS :: ByteString configBS = $(embedFile "config/config.yml") +instance ToJSON OutputFormat where+ toJSON OutputNormal = String "normal"+ toJSON OutputJSON = String "json"+ toJSON OutputYAML = String "yaml"++instance FromJSON OutputFormat where+ parseJSON (String "normal") = return OutputNormal+ parseJSON (String "json") = return OutputJSON+ parseJSON (String "yaml") = return OutputYAML+ parseJSON _ = mzero++instance ToJSON SPVMode where+ toJSON SPVOnline = String "online"+ toJSON SPVOffline = String "offline"++instance FromJSON SPVMode where+ parseJSON (String "online") = return SPVOnline+ parseJSON (String "offline") = return SPVOffline+ parseJSON _ = mzero++instance ToJSON LogLevelJSON where+ toJSON (LogLevelJSON LevelDebug) = String "debug"+ toJSON (LogLevelJSON LevelInfo) = String "info"+ toJSON (LogLevelJSON LevelWarn) = String "warn"+ toJSON (LogLevelJSON LevelError) = String "error"+ toJSON (LogLevelJSON (LevelOther t)) = String t++instance FromJSON LogLevelJSON where+ parseJSON (String "debug") = return $ LogLevelJSON LevelDebug+ parseJSON (String "info") = return $ LogLevelJSON LevelInfo+ parseJSON (String "warn") = return $ LogLevelJSON LevelWarn+ parseJSON (String "error") = return $ LogLevelJSON LevelError+ parseJSON (String x) = return $ LogLevelJSON (LevelOther x)+ parseJSON _ = mzero+ instance Default Config where- def = either throw id $ decodeEither' configBS+ def = either throw id $ decodeEither' "{}" 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+ parseJSON = withObject "config" $ \o' -> do+ let defValue = either throw id $ decodeEither' configBS+ (Object o) = mergeValues defValue (Object o')+ configPath = Nothing+ configFile <- o .: "config-file"+ configRcptFee <- o .: "recipient-fee"+ configCount <- o .: "output-size"+ configMinConf <- o .: "minimum-confirmations"+ configSignTx <- o .: "sign-transactions"+ configFee <- o .: "transaction-fee"+ configAddrType <- o .: "address-type"+ configOffline <- o .: "offline"+ configReversePaging <- o .: "reverse-paging"+ configFormat <- o .: "display-format"+ configConnect <- o .: "connect-uri"+ configConnectNotif <- o .: "connect-uri-notif"+ configDetach <- o .: "detach-server"+ configTestnet <- o .: "use-testnet"+ configDir <- o .: "work-dir"+ configBind <- o .: "bind-socket"+ configBindNotif <- o .: "bind-socket-notif"+ configBTCNodes <- o .: "bitcoin-full-nodes"+ configMode <- o .: "server-mode"+ configBloomFP <- o .: "bloom-false-positive"+ configLogFile <- o .: "log-file"+ configPidFile <- o .: "pid-file"+ LogLevelJSON configLogLevel <- o .: "log-level"+ configVerbose <- o .: "verbose"+ configDatabase <- o .: "database"+ configServerKey <- getKey o "server-key"+ configServerKeyPub <- getKey o "server-key-public"+ configClientKey <- getKey o "client-key"+ configClientKeyPub <- getKey o "client-key-public" 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+ getKey o i = o .: i >>= \kM ->+ case kM of+ Nothing -> return Nothing+ Just k ->+ case toRestricted $ encodeUtf8 k of+ Just k' -> return $ Just k'+ Nothing -> fail $ "Invalid " ++ cs k ++mergeValues :: Value -> Value -> Value+mergeValues (Object d) (Object c) = Object (unionWith mergeValues d c)+mergeValues _ c = c
Network/Haskoin/Wallet/Transaction.hs view
@@ -1,1306 +1,1356 @@-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+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Haskoin.Wallet.Transaction+(+-- *Database transactions+ txs+, addrTxs+, accTxsFromBlock+, getTx+, getAccountTx+, importTx+, importNetTx+, signAccountTx+, createTx+, signOfflineTx+, getOfflineTxData+, killTxs+, reviveTx+, getPendingTxs+, deleteTx++-- *Database blocks+, importMerkles+, walletBestBlock++-- *Database coins and balances+, spendableCoins+, accountBalance+, addressBalances++-- *Rescan+, resetRescan++-- *Helpers+, InCoinData(..)+) where++import Control.Arrow (second)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TBMChan (TBMChan, writeTBMChan)+import Control.Exception (throw, throwIO)+import Control.Monad (forM, forM_, unless, when)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Trans.Resource (MonadResource)+import Data.Either (rights)+import Data.List (find, nub, nubBy, (\\))+import qualified Data.Map.Strict as M (Map, fromListWith, map,+ toList, unionWith)+import Data.Maybe (fromMaybe, isJust, isNothing,+ listToMaybe, mapMaybe)+import Data.String.Conversions (cs)+import Data.Time (UTCTime, getCurrentTime)+import Data.Word (Word32, Word64)+import Database.Esqueleto (Entity (..), InnerJoin (..),+ LeftOuterJoin (..), OrderBy,+ SqlExpr, SqlPersistT,+ SqlQuery, Value (..), asc,+ case_, coalesceDefault, count,+ countDistinct, countRows,+ delete, desc, distinct, else_,+ from, get, getBy, groupBy,+ in_, just, limit, not_, on,+ orderBy, replace, select, set,+ sub_select, sum_, then_,+ unValue, update, val, valList,+ when_, where_, (!=.), (&&.),+ (-.), (<.), (<=.), (=.),+ (==.), (>=.), (?.), (^.),+ (||.))+import qualified Database.Esqueleto as E (isNothing)+import qualified Database.Persist as P (Filter, deleteWhere,+ insertBy, selectFirst)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Crypto+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.STM+import Network.Haskoin.Script+import Network.Haskoin.Transaction+import Network.Haskoin.Util+import Network.Haskoin.Wallet.Accounts+import Network.Haskoin.Wallet.Model+import Network.Haskoin.Wallet.Types++-- Input coin type with transaction and address information+data InCoinData = InCoinData+ { inCoinDataCoin :: !(Entity WalletCoin)+ , inCoinDataTx :: !WalletTx+ , inCoinDataAddr :: !WalletAddr+ }++instance Coin InCoinData where+ coinValue (InCoinData (Entity _ c) _ _) = walletCoinValue c++-- Output coin type with address information+data OutCoinData = OutCoinData+ { outCoinDataAddr :: !(Entity WalletAddr)+ , outCoinDataPos :: !KeyIndex+ , outCoinDataValue :: !Word64+ , outCoinDataScript :: !ScriptOutput+ }++{- List transactions -}++-- | Get transactions.+txs :: MonadIO m+ => Maybe TxConfidence+ -> AccountId -- ^ Account ID+ -> ListRequest -- ^ List request+ -> SqlPersistT m ([WalletTx], Word32)+ -- ^ List result+txs conf ai ListRequest{..} = do+ [cnt] <- fmap (map unValue) $ select $ from $ \t -> do+ cond t+ return countRows+ when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException+ "Offset beyond end of data set"+ res <- fmap (map entityVal) $ select $ from $ \t -> do+ cond t+ orderBy [ order (t ^. WalletTxId) ]+ limitOffset listLimit listOffset+ return t+ return (res, cnt)+ where+ account t = t ^. WalletTxAccount ==. val ai+ cond t = where_ $ case conf of+ Just n -> account t &&. t ^. WalletTxConfidence ==. val n+ Nothing -> account t+ order = if listReverse then asc else desc++{- List transactions for an account and address -}++addrTxs :: MonadIO m+ => Entity Account -- ^ Account entity+ -> Entity WalletAddr -- ^ Address entity+ -> ListRequest -- ^ List request+ -> SqlPersistT m ([WalletTx], Word32)+addrTxs (Entity ai _) (Entity addrI WalletAddr{..}) ListRequest{..} = do+ let joinSpentCoin c2 s =+ c2 ?. WalletCoinAccount ==. s ?. SpentCoinAccount+ &&. c2 ?. WalletCoinHash ==. s ?. SpentCoinHash+ &&. c2 ?. WalletCoinPos ==. s ?. SpentCoinPos+ &&. c2 ?. WalletCoinAddr ==. just (val addrI)+ joinSpent s t =+ s ?. SpentCoinSpendingTx ==. just (t ^. WalletTxId)+ joinCoin c t =+ c ?. WalletCoinTx ==. just (t ^. WalletTxId)+ &&. c ?. WalletCoinAddr ==. just (val addrI)+ joinAll t c c2 s = do+ on $ joinSpentCoin c2 s+ on $ joinSpent s t+ on $ joinCoin c t+ tables f = from $ \(t `LeftOuterJoin` c `LeftOuterJoin`+ s `LeftOuterJoin` c2) -> f t c s c2+ query t c s c2 = do+ joinAll t c c2 s+ where_ ( t ^. WalletTxAccount ==. val ai+ &&. ( not_ (E.isNothing (c ?. WalletCoinId))+ ||. not_ (E.isNothing (c2 ?. WalletCoinId))+ )+ )+ let order = if listReverse then asc else desc+ orderBy [ order (t ^. WalletTxId) ]+++ cntRes <- select $ tables $ \t c s c2 -> do+ query t c s c2+ return $ countDistinct $ t ^. WalletTxId++ let cnt = maybe 0 unValue $ listToMaybe cntRes++ when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException+ "Offset beyond end of data set"++ res <- select $ distinct $ tables $ \t c s c2 -> do+ query t c s c2+ limitOffset listLimit listOffset+ return t++ return (map (updBals . entityVal) res, cnt)++ where+ agg = sum . mapMaybe addressInfoValue .+ filter ((== walletAddrAddress) . addressInfoAddress)+ updBals t =+ let+ input = agg $ walletTxInputs t+ output = agg $ walletTxOutputs t+ change = agg $ walletTxChange t+ in+ t { walletTxInValue = output + change+ , walletTxOutValue = input+ }++accTxsFromBlock :: (MonadIO m, MonadThrow m)+ => AccountId+ -> BlockHeight+ -> Word32 -- ^ Block count (0 for all)+ -> SqlPersistT m [WalletTx]+accTxsFromBlock ai bh n =+ fmap (map entityVal) $ select $ from $ \t -> do+ query t+ orderBy [ asc (t ^. WalletTxConfirmedHeight), asc (t ^. WalletTxId) ]+ return t+ where+ query t+ | n == 0 = where_ $+ t ^. WalletTxAccount ==. val ai &&.+ t ^. WalletTxConfirmedHeight >=. just (val bh)+ | otherwise = where_ $+ t ^. WalletTxAccount ==. val ai &&.+ t ^. WalletTxConfirmedHeight >=. just (val bh) &&.+ t ^. WalletTxConfirmedHeight <. just (val $ bh + n)++-- 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 =+ fmap (listToMaybe . map unValue) $ select $ from $ \t -> do+ where_ $ t ^. WalletTxHash ==. val txid+ limit 1+ return $ t ^. WalletTxTx++getAccountTx :: MonadIO m+ => AccountId -> TxHash -> SqlPersistT m WalletTx+getAccountTx ai txid = do+ res <- select $ from $ \t -> do+ where_ ( t ^. WalletTxAccount ==. val ai+ &&. t ^. WalletTxHash ==. 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 =+ fmap (map unValue) $ select $ from $ \t -> do+ where_ $ t ^. WalletTxConfidence ==. val TxPending+ when (i > 0) $ limit $ fromIntegral i+ return $ t ^. WalletTxHash++{- 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+ -> Maybe (TBMChan Notif)+ -> AccountId -- ^ Account ID+ -> SqlPersistT m ([WalletTx], [WalletAddr])+ -- ^ New transactions and addresses created+importTx tx notifChanM ai =+ importTx' tx notifChanM ai =<< getInCoins tx (Just ai)++importTx' :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Tx -- ^ Transaction to import+ -> Maybe (TBMChan Notif)+ -> AccountId -- ^ Account ID+ -> [InCoinData] -- ^ Input coins+ -> SqlPersistT m ([WalletTx], [WalletAddr])+ -- ^ Transaction hash (after possible merges)+importTx' origTx notifChanM 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 [ WalletTxHash =. val txid+ , WalletTxTx =. val tx+ ]+ where_ ( t ^. WalletTxAccount ==. val ai+ &&. t ^. WalletTxHash ==. val origTxid+ )+ -- Update coins+ update $ \t -> do+ set t [ WalletCoinHash =. val txid ]+ where_ ( t ^. WalletCoinAccount ==. val ai+ &&. t ^. WalletCoinHash ==. val origTxid+ )+ let f (InCoinData c t x) = if walletTxHash t == origTxid+ then InCoinData c+ t{ walletTxHash = txid, walletTxTx = 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 notifChanM+ else importOfflineTx tx notifChanM ai inCoins spendingTxs+ where+ toVerDat (InCoinData (Entity _ c) t _) =+ (walletCoinScript c, OutPoint (walletTxHash t) (walletCoinPos 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+ => AccountId+ -> 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 walletTxConfidence prev of+ TxOffline -> eitherToMaybe $+ mergeTxs [tx, walletTxTx prev] outPoints+ _ -> Nothing+ -- Nothing to merge. Return the original transaction.+ _ -> Nothing+ where+ buildOutpoint c t = OutPoint (walletTxHash t) (walletCoinPos c)+ f (InCoinData (Entity _ c) t _) = (walletCoinScript 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+ -> Maybe (TBMChan Notif)+ -> AccountId+ -> [InCoinData]+ -> [Entity WalletTx]+ -> SqlPersistT m ([WalletTx], [WalletAddr])+importOfflineTx tx notifChanM 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 <- fmap (fmap entityVal) $ getBy $ UniqueAccTx ai txid+ -- Check if we can import the transaction+ unless (canImport $ walletTxConfidence <$> prevM) err+ -- Kill transactions that are spending our coins+ killTxIds notifChanM $ map entityKey spendingTxs+ -- Create all the transaction records for this account.+ -- This will spend the input coins and create the output coins+ txsRes <- buildAccTxs notifChanM 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+ -> Maybe (TBMChan Notif)+ -> SqlPersistT m ([WalletTx], [WalletAddr])+ -- ^ Returns the new transactions and addresses created+importNetTx tx notifChanM = 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 notifChanM $ map entityKey spendingTxs+ -- Create all the transaction records for this account.+ -- This will spend the input coins and create the output coins+ txRes <- buildAccTxs notifChanM tx confidence inCoins outCoins+ -- Use up the addresses of our new coins (replenish gap addresses)+ newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $+ useAddress . entityVal+ forM_ notifChanM $ \notifChan -> forM_ txRes $+ \tx' -> do+ let ai = walletTxAccount tx'+ Account{..} <-+ fromMaybe (error "Velociraptors ate you") <$> get ai+ liftIO $ atomically $ writeTBMChan notifChan $+ NotifTx $ toJsonTx accountName Nothing tx'+ 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 ^. WalletTxNosigHash ==. val nosig+ &&. t ^. WalletTxHash !=. val txid+ )+ return $ t ^. WalletTxHash+ let toUpdate = map unValue res+ unless (null toUpdate) $ do+ splitUpdate toUpdate $ \hs t -> do+ set t [ WalletTxHash =. val txid+ , WalletTxTx =. val tx+ ]+ where_ $ t ^. WalletTxHash `in_` valList hs+ splitUpdate toUpdate $ \hs c -> do+ set c [ WalletCoinHash =. val txid ]+ where_ $ c ^. WalletCoinHash `in_` valList hs++-- Check if the given coins can be spent.+canSpendCoins :: [InCoinData]+ -> [Entity WalletTx]+ -> 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 = walletTxConfidence t /= TxDead+ | otherwise = walletTxConfidence t `elem` [TxPending, TxBuilding]+ -- All transactions spending the same coins as us should be offline+ validSpend = (== TxOffline) . walletTxConfidence . 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 AccountId+ -> SqlPersistT m [InCoinData]+getInCoins tx aiM = do+ res <- splitSelect ops $ \os -> from $ \(c `InnerJoin` t `InnerJoin` x) -> do+ on $ x ^. WalletAddrId ==. c ^. WalletCoinAddr+ on $ t ^. WalletTxId ==. c ^. WalletCoinTx+ where_ $ case aiM of+ Just ai ->+ c ^. WalletCoinAccount ==. 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 ^. WalletCoinHash ==. val h &&.+ c ^. WalletCoinPos ==. 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 AccountId+ -> SqlPersistT m [Entity WalletTx]+getSpendingTxs tx aiM+ | null txInputs = return []+ | otherwise =+ splitSelect txInputs $ \ins -> from $ \(s `InnerJoin` t) -> do+ on $ s ^. SpentCoinSpendingTx ==. t ^. WalletTxId+ -- Filter out the given transaction+ let cond = t ^. WalletTxHash !=. val txid+ -- Limit to only the input coins of the given tx+ &&. limitSpent s ins+ where_ $ case aiM of+ Just ai -> cond &&. s ^. SpentCoinAccount ==. 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 ^. SpentCoinHash ==. val h &&.+ s ^. SpentCoinPos ==. 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 AccountId+ -> 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 ^. WalletAddrAddress `in_` valList as+ where_ $ case aiM of+ Just ai -> cond &&. x ^. WalletAddrAccount ==. 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 == walletAddrAddress 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+ => AccountId+ -> WalletTxId+ -> Tx+ -> SqlPersistT m ()+spendInputs ai ti tx = do+ now <- liftIO getCurrentTime+ -- Spend the coins by inserting values in SpentCoin+ splitInsertMany_ $ map (buildSpentCoin now) txInputs+ where+ txInputs = map prevOutput $ txIn tx+ buildSpentCoin now (OutPoint h p) =+ SpentCoin{ spentCoinAccount = ai+ , spentCoinHash = h+ , spentCoinPos = p+ , spentCoinSpendingTx = ti+ , spentCoinCreated = now+ }++-- Build account transaction for the given input and output coins+buildAccTxs :: MonadIO m+ => Maybe (TBMChan Notif)+ -> Tx+ -> TxConfidence+ -> [InCoinData]+ -> [OutCoinData]+ -> SqlPersistT m [WalletTx]+buildAccTxs notifChanM 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 = walletTxConfidence prev+ newConf | confidence == TxDead = TxDead+ | prevConf == TxBuilding = TxBuilding+ | otherwise = confidence+ -- If the transaction already exists, preserve confirmation data+ let newAtx = atx+ { walletTxConfidence = newConf+ , walletTxConfirmedBy = walletTxConfirmedBy prev+ , walletTxConfirmedHeight = walletTxConfirmedHeight prev+ , walletTxConfirmedDate = walletTxConfirmedDate 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 notifChanM [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) = WalletCoin+ { walletCoinAccount = ai+ , walletCoinHash = txHash tx+ , walletCoinPos = pos+ , walletCoinTx = accTxId+ , walletCoinValue = vl+ , walletCoinScript = so+ , walletCoinAddr = entityKey addrEnt+ , walletCoinCreated = 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+ -> AccountId+ -> [InCoinData]+ -> [OutCoinData]+ -> UTCTime+ -> WalletTx+buildAccTx tx confidence ai inCoins outCoins now = WalletTx+ { walletTxAccount = ai+ , walletTxHash = 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.+ , walletTxNosigHash = nosigTxHash tx+ , walletTxType = txType+ , walletTxInValue = inVal+ , walletTxOutValue = outVal+ , walletTxInputs =+ let f h i (InCoinData (Entity _ c) t _) =+ walletTxHash t == h && walletCoinPos c == i+ toInfo (a, OutPoint h i) = case find (f h i) inCoins of+ Just (InCoinData (Entity _ c) _ _) ->+ AddressInfo a (Just $ walletCoinValue c) True+ _ -> AddressInfo a Nothing False+ in map toInfo allInAddrs+ , walletTxOutputs =+ let toInfo (a,i,v) = AddressInfo a (Just v) $ ours i+ ours i = isJust $ find ((== i) . outCoinDataPos) outCoins+ in map toInfo allOutAddrs \\ changeAddrs+ , walletTxChange = changeAddrs+ , walletTxTx = tx+ , walletTxIsCoinbase = isCoinbaseTx tx+ , walletTxConfidence = confidence+ -- Reuse the confirmation information of the existing transaction if+ -- we have it.+ , walletTxConfirmedBy = Nothing+ , walletTxConfirmedHeight = Nothing+ , walletTxConfirmedDate = Nothing+ , walletTxCreated = 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) . walletAddrType+ . entityVal . outCoinDataAddr+ f = walletAddrAddress . 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 AccountId ([InCoinData], [OutCoinData])+groupCoinsByAccount inCoins outCoins =+ M.unionWith merge inMap outMap+ where+ -- Build a map from accounts -> (inCoins, outCoins)+ f coin@(InCoinData _ t _) = (walletTxAccount t, [coin])+ g coin = (walletAddrAccount $ 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++deleteTx :: (MonadIO m, MonadThrow m) => TxHash -> SqlPersistT m ()+deleteTx txid = do+ ts <- select $ from $ \t -> do+ where_ $ t ^. WalletTxHash ==. val txid+ return t+ case ts of+ [] -> throwM $ WalletException $ unwords+ [ "Cannot delete inexistent transaction"+ , cs (txHashToHex txid)+ ]+ Entity{entityVal = WalletTx{walletTxConfidence = TxBuilding}} : _ ->+ throwM $ WalletException $ unwords+ [ "Cannot delete confirmed transaction"+ , cs (txHashToHex txid)+ ]+ _ -> return ()+ children <- fmap (map unValue) $ select $ from $+ \(t `InnerJoin` c `InnerJoin` s `InnerJoin` t2) -> do+ on $ s ^. SpentCoinSpendingTx ==. t2 ^. WalletTxId+ on ( c ^. WalletCoinAccount ==. t ^. WalletTxAccount+ &&. c ^. WalletCoinHash ==. s ^. SpentCoinHash+ &&. c ^. WalletCoinPos ==. s ^. SpentCoinPos+ )+ on $ c ^. WalletCoinTx ==. t ^. WalletTxId+ where_ $ t ^. WalletTxHash ==. val txid+ return $ t2 ^. WalletTxHash+ forM_ children deleteTx+ forM_ ts $ \Entity{entityKey = ti} ->+ delete $ from $ \s -> where_ $ s ^. SpentCoinSpendingTx ==. val ti+ delete $ from $ \s -> where_ $ s ^. SpentCoinHash ==. val txid+ forM_ ts $ \Entity{entityKey = ti} -> do+ delete $ from $ \c -> where_ $ c ^. WalletCoinTx ==. val ti+ delete $ from $ \t -> where_ $ t ^. WalletTxId ==. val ti++-- Kill transactions and their children by ids.+killTxIds :: MonadIO m+ => Maybe (TBMChan Notif)+ -> [WalletTxId]+ -> SqlPersistT m ()+killTxIds notifChanM txIds = do+ -- Find all the transactions spending the coins of these transactions+ -- (Find all the child transactions)+ children <- splitSelect txIds $ \ts -> from $ \(t `InnerJoin` s) -> do+ on ( s ^. SpentCoinAccount ==. t ^. WalletTxAccount+ &&. s ^. SpentCoinHash ==. t ^. WalletTxHash+ )+ where_ $ t ^. WalletTxId `in_` valList ts+ return $ s ^. SpentCoinSpendingTx++ -- Kill these transactions+ splitUpdate txIds $ \ts t -> do+ set t [ WalletTxConfidence =. val TxDead ]+ where_ $ t ^. WalletTxId `in_` valList ts++ case notifChanM of+ Nothing -> return ()+ Just notifChan -> do+ ts' <- fmap (map entityVal) $+ splitSelect txIds $ \ts -> from $ \t -> do+ where_ $ t ^. WalletTxId `in_` valList ts+ return t+ forM_ ts' $ \tx -> do+ let ai = walletTxAccount tx+ Account{..} <-+ fromMaybe (error "More velociraptors coming") <$> get ai+ liftIO $ atomically $ writeTBMChan notifChan $+ NotifTx $ toJsonTx accountName Nothing tx+++ -- This transaction doesn't spend any coins+ splitDelete txIds $ \ts -> from $ \s ->+ where_ $ s ^. SpentCoinSpendingTx `in_` valList ts++ -- Recursively kill all the child transactions.+ -- (Recurse at the end in case there are closed loops)+ unless (null children) $ killTxIds notifChanM $ nub $ map unValue children++-- Kill transactions and their child transactions by hashes.+killTxs :: MonadIO m+ => Maybe (TBMChan Notif)+ -> [TxHash]+ -> SqlPersistT m ()+killTxs notifChanM txHashes = do+ res <- splitSelect txHashes $ \hs -> from $ \t -> do+ where_ $ t ^. WalletTxHash `in_` valList hs+ return $ t ^. WalletTxId+ killTxIds notifChanM $ map unValue res++{- Confirmations -}++importMerkles :: MonadIO m+ => BlockChainAction+ -> [MerkleTxs]+ -> Maybe (TBMChan Notif)+ -> SqlPersistT m ()+importMerkles action expTxsLs notifChanM =+ when (isBestChain action || isChainReorg action) $ do+ case action of+ ChainReorg _ os _ ->+ -- Unconfirm transactions from the old chain.+ let hs = map (Just . nodeHash) os+ in splitUpdate hs $ \h t -> do+ set t [ WalletTxConfidence =. val TxPending+ , WalletTxConfirmedBy =. val Nothing+ , WalletTxConfirmedHeight =. val Nothing+ , WalletTxConfirmedDate =. val Nothing+ ]+ where_ $ t ^. WalletTxConfirmedBy `in_` valList h+ _ -> return ()++ -- Find all the dead transactions which need to be revived+ deadTxs <- splitSelect (concat expTxsLs) $ \ts -> from $ \t -> do+ where_ ( t ^. WalletTxHash `in_` valList ts+ &&. t ^. WalletTxConfidence ==. val TxDead+ )+ return $ t ^. WalletTxTx++ -- Revive dead transactions (in no particular order)+ forM_ deadTxs $ reviveTx notifChanM . unValue++ -- Confirm the transactions+ forM_ (zip (actionNodes action) expTxsLs) $ \(node, hs) -> do+ let hash = nodeHash node+ height = nodeBlockHeight node++ splitUpdate hs $ \h t -> do+ set t [ WalletTxConfidence =. val TxBuilding+ , WalletTxConfirmedBy =. val (Just hash)+ , WalletTxConfirmedHeight =.+ val (Just height)+ , WalletTxConfirmedDate =.+ val (Just $ nodeTimestamp node)+ ]+ where_ $ t ^. WalletTxHash `in_` valList h++ ts <- fmap (map entityVal) $ splitSelect hs $ \h -> from $ \t -> do+ where_ $ t ^. WalletTxHash `in_` valList h+ return t++ -- Update the best height in the wallet (used to compute the number+ -- of confirmations of transactions)+ setBestBlock hash height++ -- Send notification for block+ forM_ notifChanM $ \notifChan -> do+ liftIO $ atomically $ writeTBMChan notifChan $+ NotifBlock JsonBlock+ { jsonBlockHash = hash+ , jsonBlockHeight = height+ , jsonBlockPrev = nodePrev node+ }+ sendTxs notifChan ts hash height+ where+ sendTxs notifChan ts hash height = forM_ ts $ \tx -> do+ let ai = walletTxAccount tx+ Account{..} <- fromMaybe (error "Dino crisis") <$> get ai+ liftIO $ atomically $ writeTBMChan notifChan $+ NotifTx $ toJsonTx accountName (Just (hash, height)) tx++-- 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 [ WalletStateBlock =. val bid+ , WalletStateHeight =. val i+ ]++-- Helper function to get the best block and best block height from the DB+walletBestBlock :: MonadIO m => SqlPersistT m (BlockHash, Word32)+walletBestBlock = do+ cfgM <- fmap entityVal <$> P.selectFirst [] []+ return $ case cfgM of+ Just WalletState{..} -> (walletStateBlock, walletStateHeight)+ 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+ => Maybe (TBMChan Notif)+ -> Tx+ -> SqlPersistT m ()+reviveTx notifChanM tx = do+ -- Kill all transactions spending our coins+ spendingTxs <- getSpendingTxs tx Nothing+ killTxIds notifChanM $ map entityKey spendingTxs++ -- Find all the WalletTxId that have to be revived+ ids <- select $ from $ \t -> do+ where_ $ t ^. WalletTxHash ==. val (txHash tx)+ &&. t ^. WalletTxConfidence ==. val TxDead+ return (t ^. WalletTxAccount, t ^. WalletTxId)++ -- Spend the inputs for all our transactions+ forM_ ids $ \(Value ai, Value ti) -> spendInputs ai ti tx++ let ids' = map (unValue . snd) ids+ -- Update the transactions+ splitUpdate ids' $ \is t -> do+ set t [ WalletTxConfidence =. val TxPending+ , WalletTxConfirmedBy =. val Nothing+ , WalletTxConfirmedHeight =. val Nothing+ , WalletTxConfirmedDate =. val Nothing+ ]+ where_ $ t ^. WalletTxId `in_` valList is++ case notifChanM of+ Nothing -> return ()+ Just notifChan -> do+ ts' <- fmap (map entityVal) $+ splitSelect ids' $ \ts -> from $ \t -> do+ where_ $ t ^. WalletTxId `in_` valList ts+ return t+ forM_ ts' $ \tx' -> do+ let ai = walletTxAccount tx'+ Account{..} <-+ fromMaybe (error "Tyranossaurus Rex attacks") <$> get ai+ liftIO $ atomically $ writeTBMChan notifChan $+ NotifTx $ toJsonTx accountName Nothing tx'++{- 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)+ => Entity Account -- ^ Account Entity+ -> Maybe (TBMChan Notif) -- ^ Notification channel+ -> Maybe XPrvKey -- ^ Key if not provided by account+ -> [(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 (WalletTx, [WalletAddr])+ -- ^ (New transaction hash, Completed flag)+createTx accE@(Entity ai acc) notifM masterM dests fee minConf rcptFee sign = do+ -- Build an unsigned transaction from the given recipient values and fee+ (unsignedTx, inCoins, newChangeAddrs) <-+ buildUnsignedTx accE dests fee minConf rcptFee+ -- Sign our new transaction if signing was requested+ let dat = map toCoinSignData inCoins+ tx | sign = signOfflineTx acc masterM 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 notifM ai inCoins+ case res of+ (txRes:_) -> return (txRes, newAddrs ++ newChangeAddrs)+ _ -> liftIO . throwIO $ WalletException+ "Error while importing the new transaction"++toCoinSignData :: InCoinData -> CoinSignData+toCoinSignData (InCoinData (Entity _ c) t x) =+ CoinSignData (OutPoint (walletTxHash t) (walletCoinPos c))+ (walletCoinScript c)+ deriv+ where+ deriv = Deriv :/ addrTypeIndex (walletAddrType x) :/ walletAddrIndex 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 Account+ -> [(Address, Word64)]+ -> Word64+ -> Word32+ -> Bool+ -> SqlPersistT m (Tx, [InCoinData], [WalletAddr])+ -- ^ Generated change addresses+buildUnsignedTx _ [] _ _ _ = liftIO . throwIO $ WalletException+ "buildUnsignedTx: No transaction recipients have been provided"+buildUnsignedTx accE@(Entity ai acc) origDests origFee minConf rcptFee = do+ let p = case accountType acc of+ AccountMultisig m n -> (m, n)+ _ -> throw . WalletException $ "Invalid account type"+ fee = if rcptFee then 0 else origFee+ coins | isMultisigAccount acc = chooseMSCoins tot fee p True+ | otherwise = chooseCoins tot fee True+ -- TODO: Add more policies like confirmations or coin age+ -- Sort coins by their values in descending order+ orderPolicy c _ = [desc $ c ^. WalletCoinValue]+ -- Find the spendable coins in the given account with the required number+ -- of minimum confirmations.+ selectRes <- spendableCoins ai minConf orderPolicy+ -- Find a selection of spendable coins that matches our target value+ let (selected, change) = either (throw . WalletException) id $ coins 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, addrs) <- if change < 5430+ then return (dests, [])+ else do+ (addr, chng) <- newChangeAddr change+ return ((walletAddrAddress addr, chng) : dests, [addr])++ case buildAddrTx (map toOutPoint selected) $ map toBase58 allDests of+ Right tx -> return (tx, selected, addrs)+ Left err -> liftIO . throwIO $ WalletException err+ where+ tot = sum $ map snd origDests+ toBase58 (a, v) = (addrToBase58 a, v)+ toOutPoint (InCoinData (Entity _ c) t _) =+ OutPoint (walletTxHash t) (walletCoinPos c)+ newChangeAddr change = do+ let lq = ListRequest 0 0 False+ (as, _) <- unusedAddresses accE AddressInternal lq+ case as of+ (a:_) -> do+ -- Use the address to prevent reusing it again+ _ <- useAddress a+ -- TODO: Randomize the change position+ return (a, change)+ _ -> liftIO . throwIO $ WalletException+ "No unused addresses available"++signAccountTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => Entity Account+ -> Maybe (TBMChan Notif)+ -> Maybe XPrvKey+ -> TxHash+ -> SqlPersistT m ([WalletTx], [WalletAddr])+signAccountTx (Entity ai acc) notifChanM masterM txid = do+ (OfflineTxData tx dat, inCoins) <- getOfflineTxData ai txid+ let signedTx = signOfflineTx acc masterM tx dat+ importTx' signedTx notifChanM ai inCoins++getOfflineTxData+ :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)+ => AccountId+ -> TxHash+ -> SqlPersistT m (OfflineTxData, [InCoinData])+getOfflineTxData ai txid = do+ txM <- getBy $ UniqueAccTx ai txid+ case txM of+ Just (Entity _ tx) -> do+ unless (walletTxConfidence tx == TxOffline) $ liftIO . throwIO $+ WalletException "Can only sign offline transactions."+ inCoins <- getInCoins (walletTxTx tx) $ Just ai+ return+ ( OfflineTxData (walletTxTx 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 :: Account -- ^ Account used for signing+ -> Maybe XPrvKey -- ^ Key if not provided in account+ -> Tx -- ^ Transaction to sign+ -> [CoinSignData] -- ^ Input signing data+ -> Tx+signOfflineTx acc masterM tx coinSignData+ | not validMaster = throw $ WalletException+ "Master key not valid"+ -- 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 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 (CoinSignData _ _ deriv) = derivePath deriv master+ master = case masterM of+ Just m -> case accountDerivation acc of+ Just d -> derivePath d m+ Nothing -> m+ Nothing -> fromMaybe+ (throw $ WalletException "No extended private key available")+ (accountMaster acc)+ validMaster = deriveXPubKey master `elem` accountKeys 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)+ => AccountId -- ^ Account key+ -> Word32 -- ^ Minimum confirmations+ -> ( SqlExpr (Entity WalletCoin)+ -> SqlExpr (Entity WalletTx)+ -> [SqlExpr OrderBy]+ )+ -- ^ Coin ordering policy+ -> SqlPersistT m [InCoinData] -- ^ Spendable coins+spendableCoins ai minConf orderPolicy =+ fmap (map f) $ select $ spendableCoinsFrom ai minConf orderPolicy+ where+ f (c, t, x) = InCoinData c (entityVal t) (entityVal x)++spendableCoinsFrom+ :: AccountId -- ^ Account key+ -> Word32 -- ^ Minimum confirmations+ -> ( SqlExpr (Entity WalletCoin)+ -> SqlExpr (Entity WalletTx)+ -> [SqlExpr OrderBy]+ )+ -- ^ Coin ordering policy+ -> SqlQuery ( SqlExpr (Entity WalletCoin)+ , SqlExpr (Entity WalletTx)+ , SqlExpr (Entity WalletAddr)+ )+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 ?. SpentCoinAccount ==. just (c ^. WalletCoinAccount)+ &&. s ?. SpentCoinHash ==. just (c ^. WalletCoinHash)+ &&. s ?. SpentCoinPos ==. just (c ^. WalletCoinPos)+ )+ on $ x ^. WalletAddrId ==. c ^. WalletCoinAddr+ -- Inner join on coins and transactions+ on $ t ^. WalletTxId ==. c ^. WalletCoinTx+ where_ ( c ^. WalletCoinAccount ==. val ai+ &&. t ^. WalletTxConfidence+ `in_` valList [ TxPending, TxBuilding ]+ -- We only want unspent coins+ &&. E.isNothing (s ?. SpentCoinId)+ &&. 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 WalletTx)))+ (SqlExpr (Entity WalletTx))+ -> 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 ?. WalletTxConfirmedHeight+ <=. just (just (selectHeight -. val (i - 1)))+ Right t -> t ^. WalletTxConfirmedHeight+ <=. just (selectHeight -. val (i - 1))+ -- Coinbase transactions require 100 confirmations+ limitCoinbase = case txE of+ Left t ->+ not_ (coalesceDefault [t ?. WalletTxIsCoinbase] (val False)) ||.+ limitConfs 100+ Right t ->+ not_ (t ^. WalletTxIsCoinbase) ||. limitConfs 100+ selectHeight :: SqlExpr (Value Word32)+ selectHeight = sub_select $ from $ \co -> do+ limit 1+ return $ co ^. WalletStateHeight++{- Balances -}++accountBalance :: MonadIO m+ => AccountId+ -> Word32+ -> Bool+ -> SqlPersistT m Word64+accountBalance ai minconf offline = do+ res <- select $ from $ \(c `InnerJoin`+ t `LeftOuterJoin` s `LeftOuterJoin` st) -> do+ on $ st ?. WalletTxId ==. s ?. SpentCoinSpendingTx+ on ( s ?. SpentCoinAccount ==. just (c ^. WalletCoinAccount)+ &&. s ?. SpentCoinHash ==. just (c ^. WalletCoinHash)+ &&. s ?. SpentCoinPos ==. just (c ^. WalletCoinPos)+ )+ on $ t ^. WalletTxId ==. c ^. WalletCoinTx+ let unspent = E.isNothing ( s ?. SpentCoinId )+ spentOffline = st ?. WalletTxConfidence ==. just (val TxOffline)+ cond = c ^. WalletCoinAccount ==. val ai+ &&. t ^. WalletTxConfidence `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 ^. WalletCoinValue)+ case res of+ (Value (Just s):_) -> return $ floor (s :: Double)+ _ -> return 0+ where+ validConfidence = TxPending : TxBuilding : [ TxOffline | offline ]++addressBalances :: MonadIO m+ => Entity Account+ -> 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 ?. WalletTxId ==. s ?. SpentCoinSpendingTx+ -- 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 ?. WalletTxConfidence !=. just (val TxOffline)+ on $ s ?. SpentCoinAccount ==. c ?. WalletCoinAccount+ &&. s ?. SpentCoinHash ==. c ?. WalletCoinHash+ &&. s ?. SpentCoinPos ==. c ?. WalletCoinPos+ let txJoin = t ?. WalletTxId ==. c ?. WalletCoinTx+ &&. t ?. WalletTxConfidence `in_` valList validConfidence+ on $ if minconf == 0+ then txJoin+ else txJoin &&. limitConfirmations (Left t) minconf+ on $ c ?. WalletCoinAddr ==. just (x ^. WalletAddrId)+ let limitIndex+ | iMin == iMax = x ^. WalletAddrIndex ==. val iMin+ | otherwise = x ^. WalletAddrIndex >=. val iMin+ &&. x ^. WalletAddrIndex <=. val iMax+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. limitIndex+ &&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType+ &&. x ^. WalletAddrType ==. val addrType+ )+ groupBy $ x ^. WalletAddrIndex+ let unspent = E.isNothing $ st ?. WalletTxId+ invalidTx = E.isNothing $ t ?. WalletTxId+ return ( x ^. WalletAddrIndex -- Address index+ , sum_ $ case_+ [ when_ invalidTx+ then_ (val (Just 0))+ ] (else_ $ c ?. WalletCoinValue) -- Out value+ , sum_ $ case_+ [ when_ (unspent ||. invalidTx)+ then_ (val (Just 0))+ ] (else_ $ c ?. WalletCoinValue) -- Out value+ , count $ t ?. WalletTxId -- New coins+ , count $ case_+ [ when_ invalidTx+ then_ (val Nothing)+ ] (else_ $ st ?. WalletTxId) -- 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 WalletCoin])+ P.deleteWhere ([] :: [P.Filter SpentCoin])+ P.deleteWhere ([] :: [P.Filter WalletTx])+ setBestBlock (headerHash genesisHeader) 0
Network/Haskoin/Wallet/Types.hs view
@@ -1,23 +1,17 @@+{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Haskoin.Wallet.Types-( KeyRingName-, AccountName+( AccountName -- JSON Types-, JsonKeyRing(..) , JsonAccount(..) , JsonAddr(..) , JsonCoin(..) , JsonTx(..)-, JsonWithKeyRing(..)-, JsonWithAccount(..)-, JsonWithAddr(..) -- Request Types , WalletRequest(..)-, PageRequest(..)-, validPageRequest-, NewKeyRing(..)+, ListRequest(..) , NewAccount(..) , SetAccountGap(..) , OfflineTxData(..)@@ -36,53 +30,73 @@ -- Response Types , WalletResponse(..) , TxCompleteRes(..)-, AddrTx(..)-, PageRes(..)+, ListResult(..) , RescanRes(..)+, JsonSyncBlock(..)+, JsonBlock(..)+, Notif(..) -- 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- )+, BTCNode(..) -import Database.Persist.Class (PersistField, toPersistValue, fromPersistValue)-import Database.Persist.Types (PersistValue(..))-import Database.Persist.Sql (PersistFieldSql, SqlType(..), sqlType)+-- *Helpers+, splitSelect+, splitUpdate+, splitDelete+, splitInsertMany_+, join2+, limitOffset+) where -import Network.Haskoin.Block-import Network.Haskoin.Crypto-import Network.Haskoin.Script-import Network.Haskoin.Transaction-import Network.Haskoin.Node-import Network.Haskoin.Util+import Control.DeepSeq (NFData (..))+import Control.Exception (Exception)+import Control.Monad (forM, forM_, mzero, when)+import Control.Monad.Trans (MonadIO)+import Data.Aeson (FromJSON, ToJSON, Value (..),+ decodeStrict', encode, object,+ parseJSON, toJSON, withObject,+ (.!=), (.:), (.:?), (.=))+import Data.Aeson.TH (deriveJSON)+import Data.Aeson.Types (Options (..),+ SumEncoding (..),+ defaultOptions,+ defaultTaggedObject)+import Data.Binary (Binary)+import Data.Char (toLower)+import Data.Int (Int64)+import Data.List.Split (chunksOf)+import Data.Maybe (maybeToList)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Typeable (Typeable)+import Data.Word (Word32, Word64)+import Database.Esqueleto (Entity (..), SqlBackend,+ SqlExpr, SqlPersistT,+ SqlQuery, limit, offset,+ select, update, val, (||.))+import qualified Database.Esqueleto as E (Value, delete)+import Database.Esqueleto.Internal.Sql (SqlSelect)+import qualified Database.Persist as P (PersistEntity,+ PersistEntityBackend,+ insertMany_)+import Database.Persist.Class (PersistField,+ fromPersistValue,+ toPersistValue)+import Database.Persist.Sql (PersistFieldSql, SqlType (..),+ sqlType)+import Database.Persist.Types (PersistValue (..))+import GHC.Generics (Generic)+import Network.Haskoin.Block+import Network.Haskoin.Crypto+import Network.Haskoin.Node+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Script+import Network.Haskoin.Transaction+import Network.Haskoin.Util+import Network.Haskoin.Wallet.Database -type KeyRingName = Text type AccountName = Text -- TODO: Add NFData instances for all those types@@ -110,15 +124,17 @@ instance NFData TxConfidence where rnf x = x `seq` () -$(deriveJSON (dropFieldLabel 2) ''TxConfidence)+$(deriveJSON (dropSumLabels 2 0 "") ''TxConfidence) data AddressInfo = AddressInfo { addressInfoAddress :: !Address , addressInfoValue :: !(Maybe Word64) , addressInfoIsLocal :: !Bool }- deriving (Eq, Show, Read)+ deriving (Eq, Show, Read, Generic) +instance Binary AddressInfo+ $(deriveJSON (dropFieldLabel 11) ''AddressInfo) instance NFData AddressInfo where@@ -128,10 +144,10 @@ rnf addressInfoIsLocal data BalanceInfo = BalanceInfo- { balanceInfoInBalance :: !Word64- , balanceInfoOutBalance :: !Word64- , balanceInfoCoins :: !Int- , balanceInfoSpentCoins :: !Int+ { balanceInfoInBalance :: !Word64+ , balanceInfoOutBalance :: !Word64+ , balanceInfoCoins :: !Int+ , balanceInfoSpentCoins :: !Int } deriving (Eq, Show, Read) @@ -144,38 +160,25 @@ 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+ { 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+ AccountRegular -> ()+ AccountMultisig m n -> 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+ AccountRegular -> object+ [ "type" .= String "regular" ]+ AccountMultisig m n -> object [ "type" .= String "multisig"- , "readonly" .= r , "requiredsigs" .= m , "totalkeys" .= n ]@@ -183,16 +186,19 @@ 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"+ "regular" -> return AccountRegular+ "multisig" -> AccountMultisig <$> o .: "requiredsigs" <*> o .: "totalkeys" _ -> mzero data NewAccount = NewAccount- { newAccountAccountName :: !AccountName- , newAccountType :: !AccountType- , newAccountKeys :: ![XPubKey]+ { newAccountName :: !AccountName+ , newAccountType :: !AccountType+ , newAccountMnemonic :: !(Maybe Text)+ , newAccountMaster :: !(Maybe XPrvKey)+ , newAccountDeriv :: !(Maybe HardPath)+ , newAccountKeys :: ![XPubKey]+ , newAccountReadOnly :: !Bool } deriving (Eq, Show, Read) @@ -203,17 +209,14 @@ $(deriveJSON (dropFieldLabel 10) ''SetAccountGap) -data PageRequest = PageRequest- { pageNum :: !Word32- , pageLen :: !Word32- , pageReverse :: !Bool+data ListRequest = ListRequest+ { listOffset :: !Word32+ , listLimit :: !Word32+ , listReverse :: !Bool } deriving (Eq, Show, Read) -$(deriveJSON (dropFieldLabel 0) ''PageRequest)--validPageRequest :: PageRequest -> Bool-validPageRequest PageRequest{..} = pageNum >= 1 && pageLen >= 1+$(deriveJSON (dropFieldLabel 4) ''ListRequest) data CoinSignData = CoinSignData { coinSignOutPoint :: !OutPoint@@ -320,29 +323,30 @@ 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+ = GetAccountsR !ListRequest+ | PostAccountsR !NewAccount+ | PostAccountRenameR !AccountName !AccountName+ | GetAccountR !AccountName+ | PostAccountKeysR !AccountName ![XPubKey]+ | PostAccountGapR !AccountName !SetAccountGap+ | GetAddressesR !AccountName !AddressType !Word32 !Bool !ListRequest+ | GetAddressesUnusedR !AccountName !AddressType !ListRequest+ | GetAddressR !AccountName !KeyIndex !AddressType !Word32 !Bool+ | PutAddressR !AccountName !KeyIndex !AddressType !AddressLabel+ | PostAddressesR !AccountName !KeyIndex !AddressType+ | GetTxsR !AccountName !ListRequest+ | GetAddrTxsR !AccountName !KeyIndex !AddressType !ListRequest+ | PostTxsR !AccountName !(Maybe XPrvKey) !TxAction+ | GetTxR !AccountName !TxHash+ | GetOfflineTxR !AccountName !TxHash+ | PostOfflineTxR !AccountName !(Maybe XPrvKey) !Tx ![CoinSignData]+ | GetBalanceR !AccountName !Word32 !Bool | PostNodeR !NodeAction+ | DeleteTxIdR !TxHash+ | GetSyncR !AccountName !BlockHash !ListRequest+ | GetSyncHeightR !AccountName !BlockHeight !ListRequest+ | GetPendingR !AccountName !ListRequest+ | GetDeadR !AccountName !ListRequest -- TODO: Set omitEmptyContents on aeson-0.9 $(deriveJSON@@ -358,45 +362,11 @@ {- 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+ , jsonAccountMaster :: !(Maybe XPrvKey)+ , jsonAccountMnemonic :: !(Maybe Text) , jsonAccountDerivation :: !(Maybe HardPath) , jsonAccountKeys :: ![XPubKey] , jsonAccountGap :: !Word32@@ -406,40 +376,21 @@ $(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+ { jsonAddrAddress :: !Address+ , jsonAddrIndex :: !KeyIndex+ , jsonAddrType :: !AddressType+ , jsonAddrLabel :: !Text+ , jsonAddrRedeem :: !(Maybe ScriptOutput)+ , jsonAddrKey :: !(Maybe PubKeyC)+ , jsonAddrCreated :: !UTCTime -- Optional Balance- , jsonAddrBalance :: !(Maybe BalanceInfo)+ , 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@@ -457,8 +408,11 @@ , jsonTxConfirmedHeight :: !(Maybe Word32) , jsonTxConfirmedDate :: !(Maybe Word32) , jsonTxCreated :: !UTCTime+ , jsonTxAccount :: !AccountName -- Optional confirmation , jsonTxConfirmations :: !(Maybe Word32)+ , jsonTxBestBlock :: !(Maybe BlockHash)+ , jsonTxBestBlockHeight :: !(Maybe BlockHeight) } deriving (Eq, Show, Read) @@ -483,13 +437,6 @@ {- Response Types -} -data AddrTx = AddrTx- { addrTxTx :: !JsonTx- , addrTxBalance :: !BalanceInfo- }--$(deriveJSON (dropFieldLabel 6) ''AddrTx)- data TxCompleteRes = TxCompleteRes { txCompleteTx :: !Tx , txCompleteComplete :: !Bool@@ -497,12 +444,12 @@ $(deriveJSON (dropFieldLabel 10) ''TxCompleteRes) -data PageRes a = PageRes- { pageResPage :: ![a]- , pageResMaxPage :: !Word32+data ListResult a = ListResult+ { listResultItems :: ![a]+ , listResultTotal :: !Word32 } -$(deriveJSON (dropFieldLabel 7) ''PageRes)+$(deriveJSON (dropFieldLabel 10) ''ListResult) data RescanRes = RescanRes { rescanTimestamp :: !Word32 } deriving (Eq, Show, Read)@@ -510,23 +457,54 @@ $(deriveJSON (dropFieldLabel 6) ''RescanRes) data WalletResponse a- = ResponseError { responseError :: !Text }+ = ResponseError { responseError :: !Text } | ResponseValid { responseResult :: !(Maybe a) } deriving (Eq, Show) -$(deriveJSON (dropSumLabels 8 8 "status" ) ''WalletResponse)+$(deriveJSON (dropSumLabels 8 8 "status") ''WalletResponse) +data JsonSyncBlock = JsonSyncBlock+ { jsonSyncBlockHash :: !BlockHash+ , jsonSyncBlockHeight :: !BlockHeight+ , jsonSyncBlockPrev :: !BlockHash+ , jsonSyncBlockTxs :: ![JsonTx]+ } deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 13) ''JsonSyncBlock)++data JsonBlock = JsonBlock+ { jsonBlockHash :: !BlockHash+ , jsonBlockHeight :: !BlockHeight+ , jsonBlockPrev :: !BlockHash+ } deriving (Eq, Show, Read)++$(deriveJSON (dropFieldLabel 9) ''JsonBlock)++data Notif+ = NotifBlock !JsonBlock+ | NotifTx !JsonTx+ deriving (Eq, Show, Read)++$(deriveJSON (dropSumLabels 5 5 "type") ''Notif)+ {- Helper Types -} -data WalletException = WalletException String+data WalletException = WalletException !String deriving (Eq, Read, Show, Typeable) instance Exception WalletException +data BTCNode = BTCNode { btcNodeHost :: !String, btcNodePort :: !Int }+ deriving (Eq, Read, Show)++$(deriveJSON (dropFieldLabel 7) ''BTCNode)+ {- Persistent Instances -} instance PersistField XPrvKey where- toPersistValue = PersistByteString . xPrvExport+ toPersistValue = PersistText . cs . xPrvExport+ fromPersistValue (PersistText txt) =+ maybeToEither "Invalid Persistent XPrvKey" $ xPrvImport $ cs txt fromPersistValue (PersistByteString bs) = maybeToEither "Invalid Persistent XPrvKey" $ xPrvImport bs fromPersistValue _ = Left "Invalid Persistent XPrvKey"@@ -535,7 +513,9 @@ sqlType _ = SqlString instance PersistField [XPubKey] where- toPersistValue = PersistByteString . L.toStrict . encode+ toPersistValue = PersistText . cs . encode+ fromPersistValue (PersistText txt) =+ maybeToEither "Invalid Persistent XPubKey" $ decodeStrict' $ cs txt fromPersistValue (PersistByteString bs) = maybeToEither "Invalid Persistent XPubKey" $ decodeStrict' bs fromPersistValue _ = Left "Invalid Persistent XPubKey"@@ -544,62 +524,80 @@ sqlType _ = SqlString instance PersistField DerivPath where- toPersistValue = PersistByteString . cs . pathToStr- fromPersistValue (PersistByteString bs) =- maybeToEither "Invalid Persistent DerivPath" $ parsePath $ cs bs+ toPersistValue = PersistText . cs . pathToStr+ fromPersistValue (PersistText txt) = maybeToEither+ "Invalid Persistent DerivPath" . fmap getParsedPath .+ parsePath . cs $ txt+ fromPersistValue (PersistByteString bs) = maybeToEither+ "Invalid Persistent DerivPath" . fmap getParsedPath .+ 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+ toPersistValue = PersistText . cs . pathToStr+ fromPersistValue (PersistText txt) = maybeToEither+ "Invalid Persistent HardPath" $ parseHard $ cs txt+ 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+ toPersistValue = PersistText . cs . pathToStr+ fromPersistValue (PersistText txt) = maybeToEither+ "Invalid Persistent SoftPath" $ parseSoft $ cs txt+ 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+ toPersistValue = PersistText . cs . encode+ fromPersistValue (PersistText txt) = maybeToEither+ "Invalid Persistent AccountType" $ decodeStrict' $ cs txt+ 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+ toPersistValue ts = PersistBool $ case ts of+ AddressExternal -> True+ AddressInternal -> False - fromPersistValue (PersistInt64 t) = case t of- 0 -> return AddressExternal- 1 -> return AddressInternal- _ -> Left "Invalid Persistent AddressType"+ fromPersistValue (PersistBool b) = return $+ if b then AddressExternal else AddressInternal + fromPersistValue (PersistInt64 i) = return $ case i of+ 0 -> AddressInternal+ _ -> AddressExternal+ fromPersistValue _ = Left "Invalid Persistent AddressType" instance PersistFieldSql AddressType where- sqlType _ = SqlInt64+ sqlType _ = SqlBool instance PersistField TxType where- toPersistValue ts = PersistByteString $ case ts of+ toPersistValue ts = PersistText $ case ts of TxIncoming -> "incoming" TxOutgoing -> "outgoing" TxSelf -> "self" + fromPersistValue (PersistText txt) = case txt of+ "incoming" -> return TxIncoming+ "outgoing" -> return TxOutgoing+ "self" -> return TxSelf+ _ -> Left "Invalid Persistent TxType"+ fromPersistValue (PersistByteString bs) = case bs of "incoming" -> return TxIncoming "outgoing" -> return TxOutgoing@@ -612,7 +610,9 @@ sqlType _ = SqlString instance PersistField Address where- toPersistValue = PersistByteString . addrToBase58+ toPersistValue = PersistText . cs . addrToBase58+ fromPersistValue (PersistText a) =+ maybeToEither "Invalid Persistent Address" $ base58ToAddr $ cs a fromPersistValue (PersistByteString a) = maybeToEither "Invalid Persistent Address" $ base58ToAddr a fromPersistValue _ = Left "Invalid Persistent Address"@@ -630,7 +630,9 @@ sqlType _ = SqlBlob instance PersistField BlockHash where- toPersistValue = PersistByteString . blockHashToHex+ toPersistValue = PersistText . cs . blockHashToHex+ fromPersistValue (PersistText h) =+ maybeToEither "Could not decode BlockHash" $ hexToBlockHash $ cs h fromPersistValue (PersistByteString h) = maybeToEither "Could not decode BlockHash" $ hexToBlockHash h fromPersistValue _ = Left "Invalid Persistent BlockHash"@@ -639,7 +641,9 @@ sqlType _ = SqlString instance PersistField TxHash where- toPersistValue = PersistByteString . txHashToHex+ toPersistValue = PersistText . cs . txHashToHex+ fromPersistValue (PersistText h) =+ maybeToEither "Invalid Persistent TxHash" $ hexToTxHash $ cs h fromPersistValue (PersistByteString h) = maybeToEither "Invalid Persistent TxHash" $ hexToTxHash h fromPersistValue _ = Left "Invalid Persistent TxHash"@@ -648,18 +652,26 @@ sqlType _ = SqlString instance PersistField TxConfidence where- toPersistValue tc = PersistByteString $ case tc of+ toPersistValue tc = PersistText $ case tc of TxOffline -> "offline" TxDead -> "dead" TxPending -> "pending" TxBuilding -> "building" + fromPersistValue (PersistText txt) = case txt of+ "offline" -> return TxOffline+ "dead" -> return TxDead+ "pending" -> return TxPending+ "building" -> return TxBuilding+ _ -> Left "Invalid Persistent TxConfidence"+ 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@@ -675,7 +687,10 @@ sqlType _ = SqlOther "MEDIUMBLOB" instance PersistField PubKeyC where- toPersistValue = PersistByteString . encodeHex . encode'+ toPersistValue = PersistText . cs . encodeHex . encode'+ fromPersistValue (PersistText txt) =+ maybeToEither "Invalid Persistent PubKeyC" $+ decodeToMaybe =<< decodeHex (cs txt) fromPersistValue (PersistByteString bs) = maybeToEither "Invalid Persistent PubKeyC" $ decodeToMaybe =<< decodeHex bs@@ -695,11 +710,60 @@ sqlType _ = SqlBlob instance PersistField [AddressInfo] where- toPersistValue = PersistByteString . L.toStrict . encode+ toPersistValue = PersistByteString . encode' fromPersistValue (PersistByteString bs) =- maybeToEither "Invalid Persistent AddressInfo" $ decodeStrict' bs+ maybeToEither "Invalid Persistent AddressInfo" $ decodeToMaybe bs fromPersistValue _ = Left "Invalid Persistent AddressInfo" instance PersistFieldSql [AddressInfo] where- sqlType _ = SqlString+ sqlType _ = SqlOther "MEDIUMBLOB"++{- Helpers -}++-- Join AND expressions with OR conditions in a binary way+join2 :: [SqlExpr (E.Value Bool)] -> SqlExpr (E.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 =+ fmap 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++splitInsertMany_ :: ( MonadIO m+ , P.PersistEntity val+ , P.PersistEntityBackend val ~ SqlBackend+ )+ => [val] -> SqlPersistT m ()+splitInsertMany_ = mapM_ P.insertMany_ . chunksOf paramLimit++limitOffset :: Word32 -> Word32 -> SqlQuery ()+limitOffset l o = do+ when (l > 0) $ limit $ fromIntegral l+ when (o > 0) $ offset $ fromIntegral o
config/config.yml view
@@ -1,7 +1,13 @@ # ZeroMQ socket on which to listen to. Either absolute path or relative to # work-dir/network.-bind-socket: ipc://hw.sock+bind-socket: ipc://hw.sock+bind-socket-notif: ipc://notif.sock +# ZeroMQ socket to communicate with the server.+# Either absolute path or relative to the server work-dir/network path.+connect-uri: ipc://hw.sock+connect-uri-notif: ipc://notif.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@@ -12,27 +18,11 @@ # 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+ database: hw-wallet.sqlite3+ poolsize: 1 prodnet:- sqlite:- database: hw-wallet.sqlite3- poolsize: 1- mysql:- database: haskoin_wallet- poolsize: 1- user: root- password: ""- host: localhost- port: 5432+ database: hw-wallet.sqlite3+ poolsize: 1 # List of trusted bitcoin full-nodes to connect to. bitcoin-full-nodes:@@ -70,9 +60,6 @@ # 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 @@ -101,10 +88,6 @@ # 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 @@ -118,3 +101,18 @@ # Print verbose verbose: false +# Recipient pays transaction fee. DANGEROUS.+recipient-fee: false++# Configuration file name. Only set at compile time.+config-file: config.yml++# Server key for authentication and encryption (server config).+server-key:+# Server public key for authentication and encryption (client config).+server-key-public:++# Client key for authentication and encryption (client config).+client-key:+# Client public key for aunthentication and encryption (client + server config).+client-key-public:
config/help view
@@ -1,47 +1,49 @@ 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+ start [--detach] Start the haskoin daemon+ stop Stop the haskoin daemon+ status [--verbose] Display node runtime information 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+ newacc name Create a new account+ newread name Create a new read-only account+ newms name M N Create a new multisig account+ newreadms name M N Create a new read-only ms account+ addkey acc Add pubkeys to a multisig account+ setgap acc gap Set the address gap for an account+ accounts [page] [-c pagesize] [-r] List all accounts in a keyring+ account acc Display an account by name+ rename old new Rename account 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+ list acc [page] [-c pagesize] [-r] Display addresses by page+ unused acc [page] [-c pagesize] [-r] 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+ txs acc [page] [-c pagesize] [-r] Display all transactions by page+ pending acc [page] [-c pagesize] [-r] Display pending transactions by page+ dead acc [page] [-c pagesize] [-r] Display dead 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 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+ deletetx txid Delete unconfirmed transaction+ sync acc {hash|height} [page] Get blocks following specified one 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+ 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+ decodetx Decode HEX transaction+ rescan [timestamp] Rescan the wallet+ keypair Get curve key pair for ØMQ auth+ monitor [account] Monitor events (no account: blocks) Other commands:- version Display version information- help Display this help information+ version Display version information+ help Display this help information
config/models view
@@ -1,29 +1,20 @@-KeyRing- name Text maxlen=200- master XPrvKey maxlen=200- created UTCTime- UniqueKeyRing name- deriving Show--KeyRingAccount- keyRing KeyRingId+Account name Text maxlen=200 type AccountType maxlen=64 derivation HardPath Maybe maxlen=200+ master XPrvKey Maybe keys [XPubKey] gap Word32 created UTCTime- UniqueAccount keyRing name+ UniqueAccount name deriving Show -KeyRingAddr- account KeyRingAccountId+WalletAddr+ account AccountId 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@@ -32,8 +23,8 @@ UniqueAddrIndex account type index deriving Show -KeyRingTx- account KeyRingAccountId+WalletTx+ account AccountId hash TxHash maxlen=64 nosigHash TxHash maxlen=64 type TxType maxlen=16@@ -55,12 +46,12 @@ UniqueAccNoSigRev nosigHash account deriving Show -KeyRingCoin- account KeyRingAccountId+WalletCoin+ account AccountId hash TxHash maxlen=64 pos Word32- tx KeyRingTxId- addr KeyRingAddrId+ tx WalletTxId+ addr WalletAddrId value Word64 script ScriptOutput created UTCTime@@ -70,11 +61,11 @@ UniqueCoinTxRev pos tx deriving Show -KeyRingSpentCoin- account KeyRingAccountId+SpentCoin+ account AccountId hash TxHash maxlen=64 pos Word32- spendingTx KeyRingTxId+ spendingTx WalletTxId created UTCTime UniqueSpentCoins account hash pos UniqueSpentCoinsRev hash pos account@@ -82,7 +73,7 @@ UniqueSpentTxRev hash pos spendingTx deriving Show -KeyRingConfig+WalletState height BlockHeight block BlockHash maxlen=64 bloomFilter BloomFilter
− database/mysql/Network/Haskoin/Wallet/Database.hs
@@ -1,21 +0,0 @@-module Network.Haskoin.Wallet.Database where--import Control.Monad.Logger (runNoLoggingT)--import Data.Text (Text)--import Database.Persist.MySQL (MySQLConf(..), createMySQLPool)-import Database.Persist.Sql (ConnectionPool)--type DatabaseConfType = MySQLConf--databaseEngine :: Text-databaseEngine = "mysql"--getDatabasePool :: DatabaseConfType -> IO ConnectionPool-getDatabasePool conf = runNoLoggingT $- createMySQLPool (myConnInfo conf) (myPoolSize conf)--paramLimit :: Int-paramLimit = 20-
− database/sqlite/Network/Haskoin/Wallet/Database.hs
@@ -1,21 +0,0 @@-module Network.Haskoin.Wallet.Database where--import Control.Monad.Logger (runNoLoggingT)--import Data.Text (Text)--import Database.Persist.Sql (ConnectionPool)-import Database.Persist.Sqlite (SqliteConf(..), createSqlitePool)--type DatabaseConfType = SqliteConf--databaseEngine :: Text-databaseEngine = "sqlite"--getDatabasePool :: DatabaseConfType -> IO ConnectionPool-getDatabasePool conf = runNoLoggingT $- createSqlitePool (sqlDatabase conf) (sqlPoolSize conf)--paramLimit :: Int-paramLimit = 20-
haskoin-wallet.cabal view
@@ -1,5 +1,5 @@ name: haskoin-wallet-version: 0.2.0+version: 0.3.0 synopsis: Implementation of a Bitcoin SPV Wallet with BIP32 and multisig support. description:@@ -10,6 +10,7 @@ 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+tested-with: GHC==7.10.3, GHC==7.10.2, GHC==7.10.1 license: PublicDomain license-file: UNLICENSE author: Philippe Laprade@@ -17,19 +18,12 @@ 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+extra-source-files: config/help, config/config.yml, config/models source-repository head type: 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@@ -43,8 +37,9 @@ Network.Haskoin.Wallet.Internals other-modules: Network.Haskoin.Wallet.Types- Network.Haskoin.Wallet.KeyRing+ Network.Haskoin.Wallet.Accounts Network.Haskoin.Wallet.Transaction+ Network.Haskoin.Wallet.Block Network.Haskoin.Wallet.Server.Handler Network.Haskoin.Wallet.Client.Commands Network.Haskoin.Wallet.Database@@ -62,9 +57,10 @@ RecordWildCards GeneralizedNewtypeDeriving - build-depends: aeson >= 0.7 && < 0.9+ build-depends: aeson >= 0.7 && < 0.12 , aeson-pretty >= 0.7 && < 0.8 , base >= 4.8 && < 5+ , binary >= 0.7 && < 0.9 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , conduit >= 1.2 && < 1.3@@ -76,25 +72,26 @@ , 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+ , haskeline+ , haskoin-core >= 0.3 && < 0.5+ , haskoin-node >= 0.3 && < 0.5+ , lifted-async >= 0.2 && < 0.9 , 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+ , persistent-sqlite >= 2.2 && < 2.3 , resourcet >= 1.1 && < 1.2- , SafeSemaphore >= 0.10 && < 0.11+ , semigroups , split >= 0.2 && < 0.3 , stm >= 2.4 && < 2.5 , stm-chans >= 3.0 && < 3.1- , stm-conduit >= 2.6 && < 2.7+ , stm-conduit >= 2.6 && < 2.8 , string-conversions >= 0.4 && < 0.5 , text >= 0.11 && < 1.3- , time >= 1.5 && < 1.6+ , time >= 1.5 && < 1.7 , transformers-base >= 0.4 && < 0.5 , unix >= 2.6 && < 2.8 , unordered-containers >= 0.2 && < 0.3@@ -103,13 +100,6 @@ 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 if flag(library-only) Buildable: False@@ -117,6 +107,10 @@ build-depends: base, haskoin-wallet hs-source-dirs: app ghc-options: -Wall+ -O3+ -threaded+ -rtsopts+ -with-rtsopts=-N4 test-suite test-haskoin-wallet type: exitcode-stdio-1.0@@ -129,13 +123,13 @@ extensions: RecordWildCards OverloadedStrings - build-depends: aeson >= 0.7 && < 0.9+ build-depends: aeson >= 0.7 && < 0.12 , 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-core >= 0.3 && < 0.5+ , haskoin-node >= 0.3 && < 0.5 , haskoin-wallet , monad-logger >= 0.3 && < 0.4 , mtl >= 2.1 && < 2.3@@ -143,8 +137,12 @@ , persistent-sqlite >= 2.2 && < 2.3 , resourcet >= 1.1 && < 1.2 , text >= 0.11 && < 1.3- , HUnit >= 1.2 && < 1.3+ , unordered-containers >= 0.2 && < 0.3+ , HUnit >= 1.2 && < 1.4 , QuickCheck >= 2.8 && < 2.9+ , stm >= 2.4 && < 2.5+ , stm-chans >= 3.0 && < 3.1+ , string-conversions >= 0.4 && < 0.5 , test-framework >= 0.8 && < 0.9 , test-framework-quickcheck2 >= 0.3 && < 0.4 , test-framework-hunit >= 0.3 && < 0.4
− stack.yaml
@@ -1,16 +0,0 @@-flags: {}-packages:-- '.'-- '../haskoin-core'-- '../haskoin-node'-- location:- git: https://github.com/haskoin/secp256k1.git- commit: 5ee603061b3c1eaf2943e8d2c08e6effe85f38e7- extra-dep: true-extra-deps:-- daemons-0.2.1-- leveldb-haskell-0.6.3-- murmur3-1.0.0-- pbkdf-1.1.1.1-- largeword-1.2.4-resolver: lts-3.4
tests/Network/Haskoin/Wallet/Arbitrary.hs view
@@ -8,11 +8,10 @@ instance Arbitrary AccountType where arbitrary = oneof- [ AccountRegular <$> arbitrary+ [ return AccountRegular , do ArbitraryMSParam m n <- arbitrary- r <- arbitrary- return $ AccountMultisig r m n+ return $ AccountMultisig m n ] instance Arbitrary NodeAction where
tests/Network/Haskoin/Wallet/Tests.hs view
@@ -4,6 +4,7 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Data.Aeson (FromJSON, ToJSON, encode, decode)+import Data.HashMap.Strict (singleton) import Network.Haskoin.Wallet.Arbitrary () import Network.Haskoin.Wallet@@ -18,5 +19,6 @@ ] metaID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool-metaID x = (decode . encode) [x] == Just [x]+metaID x = (decode . encode) (singleton ("object" :: String) x) ==+ Just (singleton ("object" :: String) x)
tests/Network/Haskoin/Wallet/Units.hs view
@@ -1,1602 +1,1521 @@-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)+{-# LANGUAGE RecordWildCards #-}+module Network.Haskoin.Wallet.Units (tests) where++import Control.Concurrent.STM+import Control.Concurrent.STM.TBMChan+import Control.Exception (Exception, handleJust)+import Control.Monad (guard)+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Resource (ResourceT)+import qualified Data.ByteString as BS (ByteString, pack)+import Data.List (sort)+import Data.Maybe (fromJust, isJust)+import Data.String.Conversions (cs)+import Data.Word (Word32, Word64)+import Database.Persist (Entity (..), entityVal,+ getBy)+import Database.Persist.Sqlite (SqlPersistT,+ runMigrationSilent,+ runSqlite)+import Network.Haskoin.Block+import Network.Haskoin.Crypto+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Script+import Network.Haskoin.Transaction+import Network.Haskoin.Wallet.Internals+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertBool,+ assertEqual, assertFailure)++type App = SqlPersistT (NoLoggingT (ResourceT IO))++-- TODO: Add tests for accounts with no private key+tests :: [Test]+tests =+ [ testGroup "Account tests"+ [ testCase "Fail create account with wrong keys" $+ assertException+ (WalletException "Invalid account keys")+ ( newAccount NewAccount+ { newAccountName = "fail-this"+ , newAccountType = AccountRegular+ -- This key does not correspond to the one below+ , newAccountMaster = Just+ "xprv9s21ZrQH143K33Ezpb81k5upGyhrVcwgqNzHRHnQ2kGBPHkJ3sLPjGwj4LML1kr1bLfguJiY21XrYfVrL1CGurfVoMKSPwRdmzt1LwBtVyR"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ )++ , testCase "Creating two accounts with the same data should fail" $+ assertException+ (WalletException "Account already exists") $ do+ _ <- newAccount NewAccount+ { newAccountName = "main"+ , newAccountType = AccountRegular+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ newAccount NewAccount+ { newAccountName = "main"+ , newAccountType = AccountRegular+ , newAccountMaster = Nothing+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ , testCase "Invalid multisig parameters (0 of 1)" $+ assertException (WalletException "Invalid account type") $+ newAccount NewAccount+ { newAccountName = "multisig-0-of-1"+ , newAccountType = AccountMultisig 0 1+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }++ , testCase "Invalid multisig parameters (2 of 1)" $+ assertException (WalletException "Invalid account type") $+ newAccount NewAccount+ { newAccountName = "multisig-2-of-1"+ , newAccountType = AccountMultisig 2 1+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }++ , testCase "Invalid multisig parameters (15 of 16)" $+ assertException (WalletException "Invalid account type") $+ newAccount NewAccount+ { newAccountName = "multisig-15-of-16"+ , newAccountType = AccountMultisig 15 16+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }++ , testCase "To many multisig keys (3 keys for 1 of 2)" $+ assertException (WalletException "Invalid account keys") $+ newAccount NewAccount+ { newAccountName = "multisig-1-of-2-with-3"+ , newAccountType = AccountMultisig 1 2+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ [ "xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"+ , "xpub661MyMwAqRbcFEPH5Aon6F7edspeu1v6a1Nw5qJgk1aX5XYg1ktBL9Azra2CKaAJ2bHXEXkeKHE3eFaCJktFiA5tSMDQDs6bi83maQtdYby"+ , "xpub661MyMwAqRbcFtDszBWpawpg4KbNWL9qD4VdRwjd1L5cmcS8nXHWXpg9WL1Xc9Yh7HbQBwWDw37YJfc4AF3YEpvAHEBPBFQPFkUcFHnopw8"+ ]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }++ , testCase "Calling addAccountKeys with an empty key list should fail" $+ assertException+ (WalletException "Invalid account keys") $ do+ res <- newAccount NewAccount+ { newAccountName = "multisig-1-of-2-plus-empty"+ , newAccountType = AccountMultisig 1 2+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ addAccountKeys (fst res) []++ , testCase "Calling addAccountKeys on a non-multisig account should fail" $+ assertException+ (WalletException "The account is already complete") $ do+ res <- newAccount NewAccount+ { newAccountName = "regular-plus-more"+ , newAccountType = AccountRegular+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ addAccountKeys (fst res)+ ["xpub661MyMwAqRbcFEPH5Aon6F7edspeu1v6a1Nw5qJgk1aX5XYg1ktBL9Azra2CKaAJ2bHXEXkeKHE3eFaCJktFiA5tSMDQDs6bi83maQtdYby"]++ , testCase "Adding keys to a complete multisig account should fail" $+ assertException+ (WalletException "The account is already complete") $ do+ res <- newAccount NewAccount+ { newAccountName = "regular-plus-more"+ , newAccountType = AccountMultisig 1 2+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ [ "xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"+ , "xpub661MyMwAqRbcFEPH5Aon6F7edspeu1v6a1Nw5qJgk1aX5XYg1ktBL9Azra2CKaAJ2bHXEXkeKHE3eFaCJktFiA5tSMDQDs6bi83maQtdYby"+ ]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ addAccountKeys (fst res)+ ["xpub661MyMwAqRbcFtDszBWpawpg4KbNWL9qD4VdRwjd1L5cmcS8nXHWXpg9WL1Xc9Yh7HbQBwWDw37YJfc4AF3YEpvAHEBPBFQPFkUcFHnopw8"]++ , testCase "Getting a non-existing account should fail" $+ assertException+ (WalletException "Account inexistent does not exist") $+ getAccount "inexistent"++ ]+ , testGroup "Address tests"+ [ testCase "Decreasing the address gap should fail" $+ assertException (WalletException "The gap of an account can only be increased") $ do+ res <- newAccount NewAccount+ { newAccountName = "reduce-gap"+ , newAccountType = AccountRegular+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ accE' <- setAccountGap (fst res) 15+ setAccountGap accE' 14++ , testCase "Setting a label on a hidden address key should fail" $+ assertException (WalletException "Invalid address index 10") $ do+ res <- newAccount NewAccount+ { newAccountName = "label-hidden"+ , newAccountType = AccountRegular+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ setAddrLabel (fst res) 10 AddressExternal "Gym membership"++ , testCase "Setting a label on an invalid address key should fail" $+ assertException (WalletException "Invalid address index 20") $ do+ res <- newAccount NewAccount+ { newAccountName = "label-invalid"+ , newAccountType = AccountRegular+ , newAccountMaster = Just+ "xprv9s21ZrQH143K4a5123LatJaWPdyMvCG4Phpb79kLUXNF3Y9U537QUeKzUjkrdoZVVse747ZnNNUGryPZXEoMFjkuUKyWpEMcg7jbxYECE2b"+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ setAddrLabel (fst res) 20 AddressExternal "Gym membership"++ , testCase "Requesting an address prvkey on a read-only account should fail" $+ assertException+ (WalletException "Could not get private key") $ do+ res <- newAccount NewAccount+ { newAccountName = "label-invalid"+ , newAccountType = AccountRegular+ , newAccountMaster = Nothing+ , newAccountDeriv = Nothing+ , newAccountKeys =+ ["xpub661MyMwAqRbcH49U84sbFSXEwforKeyukvkBuY9x2ruDvLUccaRf2SeUL1f6StQke7sCuvott5CjzFqw6aA49g2NSjaARBkQdHE18zjC5hB"]+ , newAccountMnemonic = Nothing+ , newAccountReadOnly = False+ }+ addressPrvKey (fst res) Nothing 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 its coins" $ runUnit testKillOffline+ , testCase "Offline transaction exceptions" testOfflineExceptions+ , testCase "Multisig test 1" $ runUnit testImportMultisig+ , testCase "Kill Tx" $ runUnit testKillTx+ , testCase "Delete Tx" $ runUnit testDeleteTx+ , testCase "Delete Unsigned Tx" $ runUnit testDeleteUnsignedTx+ , testCase "Notifications" $ runUnit testNotification+ ]+ ]++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 ()++ms :: Mnemonic+ms = "mass coast dance birth online various renew alert crunch middle absurd health"++tid1 :: TxHash+tid1 = "0000000000000000000000000000000000000000000000000000000000000001"++z :: Hash256+z = "0000000000000000000000000000000000000000000000000000000000000000"++fakeNode :: NodeBlock -- ^ Parent+ -> [TxHash] -- ^ Transactions+ -> Word32 -- ^ Chain+ -> Word32 -- ^ Nonce+ -> NodeBlock+fakeNode parent tids chain nonce =+ nodeBlock parent chain header+ where+ header = BlockHeader+ { blockVersion = blockVersion $ nodeHeader parent+ , prevBlock = nodeHash parent+ , merkleRoot = if null tids then z else buildMerkleRoot tids+ , blockTimestamp = nodeTimestamp parent + 600+ , blockBits = blockBits $ nodeHeader parent+ , bhNonce = nonce+ }++-- -- Creates fake testing blocks+-- fakeNode :: Word32 -> BlockHash -> NodeBlock+-- fakeNode i h = BlockHeaderNode+-- { blockHeaderNodeHash = headerHash header+-- , blockHeaderNodeHeader = BlockHeader 1 z1 z2 0 0 0+-- , blockHeaderNodeHeight = i+-- , blockHeaderNodeWork = 0+-- , blockHeaderNodeMedianTimes = []+-- , blockHeaderNodeMinWork = 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+ accE <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }++ unusedAddresses accE AddressExternal (ListRequest 0 0 False)+ >>= liftIO . assertEqual "Generated external addresses do not match"+ [ "1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe"+ , "1NrcKe9UNtxjjgMSLdhBYaEgrQWQFnvJXX"+ , "123XgHRNxkprjec72EpxBFPytPim21u9Kc"+ , "16AuD3mAQMzsUHkMGfkQQapG6jhHmV3Rys"+ , "1AjF1GhsxyXCN5doPGLjSztDcuLbfYMkqw"+ , "1LPUYEjUd1u9dgjM3RqnoYj7Zt4j4dmZYA"+ , "1Kzyb5Fpj2VmMoCNWxLNMYeMSu5ocS7u7e"+ , "131L3UXV6WakXpyXvmqzqNkHwWJzWExR9i"+ , "19FWGTZERHzMePTqKoR8nB9y6w7S5u9yGr"+ , "135dwGc8JG2dmhy79onerHKdqoqibHShRJ"+ ] . map (addrToBase58 . walletAddrAddress) . fst++ unusedAddresses accE AddressInternal (ListRequest 0 0 False)+ >>= liftIO . assertEqual "Generated internal addresses do not match"+ [ "1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm"+ , "1JVocGcqZvQFbfpeQUY92iL9ARLsAP4DjW"+ , "15yaPowqF2g9B3xbdyXaPygV9bfXFjYj2X"+ , "187xp9nQTsCa7QJLHYSMyaM1Mf5u2knJYY"+ , "1QDQwk4d4zVWH3TnUHMCvDvvrTqFSaA3hr"+ , "17ATGqWhkXYLxPdynWrFjnJBvD3EYxqC5A"+ , "1EHgPV5DEs3GwUSaRQD7hd2m5MkR4hdByb"+ , "1EvUYGoC7p7GC8BtYTz4RX2ERxjUsT3zLz"+ , "15857PJZQxUH8Jgomv83mYqJqDsVEUZwz1"+ , "18L5fQjr5yXdqqnK98v2UQi1WHAXfYHr7L"+ ] . map (addrToBase58 . walletAddrAddress) . fst+++assertBalance :: AccountId -> Word32 -> Word64 -> App ()+assertBalance ai conf b = do+ bal <- accountBalance ai conf False+ liftIO $ assertEqual ("Balance is not " ++ show b) b bal++assertBalanceOffline :: AccountId -> Word32 -> Word64 -> App ()+assertBalanceOffline ai conf b = do+ bal <- accountBalance ai conf True+ liftIO $ assertEqual ("Balance is not " ++ show b) b bal++assertAddress :: Entity Account+ -> Word32 -- Confirmations+ -> Word32 -- Address Index+ -> AddressType+ -> [(KeyIndex, BalanceInfo)]+ -> App ()+assertAddress acc conf addr addrtype b = do+ b' <- addressBalances acc addr addr addrtype conf False+ liftIO $ assertEqual "Address Balance incorrect" b b'++assertAddressOffline :: Entity Account+ -> Word32 -- Confirmations+ -> Word32 -- Address Index+ -> AddressType+ -> [(KeyIndex, BalanceInfo)]+ -> App ()+assertAddressOffline acc conf addr addrtype b = do+ b' <- addressBalances acc addr addr addrtype conf True+ liftIO $ assertEqual "Address Balance incorrect" b b'++assertImportTx :: AccountId -> Int -> TxConfidence -> Tx -> App ()+assertImportTx ai as conf tx = do+ tx' <- testTx <$> importNetTx tx Nothing+ liftIO $ assertEqual "Transaction import failed" ([(ai, conf)], as) tx'++assertImportTxOffline :: AccountId -> Int -> TxConfidence -> Tx -> App ()+assertImportTxOffline ai as conf tx = do+ tx' <- testTx <$> importTx tx Nothing ai+ liftIO $ assertEqual "Transaction import failed" ([(ai, conf)], as) tx'++assertTxConfidence :: AccountId -> TxHash -> TxConfidence -> App ()+assertTxConfidence ai txh conf = do+ txM <- getBy $ UniqueAccTx ai txh+ case txM of+ Just tx -> do+ let conf' = walletTxConfidence $ entityVal tx+ liftIO $ assertEqual "Transaction confidence wrong" conf' conf+ Nothing -> liftIO $ assertFailure "Transaction not found"++testBalances :: App ()+testBalances = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let fundingTx = fakeTx+ [ (tid1, 0) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000)+ , ("1NrcKe9UNtxjjgMSLdhBYaEgrQWQFnvJXX", 20000000)+ ]+ let tx1 = fakeTx+ [ (txHash fundingTx, 0)+ , (txHash fundingTx, 1)+ ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 30000000) ] -- external+ tx2 = fakeTx+ [ (txHash fundingTx, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 5000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 5000000) -- change+ ]++ assertBalance ai 0 0++ -- Import funding transaction twice. This operation should be idempotent+ assertImportTx ai 2 TxPending fundingTx+ assertImportTx ai 0 TxPending fundingTx++ 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++ assertBalance ai 0 30000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal [(0, BalanceInfo 10000000 0 1 0)]+ assertAddress accE 0 1 AddressExternal [(1, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 1 0 AddressExternal [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 1 1 AddressExternal [(1, BalanceInfo 0 0 0 0)]++ assertImportTx ai 0 TxPending tx1++ assertBalance ai 0 0+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 1 1 AddressExternal+ [(1, BalanceInfo 0 0 0 0)]++ -- We re-import tx1. This operation has to be idempotent with respect to+ -- balances.+ assertImportTx ai 0 TxPending tx1++ assertBalance ai 1 0+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 1 1 AddressExternal+ [(1, BalanceInfo 0 0 0 0)]++ -- Importing tx2 twice. This operation has to be idempotent.+ assertImportTx ai 1 TxDead tx2+ assertImportTx ai 0 TxDead tx2++ assertBalance ai 0 0+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]++ -- Confirm the funding transaction at height 1+ let block1 = fakeNode genesisBlock [txHash fundingTx] 0 1+ importMerkles (BestChain [block1]) [[txHash fundingTx]] Nothing++ assertBalance ai 0 0+ assertBalance ai 1 0+ assertBalance ai 2 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 1 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]++ -- Confirm tx1 at height 2+ let block2 = fakeNode block1 [txHash tx1] 0 2+ importMerkles (BestChain [block2]) [[txHash tx1]] Nothing++ assertBalance ai 0 0+ assertBalance ai 1 0+ assertBalance ai 2 0+ assertBalance ai 3 0++ assertAddress accE 2 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 2 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 3 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 3 1 AddressExternal+ [(1, BalanceInfo 0 0 0 0)]++ -- Reorg on tx2+ let block2' = fakeNode block1 [] 1 22+ block3' = fakeNode block2 [txHash tx2] 1 33+ importMerkles (ChainReorg block1 [block2] [block2', block3']) [[], [txHash tx2]] Nothing++ getBy (UniqueAccTx ai (txHash tx1))+ >>= liftIO+ . assertEqual "Confidence is not dead" TxDead+ . walletTxConfidence . entityVal . fromJust++ getBy (UniqueAccTx ai (txHash tx2))+ >>= liftIO+ . assertEqual "Confidence is not building" TxBuilding+ . walletTxConfidence . entityVal . fromJust++ assertBalance ai 0 25000000+ assertBalance ai 1 25000000+ assertBalance ai 2 20000000+ assertBalance ai 3 20000000+ assertBalance ai 4 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 0 1 0)]++ assertAddress accE 3 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 3 1 AddressExternal+ [(1, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 5000000 0 1 0)]+ assertAddress accE 1 0 AddressInternal+ [(0, BalanceInfo 5000000 0 1 0)]+ assertAddress accE 2 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Reimporting tx2 should be idempotent and return TxBuilding+ assertImportTx ai 0 TxBuilding tx2++ 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++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 3 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 3 1 AddressExternal+ [(1, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 5000000 0 1 0)]+ assertAddress accE 1 0 AddressInternal+ [(0, BalanceInfo 5000000 0 1 0)]+ assertAddress accE 2 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Reorg back onto tx1+ let block3 = fakeNode block2 [] 0 3+ block4 = fakeNode block3 [] 0 4+ importMerkles (ChainReorg block1 [block2', block3'] [block2, block3, block4])+ [[txHash tx1], [], []] Nothing++ assertBalance ai 0 0+ assertBalance ai 1 0+ assertBalance ai 2 0+ assertBalance ai 3 0+ assertBalance ai 4 0+ assertBalance ai 5 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 4 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 4 1 AddressExternal+ [(1, BalanceInfo 20000000 20000000 1 1)]+ assertAddress accE 5 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 5 1 AddressExternal+ [(1, BalanceInfo 0 0 0 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++-- tx1, tx2 and tx3 form a chain, and tx4 is in conflict with tx1+testConflictBalances :: App ()+testConflictBalances = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 20000000) ]++ -- Import first transaction+ assertImportTx ai 1 TxPending tx1++ assertBalance ai 0 10000000+ assertBalance ai 0 10000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import second transaction+ assertImportTx ai 1 TxPending tx2++ assertBalance ai 0 4000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Let's confirm these two transactions+ let block1 = fakeNode genesisBlock [txHash tx1] 0 1+ block2 = fakeNode block1 [txHash tx2] 0 2+ importMerkles (BestChain [block1, block2])+ [[txHash tx1], [txHash tx2]] Nothing++ assertBalance ai 0 4000000+ assertBalance ai 1 4000000+ assertBalance ai 2 0+ assertBalance ai 3 0++ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 1 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]+ assertAddress accE 2 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 2 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Import third transaction+ assertImportTx ai 0 TxPending tx3++ assertBalance ai 0 0+ assertBalance ai 1 0+ assertBalance ai 2 0+ assertBalance ai 3 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]+ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 1 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]+ assertAddress accE 2 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 2 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Now let's add tx4 which is in conflict with tx1+ assertImportTx ai 0 TxDead tx4++ assertBalance ai 0 0+ assertBalance ai 1 0+ assertBalance ai 2 0+ assertBalance ai 3 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]+ assertAddress accE 1 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 1 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]+ assertAddress accE 2 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 2 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Now we trigger a reorg that validates tx4. tx1, tx2 and tx3 should be dead+ let block1' = fakeNode genesisBlock [] 1 11+ block2' = fakeNode block1' [txHash tx4] 1 22+ block3' = fakeNode block2' [] 1 33+ importMerkles+ (ChainReorg genesisBlock [block1, block2] [block1', block2', block3'])+ [[], [txHash tx4], []] Nothing++ assertTxConfidence ai (txHash tx1) TxDead+ assertTxConfidence ai (txHash tx2) TxDead+ assertTxConfidence ai (txHash tx3) TxDead++ assertBalance ai 0 20000000+ assertBalance ai 1 20000000+ assertBalance ai 2 20000000+ assertBalance ai 3 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 2 0 AddressExternal+ [(0, BalanceInfo 20000000 0 1 0)]+ assertAddress accE 3 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Reorg back to tx1, tx2 and tx3+ let block3 = fakeNode block2 [] 0 3+ block4 = fakeNode block3 [] 0 4+ importMerkles+ (ChainReorg genesisBlock [block1', block2', block3']+ [block1, block2, block3, block4])+ [[txHash tx1], [txHash tx2], [], []] Nothing++ assertTxConfidence ai (txHash tx1) TxBuilding+ assertTxConfidence ai (txHash tx2) TxBuilding++ -- 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.+ assertTxConfidence ai (txHash tx3) TxDead+ assertTxConfidence ai (txHash tx4) TxDead++ assertBalance ai 0 4000000+ assertBalance ai 1 4000000+ assertBalance ai 2 4000000+ assertBalance ai 3 4000000+ assertBalance ai 4 0+ assertBalance ai 5 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]+ assertAddress accE 3 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 3 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]+ assertAddress accE 4 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddress accE 4 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddress accE 5 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]++testOffline :: App ()+testOffline = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 20000000) ]++ -- Import first transaction+ assertImportTxOffline ai 1 TxOffline tx1++ assertBalance ai 0 0+ assertBalanceOffline ai 0 10000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Reimporting a transaction should me idempotent+ assertImportTxOffline ai 0 TxOffline tx1++ assertBalance ai 0 0+ assertBalanceOffline ai 0 10000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import tx2+ assertImportTxOffline ai 1 TxOffline tx2++ assertBalanceOffline ai 0 4000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Import tx3+ assertImportTxOffline ai 0 TxOffline tx3++ assertBalanceOffline ai 0 0++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]++ -- Import tx4+ assertImportTxOffline ai 0 TxOffline tx4++ assertTxConfidence ai (txHash tx1) TxDead+ assertTxConfidence ai (txHash tx2) TxDead+ assertTxConfidence ai (txHash tx3) TxDead++ assertBalanceOffline ai 0 20000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 20000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- importTx should be idempotent+ assertImportTxOffline ai 0 TxOffline tx4++ assertBalanceOffline ai 0 20000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 20000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++testKillOffline :: App ()+testKillOffline = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 2000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 3000000) -- change+ , ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 5000000) -- more change+ ]++ -- Import tx1 as a network transaction+ assertImportTx ai 1 TxPending tx1++ assertBalance ai 0 10000000+ assertBalanceOffline ai 0 10000000+ assertBalance ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]++ -- Import tx2 as offline+ assertImportTxOffline ai 1 TxOffline tx2++ assertBalance ai 0 10000000+ assertBalanceOffline ai 0 4000000+ assertBalance ai 1 0+ assertBalanceOffline ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Import tx3 as offline+ assertImportTxOffline ai 0 TxOffline tx3++ assertBalance ai 0 10000000+ assertBalanceOffline ai 0 0+ assertBalance ai 1 0+ assertBalanceOffline ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]+ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]++ -- Import tx4 as a network transaction. It should override tx2 and tx3.+ assertImportTx ai 0 TxPending tx4++ assertTxConfidence ai (txHash tx2) TxDead+ assertTxConfidence ai (txHash tx3) TxDead++ assertBalance ai 0 8000000+ assertBalanceOffline ai 0 8000000+ assertBalance ai 1 0+ assertBalanceOffline ai 1 0++ assertAddress accE 0 0 AddressExternal+ [(0, BalanceInfo 15000000 10000000 2 1)]+ assertAddress accE 0 0 AddressInternal+ [(0, BalanceInfo 3000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 15000000 10000000 2 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 3000000 0 1 0)]++testOfflineExceptions :: Assertion+testOfflineExceptions = do+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external+ tx4 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 20000000) ]++ assertException (WalletException "Could not import offline transaction") $ do+ _ <- newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ Entity ai _ <- getAccount "acc1"+ assertImportTx ai 1 TxPending tx1+ importTx tx4 Nothing ai++ assertException (WalletException "Could not import offline transaction") $ do+ _ <- newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ Entity ai _ <- getAccount "acc1"+ assertImportTx ai 1 TxPending tx4+ assertImportTx ai 0 TxDead tx1+ assertImportTx ai 1 TxDead tx2+ importTx tx3 Nothing ai++ assertException (WalletException "Could not import offline transaction") $ do+ _ <- newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ Entity ai _ <- getAccount "acc1"+ assertImportTx ai 1 TxPending tx1+ importTx tx1 Nothing ai++-- This test create a multisig account with the key of testImportMultisig2+testImportMultisig :: App ()+testImportMultisig = do+ accE1@(Entity ai1 _) <- fst <$> newAccount NewAccount+ { newAccountName = "ms1"+ , newAccountType = AccountMultisig 2 2+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = ["xpub68kRFKHWxUt3oS8X5kVogwH5rvuAd4jrLkxVfHeudFC4MfwQ8oYV59F91uFnsLXANRB1MkN4Wa1PwymE4cRsU8PE755HNCb1EoBbSoAKXpW"]+ , newAccountReadOnly = False+ }+ accE2@(Entity ai2 _) <- fst <$> newAccount NewAccount+ { newAccountName = "ms2"+ , newAccountType = AccountMultisig 2 2+ , newAccountDeriv = Just (Deriv :| 1)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = ["xpub68kRFKHWxUt3mfJjcXdLeuDjCHnByqKSBVfMktJRXM6LSNNDR4ae6Nw1Kh621fzyKiBf6ssyZWPPTDUTQp1BhuZQuoVdtb8j2TRzqDLHmY7"]+ , newAccountReadOnly = False+ }+ let fundingTx =+ Tx 1 [ TxIn (OutPoint tid1 0) (BS.pack [1]) maxBound ] -- dummy input+ [ TxOut 10000000 $+ encodeOutputBS $ PayScriptHash $ fromJust $+ base58ToAddr "32RexHZdsMoV8yzL1pQyFhYY6XeUNcWP78"+ ] 0++ importNetTx fundingTx Nothing+ >>= liftIO+ . assertEqual "Transaction import failed"+ ([(ai1, TxPending), (ai2, TxPending)], 2)+ . testTx++ -- Create a transaction which has 0 signatures in ms1+ tx1 <- fst <$> createTx accE1 Nothing Nothing+ [ ( fromJust $ base58ToAddr "3BYWaQHz6AVXx7wXmCka4846tRfa1ccWvh"+ , 5000000+ )+ ] 10000 0 False True++ liftIO $ assertEqual "Confidence is not offline" TxOffline $+ walletTxConfidence tx1++ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins" []+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai1 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx1])+ . sort . map walletTxHash . fst++ assertBalance ai1 0 10000000+ assertBalance ai1 1 0+ assertBalanceOffline ai1 0 9990000++ -- Import the empty transaction in ms2+ tx2 <- head . fst <$> importTx (walletTxTx tx1) Nothing ai2++ -- This second import should be idempotent+ _ <- importTx (walletTxTx tx1) Nothing ai2++ liftIO $ assertEqual "Txid do not match"+ (walletTxHash tx1) (walletTxHash tx2)++ liftIO $ assertEqual "Confidence is not offline" TxOffline $+ walletTxConfidence tx2++ spendableCoins ai2 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins" []+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai2 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx2])+ . sort . map walletTxHash . fst++ assertBalance ai2 0 10000000+ assertBalance ai2 1 0+ assertBalanceOffline ai2 0 9990000++ -- Sign the transaction in ms2+ tx3:_ <- fst <$> signAccountTx accE2 Nothing Nothing (walletTxHash tx2)++ liftIO $ assertEqual "Confidence is not pending" TxPending $+ walletTxConfidence tx3++ spendableCoins ai2 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins"+ [walletTxHash tx3, walletTxHash tx3]+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai2 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx3])+ . sort . map walletTxHash . fst++ assertBalance ai2 0 9990000+ assertBalance ai2 1 0+ assertBalanceOffline ai2 0 9990000++ tx4 <- fmap (entityVal . fromJust) $+ getBy $ UniqueAccTx ai1 $ walletTxHash tx3++ liftIO $ assertEqual "Confidence is not pending" TxPending $+ walletTxConfidence tx4++ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins"+ [walletTxHash tx3, walletTxHash tx3]+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai1 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx3])+ . sort . map walletTxHash . fst++ assertBalance ai1 0 9990000+ assertBalance ai1 1 0+ assertBalanceOffline ai1 0 9990000++ -- Importing the transaction should have no effect as it was globally+ -- imported already in the previous step.+ tx5 <- head . fst <$> importTx (walletTxTx tx3) Nothing ai1++ liftIO $ assertEqual "Confidence is not pending" TxPending $+ walletTxConfidence tx5++ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins"+ [walletTxHash tx5, walletTxHash tx5]+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai1 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx5])+ . sort . map walletTxHash . fst++ assertBalance ai1 0 9990000+ assertBalance ai1 1 0+ assertBalanceOffline ai1 0 9990000++testDeleteTx :: App ()+testDeleteTx = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external++ assertImportTx ai 1 TxPending tx1+ assertImportTx ai 1 TxPending tx2+ assertImportTx ai 0 TxPending tx3++ assertBalance ai 0 0++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]++ tx2M' <- getTx $ txHash tx2+ liftIO $ assertBool "Transaction 2 not found" $ isJust tx2M'+ deleteTx $ txHash tx2++ tx1M <- getTx $ txHash tx1+ tx2M'' <- getTx $ txHash tx2+ tx3M <- getTx $ txHash tx3+ liftIO $ assertEqual "Transaction 1 removed" (Just tx1) tx1M+ liftIO $ assertEqual "Transaction 2 not removed" Nothing tx2M''+ liftIO $ assertEqual "Transaction 3 not removed" Nothing tx3M++ assertBalance ai 0 10000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++testDeleteUnsignedTx :: App ()+testDeleteUnsignedTx = do+ accE1@(Entity ai1 _) <- fst <$> newAccount NewAccount+ { newAccountName = "ms1"+ , newAccountType = AccountMultisig 2 2+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = ["xpub68kRFKHWxUt3oS8X5kVogwH5rvuAd4jrLkxVfHeudFC4MfwQ8oYV59F91uFnsLXANRB1MkN4Wa1PwymE4cRsU8PE755HNCb1EoBbSoAKXpW"]+ , newAccountReadOnly = False+ }+ Entity ai2 _ <- fst <$> newAccount NewAccount+ { newAccountName = "ms2"+ , newAccountType = AccountMultisig 2 2+ , newAccountDeriv = Just (Deriv :| 1)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = ["xpub68kRFKHWxUt3mfJjcXdLeuDjCHnByqKSBVfMktJRXM6LSNNDR4ae6Nw1Kh621fzyKiBf6ssyZWPPTDUTQp1BhuZQuoVdtb8j2TRzqDLHmY7"]+ , newAccountReadOnly = False+ }+ let fundingTx =+ Tx 1 [ TxIn (OutPoint tid1 0) (BS.pack [1]) maxBound ] -- dummy input+ [ TxOut 10000000 $+ encodeOutputBS $ PayScriptHash $ fromJust $+ base58ToAddr "32RexHZdsMoV8yzL1pQyFhYY6XeUNcWP78"+ ] 0++ importNetTx fundingTx Nothing+ >>= liftIO+ . assertEqual "Confidence is not pending"+ ([(ai1, TxPending), (ai2, TxPending)], 2)+ . testTx++ -- Create a transaction which has 0 signatures in ms1+ tx1 <- fst <$> createTx accE1 Nothing Nothing+ [ ( fromJust $ base58ToAddr "3BYWaQHz6AVXx7wXmCka4846tRfa1ccWvh"+ , 5000000+ )+ ] 10000 0 False True++ liftIO $ assertEqual "Confidence is not offline" TxOffline $+ walletTxConfidence tx1++ spendableCoins ai1 0 (const . const [])+ >>= liftIO+ . assertEqual "Wrong txhash in coins" []+ . map (walletCoinHash . entityVal . inCoinDataCoin)++ txs Nothing ai1 (ListRequest 0 10 False)+ >>= liftIO+ . assertEqual "Wrong txhash in tx list"+ (sort [txHash fundingTx, walletTxHash tx1])+ . sort . map walletTxHash . fst++ assertBalance ai1 0 10000000+ assertBalance ai1 1 0+ assertBalanceOffline ai1 0 9990000++ tx1EM <- getTx $ walletTxHash tx1+ liftIO $ assertBool "Transaction 1 not found" $ isJust tx1EM+ deleteTx $ walletTxHash tx1++ tx1M <- getTx $ walletTxHash tx1+ liftIO $ assertEqual "Transaction not removed" Nothing tx1M++testNotification :: App ()+testNotification = do+ _ <- newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external++ notifChan <- liftIO $ atomically $ newTBMChan 1000++ _ <- importNetTx tx1 (Just notifChan)+ tx1NM <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx1NM of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Notif hash does not match" (txHash tx1) jsonTxHash+ _ -> assertFailure "Transaction notification is not the right type"++ _ <- importNetTx tx2 (Just notifChan)+ tx2NM <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx2NM of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Notif hash does not match" (txHash tx2) jsonTxHash+ _ -> assertFailure "Transaction notification is not the right type"++ _ <- importNetTx tx3 Nothing++ let block1 = fakeNode genesisBlock [txHash tx1] 0 1+ block2 = fakeNode block1 [txHash tx2] 0 2+ best = BestChain [block1, block2]+ txs1 = [[txHash tx1], [txHash tx2]]+ importMerkles best txs1 (Just notifChan)+ b1NM <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case b1NM of+ Just (NotifBlock JsonBlock{..}) ->+ assertEqual "Block hash does not match"+ (nodeHash block1) jsonBlockHash+ _ -> assertFailure "Block notification not the right type"+ tx1NM' <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx1NM' of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Transaction list does not match" (txHash tx1)+ jsonTxHash+ _ -> assertFailure "Transaction notification not the right type"+ b2NM <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case b2NM of+ Just (NotifBlock JsonBlock{..}) ->+ assertEqual "Block hash does not match"+ (nodeHash block2) jsonBlockHash+ _ -> assertFailure "Block notification not the right type"+ tx2NM' <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx2NM' of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Transaction list does not match" (txHash tx2)+ jsonTxHash+ _ -> assertFailure "Transaction notification not the right type"+++ let block2' = fakeNode block1 [txHash tx2, txHash tx3] 1 22+ txs2 = [[txHash tx2, txHash tx3]]+ reorg = ChainReorg block1 [block2] [block2']+ importMerkles reorg txs2 (Just notifChan)+ b3NM <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case b3NM of+ Just (NotifBlock JsonBlock{..}) ->+ assertEqual "Block hash does not match"+ (nodeHash block2') jsonBlockHash+ _ -> assertFailure "Block notification not the right type"+ tx3NM2 <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx3NM2 of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Transaction does not match"+ (txHash tx2)+ jsonTxHash+ _ -> assertFailure "Transaction notification not the right type"+ tx3NM3 <- liftIO $ atomically $ readTBMChan notifChan+ liftIO $ case tx3NM3 of+ Just (NotifTx JsonTx{..}) ->+ assertEqual "Transaction does not match"+ (txHash tx3)+ jsonTxHash+ _ -> assertFailure "Transaction notification not the right type"+++testKillTx :: App ()+testKillTx = do+ accE@(Entity ai _) <- fst <$> newAccount NewAccount+ { newAccountName = "acc1"+ , newAccountType = AccountRegular+ , newAccountDeriv = Just (Deriv :| 0)+ , newAccountMaster = Nothing+ , newAccountMnemonic = Just (cs ms)+ , newAccountKeys = []+ , newAccountReadOnly = False+ }+ let tx1 = fakeTx+ [ (tid1, 4) ]+ [ ("1DLW4wieCwUPMh6ThVwT2bKqSzkjeb8wUe", 10000000) ]+ tx2 = fakeTx+ [ (txHash tx1, 0) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 6000000) -- external+ , ("1PY7pWZ5FddWi747C6k5Y7okNHFUM2BKAm", 4000000) -- change+ ]+ tx3 = fakeTx+ [ (txHash tx2, 1) ]+ [ ("1MchgrtQEUgV1f7Nqe1vEzvdmBzJHz8zrY", 4000000) ] -- external++ assertImportTx ai 1 TxPending tx1+ assertImportTx ai 1 TxPending tx2+ assertImportTx ai 0 TxPending tx3++ assertBalanceOffline ai 0 0++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 4000000 1 1)]++ killTxs Nothing [txHash tx2]++ assertBalanceOffline ai 0 10000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ -- Killing a transaction should be idempotent+ killTxs Nothing [txHash tx2]++ assertBalanceOffline ai 0 10000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ killTxs Nothing [txHash tx3]++ assertBalanceOffline ai 0 10000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 0 1 0)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 0 0 0 0)]++ reviveTx Nothing tx2++ assertBalanceOffline ai 0 4000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]++ -- Reviving a transaction should be idempotent+ reviveTx Nothing tx2++ assertBalanceOffline ai 0 4000000++ assertAddressOffline accE 0 0 AddressExternal+ [(0, BalanceInfo 10000000 10000000 1 1)]+ assertAddressOffline accE 0 0 AddressInternal+ [(0, BalanceInfo 4000000 0 1 0)]++testTx :: ([WalletTx], [WalletAddr])+ -> ([(AccountId, TxConfidence)], Int)+testTx (txls, addrs) = (map f txls, length addrs)+ where+ f tx = (walletTxAccount tx, walletTxConfidence tx)