diff --git a/Network/Haskoin/Wallet.hs b/Network/Haskoin/Wallet.hs --- a/Network/Haskoin/Wallet.hs +++ b/Network/Haskoin/Wallet.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Accounts.hs b/Network/Haskoin/Wallet/Accounts.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Accounts.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Block.hs b/Network/Haskoin/Wallet/Block.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Block.hs @@ -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) diff --git a/Network/Haskoin/Wallet/Client.hs b/Network/Haskoin/Wallet/Client.hs --- a/Network/Haskoin/Wallet/Client.hs +++ b/Network/Haskoin/Wallet/Client.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Client/Commands.hs b/Network/Haskoin/Wallet/Client/Commands.hs --- a/Network/Haskoin/Wallet/Client/Commands.hs +++ b/Network/Haskoin/Wallet/Client/Commands.hs @@ -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] diff --git a/Network/Haskoin/Wallet/Database.hs b/Network/Haskoin/Wallet/Database.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Database.hs @@ -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 + diff --git a/Network/Haskoin/Wallet/Internals.hs b/Network/Haskoin/Wallet/Internals.hs --- a/Network/Haskoin/Wallet/Internals.hs +++ b/Network/Haskoin/Wallet/Internals.hs @@ -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 diff --git a/Network/Haskoin/Wallet/KeyRing.hs b/Network/Haskoin/Wallet/KeyRing.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/KeyRing.hs +++ /dev/null @@ -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 - diff --git a/Network/Haskoin/Wallet/Model.hs b/Network/Haskoin/Wallet/Model.hs --- a/Network/Haskoin/Wallet/Model.hs +++ b/Network/Haskoin/Wallet/Model.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Server.hs b/Network/Haskoin/Wallet/Server.hs --- a/Network/Haskoin/Wallet/Server.hs +++ b/Network/Haskoin/Wallet/Server.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Server/Handler.hs b/Network/Haskoin/Wallet/Server/Handler.hs --- a/Network/Haskoin/Wallet/Server/Handler.hs +++ b/Network/Haskoin/Wallet/Server/Handler.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Settings.hs b/Network/Haskoin/Wallet/Settings.hs --- a/Network/Haskoin/Wallet/Settings.hs +++ b/Network/Haskoin/Wallet/Settings.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Transaction.hs b/Network/Haskoin/Wallet/Transaction.hs --- a/Network/Haskoin/Wallet/Transaction.hs +++ b/Network/Haskoin/Wallet/Transaction.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Types.hs b/Network/Haskoin/Wallet/Types.hs --- a/Network/Haskoin/Wallet/Types.hs +++ b/Network/Haskoin/Wallet/Types.hs @@ -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 diff --git a/config/config.yml b/config/config.yml --- a/config/config.yml +++ b/config/config.yml @@ -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: diff --git a/config/help b/config/help --- a/config/help +++ b/config/help @@ -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 diff --git a/config/models b/config/models --- a/config/models +++ b/config/models @@ -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 diff --git a/database/mysql/Network/Haskoin/Wallet/Database.hs b/database/mysql/Network/Haskoin/Wallet/Database.hs deleted file mode 100644 --- a/database/mysql/Network/Haskoin/Wallet/Database.hs +++ /dev/null @@ -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 - diff --git a/database/sqlite/Network/Haskoin/Wallet/Database.hs b/database/sqlite/Network/Haskoin/Wallet/Database.hs deleted file mode 100644 --- a/database/sqlite/Network/Haskoin/Wallet/Database.hs +++ /dev/null @@ -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 - diff --git a/haskoin-wallet.cabal b/haskoin-wallet.cabal --- a/haskoin-wallet.cabal +++ b/haskoin-wallet.cabal @@ -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 diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -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 diff --git a/tests/Network/Haskoin/Wallet/Arbitrary.hs b/tests/Network/Haskoin/Wallet/Arbitrary.hs --- a/tests/Network/Haskoin/Wallet/Arbitrary.hs +++ b/tests/Network/Haskoin/Wallet/Arbitrary.hs @@ -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 diff --git a/tests/Network/Haskoin/Wallet/Tests.hs b/tests/Network/Haskoin/Wallet/Tests.hs --- a/tests/Network/Haskoin/Wallet/Tests.hs +++ b/tests/Network/Haskoin/Wallet/Tests.hs @@ -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) diff --git a/tests/Network/Haskoin/Wallet/Units.hs b/tests/Network/Haskoin/Wallet/Units.hs --- a/tests/Network/Haskoin/Wallet/Units.hs +++ b/tests/Network/Haskoin/Wallet/Units.hs @@ -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)