diff --git a/Network/Haskoin/Wallet.hs b/Network/Haskoin/Wallet.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-| - This package provides a command line application called /hw/ (haskoin - wallet). It is a lightweight bitcoin wallet featuring BIP32 key management, - deterministic signatures (RFC-6979) and first order support for - multisignature transactions. A library API for /hw/ is also exposed. --} -module Network.Haskoin.Wallet -( --- *Client - clientMain -, OutputFormat(..) -, Config(..) - --- *Server -, runSPVServer -, stopSPVServer -, SPVMode(..) - --- *API JSON Types -, JsonAccount(..) -, JsonAddr(..) -, JsonCoin(..) -, JsonTx(..) - --- *API Request Types -, WalletRequest(..) -, ListRequest(..) -, NewAccount(..) -, SetAccountGap(..) -, OfflineTxData(..) -, CoinSignData(..) -, TxAction(..) -, AddressLabel(..) -, NodeAction(..) -, AccountType(..) -, AddressType(..) -, addrTypeIndex -, TxType(..) -, TxConfidence(..) -, AddressInfo(..) -, BalanceInfo(..) - --- *API Response Types -, WalletResponse(..) -, TxCompleteRes(..) -, ListResult(..) -, RescanRes(..) - --- *Database Accounts -, initWallet -, accounts -, newAccount -, addAccountKeys -, getAccount -, isMultisigAccount -, isReadAccount -, isCompleteAccount - --- *Database Addresses -, getAddress -, addressesAll -, addresses -, addressList -, unusedAddresses -, addressCount -, setAddrLabel -, addressPrvKey -, useAddress -, setAccountGap -, firstAddrTime -, getPathRedeem -, getPathPubKey - --- *Database Bloom Filter -, getBloomFilter - --- *Database transactions -, txs -, addrTxs -, getTx -, getAccountTx -, importTx -, importNetTx -, signAccountTx -, createWalletTx -, signOfflineTx -, getOfflineTxData - --- *Database blocks -, importMerkles -, walletBestBlock - --- *Database coins and balances -, spendableCoins -, accountBalance -, addressBalances - --- *Rescan -, resetRescan -) where - -import Network.Haskoin.Wallet.Client -import Network.Haskoin.Wallet.Server -import Network.Haskoin.Wallet.Settings -import Network.Haskoin.Wallet.Types -import Network.Haskoin.Wallet.Accounts -import Network.Haskoin.Wallet.Transaction - diff --git a/Network/Haskoin/Wallet/Accounts.hs b/Network/Haskoin/Wallet/Accounts.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Accounts.hs +++ /dev/null @@ -1,709 +0,0 @@ -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 -, lookupByPubKey -, 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 Data.Serialize (encode) - -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 - -lookupByPubKey :: (MonadIO m, MonadThrow m) - => Entity Account -- ^ Account Entity - -> PubKeyC -- ^ Pubkey of interest - -> AddressType -- ^ Address type - -> SqlPersistT m [WalletAddr] -lookupByPubKey (Entity ai _) key addrType = - fmap (map entityVal) $ select $ from $ \x -> do - where_ ( x ^. WalletAddrAccount ==. val ai - &&. x ^. WalletAddrType ==. val addrType - &&. x ^. WalletAddrKey ==. val (Just key) - ) - return x - --- | 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 deleted file mode 100644 --- a/Network/Haskoin/Wallet/Block.hs +++ /dev/null @@ -1,59 +0,0 @@ -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 deleted file mode 100644 --- a/Network/Haskoin/Wallet/Client.hs +++ /dev/null @@ -1,252 +0,0 @@ -module Network.Haskoin.Wallet.Client (clientMain) where - -import System.FilePath (()) -import System.Directory (createDirectoryIfMissing) -import System.Posix.Directory (changeWorkingDirectory) -import System.Posix.Files - ( setFileMode - , setFileCreationMask - , unionFileModes - , ownerModes - , groupModes - , otherModes - , fileExist - ) -import System.Environment (getArgs, lookupEnv) -import System.Info (os) -import System.Console.GetOpt - ( getOpt - , usageInfo - , OptDescr (Option) - , ArgDescr (NoArg, ReqArg) - , ArgOrder (Permute) - ) - -import Control.Monad (when, forM_) -import Control.Monad.Trans (liftIO) -import qualified Control.Monad.Reader as R (runReaderT) - -import Data.Default (def) -import Data.FileEmbed (embedFile) -import 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 -usageHeader = "Usage: hw [] []" - -cmdHelp :: [String] -cmdHelp = lines $ cs $ $(embedFile "config/help") - -warningMsg :: String -warningMsg = unwords - [ "!!!", "This software is experimental." - , "Use only small amounts of Bitcoins.", "!!!" - ] - -usage :: [String] -usage = warningMsg : usageInfo usageHeader options : cmdHelp - -read' :: Read x => String -> String -> x -read' e s = case reads s of - [(x, "")] -> x - _ -> error e - -options :: [OptDescr (Config -> Config)] -options = - [ 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' "Colud not parse minconf" s } - ) "INT" - ) $ "Minimum confirmations. Default: " - ++ show (configMinConf def) - , Option "f" ["fee"] - ( 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) - , Option "S" ["nosig"] - (NoArg $ \cfg -> cfg { configSignTx = False }) $ - "Do not sign. Default: " ++ show (not $ configSignTx def) - , Option "i" ["internal"] - (NoArg $ \cfg -> cfg { configAddrType = AddressInternal }) $ - "Internal addresses. Default: " - ++ show (configAddrType def == AddressInternal) - , Option "o" ["offline"] - (NoArg $ \cfg -> cfg { configOffline = True }) $ - "Offline balance. Default: " ++ show (configOffline def) - , Option "r" ["revpage"] - (NoArg $ \cfg -> cfg { configReversePaging = True }) $ - "Reverse paging. Default: " - ++ show (configReversePaging def) - , Option "p" ["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" - , Option "y" ["yaml"] - (NoArg $ \cfg -> cfg { configFormat = OutputYAML }) - "Output YAML" - , Option "s" ["socket"] - (ReqArg (\s cfg -> cfg { configConnect = s }) "URI") $ - "Server socket. Default: " ++ configConnect def - , Option "d" ["detach"] - (NoArg $ \cfg -> cfg { configDetach = True }) $ - "Detach server. Default: " ++ show (configDetach def) - , Option "t" ["testnet"] - (NoArg $ \cfg -> cfg { configTestnet = True }) "Testnet3 network" - , Option "g" ["config"] - (ReqArg (\s cfg -> cfg { configFile = s }) "FILE") $ - "Config file. Default: " ++ configFile def - , Option "w" ["workdir"] - (ReqArg (\s cfg -> cfg { configDir = s }) "DIR") - "Working directory. OS-dependent default" - , Option "v" ["verbose"] - (NoArg $ \cfg -> cfg { configVerbose = True }) "Verbose output" - ] - --- Create and change current working directory -setWorkDir :: Config -> IO () -setWorkDir cfg = do - let workDir = configDir cfg networkName - _ <- setFileCreationMask $ otherModes `unionFileModes` groupModes - createDirectoryIfMissing True workDir - setFileMode workDir ownerModes - changeWorkingDirectory workDir - --- Build application configuration -getConfig :: [Config -> Config] -> IO Config -getConfig fs = do - -- Create initial configuration from defaults and command-line arguments - let initCfg = foldr ($) def fs - - -- If working directory set in initial configuration, use it - dir <- case configDir initCfg of "" -> appDir - d -> return d - - -- Make configuration file relative to working directory - let cfgFile = if isAbsolute (configFile initCfg) - then configFile initCfg - else dir configFile initCfg - - -- Get configuration from file, if it exists - e <- fileExist cfgFile - if e then do - cfgE <- decodeFileEither cfgFile - case cfgE of - Left x -> error $ show x - -- Override settings from file using command-line - Right cfg -> return $ fixConfigDir (foldr ($) cfg fs) dir - else return $ fixConfigDir initCfg dir - where - -- If working directory not set, use default - fixConfigDir cfg dir = case configDir cfg of "" -> cfg{ configDir = dir } - _ -> cfg - - -clientMain :: IO () -clientMain = getArgs >>= \args -> case getOpt Permute options args of - (fs, commands, []) -> do - cfg <- getConfig fs - when (configTestnet cfg) switchToTestnet3 - setWorkDir cfg - dispatchCommand cfg commands - (_, _, msgs) -> forM_ (msgs ++ usage) putStrLn - -dispatchCommand :: Config -> [String] -> IO () -dispatchCommand cfg args = flip R.runReaderT cfg $ case args of - "start" : [] -> cmdStart - "stop" : [] -> cmdStop - "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 - "pubkeys" : name : page -> cmdPubKeys 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 - "getindex" : name : key : [] -> cmdKeyIndex name key - "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 - "blockinfo" : hashes -> cmdBlockInfo hashes - "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 - "mingw32" -> windows - "mingw64" -> windows - "darwin" -> osx - "linux" -> unix - _ -> unix - where - windows = do - localAppData <- lookupEnv "LOCALAPPDATA" - dirM <- case localAppData of - Nothing -> lookupEnv "APPDATA" - Just l -> return $ Just l - case dirM of - Just d -> return $ d "Haskoin Wallet" - Nothing -> return "." - osx = do - homeM <- lookupEnv "HOME" - case homeM of - Just home -> return $ home "Library" - "Application Support" - "Haskoin Wallet" - Nothing -> return "." - unix = do - homeM <- lookupEnv "HOME" - case homeM of - Just home -> return $ home ".hw" - Nothing -> return "." - diff --git a/Network/Haskoin/Wallet/Client/Commands.hs b/Network/Haskoin/Wallet/Client/Commands.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Client/Commands.hs +++ /dev/null @@ -1,970 +0,0 @@ -module Network.Haskoin.Wallet.Client.Commands -( cmdStart -, cmdStop -, cmdNewAcc -, cmdAddKey -, cmdSetGap -, cmdAccount -, cmdRenameAcc -, cmdAccounts -, cmdList -, cmdPubKeys -, cmdUnused -, cmdLabel -, cmdTxs -, cmdAddrTxs -, cmdKeyIndex -, cmdGenAddrs -, cmdSend -, cmdSendMany -, cmdImport -, cmdSign -, cmdBalance -, cmdGetTx -, cmdGetOffline -, cmdSignOffline -, cmdRescan -, cmdDecodeTx -, cmdVersion -, cmdStatus -, cmdBlockInfo -, cmdMonitor -, cmdSync -, cmdKeyPair -, cmdDeleteTx -, cmdPending -, cmdDead -) -where - -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, object, - toJSON, (.=)) -import qualified Data.Aeson as Aeson (encode) -import qualified Data.ByteString.Char8 as B8 (hPutStrLn, putStrLn, - unwords) -import Data.String (fromString) -import Data.List (intercalate, intersperse) -import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe, maybeToList) -import Data.Monoid ((<>)) -import Data.Restricted (rvalue) -import Data.Serialize (encode) -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 qualified Data.Time.Format as Time -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 Network.Haskoin.Wallet.Client.PrettyJson as JSON -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 - cfg <- R.ask - liftIO $ runSPVServer cfg - --- hw stop [config] -cmdStop :: Handler () -cmdStop = do - resE <- sendZmq StopServerR - handleResponse (resE :: Either String (WalletResponse (Maybe ()))) (const $ return ()) - liftIO $ putStrLn "Process stopped" - -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" - -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 - -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 - 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? -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 - 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" - -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 - resE <- sendZmq (PostAccountGapR (pack name) setGap) - handleResponse resE $ liftIO . putStr . printAccount - where - setGap = SetAccountGap $ read gap - -cmdAccount :: String -> Handler () -cmdAccount name = do - resE <- sendZmq (GetAccountR $ pack name) - handleResponse resE $ liftIO . putStr . printAccount - -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 - -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 () -listAction page requestBuilder action = do - c <- R.asks configCount - r <- R.asks configReversePaging - 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 - pages m c | m `mod` c == 0 = m `div` c - | otherwise = m `div` c + 1 - -listJsonAddrs :: (JsonAddr -> String) - -> String - -> [String] - -> Handler () -listJsonAddrs showFunc name ls = do - t <- R.asks configAddrType - m <- R.asks configMinConf - o <- R.asks configOffline - let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe - f = GetAddressesR (pack name) t m o - listAction page f $ \as -> forM_ as (liftIO . putStrLn . showFunc) - -cmdList :: String -> [String] -> Handler () -cmdList = listJsonAddrs printAddress - -cmdPubKeys :: String -> [String] -> Handler () -cmdPubKeys = listJsonAddrs printPubKey - -cmdUnused :: String -> [String] -> Handler () -cmdUnused name ls = do - t <- R.asks configAddrType - 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 - t <- R.asks configAddrType - 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 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 ls = do - t <- R.asks configAddrType - m <- R.asks configMinConf - o <- R.asks configOffline - r <- R.asks configReversePaging - 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 - index = fromMaybe (error "Could not read index") $ readMaybe i - -cmdKeyIndex :: String -> String -> Handler () -cmdKeyIndex name k = do - t <- R.asks configAddrType - resE <- sendZmq $ GetIndexR (pack name) (fromString k) t - handleResponse resE $ \res -> case res of - [] -> liftIO $ putStrLn "No matching pubkeys found" - lst -> liftIO $ putStrLn $ unlines $ -- Two or more pubkeys with the same index is extremely improbable. But let's print it out if it happens. - map (\adr -> showLine (jsonAddrIndex adr, jsonAddrKey adr)) lst - where - showLine :: (KeyIndex, Maybe PubKeyC) -> String - showLine (idx,k') = unwords [ show (idx :: KeyIndex), ":", showPubKey k' ] - showPubKey = maybe "" (jsonStr2Str . toJSON) - jsonStr2Str (String t) = cs t - jsonStr2Str _ = "" - -cmdGenAddrs :: String -> String -> Handler () -cmdGenAddrs name i = do - t <- R.asks configAddrType - 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 - -cmdSend :: String -> String -> String -> Handler () -cmdSend name addrStr amntStr = cmdSendMany name [addrStr ++ ":" ++ amntStr] - -cmdSendMany :: String -> [String] -> Handler () -cmdSendMany name xs = case rcpsM of - Just rcps -> do - 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 - 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) (readMaybe $ cs v) - f _ = Nothing - rcpsM = mapM (f . g) xs - -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 - masterM <- getSigningKeys name - let action = SignTx txid - resE <- sendZmq (PostTxsR (pack name) masterM action) - handleResponse resE $ liftIO . putStr . printTx Nothing - _ -> error "Could not parse txid" - where - txidM = hexToTxHash $ cs txidStr - -cmdGetOffline :: String -> String -> Handler () -cmdGetOffline name tidStr = case tidM of - Just tid -> do - 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 $ Aeson.encode dat ] - _ -> error "Could not parse txid" - where - tidM = hexToTxHash $ cs tidStr - -cmdSignOffline :: String -> String -> String -> Handler () -cmdSignOffline name txStr datStr = case (txM, datM) of - (Just tx, Just dat) -> do - 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) - txM = decodeToMaybe =<< decodeHex (cs txStr) - -cmdBalance :: String -> Handler () -cmdBalance name = do - m <- R.asks configMinConf - o <- R.asks configOffline - 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 - 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 = 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 - tidM = hexToTxHash $ cs tidStr - -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 tx - _ -> YAML.encode $ val tx - where - val = encodeTxJSON - jsn = JSON.encodePretty . val - -cmdVersion :: Handler () -cmdVersion = liftIO $ do - putStrLn $ unwords [ "network :", cs networkName ] - putStrLn $ unwords [ "user-agent:", cs haskoinUserAgent ] - -cmdStatus :: Handler () -cmdStatus = do - v <- R.asks configVerbose - 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 ] - -cmdBlockInfo :: [String] -> Handler () -cmdBlockInfo headers = do - -- Show best block if no arguments are provided - hashL <- if null headers then - -- Fetch best block hash from status msg, and return as list - (: []) . parseRes <$> sendZmq (PostNodeR NodeActionStatus) - else - return (map fromString headers) - sendZmq (GetBlockInfoR hashL) >>= - \resE -> handleResponse resE (liftIO . printResults) - where - printResults :: [BlockInfo] -> IO () - printResults = mapM_ $ putStrLn . unlines . printBlockInfo - parseRes :: Either String (WalletResponse NodeStatus) -> BlockHash - parseRes = nodeStatusBestHeader . fromMaybe - (error "No response to NodeActionStatus msg") . parseResponse - - -{- Helpers -} - -handleNotif :: OutputFormat -> Either String Notif -> IO () -handleNotif _ (Left e) = error e -handleNotif fmt (Right notif) = case fmt of - OutputJSON -> formatStr $ cs $ - JSON.encodePretty notif - OutputYAML -> do - putStrLn "---" - formatStr $ cs $ YAML.encode notif - putStrLn "..." - OutputNormal -> - putStrLn $ printNotif notif - -parseResponse - :: Either String (WalletResponse a) - -> Maybe a -parseResponse resE = case resE of - Right (ResponseValid resM) -> resM - Right (ResponseError err) -> error $ unpack err - Left err -> error err - -handleResponse - :: (FromJSON a, ToJSON a) - => Either String (WalletResponse a) - -> (a -> Handler ()) - -> Handler () -handleResponse resE handle = case parseResponse resE of - Just a -> formatOutput a =<< R.asks configFormat - Nothing -> return () - where - formatOutput a format = case format of - OutputJSON -> liftIO . formatStr $ cs $ - JSON.encodePretty 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 $ Aeson.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 $ Aeson.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 - -encodeTxJSON :: Tx -> Value -encodeTxJSON tx = object - [ "txid" .= (cs $ txHashToHex (txHash tx) :: Text) - , "version" .= txVersion tx - , "inputs" .= map encodeTxInJSON (txIn tx) - , "outputs" .= map encodeTxOutJSON (txOut tx) - , "locktime" .= txLockTime tx - ] - -encodeTxInJSON :: TxIn -> Value -encodeTxInJSON (TxIn o s i) = object $ - [ "outpoint" .= encodeOutPointJSON o - , "sequence" .= i - , "raw-script" .= (cs $ encodeHex s :: Text) - , "script" .= encodeScriptJSON sp - ] ++ decoded - where - sp = fromMaybe (Script []) $ decodeToMaybe s - decoded = either (const []) f $ decodeInputBS s - f inp = ["decoded-script" .= encodeScriptInputJSON inp] - -encodeTxOutJSON :: TxOut -> Value -encodeTxOutJSON (TxOut v s) = object $ - [ "value" .= v - , "raw-script" .= (cs $ encodeHex s :: Text) - , "script" .= encodeScriptJSON sp - ] ++ decoded - where - sp = fromMaybe (Script []) $ decodeToMaybe s - decoded = either (const []) - (\out -> ["decoded-script" .= encodeScriptOutputJSON out]) - (decodeOutputBS s) - -encodeOutPointJSON :: OutPoint -> Value -encodeOutPointJSON (OutPoint h i) = object - [ "txid" .= (cs $ txHashToHex h :: Text) - , "pos" .= i - ] - -encodeScriptJSON :: Script -> Value -encodeScriptJSON (Script ops) = - toJSON $ map f ops - where - f (OP_PUSHDATA bs _) = String $ pack $ unwords - ["OP_PUSHDATA", cs $ encodeHex bs] - f x = String $ pack $ show x - -encodeScriptInputJSON :: ScriptInput -> Value -encodeScriptInputJSON si = case si of - RegularInput (SpendPK s) -> object - [ "spendpubkey" .= object [ "sig" .= encodeSigJSON s ] ] - RegularInput (SpendPKHash s p) -> object - [ "spendpubkeyhash" .= object - [ "sig" .= encodeSigJSON s - , "pubkey" .= (cs $ encodeHex (encode p) :: Text) - , "sender-address" .= (cs $ addrToBase58 (pubKeyAddr p) :: Text) - ] - ] - RegularInput (SpendMulSig sigs) -> object - [ "spendmulsig" .= object [ "sigs" .= map encodeSigJSON sigs ] ] - ScriptHashInput s r -> object - [ "spendscripthash" .= object - [ "scriptinput" .= encodeScriptInputJSON (RegularInput s) - , "redeem" .= encodeScriptOutputJSON r - , "raw-redeem" .= (cs $ encodeHex (encodeOutputBS r) :: Text) - , "sender-address" .= (cs $ addrToBase58 (scriptAddr r) :: Text) - ] - ] - -encodeScriptOutputJSON :: ScriptOutput -> Value -encodeScriptOutputJSON so = case so of - PayPK p -> object - [ "pay2pubkey" .= object - [ "pubkey" .= (cs $ encodeHex (encode p) :: Text) ] - ] - PayPKHash a -> object - [ "pay2pubkeyhash" .= object - [ "address-base64" .= - (cs $ encodeHex (encode $ getAddrHash a) :: Text) - , "address-base58" .= (cs $ addrToBase58 a :: Text) - ] - ] - PayMulSig ks r -> object - [ "pay2mulsig" .= object - [ "required-keys" .= r - , "pubkeys" .= (map (cs . encodeHex . encode) ks :: [Text]) - ] - ] - PayScriptHash a -> object - [ "pay2scripthash" .= object - [ "address-base64" .= (cs $ encodeHex $ encode $ getAddrHash a :: Text) - , "address-base58" .= (cs (addrToBase58 a) :: Text) - ] - ] - DataCarrier bs -> object - [ "op_return" .= object - [ "data" .= (cs $ encodeHex bs :: Text) - ] - ] - -encodeSigJSON :: TxSignature -> Value -encodeSigJSON ts@(TxSignature _ sh) = object - [ "raw-sig" .= (cs $ encodeHex (encodeSig ts) :: Text) - , "sighash" .= encodeSigHashJSON sh - ] - -encodeSigHashJSON :: SigHash -> Value -encodeSigHashJSON sh = case sh of - SigAll acp -> object - [ "type" .= String "SigAll" - , "acp" .= acp - ] - SigNone acp -> object - [ "type" .= String "SigNone" - , "acp" .= acp - ] - SigSingle acp -> object - [ "type" .= String "SigSingle" - , "acp" .= acp - ] - SigUnknown acp v -> object - [ "type" .= String "SigUnknown" - , "acp" .= acp - , "value" .= v - ] - -{- Print utilities -} - -printAccount :: JsonAccount -> String -printAccount JsonAccount{..} = unlines $ - [ "Account : " ++ unpack jsonAccountName - , "Type : " ++ showType - , "Gap : " ++ show jsonAccountGap - ] - ++ - [ "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) - showType = case jsonAccountType of - 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 - ] - -printAddress :: JsonAddr -> String -printAddress JsonAddr{..} = unwords $ - [ show jsonAddrIndex, ":", cs (addrToBase58 jsonAddrAddress) ] - ++ - [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ] - ++ concat - [ [ "[Received: " ++ show (balanceInfoInBalance bal) ++ "]" - , "[Coins: " ++ show (balanceInfoCoins bal) ++ "]" - , "[Spent Coins: " ++ show (balanceInfoSpentCoins bal) ++ "]" - ] - | isJust jsonAddrBalance && balanceInfoCoins bal > 0 - ] - where - bal = fromMaybe (error "Could not get address balance") jsonAddrBalance - -printPubKey :: JsonAddr -> String -printPubKey JsonAddr{..} = unwords $ - [ show jsonAddrIndex, ":", showPubKey jsonAddrKey ] - ++ - [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ] - where - showPubKey = maybe "" (jsonStr2Str . toJSON) - jsonStr2Str (String t) = cs t - jsonStr2Str _ = "" -- It totally is a String though - -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 ] - ++ concat - [ printAddrInfos "Inputs : " jsonTxInputs - | not (null jsonTxInputs) - ] - ++ concat - [ printAddrInfos "Outputs : " jsonTxOutputs - | not (null jsonTxOutputs) - ] - ++ concat - [ printAddrInfos "Change : " jsonTxChange - | not (null jsonTxChange) - ] - where - printAddrInfos header xs = - (header ++ f (head xs)) : - map ((" " ++) . f) (tail xs) - f (AddressInfo addr valM local) = unwords $ - cs (addrToBase58 addr) : - [ show v | v <- maybeToList valM ] - ++ - [ "<-" | maybe local (== addr) aM ] - -printTxConfidence :: JsonTx -> String -printTxConfidence JsonTx{..} = case jsonTxConfidence of - TxBuilding -> "Building" ++ confirmations - TxPending -> "Pending" ++ confirmations - TxDead -> "Dead" ++ confirmations - TxOffline -> "Offline" - where - confirmations = case jsonTxConfirmations of - Just conf -> " (Confirmations: " ++ show conf ++ ")" - _ -> "" - -printTxType :: TxType -> String -printTxType t = case t of - TxIncoming -> "Incoming" - TxOutgoing -> "Outgoing" - TxSelf -> "Self" - -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 - | h <- maybeToList nodeStatusHeaderPeer, verbose - ] ++ - [ "Merkle Peer : " ++ show m - | m <- maybeToList nodeStatusMerklePeer, verbose - ] ++ - [ "Pending Headers : " ++ show nodeStatusHaveHeaders | verbose ] ++ - [ "Pending Tickles : " ++ show nodeStatusHaveTickles | verbose ] ++ - [ "Pending Txs : " ++ show nodeStatusHaveTxs | verbose ] ++ - [ "Pending GetData : " ++ show (map txHashToHex nodeStatusGetData) - | verbose - ] ++ - [ "Pending Rescan : " ++ show r - | r <- maybeToList nodeStatusRescan, verbose - ] ++ - [ "Synced Mempool : " ++ show nodeStatusMempool | verbose ] ++ - [ "HeaderSync Lock : " ++ show nodeStatusSyncLock | verbose ] ++ - [ "Peers: " ] ++ - intercalate ["-"] (map (printPeerStatus verbose) nodeStatusPeers) - -printPeerStatus :: Bool -> PeerStatus -> [String] -printPeerStatus verbose PeerStatus{..} = - [ " Peer Id : " ++ show peerStatusPeerId - , " Peer Host: " ++ peerHostString peerStatusHost - , " Connected: " ++ if peerStatusConnected then "yes" else "no" - , " Height : " ++ show peerStatusHeight - ] ++ - [ " Protocol : " ++ show p | p <- maybeToList peerStatusProtocol - ] ++ - [ " UserAgent: " ++ ua | ua <- maybeToList peerStatusUserAgent - ] ++ - [ " Avg Ping : " ++ p | p <- maybeToList peerStatusPing - ] ++ - [ " DoS Score: " ++ show d | d <- maybeToList peerStatusDoSScore - ] ++ - [ " Merkles : " ++ show peerStatusHaveMerkles | verbose ] ++ - [ " Messages : " ++ show peerStatusHaveMessage | verbose ] ++ - [ " Nonces : " ++ show peerStatusPingNonces | verbose ] ++ - [ " Reconnect: " ++ show t - | t <- maybeToList peerStatusReconnectTimer, verbose - ] ++ - [ " Logs : " | verbose ] ++ - [ " - " ++ msg | msg <- fromMaybe [] peerStatusLog, verbose] - -printBlockInfo :: BlockInfo -> [String] -printBlockInfo BlockInfo{..} = - [ "Block Height : " ++ show blockInfoHeight - , "Block Hash : " ++ cs (blockHashToHex blockInfoHash) - , "Block Timestamp : " ++ formatUTCTime blockInfoTimestamp - , "Previous Block : " ++ cs (blockHashToHex blockInfoPrevBlock) - , "Merkle Root : " ++ cs blockInfoMerkleRoot - , "Block Version : " ++ "0x" ++ cs (encodeHex versionData) - , "Block Difficulty : " ++ show (blockDiff blockInfoBits) - , "Chain Work : " ++ show blockInfoChainWork - ] - where - blockDiff :: Word32 -> Double - blockDiff target = getTarget (blockBits genesisHeader) / getTarget target - getTarget = fromIntegral . decodeCompact - versionData = integerToBS (fromIntegral blockInfoVersion) - formatUTCTime = Time.formatTime Time.defaultTimeLocale - "%Y-%m-%d %H:%M:%S (UTC)" diff --git a/Network/Haskoin/Wallet/Client/PrettyJson.hs b/Network/Haskoin/Wallet/Client/PrettyJson.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Client/PrettyJson.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -module Network.Haskoin.Wallet.Client.PrettyJson -( encodePretty ) -where - -import qualified Data.ByteString.Lazy as BL -import Data.Aeson (ToJSON) -import Data.Aeson.Encode.Pretty as Export (Config (..), - defConfig, - encodePretty') - --- aeson-pretty 0.8.0 introduces a new way to specify indentation -#if MIN_VERSION_aeson_pretty(0,8,0) -import Data.Aeson.Encode.Pretty as Export (Indent(..)) -jsonIndent :: Indent -jsonIndent = Spaces 2 -#else -jsonIndent :: Int -jsonIndent = 2 -#endif - -encodePretty :: ToJSON a => a -> BL.ByteString -encodePretty = encodePretty' defConfig{ confIndent = jsonIndent } diff --git a/Network/Haskoin/Wallet/Database.hs b/Network/Haskoin/Wallet/Database.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Database.hs +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 --- a/Network/Haskoin/Wallet/Internals.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-| -This module expose haskoin-wallet internals. No guarantee is made on the -stability of the interface of these internal modules. --} - -module Network.Haskoin.Wallet.Internals -( module Network.Haskoin.Wallet -, module Network.Haskoin.Wallet.Accounts -, module Network.Haskoin.Wallet.Transaction -, module Network.Haskoin.Wallet.Client -, module Network.Haskoin.Wallet.Client.Commands -, module Network.Haskoin.Wallet.Server -, module Network.Haskoin.Wallet.Server.Handler -, module Network.Haskoin.Wallet.Settings -, module Network.Haskoin.Wallet.Database -, module Network.Haskoin.Wallet.Types -, module Network.Haskoin.Wallet.Model -) where - -import Network.Haskoin.Wallet -import Network.Haskoin.Wallet.Accounts -import Network.Haskoin.Wallet.Transaction -import Network.Haskoin.Wallet.Client -import Network.Haskoin.Wallet.Client.Commands -import Network.Haskoin.Wallet.Server -import Network.Haskoin.Wallet.Server.Handler -import Network.Haskoin.Wallet.Settings -import Network.Haskoin.Wallet.Database -import Network.Haskoin.Wallet.Types -import Network.Haskoin.Wallet.Model - diff --git a/Network/Haskoin/Wallet/Model.hs b/Network/Haskoin/Wallet/Model.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Model.hs +++ /dev/null @@ -1,134 +0,0 @@ -module Network.Haskoin.Wallet.Model -( -- Database types - Account(..) -, AccountId -, WalletAddr(..) -, WalletAddrId -, WalletState(..) -, WalletStateId -, WalletCoin(..) -, WalletCoinId -, SpentCoin(..) -, SpentCoinId -, WalletTx(..) -, WalletTxId -, EntityField(..) -, Unique(..) -, migrateWallet - --- JSON conversion -, toJsonAccount -, toJsonAddr -, toJsonCoin -, toJsonTx - -) where - -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) -import Database.Persist.TH - ( share - , mkPersist - , sqlSettings - , mkMigrate - , persistFileWith - ) - -import Network.Haskoin.Wallet.Types -import Network.Haskoin.Block -import Network.Haskoin.Transaction -import Network.Haskoin.Script -import Network.Haskoin.Crypto -import Network.Haskoin.Node -import Network.Haskoin.Node.HeaderTree - -share [ mkPersist sqlSettings - , mkMigrate "migrateWallet" - ] - $(persistFileWith lowerCaseSettings "config/models") - -{- JSON Types -} - -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 :: WalletAddr - -> Maybe BalanceInfo - -> JsonAddr -toJsonAddr addr balM = JsonAddr - { jsonAddrAddress = walletAddrAddress addr - , jsonAddrIndex = walletAddrIndex addr - , jsonAddrType = walletAddrType addr - , jsonAddrLabel = walletAddrLabel addr - , jsonAddrRedeem = walletAddrRedeem addr - , jsonAddrKey = walletAddrKey addr - , jsonAddrCreated = walletAddrCreated addr - , jsonAddrBalance = balM - } - -toJsonTx :: AccountName - -> Maybe (BlockHash, BlockHeight) -- ^ Current best block - -> WalletTx - -> JsonTx -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 bbM of - Just (_, h) -> return $ fromInteger $ - max 0 $ toInteger h - toInteger confirmedHeight + 1 - _ -> Nothing - -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 = walletCoinHash coin - , jsonCoinPos = walletCoinPos coin - , jsonCoinValue = walletCoinValue coin - , jsonCoinScript = walletCoinScript coin - , jsonCoinCreated = walletCoinCreated coin - -- Optional tx - , jsonCoinTx = txM - -- Optional address - , jsonCoinAddress = addrM - -- Optional spending tx - , jsonCoinSpendingTx = spendM - } - diff --git a/Network/Haskoin/Wallet/Server.hs b/Network/Haskoin/Wallet/Server.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Server.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.Haskoin.Wallet.Server -( runSPVServer -, stopSPVServer -, runSPVServerWithContext -) where - -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.Fix (fix) -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 AccountId Word32) - } - deriving (Eq, Show, Read) - -instance NFData EventSession where - rnf EventSession{..} = - rnf eventBatchSize `seq` - rnf (M.elems eventNewAddrs) - -runSPVServer :: Config -> IO () -runSPVServer cfg = maybeDetach cfg $ -- start the server process - withContext (run . runSPVServerWithContext cfg) - where - -- Setup logging monads - run = runResourceT . runLogging - runLogging = runStdoutLoggingT . filterLogger logFilter - logFilter _ level = level >= configLogLevel cfg - --- |Run the server, and use the specifed ZeroMQ context. --- Useful if you want to communicate with the server using --- the "inproc" ZeroMQ transport, where a shared context is --- required. -runSPVServerWithContext :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadBase IO m - , MonadThrow m - , MonadResource m - ) - => Config -> Context -> m () -runSPVServerWithContext cfg ctx = do - -- Initialize the database - -- Check the operation mode of the server. - 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 -> do - let session = HandlerSession cfg pool Nothing notif - as <- mapM async - -- Run the ZMQ API-command server - [ runWalletCmd ctx session - -- Run the ZMQ notification thread - , runWalletNotif ctx session - ] - mapM_ link as - (_,r) <- waitAnyCancel as - return r - -- 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 - 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 (spv pool) node - -- Merkle block synchronization - , runNodeT (runMerkleSync pool notif) node - -- Import solo transactions as they arrive from peers - , runNodeT (txSource $$ processTx pool notif) node - -- Respond to transaction GetData requests - , runNodeT (handleGetData $ (`runDBPool` pool) . getTx) node - -- Re-broadcast pending transactions - , runNodeT (broadcastPendingTxs pool) node - -- Run the ZMQ API-command server - , runWalletCmd ctx session - -- Run the ZMQ notification thread - , runWalletNotif ctx session - ] - mapM_ link as - (_,r) <- waitAnyCancel as - $(logDebug) "Exiting main thread" - return r - where - spv pool = do - -- Get our bloom filter - (bloom, elems, _) <- runDBPool getBloomFilter pool - startSPVNode hosts bloom elems - -- Bitcoin nodes to connect to - nodes = fromMaybe - (error $ "BTC nodes for " ++ networkName ++ " not found") - (pack networkName `H.lookup` configBTCNodes cfg) - hosts = map (\x -> PeerHost (btcNodeHost x) (btcNodePort x)) nodes - -- Run the merkle syncing thread - 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 <- 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 pool 500 notif - $(logDebug) "Exiting Merkle-sync thread" - -- Run a thread that will re-broadcast pending transactions - broadcastPendingTxs pool = forever $ do - (hash, _) <- runSqlNodeT $ walletBestBlock - -- Wait until we are synced - atomicallyNodeT $ do - synced <- areBlocksSynced hash - unless synced $ lift retry - -- Send an INV for those transactions to all peers - broadcastTxs =<< runDBPool (getPendingTxs 0) pool - -- Wait until we are not synced - atomicallyNodeT $ do - synced <- areBlocksSynced hash - when synced $ lift retry - $(logDebug) "Exiting tx-broadcast thread" - processTx pool notif = do - 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 getBloomFilter pool - atomicallyNodeT $ sendBloomFilter bloom elems - $(logDebug) "Exiting tx-import thread" - -initDatabase :: (MonadBaseControl IO m, MonadLoggerIO m) - => Config -> m ConnectionPool -initDatabase cfg = do - -- 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 - flip runDBPool pool $ do - _ <- runMigration migrateWallet - _ <- runMigration migrateHeaderTree - initWallet $ configBloomFP cfg - -- Return the semaphrone and the connection pool - return pool - -merkleSync - :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m, MonadResource m) - => ConnectionPool - -> Word32 - -> TBMChan Notif - -> NodeT m () -merkleSync pool bSize notif = do - -- Get our best block - (hash, _) <- runDBPool walletBestBlock pool - $(logDebug) "Starting merkle batch download" - -- Wait for a new block or a rescan - (action, source) <- merkleDownload hash bSize - $(logDebug) "Received a merkle action and source. Processing the source..." - - -- Read and process the data from the source - (lastMerkleM, mTxsAcc, aMap) <- source $$ go Nothing [] M.empty - $(logDebug) "Merkle source processed and closed" - - -- Send a new bloom filter to our peers if new addresses were generated - unless (M.null aMap) $ do - $(logInfo) $ pack $ unwords - [ "Generated", show $ sum $ M.elems aMap - , "new addresses while importing the merkle block." - , "Sending our bloom filter." - ] - (bloom, elems, _) <- runDBPool 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 <- shouldRescan aMap - when rescan $ $(logDebug) "We need to rescan the current batch" - -- Compute the new batch size - let newBSize | rescan = max 1 $ bSize `div` 2 - | otherwise = min 500 $ bSize + max 1 (bSize `div` 20) - - when (newBSize /= bSize) $ $(logDebug) $ pack $ unwords - [ "Changing block batch size from", show bSize, "to", show newBSize ] - - -- Did we receive all the merkles that we asked for ? - let missing = (headerHash <$> lastMerkleM) /= - Just (nodeHash $ last $ actionNodes action) - - when missing $ $(logWarn) $ pack $ unwords - [ "Merkle block stream closed prematurely" - , show lastMerkleM - ] - - -- TODO: We could still salvage a partially received batch - unless (rescan || missing) $ do - $(logDebug) "Importing merkles into the wallet..." - -- Confirm the transactions - runDBPool (importMerkles action mTxsAcc (Just notif)) pool - $(logDebug) "Done importing merkles into the wallet" - logBlockChainAction action - - 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 (importNetTx tx Nothing) pool - $(logDebug) $ pack $ unwords - [ "Generated", show $ length newAddrs - , "new addresses while importing tx" - , cs $ txHashToHex $ txHash tx - ] - let newMap = M.unionWith (+) aMap $ groupByAcc newAddrs - go lastMerkleM mTxsAcc newMap - Just (Left (MerkleBlock mHead _ _ _, mTxs)) -> do - $(logDebug) $ pack $ unwords - [ "Buffering merkle block" - , cs $ blockHashToHex $ headerHash mHead - ] - go (Just mHead) (mTxs:mTxsAcc) aMap - -- Done processing this batch. Reverse mTxsAcc as we have been - -- prepending new values to it. - _ -> return (lastMerkleM, reverse mTxsAcc, aMap) - groupByAcc addrs = - let xs = map (\a -> (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` pool) $ splitSelect (M.assocs aMap) $ \ks -> - from $ \a -> do - let andCond (ai, cnt) = - a ^. AccountId ==. val ai &&. - a ^. AccountGap <=. val cnt - where_ $ join2 $ map andCond ks - 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 $ nodeBlockHeight $ last nodes - , "(", cs $ blockHashToHex $ nodeHash $ last nodes - , ")" - ] - ChainReorg _ o n -> $(logInfo) $ pack $ unlines $ - [ "Chain reorg." - , "Orphaned blocks:" - ] - ++ map ((" " ++) . cs . blockHashToHex . nodeHash) o - ++ [ "New blocks:" ] - ++ map ((" " ++) . cs . blockHashToHex . nodeHash) n - ++ [ unwords [ "Best merkle chain height" - , show $ nodeBlockHeight $ last n - ] - ] - SideChain n -> $(logWarn) $ pack $ unlines $ - "Side chain:" : - map ((" " ++) . cs . blockHashToHex . nodeHash) n - KnownChain n -> $(logWarn) $ pack $ unlines $ - "Known chain:" : - map ((" " ++) . cs . blockHashToHex . nodeHash) n - -maybeDetach :: Config -> IO () -> IO () -maybeDetach cfg action = - if configDetach cfg then runDetached pidFile logFile action >> logStarted else action - where - logStarted = putStrLn "Process started" - pidFile = Just $ configPidFile cfg - logFile = ToFile $ configLogFile cfg - -stopSPVServer :: Config -> IO () -stopSPVServer cfg = - -- TODO: Should we send a message instead of killing the process ? - killAndWait $ configPidFile cfg - --- Run the main ZeroMQ loop --- TODO: Support concurrent requests using DEALER socket when we can do --- concurrent MySQL requests. -runWalletNotif :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadBase IO m - , MonadThrow m - , MonadResource m - ) - => Context -> HandlerSession -> m () -runWalletNotif ctx session = - liftBaseOpDiscard (withSocket ctx Pub) $ \sock -> do - liftIO $ setLinger (restrict (0 :: Int)) sock - setupCrypto ctx sock session - 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] - -runWalletCmd :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadBase IO m - , MonadThrow m - , MonadResource m - ) - => Context -> HandlerSession -> m () -runWalletCmd ctx session = do - liftBaseOpDiscard (withSocket ctx Rep) $ \sock -> do - liftIO $ setLinger (restrict (0 :: Int)) sock - setupCrypto ctx sock session - liftIO $ bind sock $ configBind $ handlerConfig session - fix $ \loop -> do - bs <- liftIO $ receive sock - let msg = decode $ BL.fromStrict bs - res <- case msg of - Just StopServerR -> do - $(logInfo) "Received StopServer request" - return (ResponseValid Nothing) - Just r -> catchErrors $ - runHandler (dispatchRequest r) session - Nothing -> return $ ResponseError "Could not decode request" - liftIO $ send sock [] $ BL.toStrict $ encode res - unless (msg == Just StopServerR) loop - $(logInfo) "Exiting ZMQ command thread..." - where - catchErrors m = catches m - [ E.Handler $ \(WalletException err) -> do - $(logError) $ pack err - return $ ResponseError $ pack err - , E.Handler $ \(ErrorCall err) -> do - $(logError) $ pack err - return $ ResponseError $ pack err - , E.Handler $ \(SomeException exc) -> do - $(logError) $ pack $ show exc - return $ ResponseError $ pack $ show exc - ] - -setupCrypto :: (MonadLoggerIO m, MonadBaseControl IO m) - => Context -> Socket a -> HandlerSession -> m () -setupCrypto ctx' sock session = 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 - where - cfg = handlerConfig session - serverKeyM = configServerKey cfg - clientKeyPubM = configClientKeyPub cfg - -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 - ) - => WalletRequest -> Handler m (WalletResponse Value) -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 - GetIndexR n k t -> getIndexR n k t - 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 - GetBlockInfoR l -> getBlockInfoR l - StopServerR -> error "Should be handled elsewhere" diff --git a/Network/Haskoin/Wallet/Server/Handler.hs b/Network/Haskoin/Wallet/Server/Handler.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Server/Handler.hs +++ /dev/null @@ -1,604 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.Haskoin.Wallet.Server.Handler where - -import Control.Arrow (first) -import Control.Concurrent.STM.TBMChan (TBMChan) -import Control.Exception (SomeException (..), - tryJust) -import Control.Monad (liftM, forM, 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 Data.Maybe (catMaybes) -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 -import Network.Haskoin.Wallet.Types.BlockInfo (fromNodeBlock) - -type Handler m = ReaderT HandlerSession m - -data HandlerSession = HandlerSession - { handlerConfig :: !Config - , handlerPool :: !ConnectionPool - , handlerNodeState :: !(Maybe SharedNodeState) - , handlerNotifChan :: !(TBMChan Notif) - } - -runHandler :: Monad m => Handler m a -> HandlerSession -> m a -runHandler = runReaderT - -runDB :: MonadBaseControl IO m => SqlPersistT m a -> Handler m a -runDB action = asks handlerPool >>= lift . runDBPool action - -runDBPool :: MonadBaseControl IO m => SqlPersistT m a -> ConnectionPool -> m a -runDBPool = runSqlPool - -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 - $(logError) $ pack $ unwords [ "A database error occured:", err] - return Nothing - where - f (SomeException e) = Just $ show e - -runNode :: MonadIO m => NodeT m a -> Handler m a -runNode action = do - nodeStateM <- asks handlerNodeState - case nodeStateM of - Just nodeState -> lift $ runNodeT action nodeState - _ -> error "runNode: No node state available" - -{- Server Handlers -} - -getAccountsR :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadBase IO m - , MonadThrow m - , MonadResource m - ) - => 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, MonadLoggerIO m, MonadBaseControl IO m) - => NewAccount -> Handler m (Maybe Value) -postAccountsR newAcc@NewAccount{..} = do - $(logInfo) $ format $ unlines - [ "PostAccountsR" - , " Account name: " ++ unpack newAccountName - , " Account type: " ++ show newAccountType - ] - (Entity _ newAcc', mnemonicM) <- runDB $ newAccount newAcc - -- Update the bloom filter if the account is complete - whenOnline $ when (isCompleteAccount newAcc') updateNodeFilter - return $ Just $ toJSON $ toJsonAccount mnemonicM newAcc' - -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" - , " Account name: " ++ unpack name - ] - Entity _ acc <- runDB $ getAccount name - return $ Just $ toJSON $ toJsonAccount Nothing acc - -postAccountKeysR - :: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m) - => AccountName -> [XPubKey] -> Handler m (Maybe Value) -postAccountKeysR name keys = do - $(logInfo) $ format $ unlines - [ "PostAccountKeysR" - , " Account name: " ++ unpack name - , " Key count : " ++ show (length keys) - ] - 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 $ toJsonAccount Nothing newAcc - -postAccountGapR :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadBase IO m - , MonadThrow m - , MonadResource m - ) - => AccountName -> SetAccountGap - -> Handler m (Maybe Value) -postAccountGapR name (SetAccountGap gap) = do - $(logInfo) $ format $ unlines - [ "PostAccountGapR" - , " Account name: " ++ unpack name - , " New gap size: " ++ show gap - ] - -- Update the gap - Entity _ newAcc <- runDB $ do - accE <- getAccount name - setAccountGap accE gap - -- Update the bloom filter - whenOnline updateNodeFilter - return $ Just $ toJSON $ toJsonAccount Nothing newAcc - -getAddressesR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => AccountName - -> AddressType - -> Word32 - -> Bool - -> ListRequest - -> Handler m (Maybe Value) -getAddressesR name addrType minConf offline listReq = do - $(logInfo) $ format $ unlines - [ "GetAddressesR" - , " Account name: " ++ unpack name - , " Address type: " ++ show addrType - , " Start index : " ++ show (listOffset listReq) - , " Reversed : " ++ show (listReverse listReq) - , " MinConf : " ++ show minConf - , " Offline : " ++ show offline - ] - - (res, bals, cnt) <- runDB $ do - accE <- getAccount name - (res, cnt) <- addressList accE addrType listReq - case res of - [] -> return (res, [], cnt) - _ -> do - let is = map walletAddrIndex res - (iMin, iMax) = (minimum is, maximum is) - bals <- addressBalances accE iMin iMax addrType minConf offline - 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 $ ListResult addrBals cnt - where - joinAddrs addrs bals = - let f addr = (walletAddrIndex addr, addr) - in M.intersectionWith (,) (M.fromList $ map f addrs) (M.fromList bals) - -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" - , " Account name: " ++ unpack name - , " Address type: " ++ show addrType - , " Offset : " ++ show listOffset - , " Limit : " ++ show listLimit - , " Reversed : " ++ show listReverse - ] - - (addrs, cnt) <- runDB $ do - accE <- getAccount name - unusedAddresses accE addrType lq - - return $ Just $ toJSON $ ListResult (map (`toJsonAddr` Nothing) addrs) cnt - -getAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => AccountName -> KeyIndex -> AddressType - -> Word32 -> Bool - -> Handler m (Maybe Value) -getAddressR name i addrType minConf offline = do - $(logInfo) $ format $ unlines - [ "GetAddressR" - , " Account name: " ++ unpack name - , " Index : " ++ show i - , " Address type: " ++ show addrType - ] - - (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):_) -> (entityVal addrE, Just bal) - _ -> (entityVal addrE, Nothing) - return $ Just $ toJSON $ toJsonAddr addr balM - -getIndexR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => AccountName - -> PubKeyC - -> AddressType - -> Handler m (Maybe Value) -getIndexR name key addrType = do - $(logInfo) $ format $ unlines - [ "getIndexR" - , " Account name: " ++ unpack name - , " Key : " ++ show key - , " Address type: " ++ show addrType - ] - addrLst <- runDB $ do - accE <- getAccount name - lookupByPubKey accE key addrType - let hello = map (`toJsonAddr` Nothing) addrLst - liftIO $ putStrLn $ show hello - liftIO $ print $ toJSON $ hello - return $ Just $ toJSON $ hello - -putAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => AccountName - -> KeyIndex - -> AddressType - -> AddressLabel - -> Handler m (Maybe Value) -putAddressR name i addrType (AddressLabel label) = do - $(logInfo) $ format $ unlines - [ "PutAddressR" - , " Account name: " ++ unpack name - , " Index : " ++ show i - , " Label : " ++ unpack label - ] - - newAddr <- runDB $ do - accE <- getAccount name - setAddrLabel accE i addrType label - - return $ Just $ toJSON $ toJsonAddr newAddr Nothing - -postAddressesR :: ( MonadLoggerIO m - , MonadBaseControl IO m - , MonadThrow m - , MonadBase IO m - , MonadResource m - ) - => AccountName - -> KeyIndex - -> AddressType - -> Handler m (Maybe Value) -postAddressesR name i addrType = do - $(logInfo) $ format $ unlines - [ "PostAddressesR" - , " Account name: " ++ unpack name - , " Index : " ++ show i - ] - - cnt <- runDB $ do - accE <- getAccount name - generateAddrs accE addrType i - - -- Update the bloom filter - whenOnline updateNodeFilter - - return $ Just $ toJSON cnt - -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 - [ cmd - , " Account name: " ++ unpack name - , " Offset : " ++ show listOffset - , " Limit : " ++ show listLimit - , " Reversed : " ++ show listReverse - ] - - (res, cnt, bb) <- runDB $ do - Entity ai _ <- getAccount name - bb <- walletBestBlock - (res, cnt) <- f ai lq - return (res, cnt, bb) - - return $ Just $ toJSON $ ListResult (map (g bb) res) cnt - where - g bb = toJsonTx name (Just bb) - -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 name index addrType lq@ListRequest{..} = do - $(logInfo) $ format $ unlines - [ "GetAddrTxsR" - , " Account name : " ++ unpack name - , " Address index: " ++ show index - , " Address type : " ++ show addrType - , " Offset : " ++ show listOffset - , " Limit : " ++ show listLimit - , " Reversed : " ++ show listReverse - ] - - (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 $ ListResult (map (f bb) res) cnt - where - f bb = toJsonTx name (Just bb) - -postTxsR :: ( MonadLoggerIO m, MonadBaseControl IO m, MonadBase IO m - , MonadThrow m, MonadResource m - ) - => 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" - , " Account name: " ++ unpack name - , " Recipients : " ++ show (map (first addrToBase58) rs) - , " Fee : " ++ show fee - , " Minconf : " ++ show minconf - , " Rcpt. Fee : " ++ show rcptFee - , " Sign : " ++ show sign - ] - runDB $ createWalletTx - accE (Just notif) masterM rs fee minconf rcptFee sign - ImportTx tx -> do - $(logInfo) $ format $ unlines - [ "PostTxsR ImportTx" - , " Account name: " ++ unpack name - , " TxId : " ++ cs (txHashToHex (txHash tx)) - ] - runDB $ do - (res, newAddrs) <- importTx tx (Just notif) ai - case filter ((== ai) . walletTxAccount) res of - (txRes:_) -> return (txRes, newAddrs) - _ -> throwM $ WalletException - "Could not import the transaction" - SignTx txid -> do - $(logInfo) $ format $ unlines - [ "PostTxsR SignTx" - , " Account name: " ++ unpack name - , " TxId : " ++ cs (txHashToHex txid) - ] - runDB $ do - (res, newAddrs) <- signAccountTx accE (Just notif) masterM txid - case filter ((== ai) . walletTxAccount) res of - (txRes:_) -> return (txRes, newAddrs) - _ -> 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 (walletTxConfidence txRes == TxPending) $ - runNode $ broadcastTxs [walletTxHash txRes] - return $ Just $ toJSON $ toJsonTx name (Just bb) txRes - -getTxR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => AccountName -> TxHash -> Handler m (Maybe Value) -getTxR name txid = do - $(logInfo) $ format $ unlines - [ "GetTxR" - , " Account name: " ++ unpack name - , " TxId : " ++ cs (txHashToHex txid) - ] - (res, bb) <- runDB $ do - Entity ai _ <- getAccount name - bb <- walletBestBlock - res <- getAccountTx ai txid - return (res, bb) - return $ Just $ toJSON $ toJsonTx name (Just bb) res - -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 name minconf offline = do - $(logInfo) $ format $ unlines - [ "GetBalanceR" - , " Account name: " ++ unpack name - , " Minconf : " ++ show minconf - , " Offline : " ++ show offline - ] - bal <- runDB $ do - Entity ai _ <- getAccount name - accountBalance ai minconf offline - return $ Just $ toJSON bal - -getOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m - , MonadBase IO m, MonadThrow m, MonadResource m - ) - => AccountName -> TxHash -> Handler m (Maybe Value) -getOfflineTxR accountName txid = do - $(logInfo) $ format $ unlines - [ "GetOfflineTxR" - , " Account name: " ++ unpack accountName - , " TxId : " ++ cs (txHashToHex txid) - ] - (dat, _) <- runDB $ do - Entity ai _ <- getAccount accountName - getOfflineTxData ai txid - return $ Just $ toJSON dat - -postOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m - , MonadBase IO m, MonadThrow m, MonadResource m - ) - => AccountName - -> Maybe XPrvKey - -> Tx - -> [CoinSignData] - -> Handler m (Maybe Value) -postOfflineTxR accountName masterM tx signData = do - $(logInfo) $ format $ unlines - [ "PostTxsR SignOfflineTx" - , " Account name: " ++ unpack accountName - , " TxId : " ++ cs (txHashToHex (txHash tx)) - ] - 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 :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) - => NodeAction -> Handler m (Maybe Value) -postNodeR action = case action of - NodeActionRescan tM -> do - t <- case tM of - Just t -> return $ adjustFCTime t - Nothing -> do - timeM <- runDB firstAddrTime - maybe err (return . adjustFCTime) timeM - $(logInfo) $ format $ unlines - [ "NodeR Rescan" - , " Timestamp: " ++ show t - ] - whenOnline $ do - runDB resetRescan - runNode $ atomicallyNodeT $ rescanTs t - return $ Just $ toJSON $ RescanRes t - NodeActionStatus -> do - status <- runNode $ atomicallyNodeT nodeStatus - return $ Just $ toJSON status - where - err = 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 - -getBlockInfoR :: (MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m) - => [BlockHash] - -> Handler m (Maybe Value) -getBlockInfoR headerLst = do - lstMaybeBlk <- forM headerLst (runNode . runSqlNodeT . getBlockByHash) - return $ toJSON <$> Just (handleRes lstMaybeBlk) - where - handleRes :: [Maybe NodeBlock] -> [BlockInfo] - handleRes = map fromNodeBlock . catMaybes - -{- Helpers -} - -whenOnline :: Monad m => Handler m () -> Handler m () -whenOnline handler = do - mode <- configMode `liftM` asks handlerConfig - when (mode == SPVOnline) handler - -updateNodeFilter - :: (MonadBaseControl IO m, MonadLoggerIO m, MonadThrow m) - => Handler m () -updateNodeFilter = do - $(logInfo) $ format "Sending a new bloom filter" - (bloom, elems, _) <- runDB getBloomFilter - runNode $ atomicallyNodeT $ sendBloomFilter bloom elems - -adjustFCTime :: Timestamp -> Timestamp -adjustFCTime ts = fromInteger $ max 0 $ toInteger ts - 86400 * 7 - -format :: String -> Text -format str = pack $ "[ZeroMQ] " ++ str - diff --git a/Network/Haskoin/Wallet/Settings.hs b/Network/Haskoin/Wallet/Settings.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Settings.hs +++ /dev/null @@ -1,196 +0,0 @@ -module Network.Haskoin.Wallet.Settings -( SPVMode(..) -, OutputFormat(..) -, Config(..) -) where - -import Control.Monad (mzero) -import Control.Exception (throw) -import Control.Monad.Logger (LogLevel(..)) - -import Data.Default (Default, def) -import Data.FileEmbed (embedFile) -import Data.Yaml (decodeEither') -import Data.Word (Word32, Word64) -import Data.HashMap.Strict (HashMap, unionWith) -import Data.String.Conversions (cs) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Aeson - ( 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 - { configCount :: !Word32 - -- ^ Output size of commands - , configMinConf :: !Word32 - -- ^ Minimum number of confirmations - , configSignTx :: !Bool - -- ^ Sign transactions - , configFee :: !Word64 - -- ^ Fee to pay per 1000 bytes when creating new transactions - , configRcptFee :: !Bool - -- ^ Recipient pays fee (dangerous, no config file setting) - , configAddrType :: !AddressType - -- ^ Return internal instead of external addresses - , configOffline :: !Bool - -- ^ Display the balance including offline transactions - , configReversePaging :: !Bool - -- ^ Use reverse paging for displaying addresses and transactions - , 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 - -- ^ Configuration file - , configTestnet :: !Bool - -- ^ Use Testnet3 network - , configDir :: !FilePath - -- ^ Working directory - , configBind :: !String - -- ^ 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 Text DatabaseConfType) - -- ^ Database configuration - , configLogFile :: !FilePath - -- ^ Log file - , configPidFile :: !FilePath - -- ^ PID File - , configLogLevel :: !LogLevel - -- ^ 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 :: 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' "{}" - -instance FromJSON Config where - 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 - 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 deleted file mode 100644 --- a/Network/Haskoin/Wallet/Transaction.hs +++ /dev/null @@ -1,1358 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -module Network.Haskoin.Wallet.Transaction -( --- *Database transactions - txs -, addrTxs -, accTxsFromBlock -, getTx -, getAccountTx -, importTx -, importNetTx -, signAccountTx -, createWalletTx -, 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 <- outputAddress so - return (addr, so) - -isCoinbaseTx :: Tx -> Bool -isCoinbaseTx tx = - length (txIn tx) == 1 && outPointHash (prevOutput $ head (txIn tx)) == - "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 - input <- decodeInputBS (scriptInput inp) - addr <- inputAddress input - 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 <- outputAddress =<< decodeOutputBS (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. -createWalletTx - :: (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) -createWalletTx 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 deleted file mode 100644 --- a/Network/Haskoin/Wallet/Types.hs +++ /dev/null @@ -1,790 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.Haskoin.Wallet.Types -( AccountName - --- JSON Types -, JsonAccount(..) -, JsonAddr(..) -, JsonCoin(..) -, JsonTx(..) - --- Request Types -, WalletRequest(..) -, ListRequest(..) -, NewAccount(..) -, SetAccountGap(..) -, OfflineTxData(..) -, CoinSignData(..) -, TxAction(..) -, AddressLabel(..) -, NodeAction(..) -, AccountType(..) -, AddressType(..) -, addrTypeIndex -, TxType(..) -, TxConfidence(..) -, AddressInfo(..) -, BalanceInfo(..) - --- Response Types -, WalletResponse(..) -, TxCompleteRes(..) -, ListResult(..) -, RescanRes(..) -, JsonSyncBlock(..) -, JsonBlock(..) -, Notif(..) -, BlockInfo(..) - --- Helper Types -, WalletException(..) -, BTCNode(..) - --- *Helpers -, splitSelect -, splitUpdate -, splitDelete -, splitInsertMany_ -, join2 -, limitOffset -) where - -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', object, - parseJSON, toJSON, withObject, - (.!=), (.:), (.:?), (.=)) -import qualified Data.Aeson as Aeson -import Data.Aeson.TH (deriveJSON) -import Data.Aeson.Types (Options (..), - SumEncoding (..), - defaultOptions, - defaultTaggedObject) -import Data.Char (toLower) -import Data.Int (Int64) -import Data.List.Split (chunksOf) -import Data.Maybe (maybeToList) -import Data.Serialize (Serialize, decode, encode) -import Data.String (fromString) -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 -import Network.Haskoin.Wallet.Types.BlockInfo - -type AccountName = Text - --- TODO: Add NFData instances for all those types - -{- Request Types -} - -data TxType - = TxIncoming - | TxOutgoing - | TxSelf - deriving (Eq, Show, Read) - -instance NFData TxType where - rnf x = x `seq` () - -$(deriveJSON (dropSumLabels 2 0 "") ''TxType) - -data TxConfidence - = TxOffline - | TxDead - | TxPending - | TxBuilding - deriving (Eq, Show, Read) - -instance NFData TxConfidence where - rnf x = x `seq` () - -$(deriveJSON (dropSumLabels 2 0 "") ''TxConfidence) - -data AddressInfo = AddressInfo - { addressInfoAddress :: !Address - , addressInfoValue :: !(Maybe Word64) - , addressInfoIsLocal :: !Bool - } - deriving (Eq, Show, Read, Generic) - -instance Serialize AddressInfo - -$(deriveJSON (dropFieldLabel 11) ''AddressInfo) - -instance NFData AddressInfo where - rnf AddressInfo{..} = - rnf addressInfoAddress `seq` - rnf addressInfoValue `seq` - rnf addressInfoIsLocal - -data BalanceInfo = BalanceInfo - { balanceInfoInBalance :: !Word64 - , balanceInfoOutBalance :: !Word64 - , balanceInfoCoins :: !Int - , balanceInfoSpentCoins :: !Int - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 11) ''BalanceInfo) - -instance NFData BalanceInfo where - rnf BalanceInfo{..} = - rnf balanceInfoInBalance `seq` - rnf balanceInfoOutBalance `seq` - rnf balanceInfoCoins `seq` - rnf balanceInfoSpentCoins - -data AccountType - = AccountRegular - | AccountMultisig - { accountTypeRequiredSigs :: !Int - , accountTypeTotalKeys :: !Int - } - deriving (Eq, Show, Read) - -instance NFData AccountType where - rnf t = case t of - AccountRegular -> () - AccountMultisig m n -> rnf m `seq` rnf n - -instance ToJSON AccountType where - toJSON accType = case accType of - AccountRegular -> object - [ "type" .= String "regular" ] - AccountMultisig m n -> object - [ "type" .= String "multisig" - , "requiredsigs" .= m - , "totalkeys" .= n - ] - -instance FromJSON AccountType where - parseJSON = withObject "AccountType" $ \o -> - o .: "type" >>= \t -> case (t :: Text) of - "regular" -> return AccountRegular - "multisig" -> AccountMultisig <$> o .: "requiredsigs" - <*> o .: "totalkeys" - _ -> mzero - -data NewAccount = NewAccount - { newAccountName :: !AccountName - , newAccountType :: !AccountType - , newAccountMnemonic :: !(Maybe Text) - , newAccountMaster :: !(Maybe XPrvKey) - , newAccountDeriv :: !(Maybe HardPath) - , newAccountKeys :: ![XPubKey] - , newAccountReadOnly :: !Bool - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 10) ''NewAccount) - -data SetAccountGap = SetAccountGap { getAccountGap :: !Word32 } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 10) ''SetAccountGap) - -data ListRequest = ListRequest - { listOffset :: !Word32 - , listLimit :: !Word32 - , listReverse :: !Bool - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 4) ''ListRequest) - -data CoinSignData = CoinSignData - { coinSignOutPoint :: !OutPoint - , coinSignScriptOutput :: !ScriptOutput - , coinSignDeriv :: !SoftPath - } - deriving (Eq, Show) - -$(deriveJSON (dropFieldLabel 8) ''CoinSignData) - -data OfflineTxData = OfflineTxData - { offlineTxDataTx :: !Tx - , offlineTxDataCoinData :: ![CoinSignData] - } - -$(deriveJSON (dropFieldLabel 13) ''OfflineTxData) - -data TxAction - = CreateTx - { accTxActionRecipients :: ![(Address, Word64)] - , accTxActionFee :: !Word64 - , accTxActionMinConf :: !Word32 - , accTxActionRcptFee :: !Bool - , accTxActionSign :: !Bool - } - | ImportTx - { accTxActionTx :: !Tx } - | SignTx - { accTxActionHash :: !TxHash } - deriving (Eq, Show) - -instance ToJSON TxAction where - toJSON (CreateTx recipients fee minConf rcptFee sign) = object $ - [ "type" .= ("createtx" :: Text) - , "recipients" .= recipients - , "fee" .= fee - , "minconf" .= minConf - , "sign" .= sign - ] ++ [ "rcptfee" .= True | rcptFee ] - toJSON (ImportTx tx) = object - [ "type" .= ("importtx" :: Text) - , "tx" .= tx - ] - toJSON (SignTx txid) = object - [ "type" .= ("signtx" :: Text) - , "hash" .= txid - ] - -instance FromJSON TxAction where - parseJSON = withObject "TxAction" $ \o -> do - t <- o .: "type" - case (t :: Text) of - "createtx" -> do - recipients <- o .: "recipients" - fee <- o .: "fee" - minConf <- o .: "minconf" - sign <- o .: "sign" - rcptFee <- o .:? "rcptfee" .!= False - return (CreateTx recipients fee minConf rcptFee sign) - "importtx" -> do - tx <- o .: "tx" - return (ImportTx tx) - "signtx" -> do - txid <- o .: "hash" - return (SignTx txid) - _ -> mzero - -data AddressLabel = AddressLabel { addressLabelLabel :: !Text } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 12) ''AddressLabel) - -data NodeAction - = NodeActionRescan { nodeActionTimestamp :: !(Maybe Word32) } - | NodeActionStatus - deriving (Eq, Show, Read) - -instance ToJSON NodeAction where - toJSON na = case na of - NodeActionRescan tM -> object $ - ("type" .= String "rescan") : (("timestamp" .=) <$> maybeToList tM) - NodeActionStatus -> object [ "type" .= String "status" ] - -instance FromJSON NodeAction where - parseJSON = withObject "NodeAction" $ \o -> do - String t <- o .: "type" - case t of - "rescan" -> NodeActionRescan <$> o .:? "timestamp" - "status" -> return NodeActionStatus - _ -> mzero - -data AddressType - = AddressInternal - | AddressExternal - deriving (Eq, Show, Read) - -$(deriveJSON (dropSumLabels 7 0 "") ''AddressType) - -instance NFData AddressType where - rnf x = x `seq` () - -addrTypeIndex :: AddressType -> KeyIndex -addrTypeIndex AddressExternal = 0 -addrTypeIndex AddressInternal = 1 - -data WalletRequest - = 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 - | GetIndexR !AccountName !PubKeyC !AddressType - | 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 - | GetBlockInfoR ![BlockHash] - | StopServerR - deriving (Show, Eq) - --- TODO: Set omitEmptyContents on aeson-0.9 -$(deriveJSON - defaultOptions - { constructorTagModifier = map toLower . init - , sumEncoding = defaultTaggedObject - { tagFieldName = "method" - , contentsFieldName = "request" - } - } - ''WalletRequest - ) - -{- JSON Types -} - -data JsonAccount = JsonAccount - { jsonAccountName :: !Text - , jsonAccountType :: !AccountType - , jsonAccountMaster :: !(Maybe XPrvKey) - , jsonAccountMnemonic :: !(Maybe Text) - , jsonAccountDerivation :: !(Maybe HardPath) - , jsonAccountKeys :: ![XPubKey] - , jsonAccountGap :: !Word32 - , jsonAccountCreated :: !UTCTime - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 11) ''JsonAccount) - -data JsonAddr = JsonAddr - { jsonAddrAddress :: !Address - , jsonAddrIndex :: !KeyIndex - , jsonAddrType :: !AddressType - , jsonAddrLabel :: !Text - , jsonAddrRedeem :: !(Maybe ScriptOutput) - , jsonAddrKey :: !(Maybe PubKeyC) - , jsonAddrCreated :: !UTCTime - -- Optional Balance - , jsonAddrBalance :: !(Maybe BalanceInfo) - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 8) ''JsonAddr) - -data JsonTx = JsonTx - { jsonTxHash :: !TxHash - , jsonTxNosigHash :: !TxHash - , jsonTxType :: !TxType - , jsonTxInValue :: !Word64 - , jsonTxOutValue :: !Word64 - , jsonTxValue :: !Int64 - , jsonTxInputs :: ![AddressInfo] - , jsonTxOutputs :: ![AddressInfo] - , jsonTxChange :: ![AddressInfo] - , jsonTxTx :: !Tx - , jsonTxIsCoinbase :: !Bool - , jsonTxConfidence :: !TxConfidence - , jsonTxConfirmedBy :: !(Maybe BlockHash) - , jsonTxConfirmedHeight :: !(Maybe Word32) - , jsonTxConfirmedDate :: !(Maybe Word32) - , jsonTxCreated :: !UTCTime - , jsonTxAccount :: !AccountName - -- Optional confirmation - , jsonTxConfirmations :: !(Maybe Word32) - , jsonTxBestBlock :: !(Maybe BlockHash) - , jsonTxBestBlockHeight :: !(Maybe BlockHeight) - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 6) ''JsonTx) - -data JsonCoin = JsonCoin - { jsonCoinHash :: !TxHash - , jsonCoinPos :: !Word32 - , jsonCoinValue :: !Word64 - , jsonCoinScript :: !ScriptOutput - , jsonCoinCreated :: !UTCTime - -- Optional Tx - , jsonCoinTx :: !(Maybe JsonTx) - -- Optional Address - , jsonCoinAddress :: !(Maybe JsonAddr) - -- Optional spender - , jsonCoinSpendingTx :: !(Maybe JsonTx) - } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 8) ''JsonCoin) - -{- Response Types -} - -data TxCompleteRes = TxCompleteRes - { txCompleteTx :: !Tx - , txCompleteComplete :: !Bool - } deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 10) ''TxCompleteRes) - -data ListResult a = ListResult - { listResultItems :: ![a] - , listResultTotal :: !Word32 - } - -$(deriveJSON (dropFieldLabel 10) ''ListResult) - -data RescanRes = RescanRes { rescanTimestamp :: !Word32 } - deriving (Eq, Show, Read) - -$(deriveJSON (dropFieldLabel 6) ''RescanRes) - -data WalletResponse a - = ResponseError { responseError :: !Text } - | ResponseValid { responseResult :: !(Maybe a) } - deriving (Eq, Show) - -$(deriveJSON (dropSumLabels 8 8 "status") ''WalletResponse) - -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 - 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 = 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" - -instance PersistFieldSql XPrvKey where - sqlType _ = SqlString - -instance PersistField [XPubKey] where - toPersistValue = PersistText . cs . Aeson.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" - -instance PersistFieldSql [XPubKey] where - sqlType _ = SqlString - -instance PersistField DerivPath where - 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 = 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 = 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 = PersistText . cs . Aeson.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 = PersistBool $ case ts of - AddressExternal -> True - AddressInternal -> False - - 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 _ = SqlBool - -instance PersistField TxType where - 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 - "self" -> return TxSelf - _ -> Left "Invalid Persistent TxType" - - fromPersistValue _ = Left "Invalid Persistent TxType" - -instance PersistFieldSql TxType where - sqlType _ = SqlString - -instance PersistField Address where - 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" - -instance PersistFieldSql Address where - sqlType _ = SqlString - -instance PersistField BloomFilter where - toPersistValue = PersistByteString . encode - fromPersistValue (PersistByteString bs) = - case decode bs of - Right x -> Right x - Left e -> Left (fromString e) - fromPersistValue _ = Left "Invalid Persistent BloomFilter" - -instance PersistFieldSql BloomFilter where - sqlType _ = SqlBlob - -instance PersistField BlockHash where - 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" - -instance PersistFieldSql BlockHash where - sqlType _ = SqlString - -instance PersistField TxHash where - 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" - -instance PersistFieldSql TxHash where - sqlType _ = SqlString - -instance PersistField TxConfidence where - 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 - sqlType _ = SqlString - -instance PersistField Tx where - toPersistValue = PersistByteString . encode - fromPersistValue (PersistByteString bs) = - case decode bs of - Right x -> Right x - Left e -> Left (fromString e) - fromPersistValue _ = Left "Invalid Persistent Tx" - -instance PersistFieldSql Tx where - sqlType _ = SqlOther "MEDIUMBLOB" - -instance PersistField PubKeyC where - toPersistValue = PersistText . cs . encodeHex . encode - fromPersistValue (PersistText txt) = - case hex >>= decode of - Right x -> Right x - Left e -> Left (fromString e) - where - hex = maybeToEither "Could not decode hex" (decodeHex (cs txt)) - fromPersistValue (PersistByteString bs) = - case hex >>= decode of - Right x -> Right x - Left e -> Left (fromString e) - where - hex = maybeToEither "Could not decode hex" (decodeHex bs) - fromPersistValue _ = Left "Invalid Persistent PubKeyC" - -instance PersistFieldSql PubKeyC where - sqlType _ = SqlString - -instance PersistField ScriptOutput where - toPersistValue = PersistByteString . encodeOutputBS - fromPersistValue (PersistByteString bs) = - case decodeOutputBS bs of - Right x -> Right x - Left e -> Left (fromString e) - fromPersistValue _ = Left "Invalid Persistent ScriptOutput" - -instance PersistFieldSql ScriptOutput where - sqlType _ = SqlBlob - -instance PersistField [AddressInfo] where - toPersistValue = PersistByteString . encode - fromPersistValue (PersistByteString bs) = - case decode bs of - Right x -> Right x - Left e -> Left (fromString e) - fromPersistValue _ = Left "Invalid Persistent AddressInfo" - -instance PersistFieldSql [AddressInfo] where - 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/Network/Haskoin/Wallet/Types/BlockInfo.hs b/Network/Haskoin/Wallet/Types/BlockInfo.hs deleted file mode 100644 --- a/Network/Haskoin/Wallet/Types/BlockInfo.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Network.Haskoin.Wallet.Types.BlockInfo -( - BlockInfo(..) -, JsonHash256 -, fromNodeBlock -) -where - -import Data.String.Conversions (cs, ConvertibleStrings(..)) -import Data.Maybe (fromMaybe) -import Data.Aeson.TH (deriveJSON) -import Data.Word (Word32) -import Data.Time (UTCTime) -import Data.ByteString (ByteString) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Aeson (FromJSON, ToJSON, Value (String), - parseJSON, toJSON, withText) - -import Network.Haskoin.Block -import Network.Haskoin.Node.HeaderTree -import Network.Haskoin.Crypto -import Network.Haskoin.Util - - -newtype JsonHash256 = JsonHash256 { jsonGetHash256 :: Hash256 } - deriving (Eq, Show) - -jsonHashToHex :: JsonHash256 -> ByteString -jsonHashToHex = blockHashToHex . BlockHash . jsonGetHash256 - -instance ToJSON JsonHash256 where - toJSON = String . cs . jsonHashToHex - -instance FromJSON JsonHash256 where - parseJSON = withText "JsonHash256" $ - return . JsonHash256 . getBlockHash <$> - fromMaybe (error "Invalid 256 bit hash") . - hexToBlockHash . cs - -instance ConvertibleStrings JsonHash256 String where - convertString = cs . jsonHashToHex - -data BlockInfo = BlockInfo - { blockInfoHash :: !BlockHash - , blockInfoHeight :: !BlockHeight - , blockInfoVersion :: !Word32 - , blockInfoTimestamp :: !UTCTime - , blockInfoPrevBlock :: !BlockHash - , blockInfoMerkleRoot :: !JsonHash256 - , blockInfoBits :: !Word32 - , blockInfoNonce :: !Word32 - , blockInfoChain :: !Word32 - , blockInfoChainWork :: !Double - } deriving (Eq, Show) - -$(deriveJSON (dropFieldLabel 9) ''BlockInfo) - -fromNodeBlock :: NodeBlock -> BlockInfo -fromNodeBlock nb = - BlockInfo - { blockInfoHash = headerHash header - , blockInfoVersion = blockVersion header - , blockInfoPrevBlock = prevBlock header - , blockInfoNonce = bhNonce header - , blockInfoBits = blockBits header - , blockInfoMerkleRoot = JsonHash256 $ merkleRoot header - , blockInfoTimestamp = utcTimestamp - , blockInfoChainWork = nodeWork nb - , blockInfoHeight = nodeHeight nb - , blockInfoChain = nodeChain nb - } - where - header = nodeHeader nb - utcTimestamp = posixSecondsToUTCTime . realToFrac . - blockTimestamp $ header - diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,4 @@ -module Main where - -import Network.Haskoin.Wallet.Client +import Haskoin.Wallet.Main main :: IO () main = clientMain diff --git a/config/config.yml b/config/config.yml deleted file mode 100644 --- a/config/config.yml +++ /dev/null @@ -1,118 +0,0 @@ -# ZeroMQ socket on which to listen to. Either absolute path or relative to -# work-dir/network. -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 - -# False positive rate for the bloom filters. -bloom-false-positive: 0.00001 - -# Database connection information. -database: - testnet: - database: hw-wallet.sqlite3 - poolsize: 1 - prodnet: - database: hw-wallet.sqlite3 - poolsize: 1 - -# List of trusted bitcoin full-nodes to connect to. -bitcoin-full-nodes: - testnet: - - host: testnet-seed.alexykot.me - port: 18333 - - host: testnet-seed.bitcoin.petertodd.org - port: 18333 - - host: testnet-seed.bluematt.me - port: 18333 - - host: testnet-seed.bitcoin.schildbach.de - port: 18333 - prodnet: - - host: seed.bitcoin.sipa.be - port: 8333 - - host: dnsseed.bluematt.me - port: 8333 - - host: dnsseed.bitcoin.dashjr.org - port: 8333 - - host: seed.bitcoinstats.com - port: 8333 - - host: bitseed.xf2.org - port: 8333 - - host: seed.bitcoin.jonasschnelli.ch - port: 8333 - - -# Log file name. Either absolute path or relative to work-dir/network -log-file: hw.log - -# PID file name. Either absolute path or relative to work-dir/network. -pid-file: hw.pid - -# Compile time configuration value. Either absolute path or relative to -# work-dir. Can only be set as environment variable. -config-file: config.yml - -# Default output size for commands such as page sizes. -output-size: 10 - -# Type of addresses to display. Example: external, internal -address-type: external - -# Use reverse paging for diplaying addresses and txs when set to True. -reverse-paging: false - -# Sign new and imported transactions. -sign-transactions: true - -# Default fee to pay (in satoshi) for every 1000 bytes. -transaction-fee: 10000 - -# Minimum number of confirmations for spending coins and displaying balances. -minimum-confirmations: 0 - -# Display the balance including offline transactions -offline: false - -# How command-line output should be displayed. Supported values are: -# normal, json or yaml. -display-format: normal - -# Detach the SPV server from the terminal when launched -detach-server: false - -# Use Testnet3 -use-testnet: false - -# Haskoin working directory. Either absolute path or relative to user’s home. -# Defaults to an appropriate OS-specific value. -work-dir: "" - -# Log level. Valid values are debug, info, warn and error. -log-level: info - -# Print verbose -verbose: false - -# 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 deleted file mode 100644 --- a/config/help +++ /dev/null @@ -1,52 +0,0 @@ -Server commands: - 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 - 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 - pubkeys acc [page] [-c pagesize] [-r] Display address public keys - 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 - getindex acc key Get key index by pubkey - genaddrs acc index [--internal] Generate addresses up to this index - -Transaction commands: - 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 - -Utility commands: - decodetx Decode HEX transaction - rescan [timestamp] Rescan the wallet - keypair Get curve key pair for ØMQ auth - monitor [account] Monitor events (no account: blocks) - blockinfo [hash1] [hash2] [...] Get block header information by hash - -Other commands: - version Display version information - help Display this help information diff --git a/config/models b/config/models deleted file mode 100644 --- a/config/models +++ /dev/null @@ -1,84 +0,0 @@ -Account - name Text maxlen=200 - type AccountType maxlen=64 - derivation HardPath Maybe maxlen=200 - master XPrvKey Maybe - keys [XPubKey] - gap Word32 - created UTCTime - UniqueAccount name - deriving Show - -WalletAddr - account AccountId - address Address maxlen=64 - index KeyIndex - type AddressType maxlen=16 - label Text - redeem ScriptOutput Maybe - key PubKeyC Maybe maxlen=66 - created UTCTime - UniqueAddr account address - UniqueAddrRev address account - UniqueAddrIndex account type index - deriving Show - -WalletTx - account AccountId - hash TxHash maxlen=64 - nosigHash TxHash maxlen=64 - type TxType maxlen=16 - inValue Word64 - outValue Word64 - inputs [AddressInfo] - outputs [AddressInfo] - change [AddressInfo] - tx Tx - isCoinbase Bool - confidence TxConfidence maxlen=16 - confirmedBy BlockHash Maybe maxlen=64 - confirmedHeight BlockHeight Maybe - confirmedDate Timestamp Maybe - created UTCTime - UniqueAccTx account hash - UniqueAccTxRev hash account - UniqueAccNoSig account nosigHash - UniqueAccNoSigRev nosigHash account - deriving Show - -WalletCoin - account AccountId - hash TxHash maxlen=64 - pos Word32 - tx WalletTxId - addr WalletAddrId - value Word64 - script ScriptOutput - created UTCTime - UniqueCoin account hash pos - UniqueCoinRev hash pos account - UniqueCoinTx tx pos - UniqueCoinTxRev pos tx - deriving Show - -SpentCoin - account AccountId - hash TxHash maxlen=64 - pos Word32 - spendingTx WalletTxId - created UTCTime - UniqueSpentCoins account hash pos - UniqueSpentCoinsRev hash pos account - UniqueSpentTx spendingTx hash pos - UniqueSpentTxRev hash pos spendingTx - deriving Show - -WalletState - height BlockHeight - block BlockHash maxlen=64 - bloomFilter BloomFilter - bloomElems Int - bloomFp Double - version Int - created UTCTime - deriving Show diff --git a/examples/embedded-inproc-wallet-server/Main.hs b/examples/embedded-inproc-wallet-server/Main.hs deleted file mode 100644 --- a/examples/embedded-inproc-wallet-server/Main.hs +++ /dev/null @@ -1,183 +0,0 @@ -module Main where - -import Network.Haskoin.Wallet (Config(..), - WalletRequest(..), WalletResponse(..), - AddressType(..), OutputFormat(..), - SPVMode(..), NodeAction(..)) - -import Network.Haskoin.Wallet.Server (runSPVServerWithContext) -import Network.Haskoin.Wallet.Internals (BTCNode(..), Notif(..)) -import qualified Network.Haskoin.Node.STM as Node - -import Data.String.Conversions (cs) -import qualified System.ZMQ4 as ZMQ -import qualified Control.Monad.Logger as Log -import qualified Data.HashMap.Strict as HM -import qualified Database.Persist.Sqlite as DB -import qualified Control.Monad.Trans.Resource as Resource -import qualified Data.Aeson as JSON -import qualified Control.Concurrent as Con -import qualified Data.Aeson.Encode.Pretty as PrettyJSON -import qualified Control.Monad as M -import qualified Control.Exception as Except - - -databaseConf :: DB.SqliteConf -databaseConf = DB.SqliteConf "/tmp/tmpdb" 1 - -cmdSocket :: String -cmdSocket = "inproc://cmd" - -notifSocket :: String -notifSocket = "inproc://notif" - - --- |Simple example app that embeds a haskoin-wallet server. --- Start wallet server + notification thread, and execute Status command when pressing ENTER -main :: IO () -main = ZMQ.withContext $ \ctx -> do - -- Server - putStrLn "Starting server..." - _ <- Con.forkIO $ runWallet walletServerConf ctx - -- Notify thread - putStrLn "Starting notification thread..." - _ <- Con.forkIO $ notifyThread ctx notifyHandler - -- Status loop - M.forever $ do - putStrLn "Press ENTER to get server status..." - _ <- getLine - cmdGetStatus ctx >>= printStatusJSON - where - printStatusJSON = putStrLn . cs . PrettyJSON.encodePretty - notifyHandler notif = - putStrLn $ "NOTIFY: New block: " ++ cs (PrettyJSON.encodePretty notif) - --- |Run haskoin-wallet using the specified ZeroMQ Context, --- and log to stderr. -runWallet :: Config -> ZMQ.Context -> IO () -runWallet cfg ctx = run $ runSPVServerWithContext cfg ctx - where run = Resource.runResourceT . runLogging - runLogging = Log.runStderrLoggingT . Log.filterLogger logFilter - logFilter _ l = l >= configLogLevel cfg - -cmdGetStatus :: ZMQ.Context -> IO Node.NodeStatus -cmdGetStatus ctx = - sendCmdOrFail (PostNodeR NodeActionStatus) ctx >>= - \res -> case res of - Nothing -> error "ERROR: Status command: no response." - Just status -> return status - -sendCmdOrFail :: (JSON.FromJSON a, JSON.ToJSON a) - => WalletRequest - -> ZMQ.Context - -> IO (Maybe a) -sendCmdOrFail cmd ctx = - sendCmd cmd ctx >>= - either error return >>= - \res -> case res of - ResponseError e -> error $ "ERROR: Send cmd, ResponseError: " ++ cs e - ResponseValid r -> return r - -sendCmd :: (JSON.FromJSON a, JSON.ToJSON a) - => WalletRequest - -> ZMQ.Context - -> IO (Either String (WalletResponse a)) -sendCmd req ctx = - ZMQ.withSocket ctx ZMQ.Req $ \sock -> do - ZMQ.setLinger (ZMQ.restrict (0 :: Int)) sock - ZMQ.connect sock cmdSocket - ZMQ.send sock [] (cs $ JSON.encode req) - JSON.eitherDecode . cs <$> ZMQ.receive sock - --- |Connect to notify socket, subscribe to new blocks, --- and execute the supplied handler for each new block as it arrives. -notifyThread :: ZMQ.Context -> (Notif -> IO ()) -> IO () -notifyThread ctx handler = waitAndCatch $ - ZMQ.withSocket ctx ZMQ.Sub $ \sock -> do - ZMQ.setLinger (ZMQ.restrict (0 :: Int)) sock - ZMQ.connect sock notifSocket - ZMQ.subscribe sock "[block]" - putStrLn "NOTIFY: Connected. Subscribed to new blocks." - M.forever $ do - [_,m] <- ZMQ.receiveMulti sock - notif <- either failOnErr return $ JSON.eitherDecode (cs m) - handler notif - where - failOnErr = fail . ("NOTIFY: ERROR: recv failed: " ++) - waitAndCatch ioa = Con.threadDelay 10000 >> ioa `Except.finally` waitAndCatch ioa - -btcNodes :: [BTCNode] -btcNodes = - [ BTCNode "dnsseed.bluematt.me" 8333 - , BTCNode "dnsseed.bitcoin.dashjr.org" 8333 - , BTCNode "dnsseed.bluematt.me" 8333 - , BTCNode "seed.bitcoinstats.com" 8333 - , BTCNode "seed.bitcoin.jonasschnelli.ch" 8333 - , BTCNode "seed.bitcoin.sipa.be" 8333 - , BTCNode "seed.bitnodes.io" 8333 - , BTCNode "seed.btcc.com" 8333 - ] - -walletServerConf :: Config -walletServerConf = Config - { configCount = 100 - -- ^ Output size of commands - , configMinConf = 6 - -- ^ Minimum number of confirmations - , configSignTx = True - -- ^ Sign transactions - , configFee = 50000 - -- ^ Fee to pay per 1000 bytes when creating new transactions - , configRcptFee = False - -- ^ Recipient pays fee (dangerous, no config file setting) - , configAddrType = AddressExternal - -- ^ Return internal instead of external addresses - , configOffline = False - -- ^ Display the balance including offline transactions - , configReversePaging = False - -- ^ Use reverse paging for displaying addresses and transactions - , configPath = Nothing - -- ^ Derivation path when creating account - , configFormat = OutputNormal - -- ^ How to format the command-line results - , configConnect = cmdSocket - -- ^ ZeroMQ socket to connect to (location of the server) - , configConnectNotif = notifSocket - -- ^ ZeroMQ socket to connect for notifications - , configDetach = False - -- ^ Detach server when launched from command-line - , configFile = "" - -- ^ Configuration file - , configTestnet = False - -- ^ Use Testnet3 network - , configDir = "" - -- ^ Working directory - , configBind = cmdSocket - -- ^ Bind address for the ZeroMQ socket - , configBindNotif = notifSocket - -- ^ Bind address for ZeroMQ notifications - , configBTCNodes = HM.fromList [ ( "prodnet", btcNodes ) ] - -- ^ Trusted Bitcoin full nodes to connect to - , configMode = SPVOnline - -- ^ Operation mode of the SPV node. - , configBloomFP = 0.00001 - -- ^ False positive rate for the bloom filter. - , configDatabase = HM.fromList [ ( "prodnet", databaseConf ) ] - -- ^ Database configuration - , configLogFile = "" - -- ^ Log file - , configPidFile = "" - -- ^ PID File - , configLogLevel = Log.LevelInfo - -- ^ Log level - , configVerbose = True - -- ^ Verbose - , configServerKey = Nothing - -- ^ Server key for authentication and encryption (server config) - , configServerKeyPub = Nothing - -- ^ Server public key for authentication and encryption (client config) - , configClientKey = Nothing - -- ^ Client key for authentication and encryption (client config) - , configClientKeyPub = Nothing - -- ^ Client public key for authentication and encryption - } diff --git a/haskoin-wallet.cabal b/haskoin-wallet.cabal --- a/haskoin-wallet.cabal +++ b/haskoin-wallet.cabal @@ -1,180 +1,195 @@ -name: haskoin-wallet -version: 0.4.2 -synopsis: - Implementation of a Bitcoin SPV Wallet with BIP32 and multisig support. -description: - This package provides a SPV (simple payment verification) wallet - implementation. It features BIP32 key management, deterministic signatures - (RFC-6979) and first order support for multi-signature transactions. You - can communicate with the wallet process through a ZeroMQ API or through a - command-line tool called "hw" which is also provided in this package. -homepage: http://github.com/haskoin/haskoin -bug-reports: http://github.com/haskoin/haskoin/issues -tested-with: GHC==8.0.2 -license: PublicDomain -license-file: UNLICENSE -author: Philippe Laprade, Jean-Pierre Rupp -maintainer: xenog@protonmail.com -category: Bitcoin, Finance, Network -build-type: Simple -cabal-version: >= 1.9.2 -extra-source-files: config/help, config/config.yml, config/models - -source-repository head - type: git - location: git://github.com/haskoin/haskoin.git - -Flag library-only - Description: Do not build the executables - Default: False - -library - exposed-modules: Network.Haskoin.Wallet - Network.Haskoin.Wallet.Model - Network.Haskoin.Wallet.Client - Network.Haskoin.Wallet.Server - Network.Haskoin.Wallet.Settings - Network.Haskoin.Wallet.Internals +cabal-version: 1.12 - other-modules: Network.Haskoin.Wallet.Types - Network.Haskoin.Wallet.Types.BlockInfo - 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.Client.PrettyJson - Network.Haskoin.Wallet.Database +-- This file has been generated from package.yaml by hpack version 0.38.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3e39505c3793edd3fb6ec57bd710521a7ac480b59144d1b82744f777acfbf6d8 - extensions: TemplateHaskell - QuasiQuotes - OverloadedStrings - MultiParamTypeClasses - TypeFamilies - GADTs - FlexibleContexts - FlexibleInstances - EmptyDataDecls - DeriveDataTypeable - RecordWildCards - GeneralizedNewtypeDeriving +name: haskoin-wallet +version: 0.9.4 +synopsis: Lightweight CLI wallet for Bitcoin and Bitcoin Cash +description: Lightweight command-line interface offline-friendly hierarchical-deterministic BTC/BCH wallet compatible with BIP44 and BIP39. +category: Bitcoin, Finance, Network +homepage: http://github.com/haskoin/haskoin-wallet +bug-reports: http://github.com/haskoin/haskoin-wallet/issues +author: JP Rupp +maintainer: jprupp@protonmail.ch +license: PublicDomain +license-file: UNLICENSE +build-type: Simple - build-depends: aeson >= 0.7 && < 1.1 - , aeson-pretty >= 0.7 && < 0.9 - , base >= 4.8 && < 5 - , bytestring >= 0.10 && < 0.11 - , cereal >= 0.5 && < 0.6 - , containers >= 0.5 && < 0.6 - , conduit >= 1.2 && < 1.3 - , deepseq >= 1.4 && < 1.5 - , data-default >= 0.5 && < 0.8 - , directory >= 1.2 && < 1.4 - , daemons >= 0.2 && < 0.3 - , exceptions >= 0.6 && < 0.9 - , esqueleto >= 2.4 && < 2.6 - , file-embed >= 0.0 && < 0.1 - , filepath >= 1.4 && < 1.5 - , haskeline - , haskoin-core >= 0.3 && < 0.5 - , haskoin-node >= 0.3 && < 0.5 - , lifted-async >= 0.2 && < 0.10 - , 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.7 - , persistent-template >= 2.1 && < 2.6 - , persistent-sqlite >= 2.2 && < 2.7 - , resourcet >= 1.1 && < 1.2 - , semigroups - , split >= 0.2 && < 0.3 - , stm >= 2.4 && < 2.5 - , stm-chans >= 3.0 && < 3.1 - , stm-conduit >= 2.6 && < 3.1 - , string-conversions >= 0.4 && < 0.5 - , text >= 0.11 && < 1.3 - , time >= 1.5 && < 1.7 - , transformers-base >= 0.4 && < 0.5 - , unix >= 2.6 && < 2.8 - , unordered-containers >= 0.2 && < 0.3 - , yaml >= 0.8 && < 0.9 - , zeromq4-haskell >= 0.6 && < 0.7 +source-repository head + type: git + location: https://github.com/haskoin/haskoin-wallet.git - ghc-options: -Wall +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + Decimal >=0.5.1 + , aeson >=1.4.6.0 + , aeson-pretty >=0.8.8 + , ansi-terminal >=1.0 + , base >=4.9 && <5 + , base16-bytestring >=1.0.0.0 + , base64-bytestring >=1.0.0.3 + , bytestring >=0.10.10.0 + , cereal >=0.5.8.1 + , conduit >=1.3.5 + , containers >=0.6.2.1 + , data-default >=0.7.1.1 + , directory >=1.3.6.0 + , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 + , haskeline >=0.7.5.0 + , haskoin-core >=1.0.4 + , haskoin-store-data >=1.2.2 + , http-types >=0.12.3 + , lens >=4.18.1 + , lens-aeson >=1.1 + , monad-logger >=0.3.40 + , mtl >=2.2.2 + , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 + , pretty >=1.1.3.6 + , random >=1.1 + , raw-strings-qq >=1.1 + , secp256k1-haskell >=1.1.0 + , split >=0.2.3.5 + , string-conversions >=0.4.0.1 + , text >=1.2.4.0 + , time >=1.12.2 + , transformers >=0.5.6.2 + , unordered-containers >=0.2.10.0 + , wreq >=0.5.3.2 + exposed-modules: + Haskoin.Wallet + Haskoin.Wallet.Amounts + Haskoin.Wallet.Backup + Haskoin.Wallet.Commands + Haskoin.Wallet.Config + Haskoin.Wallet.Database + Haskoin.Wallet.Entropy + Haskoin.Wallet.FileIO + Haskoin.Wallet.Main + Haskoin.Wallet.Migration + Haskoin.Wallet.Migration.SemVersion + Haskoin.Wallet.Migration.V0_9_0 + Haskoin.Wallet.Parser + Haskoin.Wallet.PrettyPrinter + Haskoin.Wallet.Signing + Haskoin.Wallet.TxInfo + Haskoin.Wallet.Util + other-modules: + Paths_haskoin_wallet + default-language: Haskell2010 executable hw - if flag(library-only) - Buildable: False - main-is: Main.hs - build-depends: base, haskoin-wallet - hs-source-dirs: app - ghc-options: -Wall - -O3 - -threaded - -eventlog - -rtsopts - -with-rtsopts=-N4 - -test-suite test-haskoin-wallet - type: exitcode-stdio-1.0 - main-is: Main.hs - - other-modules: Network.Haskoin.Wallet.Arbitrary - , Network.Haskoin.Wallet.Tests - , Network.Haskoin.Wallet.Units - - extensions: RecordWildCards - OverloadedStrings - - build-depends: aeson >= 0.7 && < 1.1 - , base >= 4.8 && < 5 - , bytestring >= 0.10 && < 0.11 - , containers >= 0.5 && < 0.6 - , directory >= 1.2 && < 1.4 - , 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 - , persistent >= 2.2 && < 2.7 - , persistent-sqlite >= 2.2 && < 2.7 - , resourcet >= 1.1 && < 1.2 - , text >= 0.11 && < 1.3 - , unordered-containers >= 0.2 && < 0.3 - , HUnit >= 1.2 && < 1.6 - , QuickCheck >= 2.8 && < 2.10 - , 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 - - hs-source-dirs: tests - ghc-options: -Wall - -executable example-inproc-wallet-server - if flag(library-only) - Buildable: False - - main-is: Main.hs - hs-source-dirs: examples/embedded-inproc-wallet-server/ - extensions: OverloadedStrings - - ghc-options: -Wall - -O3 - -threaded - -rtsopts - -with-rtsopts=-N4 + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall + build-depends: + Decimal >=0.5.1 + , aeson >=1.4.6.0 + , aeson-pretty >=0.8.8 + , ansi-terminal >=1.0 + , base >=4.9 && <5 + , base16-bytestring >=1.0.0.0 + , base64-bytestring >=1.0.0.3 + , bytestring >=0.10.10.0 + , cereal >=0.5.8.1 + , conduit >=1.3.5 + , containers >=0.6.2.1 + , data-default >=0.7.1.1 + , directory >=1.3.6.0 + , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 + , haskeline >=0.7.5.0 + , haskoin-core >=1.0.4 + , haskoin-store-data >=1.2.2 + , haskoin-wallet + , http-types >=0.12.3 + , lens >=4.18.1 + , lens-aeson >=1.1 + , monad-logger >=0.3.40 + , mtl >=2.2.2 + , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 + , pretty >=1.1.3.6 + , random >=1.1 + , raw-strings-qq >=1.1 + , secp256k1-haskell >=1.1.0 + , split >=0.2.3.5 + , string-conversions >=0.4.0.1 + , text >=1.2.4.0 + , time >=1.12.2 + , transformers >=0.5.6.2 + , unordered-containers >=0.2.10.0 + , wreq >=0.5.3.2 + other-modules: + Paths_haskoin_wallet + default-language: Haskell2010 - build-depends: base >= 4.8 && < 5 - , aeson >= 0.7 && < 1.1 - , aeson-pretty >= 0.7 && < 0.9 - , haskoin-node >= 0.3 && < 0.5 - , haskoin-wallet - , monad-logger >= 0.3 && < 0.4 - , persistent-sqlite >= 2.2 && < 2.7 - , resourcet >= 1.1 && < 1.2 - , unordered-containers >= 0.2 && < 0.3 - , string-conversions >= 0.4 && < 0.5 - , zeromq4-haskell >= 0.6 && < 0.7 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Haskoin.Wallet.AmountsSpec + Haskoin.Wallet.CommandsSpec + Haskoin.Wallet.EntropySpec + Haskoin.Wallet.SigningSpec + Haskoin.Wallet.TestUtils + Haskoin.Wallet.VersionSpec + Paths_haskoin_wallet + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + Decimal >=0.5.1 + , HUnit >=1.6.0.0 + , QuickCheck >=2.13.2 + , aeson >=1.4.6.0 + , aeson-pretty >=0.8.8 + , ansi-terminal >=1.0 + , base >=4.9 && <5 + , base16-bytestring >=1.0.0.0 + , base64-bytestring >=1.0.0.3 + , bytestring >=0.10.10.0 + , cereal >=0.5.8.1 + , conduit >=1.3.5 + , containers >=0.6.2.1 + , data-default >=0.7.1.1 + , directory >=1.3.6.0 + , entropy >=0.4.1.6 + , esqueleto >=3.5.10.1 + , haskeline >=0.7.5.0 + , haskoin-core >=1.0.4 + , haskoin-store-data >=1.2.2 + , haskoin-wallet + , hspec >=2.7.1 + , http-types >=0.12.3 + , lens >=4.18.1 + , lens-aeson >=1.1 + , monad-logger >=0.3.40 + , mtl >=2.2.2 + , optparse-applicative >=0.15.1.0 + , persistent >=2.14.5.1 + , persistent-sqlite >=2.13.1.1 + , pretty >=1.1.3.6 + , random >=1.1 + , raw-strings-qq >=1.1 + , secp256k1-haskell >=1.1.0 + , split >=0.2.3.5 + , string-conversions >=0.4.0.1 + , text >=1.2.4.0 + , time >=1.12.2 + , transformers >=0.5.6.2 + , unordered-containers >=0.2.10.0 + , wreq >=0.5.3.2 + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Haskoin/Wallet.hs b/src/Haskoin/Wallet.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet.hs @@ -0,0 +1,24 @@ +module Haskoin.Wallet + ( module Amounts, + module Commands, + module Config, + module Database, + module Entropy, + module FileIO, + module Parser, + module Signing, + module TxInfo, + module Util, + ) +where + +import Haskoin.Wallet.Amounts as Amounts +import Haskoin.Wallet.Commands as Commands +import Haskoin.Wallet.Config as Config +import Haskoin.Wallet.Database as Database +import Haskoin.Wallet.Entropy as Entropy +import Haskoin.Wallet.FileIO as FileIO +import Haskoin.Wallet.Parser as Parser +import Haskoin.Wallet.Signing as Signing +import Haskoin.Wallet.TxInfo as TxInfo +import Haskoin.Wallet.Util as Util diff --git a/src/Haskoin/Wallet/Amounts.hs b/src/Haskoin/Wallet/Amounts.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Amounts.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Haskoin.Wallet.Amounts where + +import Control.Arrow (second) +import Control.Monad (guard) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Read as Read +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) + +data AmountUnit + = UnitBitcoin + | UnitBit + | UnitSatoshi + deriving (Eq, Show) + +-- Amount Parsing -- + +showUnit :: AmountUnit -> Integer -> Text +showUnit unit amnt + | unit == UnitSatoshi = strUnit -- satoshi is always singular + | abs amnt == 1 = strUnit + | otherwise = strUnit <> "s" -- plural form bitcoins and bits + where + strUnit = + case unit of + UnitBitcoin -> "bitcoin" + UnitBit -> "bit" + UnitSatoshi -> "satoshi" + +showAmount :: AmountUnit -> Natural -> Text +showAmount unit amnt = + case unit of + UnitBitcoin -> + let (q, r) = amnt `divMod` 100000000 + in addSep (showT q) <> "." <> removeEnd (padStart 8 "0" (showT r)) + UnitBit -> + let (q, r) = amnt `divMod` 100 + in addSep (showT q) <> "." <> padStart 2 "0" (showT r) + UnitSatoshi -> addSep (showT amnt) + where + removeEnd = dropPatternEnd "0000" . dropPatternEnd "000000" + addSep = Text.intercalate "'" . chunksOfEnd 3 + showT = Text.pack . show + +readAmount :: AmountUnit -> Text -> Maybe Natural +readAmount unit amntStr = + case unit of + UnitBitcoin -> do + guard $ Text.length r <= 8 + a <- readNatural q + b <- readNatural $ padEnd 8 "0" r + return $ a * 100000000 + b + UnitBit -> do + guard $ Text.length r <= 2 + a <- readNatural q + b <- readNatural $ padEnd 2 "0" r + return $ a * 100 + b + UnitSatoshi -> readNatural str + where + str = dropAmountSep amntStr + (q, r) = second (Text.drop 1) $ Text.breakOn "." str + +readNatural :: Text -> Maybe Natural +readNatural txt = + case Read.decimal txt of + Right (res, "") -> Just res + _ -> Nothing + +dropAmountSep :: Text -> Text +dropAmountSep = Text.filter (`notElem` [' ', '_', '\'']) + +-- | Like 'showAmount' but will display a minus sign for negative amounts +showIntegerAmount :: AmountUnit -> Integer -> Text +showIntegerAmount unit i + | i < 0 = "-" <> showAmount unit (fromIntegral $ abs i) + | otherwise = showAmount unit $ fromIntegral i + +-- | Like 'readAmount' but can parse a negative amount +readIntegerAmount :: AmountUnit -> Text -> Maybe Integer +readIntegerAmount unit txt = + case Text.uncons txt of + Just ('-', rest) -> negate . toInteger <$> readAmount unit rest + _ -> toInteger <$> readAmount unit txt diff --git a/src/Haskoin/Wallet/Backup.hs b/src/Haskoin/Wallet/Backup.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Backup.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Haskoin.Wallet.Backup where + +import Conduit (MonadUnliftIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..), MonadTrans (lift)) +import Data.Aeson (object, (.:), (.=)) +import qualified Data.Aeson as Json +import Data.Default (def) +import Data.List (nub, sort, (\\)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import qualified Data.Serialize as S +import Data.Text (Text) +import Data.Time (UTCTime) +import Database.Esqueleto.Legacy as E +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) + +newtype WalletBackup = WalletBackup [AccountBackup] + deriving (Eq, Show) + +instance MarshalJSON Ctx WalletBackup where + marshalValue ctx (WalletBackup accs) = + object ["accounts" .= (marshalValue ctx <$> accs)] + unmarshalValue ctx = + Json.withObject "WalletBackup" $ \o -> do + accs <- mapM (unmarshalValue ctx) =<< o .: "accounts" + return $ WalletBackup accs + +data AccountBackup = AccountBackup + { accountBackupName :: !Text, + accountBackupWallet :: !Fingerprint, + accountBackupPubKey :: !XPubKey, + accountBackupNetwork :: !Network, + accountBackupExternal :: !Natural, + accountBackupInternal :: !Natural, + accountBackupLabels :: Map Address Text, + accountBackupFree :: [Address], + accountBackupCreated :: !UTCTime + } + deriving (Eq, Show) + +instance MarshalJSON Ctx AccountBackup where + marshalValue ctx AccountBackup {..} = + let net = accountBackupNetwork + f = Map.mapKeys (fromJust . addrToText net) + in object + [ "name" .= accountBackupName, + "wallet" .= accountBackupWallet, + "xpubkey" + .= marshalValue (accountBackupNetwork, ctx) accountBackupPubKey, + "network" .= accountBackupNetwork.name, + "external" .= accountBackupExternal, + "internal" .= accountBackupInternal, + "labels" .= f accountBackupLabels, + "free" .= (fromJust . addrToText net <$> accountBackupFree), + "created" .= accountBackupCreated + ] + unmarshalValue ctx = + Json.withObject "AccountBackup" $ \o -> do + net <- maybe mzero pure . netByName =<< o .: "network" + let f = Map.mapKeys (fromJust . textToAddr net) + AccountBackup + <$> o .: "name" + <*> o .: "wallet" + <*> (unmarshalValue (net, ctx) =<< o .: "xpubkey") + <*> pure net + <*> o .: "external" + <*> o .: "internal" + <*> (f <$> o .: "labels") + <*> ((fromJust . textToAddr net <$>) <$> o .: "free") + <*> o .: "created" + +createBackup :: (MonadUnliftIO m) => Ctx -> ExceptT String (DB m) WalletBackup +createBackup ctx = do + accs <- lift getAccounts + backs <- + forM accs $ \(_, acc@DBAccount {..}) -> do + let net = accountNetwork acc + (DBWalletKey fpT) = dBAccountWallet + fp <- liftEither $ textToFingerprint fpT + labelVals <- + lift . select . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val dBAccountWallet + &&. a ^. DBAddressAccountDerivation ==. val dBAccountDerivation + &&. a ^. DBAddressInternal ==. val False + &&. a ^. DBAddressLabel !=. val "" + return (a ^. DBAddressAddress, a ^. DBAddressLabel) + labels <- forM labelVals $ \(Value at, Value l) -> do + a <- liftMaybe "Address" $ textToAddr net at + return (a, l) + freeVals <- + lift . select . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val dBAccountWallet + &&. a ^. DBAddressAccountDerivation ==. val dBAccountDerivation + &&. a ^. DBAddressInternal ==. val True + &&. a ^. DBAddressFree ==. val True + return $ a ^. DBAddressAddress + free <- mapM (liftMaybe "Address" . textToAddr net . unValue) freeVals + return + AccountBackup + { accountBackupName = dBAccountName, + accountBackupWallet = fp, + accountBackupPubKey = accountXPubKey ctx acc, + accountBackupNetwork = accountNetwork acc, + accountBackupExternal = fromIntegral dBAccountExternal, + accountBackupInternal = fromIntegral dBAccountInternal, + accountBackupLabels = Map.fromList labels, + accountBackupFree = free, + accountBackupCreated = dBAccountCreated + } + return $ WalletBackup backs + +data SyncRes = SyncRes + { syncResAccount :: !DBAccount, + syncResBlockHash :: !BlockHash, + syncResBlockHeight :: !BlockHeight, + syncResTxUpdates :: !Natural, + syncResCoinUpdates :: !Natural + } + deriving (Eq, Show) + +restoreBackup :: + (MonadUnliftIO m) => + Ctx -> + Config -> + WalletBackup -> + ExceptT String (DB m) [SyncRes] +restoreBackup ctx cfg (WalletBackup accs) = + mapM (restoreAccount ctx cfg) accs + +restoreAccount :: + (MonadUnliftIO m) => + Ctx -> + Config -> + AccountBackup -> + ExceptT String (DB m) SyncRes +restoreAccount ctx cfg AccountBackup {..} = do + -- Insert the account + (accId, acc) <- + insertAccount + accountBackupNetwork + ctx + accountBackupWallet + accountBackupName + accountBackupPubKey + let net = accountBackupNetwork + -- Set the external and internal derivation indices + (e, i) <- discoverAddrs net ctx cfg accountBackupPubKey + let idxE = max e accountBackupExternal + idxI = max i accountBackupInternal + discoverAccGenAddrs ctx cfg accId AddrExternal $ fromIntegral idxE + discoverAccGenAddrs ctx cfg accId AddrInternal $ fromIntegral idxI + -- Perform an account sync + syncRes <- sync ctx cfg net accId True + -- Set address labels + forM_ (Map.assocs accountBackupLabels) $ \(addr, l) -> do + at <- liftMaybe "Address" $ addrToText net addr + lift . update $ \a -> do + set a [DBAddressLabel =. val l] + where_ $ a ^. DBAddressAddress ==. val at + -- Set Free internal addresses + addrsT <- mapM (liftMaybe "Address" . addrToText net) accountBackupFree + _ <- lift $ setAddrsFree AddrFree addrsT + -- Set the creation time + lift . update $ \a -> do + set a [DBAccountCreated =. val accountBackupCreated] + where_ $ + a ^. DBAccountWallet ==. val (dBAccountWallet acc) + &&. a ^. DBAccountDerivation ==. val (dBAccountDerivation acc) + acc' <- getAccountById accId + return syncRes {syncResAccount = acc'} + +discoverAddrs :: + (MonadIO m) => + Network -> + Ctx -> + Config -> + XPubKey -> + ExceptT String m (Natural, Natural) +discoverAddrs net ctx cfg pub = do + let recoveryGap = configRecoveryGap cfg + e <- go extDeriv 0 (Page recoveryGap 0) + i <- go intDeriv 0 (Page recoveryGap 0) + return (fromIntegral e, fromIntegral i) + where + go path d page@(Page lim off) = do + let addrs = addrsDerivPage ctx path page pub + req = GetAddrsBalance $ fst <$> addrs + let host = apiHost net cfg + Store.SerialList bals <- liftExcept $ apiCall ctx host req + let vBals = filter ((/= 0) . (.txs)) bals + if null vBals + then return d + else do + let dMax = findMax addrs $ (.address) <$> vBals + go path (dMax + 1) (Page lim (off + lim)) + -- Find the largest ID amongst the addresses that have a positive balance + findMax :: [(Address, SoftPath)] -> [Address] -> Int + findMax addrs balAddrs = + let fAddrs = filter ((`elem` balAddrs) . fst) addrs + in fromIntegral $ maximum $ last . pathToList . snd <$> fAddrs + +sync :: + (MonadUnliftIO m) => + Ctx -> + Config -> + Network -> + DBAccountId -> + Bool -> + ExceptT String (DB m) SyncRes +sync ctx cfg net accId full = do + let host = apiHost net cfg + -- Check API health + checkHealth ctx net cfg + -- Get the new best block before starting the sync + best <- liftExcept $ apiCall ctx host (GetBlockBest def) + -- Get the addresses from our local database + (addrPathMap, addrBalMap) <- allAddressesMap net accId + -- Fetch the address balances online + Store.SerialList storeBals <- + liftExcept . apiBatch ctx (configAddrBatch cfg) host $ + GetAddrsBalance (Map.keys addrBalMap) + -- Filter only those addresses whose balances have changed + balsToUpdate <- + if full + then return storeBals + else liftEither $ filterAddresses storeBals addrBalMap + let addrsToUpdate = (.address) <$> balsToUpdate + -- Update balances + updateAddressBalances net balsToUpdate + newAcc <- lift $ updateAccountBalances accId + -- Get a list of our confirmed txs in the local database + -- Use an empty list when doing a full sync + confirmedTxs <- if full then return [] else getConfirmedTxs accId True + -- Fetch the txids of the addresses to update + aTids <- searchAddrTxs net ctx cfg confirmedTxs addrsToUpdate + -- We also want to check if there is any change in unconfirmed txs + uTids <- getConfirmedTxs accId False + let tids = nub $ uTids <> aTids + -- Fetch the full transactions + Store.SerialList txs <- + liftExcept $ apiBatch ctx (configTxFullBatch cfg) host (GetTxs tids) + -- Convert them to TxInfo and store them in the local database + let txInfos = storeToTxInfo addrPathMap (fromIntegral best.height) <$> txs + resTxInfo <- forM txInfos $ repsertTxInfo net ctx accId + -- Fetch and update coins + Store.SerialList storeCoins <- + liftExcept . apiBatch ctx (configCoinBatch cfg) host $ + GetAddrsUnspent addrsToUpdate def + (coinCount, newCoins) <- refreshCoins net accId addrsToUpdate storeCoins + -- Get the dependent tranactions of the new coins + depTxsHash <- + if full + then return $ (.outpoint.hash) <$> storeCoins + else mapM (liftEither . coinToTxHash) newCoins + Store.RawResultList rawTxs <- + liftExcept + . apiBatch ctx (configTxFullBatch cfg) host + $ GetTxsRaw + $ nub depTxsHash + lift $ forM_ rawTxs insertRawTx + -- Remove pending transactions if they are online + pendingTids <- pendingTxHashes accId + let toRemove = filter ((`elem` tids) . fst) pendingTids + forM_ toRemove $ \(_, key) -> lift $ deletePendingTxOnline key + -- Update the best block for this network + lift $ updateBest net (headerHash best.header) best.height + return $ + SyncRes + newAcc + (headerHash best.header) + (fromIntegral best.height) + (fromIntegral $ length $ filter id $ snd <$> resTxInfo) + (fromIntegral coinCount) + +-- Filter addresses that need to be updated +filterAddresses :: + [Store.Balance] -> + Map Address AddressBalance -> + Either String [Store.Balance] +filterAddresses sBals aMap + | sort ((.address) <$> sBals) /= sort (Map.keys aMap) = + Left "Sync: addresses do not match" + | otherwise = + Right $ filter f sBals + where + f s = + let b = fromJust $ s.address `Map.lookup` aMap + in s.txs /= addrBalanceTxs b + || s.confirmed /= addrBalanceConfirmed b + || s.unconfirmed /= addrBalanceUnconfirmed b + || s.utxo /= addrBalanceCoins b + +searchAddrTxs :: + (MonadIO m) => + Network -> + Ctx -> + Config -> + [TxHash] -> + [Address] -> + ExceptT String m [TxHash] +searchAddrTxs _ _ _ _ [] = return [] +searchAddrTxs net ctx cfg confirmedTxs as + | length as > fromIntegral (configAddrBatch cfg) = + nub . concat <$> mapM (go Nothing 0) (chunksOf (configAddrBatch cfg) as) + | otherwise = + nub <$> go Nothing 0 as + where + go hashM offset' xs = do + Store.SerialList txRefs <- + liftExcept $ + apiCall + ctx + (apiHost net cfg) + ( GetAddrsTxs + xs + def + { limit = Just $ fromIntegral (configTxBatch cfg), + start = StartParamHash <$> hashM, + offset = offset' + } + ) + -- Remove txs that we already have + let tids = ((.txid) <$> txRefs) \\ confirmedTxs + -- Either we have reached the end of the stream, or we have hit some + -- txs in confirmedTxs. In both cases, we can stop the search. + if length tids < fromIntegral (configTxBatch cfg) + then return tids + else do + let lastId = (last tids).get + rest <- go (Just lastId) 1 xs + return $ tids <> rest + +coinToTxHash :: DBCoin -> Either String TxHash +coinToTxHash coin = + maybeToEither "coinToTxHash: Invalid outpoint" $ do + bs <- decodeHex $ dBCoinOutpoint coin + op <- eitherToMaybe (S.decode bs) :: Maybe OutPoint + return op.hash diff --git a/src/Haskoin/Wallet/Commands.hs b/src/Haskoin/Wallet/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Commands.hs @@ -0,0 +1,833 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.Commands where + +import Conduit (MonadUnliftIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..), MonadTrans (lift)) +import Data.Aeson (object, (.:), (.=)) +import qualified Data.Aeson as Json +import qualified Data.ByteString as BS +import Data.Foldable (for_) +import Data.Maybe (fromMaybe, isJust) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Database.Persist.Sqlite (transactionUndo) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.Amounts +import Haskoin.Wallet.Backup +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.Entropy +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Migration.SemVersion +import Haskoin.Wallet.Parser +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import qualified System.Console.Haskeline as Haskeline +import qualified System.Directory as D +import System.Random (initStdGen) + +data Response + = ResponseError + { responseError :: !Text + } + | ResponseMnemonic + { responseEntropySource :: !Text, + responseMnemonic :: ![Text], + responseSplitMnemonic :: ![[Text]] + } + | ResponseAccount + { responseAccount :: !DBAccount + } + | ResponseAccResult + { responseAccount :: !DBAccount, + responseResult :: !Bool, + responseText :: !Text + } + | ResponseFile + { responseTxFile :: !FilePath + } + | ResponseAccounts + { responseAccounts :: ![DBAccount] + } + | ResponseAddress + { responseAccount :: !DBAccount, + responseAddress :: !DBAddress + } + | ResponseAddresses + { responseAccount :: !DBAccount, + responseAddresses :: ![DBAddress] + } + | ResponseTxs + { responseAccount :: !DBAccount, + responseTxs :: ![TxInfo] + } + | ResponseTx + { responseAccount :: !DBAccount, + responsePendingTx :: !TxInfo + } + | ResponseDeleteTx + { responseNoSigHash :: !TxHash, + responseFreedCoins :: !Natural, + responseFreedAddrs :: !Natural + } + | ResponseCoins + { responseAccount :: !DBAccount, + responseCoins :: ![JsonCoin] + } + | ResponseSync {responseSync :: [SyncRes]} + | ResponseRestore + { responseRestore :: ![(DBAccount, Natural, Natural)] + } + | ResponseVersion + { responseVersion :: !Text, + responseDBVersion :: !Text + } + | ResponseRollDice + { responseRollDice :: ![Natural], + responseEntropySource :: !Text + } + deriving (Eq, Show) + +jsonError :: String -> Json.Value +jsonError err = object ["type" .= Json.String "error", "error" .= err] + +instance MarshalJSON Ctx Response where + marshalValue ctx = + \case + ResponseError err -> jsonError $ cs err + ResponseMnemonic e w ws -> + object + [ "type" .= Json.String "mnemonic", + "entropysource" .= e, + "mnemonic" .= w, + "splitmnemonic" .= ws + ] + ResponseAccount a -> + object + [ "type" .= Json.String "account", + "account" .= a + ] + ResponseAccResult a b t -> + object + [ "type" .= Json.String "accresult", + "account" .= a, + "result" .= b, + "text" .= t + ] + ResponseFile f -> + object + [ "type" .= Json.String "file", + "file" .= f + ] + ResponseAccounts as -> + object + [ "type" .= Json.String "accounts", + "accounts" .= as + ] + ResponseAddress a addr -> + object + [ "type" .= Json.String "address", + "account" .= a, + "address" .= addr + ] + ResponseAddresses a adrs -> + object + [ "type" .= Json.String "addresses", + "account" .= a, + "addresses" .= adrs + ] + ResponseTxs a txs -> + object + [ "type" .= Json.String "txs", + "account" .= a, + "txs" .= (marshalValue (accountNetwork a, ctx) <$> txs) + ] + ResponseTx a t -> do + let net = accountNetwork a + object + [ "type" .= Json.String "tx", + "account" .= a, + "tx" .= marshalValue (net, ctx) t + ] + ResponseDeleteTx h c a -> + object + [ "type" .= Json.String "deletetx", + "nosighash" .= h, + "freedcoins" .= c, + "freedaddrs" .= a + ] + ResponseCoins a coins -> do + let net = accountNetwork a + object + [ "type" .= Json.String "coins", + "account" .= a, + "coins" .= (marshalValue net <$> coins) + ] + ResponseSync xs -> do + let f (SyncRes as bb bh tc cc) = + object + [ "account" .= as, + "bestblock" .= bb, + "bestheight" .= bh, + "txupdates" .= tc, + "coinupdates" .= cc + ] + object + [ "type" .= Json.String "sync", + "syncres" .= (f <$> xs) + ] + ResponseRestore xs -> + let f (acc, t, c) = + object + [ "account" .= acc, + "txupdates" .= t, + "coinupdates" .= c + ] + in object + [ "type" .= Json.String "restore", + "restore" .= (f <$> xs) + ] + ResponseVersion v dbv -> + object + [ "type" .= Json.String "version", + "version" .= v, + "dbversion" .= dbv + ] + ResponseRollDice ns e -> + object + ["type" .= Json.String "rolldice", "entropysource" .= e, "dice" .= ns] + unmarshalValue ctx = + Json.withObject "response" $ \o -> do + Json.String resType <- o .: "type" + case resType of + "error" -> ResponseError <$> o .: "error" + "mnemonic" -> + ResponseMnemonic + <$> o .: "entropysource" + <*> o .: "mnemonic" + <*> o .: "splitmnemonic" + "account" -> + ResponseAccount + <$> o .: "account" + "accresult" -> + ResponseAccResult + <$> o .: "account" + <*> o .: "result" + <*> o .: "text" + "file" -> + ResponseFile + <$> o .: "file" + "accounts" -> + ResponseAccounts + <$> o .: "accounts" + "address" -> + ResponseAddress + <$> o .: "account" + <*> o .: "address" + "addresses" -> + ResponseAddresses + <$> o .: "account" + <*> o .: "addresses" + "txs" -> do + a <- o .: "account" + let net = accountNetwork a + txs <- mapM (unmarshalValue (net, ctx)) =<< o .: "txs" + return $ ResponseTxs a txs + "tx" -> do + a <- o .: "account" + let net = accountNetwork a + t <- unmarshalValue (net, ctx) =<< o .: "tx" + return $ ResponseTx a t + "deletetx" -> + ResponseDeleteTx + <$> o .: "nosighash" + <*> o .: "freedcoins" + <*> o .: "freedaddrs" + "coins" -> do + a <- o .: "account" + xs <- o .: "coins" + coins <- mapM (unmarshalValue (accountNetwork a)) xs + return $ ResponseCoins a coins + "sync" -> do + xs <- o .: "syncres" + res <- forM xs $ \x -> + SyncRes + <$> x .: "account" + <*> x .: "bestblock" + <*> x .: "bestheight" + <*> x .: "txupdates" + <*> x .: "coinupdates" + return $ ResponseSync res + "restore" -> do + let f = + Json.withObject "account" $ \o' -> + (,,) + <$> o' .: "account" + <*> o' .: "txupdates" + <*> o' .: "coinupdates" + ResponseRestore <$> (mapM f =<< o .: "restore") + "version" -> + ResponseVersion + <$> o .: "version" + <*> o .: "dbversion" + "rolldice" -> + ResponseRollDice + <$> o .: "dice" + <*> o .: "entropysource" + _ -> fail "Invalid JSON response type" + +runDBResponse :: + (MonadUnliftIO m) => Config -> ExceptT String (DB m) Response -> m Response +runDBResponse cfg action = do + runDB cfg $ do + resE <- runExceptT action + case resE of + Left err -> do + transactionUndo -- Roll back the current sqlite transaction + return $ ResponseError $ cs err + Right res -> return res + +catchResponseError :: (Monad m) => ExceptT String m Response -> m Response +catchResponseError m = do + resE <- runExceptT m + case resE of + Left err -> return $ ResponseError $ cs err + Right res -> return res + +commandResponse :: Ctx -> Config -> AmountUnit -> Command -> IO Response +commandResponse ctx cfg unit cmd = + case cmd of + -- Mnemonic and account management + CommandMnemonic e d s -> cmdMnemonic e d s + CommandCreateAcc t n dM s -> cmdCreateAcc ctx cfg t n dM s + CommandTestAcc nameM s -> cmdTestAcc ctx cfg nameM s + CommandRenameAcc old new -> cmdRenameAcc cfg old new + CommandAccounts nameM -> cmdAccounts cfg nameM + CommandSyncAcc nameM full -> cmdSyncAcc ctx cfg nameM full + CommandDeleteAcc name net deriv -> cmdDeleteAcc cfg name net deriv + -- Address management + CommandReceive nameM labM -> cmdReceive ctx cfg nameM labM + CommandAddrs nameM p -> cmdAddrs cfg nameM p + CommandLabel nameM i l -> cmdLabel cfg nameM i l + -- Transaction management + CommandTxs nameM p -> cmdTxs ctx cfg nameM p + CommandPrepareTx rcpts nameM fee dust rcptPay minConf o -> + cmdPrepareTx ctx cfg rcpts nameM unit fee dust rcptPay minConf o + CommandPendingTxs nameM p -> cmdPendingTxs ctx cfg nameM p + CommandSignTx nameM h i o s -> cmdSignTx ctx cfg nameM h i o s + CommandSendTx h -> cmdSendTx ctx cfg h + CommandDeleteTx h -> cmdDeleteTx ctx cfg h + CommandCoins nameM p -> cmdCoins cfg nameM p + -- Import/export commands + CommandExportAcc nameM f -> cmdExportAcc ctx cfg nameM f + CommandImportAcc f -> cmdImportAcc ctx cfg f + CommandReviewTx nameM file -> cmdReviewTx ctx cfg nameM file + CommandExportTx h f -> cmdExportTx cfg h f + CommandImportTx nameM file -> cmdImportTx ctx cfg nameM file + -- Backup and Restore + CommandBackup f -> cmdBackup ctx cfg f + CommandRestore f -> cmdRestore ctx cfg f + CommandDiscoverAcc nameM -> cmdDiscoverAccount ctx cfg nameM + -- Utilities + CommandVersion -> cmdVersion cfg + CommandPrepareSweep nameM prvKey st outputM f d -> + prepareSweep ctx cfg nameM prvKey st outputM f d + CommandSignSweep nameM h i o k -> signSweep ctx cfg nameM h i o k + CommandRollDice n -> rollDice n + +-- runDBResponse Monad Stack: +-- ExceptT String (ReaderT SqlBackend (NoLoggingT (ResourceT (IO)))) + +liftEitherIO :: (MonadIO m) => IO (Either String a) -> ExceptT String m a +liftEitherIO = liftEither <=< liftIO + +cmdMnemonic :: Natural -> Bool -> Natural -> IO Response +cmdMnemonic ent useDice splitMnemIn = + catchResponseError $ do + (orig, ms, splitMs) <- genMnemonic ent useDice splitMnemIn + return $ ResponseMnemonic orig (Text.words ms) (Text.words <$> splitMs) + +cmdCreateAcc :: + Ctx -> Config -> Text -> Network -> Maybe Natural -> Natural -> IO Response +cmdCreateAcc ctx cfg name net derivM splitMnemIn = do + runDBResponse cfg $ do + mnem <- askMnemonicPass splitMnemIn + walletFP <- liftEither $ walletFingerprint net ctx mnem + d <- maybe (lift $ nextAccountDeriv walletFP net) return derivM + prvKey <- liftEither $ signingKey net ctx mnem d + let xpub = deriveXPubKey ctx prvKey + (_, acc) <- insertAccount net ctx walletFP name xpub + return $ ResponseAccount acc + +cmdTestAcc :: Ctx -> Config -> Maybe Text -> Natural -> IO Response +cmdTestAcc ctx cfg nameM splitMnemIn = + runDBResponse cfg $ do + (_, acc) <- getAccountByName nameM + let net = accountNetwork acc + xPubKey = accountXPubKey ctx acc + d = accountIndex acc + mnem <- askMnemonicPass splitMnemIn + xPrvKey <- liftEither $ signingKey net ctx mnem d + return $ + if deriveXPubKey ctx xPrvKey == xPubKey + then + ResponseAccResult + { responseAccount = acc, + responseResult = True, + responseText = + "The mnemonic and passphrase matched the account" + } + else + ResponseAccResult + { responseAccount = acc, + responseResult = False, + responseText = + "The mnemonic and passphrase did not match the account" + } + +cmdImportAcc :: Ctx -> Config -> FilePath -> IO Response +cmdImportAcc ctx cfg fp = + runDBResponse cfg $ do + (PubKeyDoc xpub net name wallet) <- liftEitherIO $ readMarshalFile ctx fp + (_, acc) <- insertAccount net ctx wallet name xpub + return $ ResponseAccount acc + +cmdExportAcc :: Ctx -> Config -> Maybe Text -> FilePath -> IO Response +cmdExportAcc ctx cfg nameM file = + runDBResponse cfg $ do + (_, acc) <- getAccountByName nameM + checkPathFree file + let xpub = accountXPubKey ctx acc + net = accountNetwork acc + name = dBAccountName acc + wallet = accountWallet acc + doc = PubKeyDoc xpub net name wallet + liftIO $ writeMarshalFile ctx file doc + return $ ResponseFile file + +cmdRenameAcc :: Config -> Text -> Text -> IO Response +cmdRenameAcc cfg oldName newName = + runDBResponse cfg $ do + acc <- renameAccount oldName newName + return $ ResponseAccount acc + +cmdDeleteAcc :: Config -> Text -> Network -> HardPath -> IO Response +cmdDeleteAcc cfg name net path = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName $ Just name + unless (accountNetwork acc == net) $ + throwError "The network of the account to delete did not match" + accPath <- liftMaybe "HardPath" $ parseHard $ cs $ dBAccountDerivation acc + unless (path == accPath) $ + throwError + "The full derivation path of the account to delete did not match" + lift $ deleteAccount accId + return $ + ResponseAccResult acc True $ + "The account " <> name <> " has been deleted" + +cmdAccounts :: Config -> Maybe Text -> IO Response +cmdAccounts cfg nameM = + runDBResponse cfg $ do + case nameM of + Just _ -> do + (_, acc) <- getAccountByName nameM + return $ ResponseAccounts [acc] + _ -> do + accs <- lift getAccounts + return $ ResponseAccounts $ snd <$> accs + +cmdReceive :: Ctx -> Config -> Maybe Text -> Maybe Text -> IO Response +cmdReceive ctx cfg nameM labelM = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + addr <- genExtAddress ctx cfg accId $ fromMaybe "" labelM + return $ ResponseAddress acc addr + +cmdAddrs :: Config -> Maybe Text -> Page -> IO Response +cmdAddrs cfg nameM page = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + as <- lift $ addressPage accId page + return $ ResponseAddresses acc as + +cmdLabel :: Config -> Maybe Text -> Natural -> Text -> IO Response +cmdLabel cfg nameM idx lab = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + adr <- setAddrLabel accId (fromIntegral idx) lab + return $ ResponseAddress acc adr + +cmdTxs :: Ctx -> Config -> Maybe Text -> Page -> IO Response +cmdTxs ctx cfg nameM page = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + txInfos <- txsPage ctx accId page + return $ ResponseTxs acc txInfos + +cmdPrepareTx :: + Ctx -> + Config -> + [(Text, Text)] -> + Maybe Text -> + AmountUnit -> + Natural -> + Natural -> + Bool -> + Natural -> + Maybe FilePath -> + IO Response +cmdPrepareTx ctx cfg rcpTxt nameM unit feeByte dust rcptPay minConf fileM = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + rcpts <- liftEither $ mapM (toRecipient net) rcpTxt + gen <- liftIO initStdGen + signDat <- buildTxSignData net ctx cfg gen accId rcpts feeByte dust rcptPay minConf + txInfo <- liftEither $ parseTxSignData net ctx pub signDat + txInfoL <- lift $ fillTxInfoLabels net txInfo + for_ fileM checkPathFree + _ <- importPendingTx net ctx accId signDat + for_ fileM $ \file -> liftIO $ writeJsonFile file $ Json.toJSON signDat + newAcc <- getAccountById accId + return $ ResponseTx newAcc txInfoL + where + toRecipient net (a, v) = do + addr <- textToAddrE net a + val <- maybeToEither (cs $ badAmnt v) (readAmount unit v) + return (addr, val) + badAmnt v = + "Could not parse the amount " <> v <> " as " <> showUnit unit 1 + +cmdPendingTxs :: Ctx -> Config -> Maybe Text -> Page -> IO Response +cmdPendingTxs ctx cfg nameM page = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + txInfos <- pendingTxPage ctx accId page + return $ ResponseTxs acc txInfos + +cmdReviewTx :: Ctx -> Config -> Maybe Text -> FilePath -> IO Response +cmdReviewTx ctx cfg nameM fp = + runDBResponse cfg $ do + (_, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsd <- liftEitherIO $ readJsonFile fp + txInfo <- liftEither $ parseTxSignData net ctx pub tsd + txInfoL <- lift $ fillTxInfoLabels net txInfo + return $ ResponseTx acc txInfoL + +cmdExportTx :: Config -> TxHash -> FilePath -> IO Response +cmdExportTx cfg nosigH fp = + runDBResponse cfg $ do + pendingTxM <- lift $ getPendingTx nosigH + case pendingTxM of + Just (_, tsd, _) -> do + checkPathFree fp + liftIO $ writeJsonFile fp $ Json.toJSON tsd + return $ ResponseFile fp + _ -> throwError "The pending transaction does not exist" + +cmdImportTx :: Ctx -> Config -> Maybe Text -> FilePath -> IO Response +cmdImportTx ctx cfg nameM fp = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + tsd <- liftEitherIO $ readJsonFile fp + txInfo <- liftEither $ parseTxSignData net ctx pub tsd + txInfoL <- lift $ fillTxInfoLabels net txInfo + _ <- importPendingTx net ctx accId tsd + return $ ResponseTx acc txInfoL + +cmdDeleteTx :: Ctx -> Config -> TxHash -> IO Response +cmdDeleteTx ctx cfg nosigH = + runDBResponse cfg $ do + (coins, addrs) <- deletePendingTx ctx nosigH + return $ ResponseDeleteTx nosigH coins addrs + +cmdSignTx :: + Ctx -> + Config -> + Maybe Text -> + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + Natural -> + IO Response +cmdSignTx ctx cfg nameM nosigHM inputM outputM splitMnemIn = + runDBResponse cfg $ do + (tsd, online) <- parseSignInput nosigHM inputM outputM + when online $ + throwError "The transaction is already online" + when (txSignDataSigned tsd) $ + throwError "The transaction is already signed" + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + idx = fromIntegral $ dBAccountIndex acc + accPub = accountXPubKey ctx acc + for_ outputM checkPathFree + mnem <- askMnemonicPass splitMnemIn + prvKey <- liftEither $ signingKey net ctx mnem idx + let xpub = deriveXPubKey ctx prvKey + unless (accPub == xpub) $ + throwError "The mnemonic did not match the provided account" + (newSignData, txInfo) <- liftEither $ signWalletTx net ctx tsd prvKey + txInfoL <- lift $ fillTxInfoLabels net txInfo + when (isJust nosigHM) $ void $ importPendingTx net ctx accId newSignData + for_ outputM $ \o -> liftIO $ writeJsonFile o $ Json.toJSON newSignData + return $ ResponseTx acc txInfoL + +parseSignInput :: + (MonadUnliftIO m) => + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + ExceptT String (DB m) (TxSignData, Bool) +parseSignInput nosigHM inputM outputM = + case (nosigHM, inputM, outputM) of + (Nothing, Nothing, _) -> + throwError + "Provide either a TXHASH or both a --input file and a --output file" + (Just _, Just _, _) -> + throwError "Can not specify both a TXHASH and a --input file" + (_, Just _, Nothing) -> + throwError "When using a --input file, also provide a --output file" + (Just h, _, _) -> do + resM <- lift $ getPendingTx h + case resM of + Just (_, t, TxInfoPending _ _ online) -> return (t, online) + _ -> throwError "The nosigHash does not exist in the wallet" + (_, Just i, _) -> do + exist <- liftIO $ D.doesFileExist i + unless exist $ throwError "Input file does not exist" + tsd <- liftEitherIO (readJsonFile i) + return (tsd, False) + +cmdCoins :: Config -> Maybe Text -> Page -> IO Response +cmdCoins cfg nameM page = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + coins <- coinPage net accId page + return $ ResponseCoins acc coins + +cmdSendTx :: Ctx -> Config -> TxHash -> IO Response +cmdSendTx ctx cfg nosigH = + runDBResponse cfg $ do + tsdM <- lift $ getPendingTx nosigH + case tsdM of + Just (accId, tsd@(TxSignData signedTx _ _ _ signed), _) -> do + acc <- getAccountById accId + let net = accountNetwork acc + pub = accountXPubKey ctx acc + txInfo <- liftEither $ parseTxSignData net ctx pub tsd + txInfoL <- lift $ fillTxInfoLabels net txInfo + let verify = verifyTxInfo net ctx signedTx txInfoL + unless (signed && verify) $ throwError "The transaction is not signed" + checkHealth ctx net cfg + let host = apiHost net cfg + Store.TxId netTxId <- liftExcept $ apiCall ctx host (PostTx signedTx) + unless (netTxId == txHash signedTx) $ + throwError $ + "The server returned the wrong TxHash: " + <> cs (txHashToHex netTxId) + _ <- lift $ setPendingTxOnline nosigH + lift $ insertRawTx signedTx + return $ ResponseTx acc $ setTxInfoOnline txInfoL + _ -> throwError "The nosigHash does not exist in the wallet" + +setTxInfoOnline :: TxInfo -> TxInfo +setTxInfoOnline txInfo = + case txInfoPending txInfo of + Just p -> txInfo {txInfoPending = Just p {pendingOnline = True}} + _ -> txInfo + +cmdSyncAcc :: Ctx -> Config -> Maybe Text -> Bool -> IO Response +cmdSyncAcc ctx cfg nameM full = + runDBResponse cfg $ do + accs <- + case nameM of + Just _ -> (:[]) <$> getAccountByName nameM + _ -> lift getAccounts + when (null accs) $ throwError "There are no accounts in the wallet" + res <- forM accs $ \(accId, acc) -> do + let net = accountNetwork acc + sync ctx cfg net accId full + return $ ResponseSync res + +cmdDiscoverAccount :: Ctx -> Config -> Maybe Text -> IO Response +cmdDiscoverAccount ctx cfg nameM = do + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + checkHealth ctx net cfg + (e, i) <- discoverAddrs net ctx cfg pub + discoverAccGenAddrs ctx cfg accId AddrExternal $ fromIntegral e + discoverAccGenAddrs ctx cfg accId AddrInternal $ fromIntegral i + -- Perform a full sync after discovery + res <- sync ctx cfg net accId True + return $ ResponseSync [res] + +cmdBackup :: Ctx -> Config -> FilePath -> IO Response +cmdBackup ctx cfg fp = + runDBResponse cfg $ do + backup <- createBackup ctx + checkPathFree fp + liftIO $ writeJsonFile fp $ marshalValue ctx backup + return $ ResponseFile fp + +cmdRestore :: Ctx -> Config -> FilePath -> IO Response +cmdRestore ctx cfg fp = + runDBResponse cfg $ do + backup <- liftEitherIO $ readMarshalFile ctx fp + let f (SyncRes a _ _ t c) = (a, t, c) + ResponseRestore . (f <$>) <$> restoreBackup ctx cfg backup + +cmdVersion :: Config -> IO Response +cmdVersion cfg = do + runDBResponse cfg $ do + dbv <- lift getVersion + return $ ResponseVersion currentVersionStr (cs $ verString dbv) + +prepareSweep :: + Ctx -> + Config -> + Maybe Text -> + FilePath -> + [Text] -> + Maybe FilePath -> + Natural -> + Natural -> + IO Response +prepareSweep ctx cfg nameM prvKeyFile sweepToT outputM feeByte dust = + runDBResponse cfg $ do + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + secKeys <- parseSecKeysFile net <$> liftIO (readFileWords prvKeyFile) + sweepTo <- liftEither $ mapM (textToAddrE net) sweepToT + checkHealth ctx net cfg + tsd <- buildSweepSignData net ctx cfg accId secKeys sweepTo feeByte dust + txInfo <- liftEither $ parseTxSignData net ctx pub tsd + txInfoL <- lift $ fillTxInfoLabels net txInfo + for_ outputM checkPathFree + _ <- importPendingTx net ctx accId tsd + for_ outputM $ \file -> liftIO $ writeJsonFile file $ Json.toJSON tsd + return $ ResponseTx acc txInfoL + +signSweep :: + Ctx -> + Config -> + Maybe Text -> + Maybe TxHash -> + Maybe FilePath -> + Maybe FilePath -> + FilePath -> + IO Response +signSweep ctx cfg nameM nosigHM inputM outputM keyFile = + runDBResponse cfg $ do + (tsd, online) <- parseSignInput nosigHM inputM outputM + when online $ + throwError "The transaction is already online" + when (txSignDataSigned tsd) $ + throwError "The transaction is already signed" + (accId, acc) <- getAccountByName nameM + let net = accountNetwork acc + pub = accountXPubKey ctx acc + for_ outputM checkPathFree + -- Read the file containing the private keys + secKeys <- parseSecKeysFile net <$> liftIO (readFileWords keyFile) + when (null secKeys) $ throwError "No private keys to sign" + -- Sign the transactions + (newTsd, txInfo) <- liftEither $ signTxWithKeys net ctx tsd pub secKeys + txInfoL <- lift $ fillTxInfoLabels net txInfo + when (isJust nosigHM) $ void $ importPendingTx net ctx accId newTsd + for_ outputM $ \o -> liftIO $ writeJsonFile o $ Json.toJSON newTsd + return $ ResponseTx acc txInfoL + +rollDice :: Natural -> IO Response +rollDice n = do + (res, origEnt) <- go [] "" + return $ ResponseRollDice (take (fromIntegral n) res) origEnt + where + go acc orig + | length acc >= fromIntegral n = return (acc, orig) + | otherwise = do + (origEnt, sysEnt) <- systemEntropy 1 + go (word8ToBase6 (head $ BS.unpack sysEnt) <> acc) origEnt + +-- Haskeline Helpers -- + +askInputLineHidden :: String -> IO String +askInputLineHidden message = do + inputM <- + Haskeline.runInputT Haskeline.defaultSettings $ + Haskeline.getPassword (Just '*') message + maybe + (error "No action due to EOF") + return + inputM + +askInputLine :: String -> IO String +askInputLine message = do + inputM <- + Haskeline.runInputT Haskeline.defaultSettings $ + Haskeline.getInputLine message + maybe + (error "No action due to EOF") + return + inputM + +askMnemonicWords :: String -> IO Mnemonic +askMnemonicWords txt = do + mnm <- askInputLineHidden txt + case fromMnemonic (cs mnm) of -- validate the mnemonic + Right _ -> return $ cs mnm + Left _ -> do + liftIO $ putStrLn "Invalid mnemonic" + askMnemonicWords txt + +askMnemonicPass :: (MonadError String m, MonadIO m) => Natural -> m MnemonicPass +askMnemonicPass splitMnemIn = do + mnm <- + if splitMnemIn == 1 + then liftIO $ askMnemonicWords "Enter your mnemonic words: " + else do + ms <- forM [1 .. splitMnemIn] $ \n -> + liftIO $ askMnemonicWords $ "Split mnemonic part #" <> show n <> ": " + liftEither $ mergeMnemonicParts ms + passStr <- liftIO askPassword + return + MnemonicPass + { mnemonicWords = mnm, + mnemonicPass = cs passStr + } + +askPassword :: IO String +askPassword = do + pass <- askInputLineHidden "Mnemonic passphrase or leave empty: " + if null pass + then return pass + else do + pass2 <- askInputLineHidden "Repeat your mnemonic passphrase: " + if pass == pass2 + then return pass + else do + putStrLn "The passphrases did not match" + askPassword diff --git a/src/Haskoin/Wallet/Config.hs b/src/Haskoin/Wallet/Config.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Config.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.Config where + +import Control.Monad (unless) +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..)) +import Data.Aeson +import Data.Default +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import qualified System.Directory as D + +hwDataDirectory :: IO FilePath +hwDataDirectory = do + dir <- D.getAppUserDataDirectory "hw" + D.createDirectoryIfMissing True dir + return dir + +databaseFile :: Config -> IO FilePath +databaseFile cfg = + case configDatabaseFile cfg of + Just dbFile -> return dbFile + _ -> do + dir <- hwDataDirectory + return $ dir "accounts.sqlite" + +data Config = Config + { configHost :: Text, + configGap :: Natural, + configRecoveryGap :: Natural, + configAddrBatch :: Natural, + configTxBatch :: Natural, + configCoinBatch :: Natural, + configTxFullBatch :: Natural, + configDatabaseFile :: Maybe FilePath + } + deriving (Eq, Show) + +instance FromJSON Config where + parseJSON = + withObject "config" $ \o -> + Config + <$> o .: "host" + <*> o .: "gap" + <*> o .: "recovery-gap" + <*> o .: "addr-batch" + <*> o .: "tx-batch" + <*> o .: "coin-batch" + <*> o .: "tx-full-batch" + <*> o .:? "database-file" + +instance ToJSON Config where + toJSON cfg = + object + [ "host" .= configHost cfg, + "gap" .= configGap cfg, + "recovery-gap" .= configRecoveryGap cfg, + "addr-batch" .= configAddrBatch cfg, + "tx-batch" .= configTxBatch cfg, + "coin-batch" .= configCoinBatch cfg, + "tx-full-batch" .= configTxFullBatch cfg, + "database-file" .= configDatabaseFile cfg + ] + +instance Default Config where + def = + Config + { configHost = cs (def :: ApiConfig).host, + configGap = 20, + configRecoveryGap = 40, + configAddrBatch = 100, + configTxBatch = 100, + configCoinBatch = 100, + configTxFullBatch = 100, + configDatabaseFile = Nothing + } + +initConfig :: IO Config +initConfig = do + dir <- hwDataDirectory + let configFile = dir "config.json" + exists <- D.doesFileExist configFile + unless exists $ writeJsonFile configFile $ toJSON (def :: Config) + resE <- readJsonFile configFile + either (error "Could not read config.json") return resE + +apiHost :: Network -> Config -> ApiConfig +apiHost net = ApiConfig net . cs . configHost + +-- Utilities -- + +checkHealth :: + (MonadIO m) => + Ctx -> + Network -> + Config -> + ExceptT String m () +checkHealth ctx net cfg = do + let host = apiHost net cfg + health <- liftExcept $ apiCall ctx host GetHealth + unless (Store.isOK health) $ + throwError "The indexer health check has failed" diff --git a/src/Haskoin/Wallet/Database.hs b/src/Haskoin/Wallet/Database.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Database.hs @@ -0,0 +1,1424 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.Database where + +import Conduit (MonadUnliftIO, ResourceT) +import Control.Arrow (Arrow (second)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (NoLoggingT) +import Control.Monad.Reader (MonadTrans (lift), ReaderT) +import Control.Monad.Trans.Maybe +import Data.Aeson +import qualified Data.Aeson as Json +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Either (fromRight) +import Data.List (find, nub, partition) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time (UTCTime, getCurrentTime) +import Data.Word (Word64) +import Database.Esqueleto.Legacy as E +import qualified Database.Persist as P +import Database.Persist.Sqlite (runSqlite) +import Database.Persist.TH +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.Config +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Migration.SemVersion +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util (Page (Page), textToAddrE) +import Numeric.Natural (Natural) + +{- SQL Table Definitions -} + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| + +DBVersion + version Text + Primary version + deriving Show + +DBWallet + fingerprint Text + Primary fingerprint + deriving Show + +DBAccount + name Text + wallet DBWalletId + index Int + network Text + derivation Text + external Int + internal Int + xPubKey Text + balanceConfirmed Word64 + balanceUnconfirmed Word64 + balanceCoins Word64 + created UTCTime default=CURRENT_TIME + Primary wallet derivation + UniqueName name + UniqueXPubKey xPubKey + UniqueNetworkId wallet network index + deriving Show + deriving Eq + +DBAddress + index Int + accountWallet DBWalletId + accountDerivation Text + derivation Text + address Text + label Text + balanceConfirmed Word64 + balanceUnconfirmed Word64 + balanceCoins Word64 + balanceTxs Word64 + balanceReceived Word64 + internal Bool + free Bool + created UTCTime default=CURRENT_TIME + Primary accountWallet accountDerivation derivation + UniqueAddress address + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBTxInfo + accountWallet DBWalletId + accountDerivation Text + txid Text + blockRef ByteString + confirmed Bool + blob ByteString + created UTCTime default=CURRENT_TIME + Primary accountWallet accountDerivation txid + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBCoin + accountWallet DBWalletId + accountDerivation Text + outpoint Text + address Text + value Word64 + blockRef ByteString + blob ByteString + confirmed Bool + locked Bool + created UTCTime default=CURRENT_TIME + Primary outpoint + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBRawTx + hash Text + blob ByteString + Primary hash + deriving Show + deriving Eq + +DBPendingTx + accountWallet DBWalletId + accountDerivation Text + nosigHash Text + blob ByteString + online Bool + created UTCTime default=CURRENT_TIME + Primary nosigHash + Foreign DBAccount fk_wallet_derivation accountWallet accountDerivation + deriving Show + deriving Eq + +DBBest + network Text + bestBlock Text + bestHeight Int + Primary network + deriving Show +|] + +type DB m = ReaderT SqlBackend (NoLoggingT (ResourceT m)) + +runDB :: (MonadUnliftIO m) => Config -> DB m a -> m a +runDB cfg action = do + dbFile <- liftIO $ databaseFile cfg + runSqlite (cs dbFile) action + +globalMigration :: (MonadUnliftIO m) => DB m () +globalMigration = void $ runMigrationQuiet migrateAll + +{- Meta -} + +-- Database versions use major.minor only. Patch versions are ignored. +setVersion :: (MonadUnliftIO m) => SemVersion -> DB m () +setVersion semVer = do + verM <- selectOne $ from return + let verTxt = cs $ verString $ toMinor semVer + case verM of + Nothing -> P.insert_ $ DBVersion verTxt + Just (Entity k _) -> P.update k [DBVersionVersion P.=. verTxt] + +getVersion :: (MonadUnliftIO m) => DB m SemVersion +getVersion = do + resM <- selectOne . from $ \v -> return $ v ^. DBVersionVersion + return $ parseSemVersion . cs . unValue $ fromJust resM + +updateBest :: + (MonadUnliftIO m) => Network -> BlockHash -> BlockHeight -> DB m () +updateBest net hash height = do + let netT = cs net.name + key = DBBestKey netT + P.repsert key $ DBBest netT (blockHashToHex hash) (fromIntegral height) + +getBest :: + (MonadUnliftIO m) => Network -> DB m (Maybe (BlockHash, BlockHeight)) +getBest net = do + let netT = cs net.name + resM <- P.get $ DBBestKey netT + return $ do + DBBest _ a b <- resM + hash <- hexToBlockHash a + return (hash, fromIntegral b) + +{- Accounts -} + +instance ToJSON DBAccount where + toJSON acc = + object + [ "name" .= dBAccountName acc, + "wallet" .= dBAccountWallet acc, + "index" .= dBAccountIndex acc, + "network" .= dBAccountNetwork acc, + "derivation" .= dBAccountDerivation acc, + "external" .= dBAccountExternal acc, + "internal" .= dBAccountInternal acc, + "xPubKey" .= dBAccountXPubKey acc, + "balance" .= toJSON (AccountBalance confirm unconfirm coins), + "created" .= dBAccountCreated acc + ] + where + confirm = dBAccountBalanceConfirmed acc + unconfirm = dBAccountBalanceUnconfirmed acc + coins = dBAccountBalanceCoins acc + +instance FromJSON DBAccount where + parseJSON = + withObject "DBAccount" $ \o -> do + bal <- o .: "balance" + DBAccount + <$> o .: "name" + <*> o .: "wallet" + <*> o .: "index" + <*> o .: "network" + <*> o .: "derivation" + <*> o .: "external" + <*> o .: "internal" + <*> o .: "xPubKey" + <*> (bal .: "confirmed") + <*> (bal .: "unconfirmed") + <*> (bal .: "coins") + <*> o .: "created" + +data AccountBalance = AccountBalance + { -- | confirmed balance + accBalanceConfirmed :: !Word64, + -- | unconfirmed balance + accBalanceUnconfirmed :: !Word64, + -- | number of unspent outputs + accBalanceCoins :: !Word64 + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON AccountBalance where + toJSON b = + object + [ "confirmed" .= accBalanceConfirmed b, + "unconfirmed" .= accBalanceUnconfirmed b, + "coins" .= accBalanceCoins b + ] + +instance FromJSON AccountBalance where + parseJSON = + withObject "accountbalance" $ \o -> + AccountBalance + <$> o .: "confirmed" + <*> o .: "unconfirmed" + <*> o .: "coins" + +accountIndex :: DBAccount -> Natural +accountIndex = fromIntegral . dBAccountIndex + +accountNetwork :: DBAccount -> Network +accountNetwork = + fromMaybe (error "Invalid Network in database") + . netByName + . cs + . dBAccountNetwork + +accountWallet :: DBAccount -> Fingerprint +accountWallet acc = + let (DBWalletKey walletFP) = dBAccountWallet acc + in fromRight (error "Invalid WalletId in database") $ + textToFingerprint walletFP + +accountXPubKey :: Ctx -> DBAccount -> XPubKey +accountXPubKey ctx acc = + fromMaybe (error "Invalid XPubKey in database") $ + xPubImport (accountNetwork acc) ctx (dBAccountXPubKey acc) + +nextAccountDeriv :: (MonadUnliftIO m) => Fingerprint -> Network -> DB m Natural +nextAccountDeriv walletFP net = do + let walletId = DBWalletKey $ fingerprintToText walletFP + idxs <- + select . from $ \a -> do + where_ $ + a ^. DBAccountNetwork ==. val (cs net.name) + &&. a ^. DBAccountWallet ==. val walletId + return $ a ^. DBAccountIndex + return $ smallestUnused $ fromIntegral . unValue <$> idxs + +smallestUnused :: [Natural] -> Natural +smallestUnused xs = fromJust $ find (not . (`elem` xs)) [0 ..] + +existsAccount :: (MonadUnliftIO m) => Text -> DB m Bool +existsAccount name = P.existsBy $ UniqueName name + +existsXPubKey :: (MonadUnliftIO m) => Network -> Ctx -> XPubKey -> DB m Bool +existsXPubKey net ctx key = P.existsBy $ UniqueXPubKey $ xPubExport net ctx key + +getWalletOrCreate :: (MonadUnliftIO m) => Fingerprint -> DB m DBWalletId +getWalletOrCreate fp = do + let key = DBWalletKey $ fingerprintToText fp + walletM <- P.get key + case walletM of + Just _ -> return key + _ -> P.insert $ DBWallet $ fingerprintToText fp + +insertAccount :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Fingerprint -> + Text -> + XPubKey -> + ExceptT String (DB m) (DBAccountId, DBAccount) +insertAccount net ctx walletFP name xpub = do + existsName <- lift $ existsAccount name + if existsName + then throwError $ "Account " <> cs name <> " already exists" + else do + existsKey <- lift $ existsXPubKey net ctx xpub + if existsKey + then throwError "The XPubKey already exists" + else do + time <- liftIO getCurrentTime + walletId <- lift $ getWalletOrCreate walletFP + let path = bip44Deriv net $ fromIntegral $ xPubChild xpub + idx = fromIntegral $ xPubIndex xpub + account = + DBAccount + { dBAccountName = name, + dBAccountWallet = walletId, + dBAccountIndex = idx, + dBAccountNetwork = cs net.name, + dBAccountDerivation = cs $ pathToStr path, + dBAccountExternal = 0, + dBAccountInternal = 0, + dBAccountXPubKey = xPubExport net ctx xpub, + dBAccountBalanceConfirmed = 0, + dBAccountBalanceUnconfirmed = 0, + dBAccountBalanceCoins = 0, + dBAccountCreated = time + } + key <- lift $ P.insert account + return (key, account) + +deleteAccount :: (MonadUnliftIO m) => DBAccountId -> DB m () +deleteAccount accId@(DBAccountKey accWallet accDeriv) = do + delete . from $ \a -> + where_ $ + a ^. DBAddressAccountWallet ==. val accWallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + delete . from $ \t -> + where_ $ + t ^. DBTxInfoAccountWallet ==. val accWallet + &&. t ^. DBTxInfoAccountDerivation ==. val accDeriv + delete . from $ \c -> + where_ $ + c ^. DBCoinAccountWallet ==. val accWallet + &&. c ^. DBCoinAccountDerivation ==. val accDeriv + delete . from $ \p -> + where_ $ + p ^. DBPendingTxAccountWallet ==. val accWallet + &&. p ^. DBPendingTxAccountDerivation ==. val accDeriv + P.delete accId + +-- When a name is provided, get that account or throw an error if it doesn't +-- exist. When no name is provided, return the account only if there is one +-- account. +getAccountByName :: + (MonadUnliftIO m) => + Maybe Text -> + ExceptT String (DB m) (DBAccountId, DBAccount) +getAccountByName (Just name) = do + aM <- lift $ P.getBy $ UniqueName name + case aM of + Just a -> return (entityKey a, entityVal a) + _ -> throwError $ "The account " <> cs name <> " does not exist" +getAccountByName Nothing = do + as <- lift getAccounts + case as of + [a] -> return a + [] -> throwError "There are no accounts in the wallet" + _ -> throwError "Specify which account to use" + +getAccountById :: + (MonadUnliftIO m) => DBAccountId -> ExceptT String (DB m) DBAccount +getAccountById accId = liftMaybe "Invalid account" =<< lift (P.get accId) + +getAccounts :: (MonadUnliftIO m) => DB m [(DBAccountId, DBAccount)] +getAccounts = + (go <$>) + <$> P.selectList + [] + [P.Asc DBAccountWallet, P.Asc DBAccountNetwork, P.Asc DBAccountIndex] + where + go a = (entityKey a, entityVal a) + +getAccountNames :: (MonadUnliftIO m) => DB m [Text] +getAccountNames = do + res <- select . from $ \a -> do + orderBy [asc $ a ^. DBAccountCreated] + return $ a ^. DBAccountName + return $ unValue <$> res + +renameAccount :: + (MonadUnliftIO m) => Text -> Text -> ExceptT String (DB m) DBAccount +renameAccount oldName newName + | oldName == newName = throwError "Old and new names are the same" + | otherwise = do + e <- lift $ existsAccount newName + if e + then throwError $ "The account " <> cs newName <> " already exists" + else do + c <- + lift . updateCount $ \a -> do + set a [DBAccountName =. val newName] + where_ $ a ^. DBAccountName ==. val oldName + if c == 0 + then throwError $ "The account " <> cs oldName <> " does not exist" + else snd <$> getAccountByName (Just newName) + +updateAccountBalances :: (MonadUnliftIO m) => DBAccountId -> DB m DBAccount +updateAccountBalances accId@(DBAccountKey wallet accDeriv) = do + confirm <- selectSum DBAddressBalanceConfirmed + unconfirm <- selectSum DBAddressBalanceUnconfirmed + coins <- selectSum DBAddressBalanceCoins + update $ \a -> do + set + a + [ DBAccountBalanceConfirmed =. val (unpack confirm), + DBAccountBalanceUnconfirmed =. val (unpack unconfirm), + DBAccountBalanceCoins =. val (unpack coins) + ] + where_ $ a ^. DBAccountId ==. val accId + fromJust <$> P.get accId + where + unpack m = fromMaybe 0 $ unValue $ fromMaybe (Value $ Just 0) m + selectSum field = + selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return $ sum_ $ a ^. field + +{- Addresses -} + +data AddrType = AddrInternal | AddrExternal + deriving (Eq, Show) + +isInternal :: AddrType -> Bool +isInternal AddrInternal = True +isInternal AddrExternal = False + +dBAccountCount :: AddrType -> DBAccount -> Int +dBAccountCount AddrInternal = dBAccountInternal +dBAccountCount AddrExternal = dBAccountExternal + +dBAccountField :: AddrType -> EntityField DBAccount Int +dBAccountField AddrInternal = DBAccountInternal +dBAccountField AddrExternal = DBAccountExternal + +addrDeriv :: AddrType -> SoftPath +addrDeriv AddrInternal = intDeriv +addrDeriv AddrExternal = extDeriv + +data AddrFree = AddrFree | AddrBusy + deriving (Eq, Show) + +isAddrFree :: AddrFree -> Bool +isAddrFree AddrFree = True +isAddrFree AddrBusy = False + +instance ToJSON DBAddress where + toJSON addr = + object + [ "index" .= dBAddressIndex addr, + "wallet" .= dBAddressAccountWallet addr, + "account" .= dBAddressAccountDerivation addr, + "derivation" .= dBAddressDerivation addr, + "address" .= dBAddressAddress addr, + "label" .= dBAddressLabel addr, + "balance" + .= AddressBalance + (dBAddressBalanceConfirmed addr) + (dBAddressBalanceUnconfirmed addr) + (dBAddressBalanceCoins addr) + (dBAddressBalanceTxs addr) + (dBAddressBalanceReceived addr), + "internal" .= dBAddressInternal addr, + "free" .= dBAddressFree addr, + "created" .= dBAddressCreated addr + ] + +instance FromJSON DBAddress where + parseJSON = + withObject "DBAddress" $ \o -> do + bal <- o .: "balance" + DBAddress + <$> o .: "index" + <*> o .: "wallet" + <*> o .: "account" + <*> o .: "derivation" + <*> o .: "address" + <*> o .: "label" + <*> bal .: "confirmed" + <*> bal .: "unconfirmed" + <*> bal .: "coins" + <*> bal .: "txs" + <*> bal .: "received" + <*> o .: "internal" + <*> o .: "free" + <*> o .: "created" + +data AddressBalance = AddressBalance + { -- | confirmed balance + addrBalanceConfirmed :: !Word64, + -- | unconfirmed balance + addrBalanceUnconfirmed :: !Word64, + -- | number of unspent outputs + addrBalanceCoins :: !Word64, + -- | number of transactions + addrBalanceTxs :: !Word64, + -- | total amount from all outputs in this address + addrBalanceReceived :: !Word64 + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON AddressBalance where + toJSON b = + object + [ "confirmed" .= addrBalanceConfirmed b, + "unconfirmed" .= addrBalanceUnconfirmed b, + "coins" .= addrBalanceCoins b, + "txs" .= addrBalanceTxs b, + "received" .= addrBalanceReceived b + ] + +instance FromJSON AddressBalance where + parseJSON = + withObject "accountbalance" $ \o -> + AddressBalance + <$> o .: "confirmed" + <*> o .: "unconfirmed" + <*> o .: "coins" + <*> o .: "txs" + <*> o .: "received" + +updateAddressBalances :: + (MonadUnliftIO m) => + Network -> + [Store.Balance] -> + ExceptT String (DB m) () +updateAddressBalances net storeBals = + forM_ storeBals $ \s -> do + addrT <- + liftEither $ maybeToEither "Invalid Address" (addrToText net s.address) + lift . update $ \a -> do + set + a + [ DBAddressBalanceConfirmed =. val s.confirmed, + DBAddressBalanceUnconfirmed =. val s.unconfirmed, + DBAddressBalanceCoins =. val s.utxo, + DBAddressBalanceTxs =. val s.txs, + DBAddressBalanceReceived =. val s.received + ] + where_ $ a ^. DBAddressAddress ==. val addrT + +insertAddress :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + SoftPath -> + Address -> + AddrFree -> + ExceptT String (DB m) DBAddress +insertAddress net (DBAccountKey wallet accDeriv) deriv addr free = do + time <- liftIO getCurrentTime + addrT <- liftEither $ maybeToEither "Invalid Address" (addrToText net addr) + let label = if isIntPath deriv then "Internal Address" else "" + derivS = cs $ pathToStr deriv + dbAddr = + DBAddress + (fromIntegral $ pathIndex deriv) + wallet + accDeriv + derivS + addrT + label + 0 + 0 + 0 + 0 + 0 + (isIntPath deriv) + (isAddrFree free) + time + lift $ P.insert_ dbAddr + return dbAddr + +-- This is an internal function +genNextAddress :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + AddrType -> + AddrFree -> + Bool -> + ExceptT String (DB m) DBAddress +genNextAddress ctx cfg accId addrType addrFree testGap = do + acc <- getAccountById accId + let net = accountNetwork acc + pub = accountXPubKey ctx acc + nextIdx = dBAccountCount addrType acc + deriv = addrDeriv addrType + when testGap $ checkGap cfg accId nextIdx addrType + let (addr, _) = derivePathAddr ctx pub deriv (fromIntegral nextIdx) + dbAddr <- + insertAddress net accId (deriv :/ fromIntegral nextIdx) addr addrFree + lift $ P.update accId [dBAccountField addrType P.=. nextIdx + 1] + return dbAddr + +checkGap :: + (MonadUnliftIO m) => + Config -> + DBAccountId -> + Int -> + AddrType -> + ExceptT String (DB m) () +checkGap cfg accId addrIdx addrType = do + let gap = configGap cfg + usedIdxM <- lift $ bestAddrWithFunds accId addrType + let usedIdx = maybe 0 (+ 1) usedIdxM + when (addrIdx >= usedIdx + fromIntegral gap) $ + throwError $ + "Can not generate addresses beyond the gap of " <> show gap + +-- Highest address with a positive transaction count +bestAddrWithFunds :: + (MonadUnliftIO m) => DBAccountId -> AddrType -> DB m (Maybe Int) +bestAddrWithFunds (DBAccountKey wallet accDeriv) addrType = do + resM <- (flatMaybe <$>) . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val (isInternal addrType) + &&. a ^. DBAddressBalanceTxs >. val 0 + return $ max_ $ a ^. DBAddressIndex + return $ fromIntegral <$> resM + +-- Generate the discovered external and internal addresses +discoverAccGenAddrs :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + AddrType -> + Int -> + ExceptT String (DB m) () +discoverAccGenAddrs ctx cfg accId addrType newAddrCnt = do + acc <- getAccountById accId + let oldAddrCnt = dBAccountCount addrType acc + cnt = max 0 $ newAddrCnt - oldAddrCnt + -- False: Don't check the gap while discovering + replicateM_ cnt $ genNextAddress ctx cfg accId addrType AddrBusy False + +genExtAddress :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + Text -> + ExceptT String (DB m) DBAddress +genExtAddress ctx cfg accId label = do + -- True: check the gap + addr <- genNextAddress ctx cfg accId AddrExternal AddrBusy True + setAddrLabel accId (dBAddressIndex addr) label + +setAddrLabel :: + (MonadUnliftIO m) => + DBAccountId -> + Int -> + Text -> + ExceptT String (DB m) DBAddress +setAddrLabel accId@(DBAccountKey wallet accDeriv) idx label = do + acc <- getAccountById accId + let path = cs $ pathToStr $ extDeriv :/ fromIntegral idx + aKey = DBAddressKey wallet accDeriv path + unless (fromIntegral idx < dBAccountExternal acc) $ + throwError $ + "Address " <> show idx <> " does not exist" + lift $ P.updateGet aKey [DBAddressLabel P.=. label] + +nextFreeIntAddr :: + (MonadUnliftIO m) => + Ctx -> + Config -> + DBAccountId -> + ExceptT String (DB m) DBAddress +nextFreeIntAddr ctx cfg accId@(DBAccountKey wallet accDeriv) = do + resM <- lift . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val True + &&. a ^. DBAddressFree ==. val True + orderBy [asc $ a ^. DBAddressIndex] + limit 1 + return a + case resM of + Just (Entity _ a) -> return a + -- True: Check the gap + Nothing -> genNextAddress ctx cfg accId AddrInternal AddrFree True + +fromDBAddr :: Network -> DBAddress -> Either String (Address, SoftPath) +fromDBAddr net addrDB = do + let addrT = dBAddressAddress addrDB + derivT = dBAddressDerivation addrDB + deriv <- maybeToEither "fromDBAddress deriv" $ parseSoft $ cs derivT + addr <- maybeToEither "fromDBAddress addr" $ textToAddr net addrT + return (addr, deriv) + +setAddrsFree :: (MonadUnliftIO m) => AddrFree -> [Text] -> DB m Natural +setAddrsFree free addrs = do + (fromIntegral <$>) . updateCount $ \a -> do + set a [DBAddressFree =. val (isAddrFree free)] + where_ $ + a ^. DBAddressAddress `in_` valList addrs + &&. (a ^. DBAddressBalanceTxs ==. val 0) + +addressPage :: (MonadUnliftIO m) => DBAccountId -> Page -> DB m [DBAddress] +addressPage (DBAccountKey wallet accDeriv) (Page lim off) = do + as <- + select $ + from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + &&. a ^. DBAddressInternal ==. val False + orderBy [desc (a ^. DBAddressIndex)] + limit $ fromIntegral lim + offset $ fromIntegral off + return a + return $ entityVal <$> as + +allAddressesMap :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + ExceptT String (DB m) (Map Address SoftPath, Map Address AddressBalance) +allAddressesMap net (DBAccountKey wallet accDeriv) = do + dbRes <- + lift . select $ + from $ \a -> do + where_ $ + a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return a + res <- + forM dbRes $ \(Entity _ dbAddr) -> do + a <- liftEither $ textToAddrE net $ dBAddressAddress dbAddr + d <- + liftEither . maybeToEither "parsePath failed" $ + parseSoft . cs $ + dBAddressDerivation dbAddr + let b = + AddressBalance + (dBAddressBalanceConfirmed dbAddr) + (dBAddressBalanceUnconfirmed dbAddr) + (dBAddressBalanceCoins dbAddr) + (dBAddressBalanceTxs dbAddr) + (dBAddressBalanceReceived dbAddr) + return ((a, d), (a, b)) + return (Map.fromList $ fst <$> res, Map.fromList $ snd <$> res) + +getCoinDeriv :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Store.Unspent -> + DB m (Either String SoftPath) +getCoinDeriv net accId unspent = + runExceptT $ do + addr <- + liftEither . maybeToEither "getCoinDeriv: no address" $ unspent.address + liftEither <=< lift $ getAddrDeriv net accId addr + +getAddrDeriv :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Address -> + DB m (Either String SoftPath) +getAddrDeriv net (DBAccountKey wallet accDeriv) addr = + runExceptT $ do + addrT <- + liftEither . maybeToEither "getAddrDeriv: no address" $ addrToText net addr + derivM <- + lift . selectOne . from $ \a -> do + where_ $ + a ^. DBAddressAddress ==. val addrT + &&. a ^. DBAddressAccountWallet ==. val wallet + &&. a ^. DBAddressAccountDerivation ==. val accDeriv + return $ a ^. DBAddressDerivation + liftEither . maybeToEither "getAddrDeriv: no derivation" $ + parseSoft . cs . unValue =<< derivM + +{- Transactions -} + +getConfirmedTxs :: + (MonadUnliftIO m) => DBAccountId -> Bool -> ExceptT String (DB m) [TxHash] +getConfirmedTxs (DBAccountKey wallet accDeriv) confirm = do + ts <- + lift . select $ + from $ \t -> do + where_ $ + t ^. DBTxInfoAccountWallet ==. val wallet + &&. t ^. DBTxInfoAccountDerivation ==. val accDeriv + &&. t ^. DBTxInfoConfirmed ==. val confirm + orderBy [asc (t ^. DBTxInfoBlockRef)] + return $ t ^. DBTxInfoTxid + forM ts $ \(Value t) -> + liftEither $ maybeToEither "getConfirmedTxs invalid TxHash" $ hexToTxHash t + +-- Insert a new transaction or replace it, if it already exists +-- Returns True if there was a change or an insert +repsertTxInfo :: + (MonadUnliftIO m) => + Network -> + Ctx -> + DBAccountId -> + TxInfo -> + ExceptT String (DB m) (DBTxInfo, Bool) +repsertTxInfo net ctx accId txInfo = do + time <- liftIO getCurrentTime + tid <- liftEither $ maybeToEither "TxId" $ txInfoHash txInfo + let confirmed' = Store.confirmed $ txInfoBlockRef txInfo + tidT = txHashToHex tid + bRef = S.encode $ txInfoBlockRef txInfo + -- Confirmations will get updated when retrieving them + blob = + BS.toStrict $ + marshalJSON + (net, ctx) + txInfo + { txInfoConfirmations = 0, + txInfoPending = Nothing + } + (DBAccountKey wallet accDeriv) = accId + key = DBTxInfoKey wallet accDeriv tidT + dbInfo = + DBTxInfo + { dBTxInfoAccountWallet = wallet, + dBTxInfoAccountDerivation = accDeriv, + dBTxInfoTxid = tidT, + dBTxInfoBlockRef = bRef, + dBTxInfoConfirmed = confirmed', + dBTxInfoBlob = blob, + dBTxInfoCreated = time + } + prevM <- lift $ P.get key + case prevM of + Just prev -> do + let newDBInfo = + prev + { dBTxInfoBlockRef = bRef, + dBTxInfoConfirmed = confirmed', + dBTxInfoBlob = blob + } + lift $ P.replace key newDBInfo + return (newDBInfo, prev /= newDBInfo) + Nothing -> do + lift $ P.insert_ dbInfo + return (dbInfo, True) + +txsPage :: + (MonadUnliftIO m) => + Ctx -> + DBAccountId -> + Page -> + ExceptT String (DB m) [TxInfo] +txsPage ctx accId@(DBAccountKey wallet accDeriv) (Page lim off) = do + acc <- getAccountById accId + let net = accountNetwork acc + dbTxs <- + lift . select . from $ \t -> do + where_ $ + t ^. DBTxInfoAccountWallet ==. val wallet + &&. t ^. DBTxInfoAccountDerivation ==. val accDeriv + orderBy [asc (t ^. DBTxInfoBlockRef)] + limit $ fromIntegral lim + offset $ fromIntegral off + return $ t ^. DBTxInfoBlob + res <- + forM dbTxs $ \(Value dbTx) -> do + liftMaybe "TxInfo unmarshalJSON Failed" $ + unmarshalJSON (net, ctx) $ + BS.fromStrict dbTx + resLabels <- lift $ mapM (fillTxInfoLabels net) res + bestM <- lift $ getBest net + return $ updateConfirmations (snd <$> bestM) <$> resLabels + where + updateConfirmations bestM tif = + tif {txInfoConfirmations = getConfirmations bestM (txInfoBlockRef tif)} + +getConfirmations :: Maybe BlockHeight -> Store.BlockRef -> Natural +getConfirmations _ (Store.MemRef _) = 0 +getConfirmations Nothing (Store.BlockRef _ _) = 1 +getConfirmations (Just best) (Store.BlockRef height _) + | best < height = 1 + | otherwise = fromIntegral $ best - height + 1 + +fillTxInfoLabels :: (MonadUnliftIO m) => Network -> TxInfo -> DB m TxInfo +fillTxInfoLabels net txInfo = do + o <- mapM fillOutput $ Map.assocs $ txInfoMyOutputs txInfo + i <- mapM fillInput $ Map.assocs $ txInfoMyInputs txInfo + return $ + txInfo + { txInfoMyOutputs = Map.fromList o, + txInfoMyInputs = Map.fromList i + } + where + fillOutput (a, o) = do + resM <- runMaybeT $ do + addrT <- hoistMaybe $ addrToText net a + (Entity _ dbAddr) <- hoistMaybe =<< lift (P.getBy $ UniqueAddress addrT) + return (a, o {myOutputsLabel = dBAddressLabel dbAddr}) + return $ fromMaybe (a, o) resM + fillInput (a, i) = do + resM <- runMaybeT $ do + addrT <- hoistMaybe $ addrToText net a + (Entity _ dbAddr) <- hoistMaybe =<< lift (P.getBy $ UniqueAddress addrT) + return (a, i {myInputsLabel = dBAddressLabel dbAddr}) + return $ fromMaybe (a, i) resM + +{- Coins -} + +data JsonCoin = JsonCoin + { jsonCoinOutpoint :: !OutPoint, + jsonCoinAddress :: !Address, + jsonCoinValue :: !Word64, + jsonCoinBlock :: !Store.BlockRef, + jsonCoinConfirmations :: !Natural, + jsonCoinLocked :: !Bool + } + deriving (Eq, Show) + +instance MarshalJSON Network JsonCoin where + marshalValue net c = + object + [ "outpoint" .= jsonCoinOutpoint c, + "address" .= marshalValue net (jsonCoinAddress c), + "value" .= jsonCoinValue c, + "block" .= jsonCoinBlock c, + "confirmations" .= jsonCoinConfirmations c, + "locked" .= jsonCoinLocked c + ] + unmarshalValue net = + withObject "JsonCoin" $ \o -> + JsonCoin + <$> o .: "outpoint" + <*> (unmarshalValue net =<< o .: "address") + <*> o .: "value" + <*> o .: "block" + <*> o .: "confirmations" + <*> o .: "locked" + +toJsonCoin :: Network -> Maybe BlockHeight -> DBCoin -> Either String JsonCoin +toJsonCoin net bestM dbCoin = do + op <- textToOutpoint $ dBCoinOutpoint dbCoin + ad <- + maybeToEither "toJsonCoin: Invalid address" $ + textToAddr net $ + dBCoinAddress dbCoin + br <- S.decode $ dBCoinBlockRef dbCoin + let confirmations = getConfirmations bestM br + return $ + JsonCoin + { jsonCoinOutpoint = op, + jsonCoinAddress = ad, + jsonCoinValue = dBCoinValue dbCoin, + jsonCoinBlock = br, + jsonCoinConfirmations = confirmations, + jsonCoinLocked = dBCoinLocked dbCoin + } + +outpointText :: OutPoint -> Text +outpointText = encodeHex . S.encode + +textToOutpoint :: Text -> Either String OutPoint +textToOutpoint t = do + bs <- maybeToEither "textToOutpoint: invalid input" $ decodeHex t + S.decode bs + +-- Get all coins in an account, spendable or not +coinPage :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Page -> + ExceptT String (DB m) [JsonCoin] +coinPage net (DBAccountKey wallet accDeriv) (Page lim off) = do + coins <- + lift . select . from $ \c -> do + where_ $ do + c ^. DBCoinAccountWallet ==. val wallet + &&. c ^. DBCoinAccountDerivation ==. val accDeriv + orderBy [asc (c ^. DBCoinBlockRef), desc (c ^. DBCoinCreated)] + limit $ fromIntegral lim + offset $ fromIntegral off + return c + bestM <- lift $ getBest net + mapM (liftEither . toJsonCoin net (snd <$> bestM) . entityVal) coins + +-- Spendable coins must be confirmed and not locked +getSpendableCoins :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + Natural -> + ExceptT String (DB m) [Store.Unspent] +getSpendableCoins net (DBAccountKey wallet accDeriv) minConf = do + bestM <- lift $ getBest net + coins <- lift . select . from $ \c -> do + where_ $ + c ^. DBCoinAccountWallet ==. val wallet + &&. c ^. DBCoinAccountDerivation ==. val accDeriv + &&. c ^. DBCoinLocked ==. val False + return c + let f c = do + ref <- liftEither $ S.decode $ dBCoinBlockRef c + return $ getConfirmations (snd <$> bestM) ref >= minConf + spendableCoins <- filterM (f . entityVal) coins + let bss = dBCoinBlob . entityVal <$> spendableCoins + mapM (liftEither . S.decode) bss + +insertCoin :: + (MonadUnliftIO m) => + DBAccountId -> + Text -> + Store.Unspent -> + DB m DBCoin +insertCoin (DBAccountKey wallet accDeriv) addr unspent = do + time <- liftIO getCurrentTime + let newCoin = + DBCoin + { dBCoinAccountWallet = wallet, + dBCoinAccountDerivation = accDeriv, + dBCoinOutpoint = outpointText unspent.outpoint, + dBCoinAddress = addr, + dBCoinValue = unspent.value, + dBCoinBlockRef = S.encode unspent.block, + dBCoinBlob = S.encode unspent, + dBCoinConfirmed = Store.confirmed unspent.block, + dBCoinLocked = False, + dBCoinCreated = time + } + P.insert_ newCoin + return newCoin + +updateCoin :: (MonadUnliftIO m) => Store.Unspent -> DB m () +updateCoin unspent = do + let key = DBCoinKey $ outpointText unspent.outpoint + P.update + key + [ DBCoinBlob P.=. S.encode unspent, + DBCoinConfirmed P.=. Store.confirmed unspent.block, + DBCoinBlockRef P.=. S.encode unspent.block + ] + +deleteCoin :: (MonadUnliftIO m) => DBCoin -> DB m () +deleteCoin coin = + delete . from $ \c -> + where_ $ + c ^. DBCoinOutpoint ==. val (dBCoinOutpoint coin) + +getCoinsByAddr :: (MonadUnliftIO m) => Text -> DB m [DBCoin] +getCoinsByAddr addr = do + coins <- select . from $ \c -> do + where_ $ c ^. DBCoinAddress ==. val addr + return c + return $ entityVal <$> coins + +-- This is the main coin function +-- Either insert, update or delete coins as required. Returns the number of +-- coins that have either been inserted, updated or deleted. +refreshCoins :: + (MonadUnliftIO m) => + Network -> + DBAccountId -> + [Address] -> + [Store.Unspent] -> + ExceptT String (DB m) (Int, [DBCoin]) +refreshCoins net accId addrsToUpdate allUnspent = do + let storeMap = groupCoins net allUnspent + addrsToUpdateE <- + mapM (liftEither . maybeToEither "Addr" . addrToText net) addrsToUpdate + res <- forM addrsToUpdateE $ \addr -> do + let storeCoins = fromMaybe [] $ Map.lookup addr storeMap + localCoins <- lift $ getCoinsByAddr addr + let storeOps = outpointText . (.outpoint) <$> storeCoins + localOps = dBCoinOutpoint <$> localCoins + toDelete = filter ((`notElem` storeOps) . dBCoinOutpoint) localCoins + toInsert = + filter ((`notElem` localOps) . outpointText . (.outpoint)) storeCoins + toUpdate = filter (f localCoins) storeCoins + lift $ forM_ toDelete deleteCoin + lift $ forM_ toUpdate updateCoin + newCoins <- lift $ forM toInsert $ insertCoin accId addr + return (length toDelete + length toUpdate + length toInsert, newCoins) + return (sum $ fst <$> res, concatMap snd res) + where + f localCoins s = + let cM = find ((== outpointText s.outpoint) . dBCoinOutpoint) localCoins + in case cM of + Just c -> dBCoinBlockRef c /= S.encode s.block + _ -> False + +groupCoins :: Network -> [Store.Unspent] -> Map Text [Store.Unspent] +groupCoins net = + Map.fromListWith (<>) . mapMaybe f + where + f x = + case x.address of + Just a -> (,[x]) <$> addrToText net a + _ -> Nothing + +setLockCoin :: (MonadUnliftIO m) => OutPoint -> Bool -> DB m Natural +setLockCoin op locked = do + cnt <- updateCount $ \c -> do + set c [DBCoinLocked =. val locked] + where_ $ + c ^. DBCoinOutpoint ==. val (outpointText op) + &&. c ^. DBCoinLocked ==. val (not locked) + return $ fromIntegral cnt + +{- Raw Transactions -} + +insertRawTx :: (MonadUnliftIO m) => Tx -> DB m () +insertRawTx tx = do + let hash = txHashToHex $ txHash tx + key = DBRawTxKey hash + P.repsert key $ DBRawTx hash (S.encode tx) + +getRawTx :: (MonadUnliftIO m) => TxHash -> ExceptT String (DB m) Tx +getRawTx hash = do + let key = DBRawTxKey $ txHashToHex hash + txM <- lift $ P.get key + case txM of + Just tx -> liftEither . S.decode $ dBRawTxBlob tx + Nothing -> throwError "getRawTx: missing transaction" + +{- Pending Transactions -} + +data TxOnline = TxOnline | TxOffline + deriving (Eq, Show) + +-- Returns (TxSignData, isOnline) +getPendingTx :: + (MonadUnliftIO m) => + TxHash -> + DB m (Maybe (DBAccountId, TxSignData, TxInfoPending)) +getPendingTx nosigHash = do + let hashT = txHashToHex nosigHash + key = DBPendingTxKey hashT + resM <- P.get key + case resM of + Just (DBPendingTx wallet accDeriv _ blob online _) -> do + let accId = DBAccountKey wallet accDeriv + tsdM = Json.decode $ BS.fromStrict blob + return $ do + tsd <- tsdM + let pending = + TxInfoPending + (nosigTxHash $ txSignDataTx tsd) + (txSignDataSigned tsd) + online + return (accId, tsd, pending) + _ -> return Nothing + +pendingTxPage :: + (MonadUnliftIO m) => + Ctx -> + DBAccountId -> + Page -> + ExceptT String (DB m) [TxInfo] +pendingTxPage ctx accId@(DBAccountKey wallet accDeriv) (Page lim off) = do + acc <- getAccountById accId + let pub = accountXPubKey ctx acc + net = accountNetwork acc + tsds <- + lift . select . from $ \p -> do + where_ $ do + p ^. DBPendingTxAccountWallet ==. val wallet + &&. p ^. DBPendingTxAccountDerivation ==. val accDeriv + orderBy [desc (p ^. DBPendingTxCreated)] + limit $ fromIntegral lim + offset $ fromIntegral off + return p + forM tsds $ \(Entity _ res) -> do + tsd <- liftEither . Json.eitherDecode . BS.fromStrict $ dBPendingTxBlob res + txInfo <- liftEither $ parseTxSignData net ctx pub tsd + let nosigHash = nosigTxHash $ txSignDataTx tsd + pending = + TxInfoPending nosigHash (txSignDataSigned tsd) (dBPendingTxOnline res) + let txInfoP = txInfo {txInfoPending = Just pending} + lift $ fillTxInfoLabels net txInfoP + +-- Returns the TxHash and NoSigHash of pending transactions. They are compared +-- during a sync in order to delete pending transactions that are now online. +pendingTxHashes :: + (MonadUnliftIO m) => + DBAccountId -> + ExceptT String (DB m) [(TxHash, DBPendingTxId)] +pendingTxHashes (DBAccountKey wallet accDeriv) = do + blobs <- + lift . select . from $ \p -> do + where_ $ do + p ^. DBPendingTxAccountWallet ==. val wallet + &&. p ^. DBPendingTxAccountDerivation ==. val accDeriv + return (p ^. DBPendingTxBlob, p ^. DBPendingTxId) + res <- forM blobs $ \(Value blob, Value key) -> do + tsd <- liftEither . Json.eitherDecode $ BS.fromStrict blob + if txSignDataSigned tsd + then return [(txHash $ txSignDataTx tsd, key)] + else return [] + return $ concat res + +-- Imports a pending transaction, locks coins and locks internal addresses +importPendingTx :: + (MonadUnliftIO m) => + Network -> + Ctx -> + DBAccountId -> + TxSignData -> + ExceptT String (DB m) TxHash +importPendingTx net ctx accId tsd@(TxSignData tx _ _ _ signed) = do + acc <- getAccountById accId + let pub = accountXPubKey ctx acc + nosigHash = nosigTxHash $ txSignDataTx tsd + bs = BS.toStrict $ Json.encode tsd + prevM <- lift $ getPendingTx nosigHash + case prevM of + Just (_, TxSignData prevTx _ _ _ prevSigned, pending) -> do + when (pendingOnline pending) $ + throwError "The transaction is already online" + when (prevSigned && not signed) $ + throwError "Can not replace a signed transaction with an unsigned one" + when (prevTx == tx) $ + throwError "The transaction already exists" + when (not prevSigned && signed) $ do + let key = DBPendingTxKey $ txHashToHex nosigHash + lift $ P.update key [DBPendingTxBlob P.=. bs] + return nosigHash + Nothing -> do + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let (outpoints, outIntAddrs, restAddrs) = parseTxInfoU txInfoU + -- Verify coins and lock them + forM_ outpoints $ \outpoint -> do + coinM <- lift $ P.get $ DBCoinKey $ outpointText outpoint + case coinM of + Just coin -> do + when (dBCoinLocked coin) $ + throwError "A coin referenced by the transaction is locked" + lift $ setLockCoin outpoint True + _ -> throwError "A coin referenced by the transaction does not exist" + -- Verify addresses and set internal output addresses to busy + outIntAddrsT <- mapM (liftMaybe "Addrs" . addrToText net . fst) outIntAddrs + restAddrsT <- mapM (liftMaybe "Addrs" . addrToText net) restAddrs + outIntAddrsE <- lift . select . from $ \a -> do + where_ $ a ^. DBAddressAddress `in_` valList outIntAddrsT + return a + restAddrsE <- lift . select . from $ \a -> do + where_ $ a ^. DBAddressAddress `in_` valList restAddrsT + return a + when + ( length (outIntAddrsT <> restAddrsT) + /= length (outIntAddrsE <> restAddrsE) + ) + $ throwError "Some referenced addresses do not exist" + unless (all (dBAddressFree . entityVal) outIntAddrsE) $ + throwError "Some of the internal output addresses are not free" + -- Set the output internal addresses to not free + _ <- lift $ setAddrsFree AddrBusy outIntAddrsT + -- Insert the pending transaction + time <- liftIO getCurrentTime + let ptx = + DBPendingTx + (dBAccountWallet acc) + (dBAccountDerivation acc) + (txHashToHex nosigHash) + bs + False + time + lift $ P.insert_ ptx + return nosigHash + +-- (Outpoints, external addrs, internal addrs) +parseTxInfoU :: TxInfo -> ([OutPoint], [(Address, KeyIndex)], [Address]) +parseTxInfoU TxInfo {..} = + (outpoints, nub $ f <$> outIntAddrs, nub $ fst <$> restAddrs) + where + outpoints = (.outpoint) <$> concatMap myInputsSigInput (Map.elems txInfoMyInputs) + outAddrs = second myOutputsPath <$> Map.assocs txInfoMyOutputs + inAddrs = second myInputsPath <$> Map.assocs txInfoMyInputs + (outIntAddrs, outExtAddrs) = partition (isIntPath . snd) outAddrs + restAddrs = outExtAddrs <> inAddrs + f (a, p) = + case pathToList p of + (_ : i : _) -> (a, i) + _ -> error "parseTxInfoU" + +-- Delete a pending transaction, unlocks coins and frees internal addresses +deletePendingTx :: + (MonadUnliftIO m) => + Ctx -> + TxHash -> + ExceptT String (DB m) (Natural, Natural) +deletePendingTx ctx nosigHash = do + let key = DBPendingTxKey $ txHashToHex nosigHash + tsdM <- lift $ getPendingTx nosigHash + case tsdM of + Just (_, _, TxInfoPending _ _ True) -> do + throwError + "This pending transaction has been sent to the network.\ + \ Run syncacc to refresh your database." + -- We only free coins and addresses if the transaction is offline + Just (accId, tsd, _) -> do + acc <- getAccountById accId + let net = accountNetwork acc + pub = accountXPubKey ctx acc + txInfoU <- liftEither $ parseTxSignData net ctx pub tsd + let (outpoints, outIntAddrs, _) = parseTxInfoU txInfoU + outIntAddrsT <- + mapM (liftMaybe "Address" . addrToText net . fst) outIntAddrs + freedCoins <- forM outpoints $ \op -> lift $ setLockCoin op False + freedAddresses <- lift $ setAddrsFree AddrFree outIntAddrsT + lift $ P.delete key + return (sum freedCoins, fromIntegral freedAddresses) + _ -> throwError "The pending transaction does not exist" + +-- When the pending transaction is online, we just delete it +deletePendingTxOnline :: (MonadUnliftIO m) => DBPendingTxId -> DB m () +deletePendingTxOnline = P.delete + +setPendingTxOnline :: (MonadUnliftIO m) => TxHash -> DB m Natural +setPendingTxOnline nosigH = do + let nosigHT = txHashToHex nosigH + cnt <- updateCount $ \p -> do + set p [DBPendingTxOnline =. val True] + where_ $ p ^. DBPendingTxNosigHash ==. val nosigHT + return $ fromIntegral cnt + +{- Helpers -} + +extDeriv :: SoftPath +extDeriv = Deriv :/ 0 + +intDeriv :: SoftPath +intDeriv = Deriv :/ 1 + +isExtPath :: SoftPath -> Bool +isExtPath p = + case pathToList p of + [0, _] -> True + _ -> False + +isIntPath :: SoftPath -> Bool +isIntPath p = + case pathToList p of + [1, _] -> True + _ -> False + +pathIndex :: SoftPath -> KeyIndex +pathIndex p = + case pathToList p of + [_, i] -> i + _ -> error "Invalid pathIndex" + +bip44Deriv :: Network -> Natural -> HardPath +bip44Deriv net a = Deriv :| 44 :| net.bip44Coin :| fromIntegral a + +xPubIndex :: XPubKey -> Natural +xPubIndex = fromIntegral . xPubChild + +addrsDerivPage :: Ctx -> SoftPath -> Page -> XPubKey -> [(Address, SoftPath)] +addrsDerivPage ctx deriv (Page lim off) xpub = + fmap (\(a, _, i) -> (a, deriv :/ i)) addrs + where + addrs = + take (fromIntegral lim) $ + derivePathAddrs ctx xpub deriv (fromIntegral off) + +-- like `maybe` but for a maybe/value sandwich +joinMaybe :: b -> (a -> b) -> Maybe (E.Value (Maybe a)) -> b +joinMaybe d f m = + case m of + Just (Value m') -> maybe d f m' + Nothing -> d + +flatMaybe :: Maybe (E.Value (Maybe a)) -> Maybe a +flatMaybe = joinMaybe Nothing Just diff --git a/src/Haskoin/Wallet/Entropy.hs b/src/Haskoin/Wallet/Entropy.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Entropy.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.Entropy where + +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad (replicateM, unless, when) +import Control.Monad.Except +import Data.Bits (Bits (setBit, xor)) +import qualified Data.ByteString as BS +import Data.List (foldl', nub) +import Data.Text (Text) +import Data.Word (Word8) +import Haskoin.Crypto (Mnemonic, toMnemonic, fromMnemonic) +import Haskoin.Util (bsToInteger) +import Haskoin.Wallet.Util (chunksOf) +import Numeric (showIntAtBase) +import Numeric.Natural (Natural) +import qualified System.Console.Haskeline as Haskeline +import qualified System.Console.Haskeline as Haskline +import qualified System.Directory as D +import System.Entropy (getEntropy) +import System.IO (IOMode (ReadMode), withBinaryFile) +import Text.Read (readMaybe) + +-- Produces uniformily distributed dice rolls from a random byte +-- 0, 0x00 -> [6,6,6] +-- 1, 0x01 -> [6,6,1] +-- 215, 0xd7 -> [5,5,5] +-- 216, 0xd8 -> [6,6] +-- 217, 0xd9 -> [6,1] +-- 251, 0xfb -> [5,5] +-- Anything above 0xfb is dropped +word8ToBase6 :: Word8 -> [Natural] +word8ToBase6 w + | w > 0xfb = [] -- Drop otherwise we don't have uniform distribution + | w > 0xd7 = + let res = f <$> encodeBase6 (BS.pack [w - 0xd8]) + in replicate (2 - length res) 6 <> res + | otherwise = + let res = f <$> encodeBase6 (BS.pack [w]) + in replicate (3 - length res) 6 <> res + where + f :: Char -> Natural + f = read . (: []) + b6Data :: String + b6Data = "612345" + b6 :: Int -> Char + b6 = (b6Data !!) + encodeBase6 :: BS.ByteString -> String + encodeBase6 bs + | BS.null bs = mempty + | otherwise = showIntAtBase 6 b6 (bsToInteger bs) "" + +-- Produces Bools using base6ToBool. Once 8 Bools have been +-- accumulated, it is transformed to a Word8 using boolsToWord8. +-- Any unused Bools are returned along with the Word8s. +base6ToWord8 :: [Natural] -> [Bool] -> ([Word8], [Bool]) +base6ToWord8 ns obs + | length bs < 8 = ([], bs) + | otherwise = + let (ws, rest) = f bs [] + in (boolsToWord8 <$> ws, rest) + where + bs = concatMap base6ToBool ns <> obs + f :: [Bool] -> [[Bool]] -> ([[Bool]], [Bool]) + f xs acc + | length xs < 8 = (acc, xs) + | otherwise = + let (l, r) = splitAt (length xs - 8) xs + in f l ([r] <> acc) + +-- Produce uniformily distributed bits from dice rolls +-- 6 -> [0,0] +-- 1 -> [0,1] +-- 2 -> [1,0] +-- 3 -> [1,1] +-- 4 -> [0] +-- 5 -> [1] +base6ToBool :: Natural -> [Bool] +base6ToBool = + \case + 6 -> [False, False] + 1 -> [False, True] + 2 -> [True, False] + 3 -> [True, True] + 4 -> [False] + 5 -> [True] + _ -> error "Invalid base6ToBool" + +-- Big Endian +-- [T,F,F,F,F,F,F,F] -> 128 +-- [F,F,F,F,F,F,F,T] -> 1 +boolsToWord8 :: [Bool] -> Word8 +boolsToWord8 xs + | length xs /= 8 = error "Invalid boolsToWord8" + | otherwise = + foldl' setBit 0 ys + where + ys = fmap fst $ filter snd $ zip [0 ..] $ reverse xs + +-- Packs bools into a ByteString +packBools :: [Bool] -> BS.ByteString +packBools bs + | length bs `mod` 8 /= 0 = error "Invalid packBools length" + | otherwise = BS.pack $ boolsToWord8 <$> chunksOf 8 bs + +-- Mix entropy of same length by xoring them +xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString +xorBytes ent1 ent2 + | BS.length ent1 == BS.length ent2 = + BS.pack $ BS.zipWith xor ent1 ent2 + | otherwise = error "Entropy is not of the same length" + +-- Split secret s into n parts +-- generate k1 .. k(n-1) randomly +-- compute kn = s xor k1 xor .. xor k(n-1) +-- return k1 .. kn +-- We have the property that s = k1 xor ... xor kn +splitEntropy :: Natural -> BS.ByteString -> IO [BS.ByteString] +splitEntropy n secret + | n < 2 = error "splitEntropy invalid number" + | otherwise = do + ks <- replicateM (fromIntegral n - 1) (snd <$> systemEntropy len) + return $ splitEntropyWith secret ks + where + len = fromIntegral $ BS.length secret + +splitEntropyWith :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString] +splitEntropyWith secret ks = foldl' xorBytes secret ks : ks + +mergeMnemonicParts :: [Text] -> Either String Mnemonic +mergeMnemonicParts mnems + | length mnems < 2 = Left "Only one mnemonic provided" + | length (nub mnems) /= length mnems = Left "Two mnemonics are identical" + | otherwise = do + bs <- mapM fromMnemonic mnems + let ent = foldl' xorBytes (head bs) (tail bs) + toMnemonic ent + +askInputDice :: IO Natural +askInputDice = do + inputM <- + Haskeline.runInputT Haskline.defaultSettings $ + Haskeline.getInputLine "Dice roll: " + case readMaybe =<< inputM of + Just n -> + if n `elem` [1 .. 6] + then return n + else badInput + _ -> badInput + where + badInput = do + putStrLn "Invalid dice roll. Must be in range [1..6]" + askInputDice + +-- TODO: Ask the dice rolls in sequences of 5 or so +getDiceEntropy :: Natural -> IO BS.ByteString +getDiceEntropy ent = do + putStrLn "Enter your dice rolls (from 1 to 6)" + f [] [] + where + f :: [Word8] -> [Bool] -> IO BS.ByteString + f res acc + | length res == fromIntegral ent = + return $ BS.pack res + | otherwise = do + d <- askInputDice + let (ws, bs) = base6ToWord8 [d] acc + unless (null ws) $ do + putStrLn $ + show (length res + length ws) + <> "/" + <> show ent + <> " bytes collected" + f (ws <> res) bs + +-- Generate a mnemonic with optional dice entropy and key splitting +genMnemonic :: + (MonadIO m) => + Natural -> + Bool -> + Natural -> + ExceptT String m (Text, Mnemonic, [Mnemonic]) +genMnemonic reqEnt reqDice splitIn + | splitIn == 0 = throwError "Invalid split option" + | reqEnt `elem` [16, 20 .. 32] = do + (origEnt, sysEnt) <- liftIO $ systemEntropy reqEnt + ent <- + if reqDice + then do + diceEnt <- liftIO $ getDiceEntropy reqEnt + return $ sysEnt `xorBytes` diceEnt + else return sysEnt + when (BS.length ent /= fromIntegral reqEnt) $ + throwError "Something went wrong with the entropy size" + mnem <- liftEither $ toMnemonic ent + if splitIn > 1 + then do + ks <- liftIO $ splitEntropy splitIn ent + unless (ent == foldl' xorBytes (head ks) (tail ks)) $ + throwError "Something went wrong while splitting the keys" + splitMnems <- liftEither $ mapM toMnemonic ks + unsplitMnem <- liftEither $ mergeMnemonicParts splitMnems + unless (mnem == unsplitMnem) $ + throwError "Something went wrong while reconstructing the mnemonic" + return (origEnt, mnem, splitMnems) + else return (origEnt, mnem, []) + | otherwise = throwError "The entropy value can only be in [16,20..32]" + +systemEntropy :: Natural -> IO (Text, BS.ByteString) +systemEntropy bytes = do + exists <- D.doesFileExist "/dev/random" + if exists + then ("/dev/random",) <$> devRandom bytes + else ("System.Entropy.getEntropy",) <$> getEntropy (fromIntegral bytes) + +devRandom :: Natural -> IO BS.ByteString +devRandom bytes = + withBinaryFile "/dev/random" ReadMode (`BS.hGet` fromIntegral bytes) diff --git a/src/Haskoin/Wallet/FileIO.hs b/src/Haskoin/Wallet/FileIO.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/FileIO.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.FileIO where + +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadIO (..)) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Char8 as C8 +import Data.Maybe (mapMaybe) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Haskoin +import Haskoin.Wallet.Util +import qualified System.Directory as D +import qualified System.IO as IO + +data PubKeyDoc = PubKeyDoc + { documentPubKey :: !XPubKey, + documentNetwork :: !Network, + documentName :: !Text, + documentWallet :: !Fingerprint + } + deriving (Eq, Show) + +instance MarshalJSON Ctx PubKeyDoc where + unmarshalValue ctx = + withObject "pubkeydocument" $ \o -> do + net <- maybe mzero return . netByName =<< o .: "network" + PubKeyDoc + <$> (unmarshalValue (net, ctx) =<< o .: "xpubkey") + <*> return net + <*> (o .: "name") + <*> (o .: "wallet") + + marshalValue ctx (PubKeyDoc k net name wallet) = + object + [ "xpubkey" .= marshalValue (net, ctx) k, + "network" .= net.name, + "name" .= name, + "wallet" .= wallet + ] + +data TxSignData = TxSignData + { txSignDataTx :: !Tx, + txSignDataInputs :: ![Tx], + txSignDataInputPaths :: ![SoftPath], + txSignDataOutputPaths :: ![SoftPath], + txSignDataSigned :: !Bool + } + deriving (Eq, Show) + +instance FromJSON TxSignData where + parseJSON = + withObject "txsigndata" $ \o -> do + let f = eitherToMaybe . S.decode <=< decodeHex + t <- maybe mzero return . f =<< o .: "tx" + i <- maybe mzero return . mapM f =<< o .: "txinputs" + TxSignData t i + <$> o .: "inputpaths" + <*> o .: "outputpaths" + <*> o .: "signed" + +instance ToJSON TxSignData where + toJSON (TxSignData t i oi op s) = + object + [ "tx" .= encodeHex (S.encode t), + "txinputs" .= (encodeHex . S.encode <$> i), + "inputpaths" .= oi, + "outputpaths" .= op, + "signed" .= s + ] + +instance MarshalJSON Ctx TxSignData where + marshalValue _ = toJSON + unmarshalValue _ = parseJSON + +checkPathFree :: (MonadIO m) => FilePath -> ExceptT String m () +checkPathFree path = do + exist <- liftIO $ D.doesPathExist path + when exist $ throwError $ "Path '" <> path <> "' already exists" + +-- JSON IO Helpers-- + +writeJsonFile :: FilePath -> Value -> IO () +writeJsonFile filePath doc = C8.writeFile filePath $ encodeJsonPrettyLn doc + +readJsonFile :: (FromJSON a) => FilePath -> IO (Either String a) +readJsonFile = eitherDecodeFileStrict' + +writeMarshalFile :: (MarshalJSON s a) => s -> FilePath -> a -> IO () +writeMarshalFile s filePath a = writeJsonFile filePath $ marshalValue s a + +readMarshalFile :: (MarshalJSON s a) => s -> FilePath -> IO (Either String a) +readMarshalFile s filePath = do + vE <- readJsonFile filePath + return $ parseEither (unmarshalValue s) =<< vE + +-- Parse wallet dump files for sweeping -- + +readFileWords :: FilePath -> IO [[Text]] +readFileWords fp = do + strContents <- IO.readFile fp + return $ removeComments $ Text.words <$> Text.lines (cs strContents) + +parseSecKeysFile :: Network -> [[Text]] -> [SecKey] +parseSecKeysFile net = + withParser $ \w -> (.key) <$> (fromWif net w <|> fromMiniKey (cs w)) + +withParser :: (Text -> Maybe a) -> [[Text]] -> [a] +withParser parser = + mapMaybe go + where + go [] = Nothing + go (w : ws) = parser w <|> go ws + +removeComments :: [[Text]] -> [[Text]] +removeComments = + mapMaybe go + where + go [] = Nothing + go ws@(w : _) + | "#" `Text.isPrefixOf` w = Nothing + | otherwise = Just ws diff --git a/src/Haskoin/Wallet/Main.hs b/src/Haskoin/Wallet/Main.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Main.hs @@ -0,0 +1,25 @@ +module Haskoin.Wallet.Main where + +import qualified Data.ByteString.Char8 as C8 +import Haskoin (Ctx, MarshalJSON (..), withContext) +import Haskoin.Wallet.Commands (Response, commandResponse) +import Haskoin.Wallet.Config (initConfig) +import Haskoin.Wallet.Database (runDB) +import Haskoin.Wallet.Migration (migrateDB) +import Haskoin.Wallet.Parser (parserMain) +import Haskoin.Wallet.PrettyPrinter (prettyPrinter) +import Haskoin.Wallet.Util (encodeJsonPretty) + +clientMain :: IO () +clientMain = + withContext $ \ctx -> do + cfg <- initConfig + runDB cfg $ migrateDB ctx cfg + (cmd, unit, json) <- parserMain + res <- commandResponse ctx cfg unit cmd + if json + then jsonPrinter ctx res + else prettyPrinter unit res + +jsonPrinter :: Ctx -> Response -> IO () +jsonPrinter ctx = C8.putStrLn . encodeJsonPretty . marshalValue ctx diff --git a/src/Haskoin/Wallet/Migration.hs b/src/Haskoin/Wallet/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Migration.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.Migration where + +import Conduit (MonadUnliftIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (MonadTrans (lift)) +import Data.Text (Text) +import Database.Esqueleto.Legacy as E +import Haskoin +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import qualified Haskoin.Wallet.Migration.V0_9_0 as V0_9_0 +import Haskoin.Wallet.Migration.SemVersion + +getDatabaseTables :: (MonadUnliftIO m) => DB m [Text] +getDatabaseTables = do + s <- rawSql "select name from sqlite_master where type='table'" [] + return $ unSingle <$> s + +databaseVersion :: (MonadUnliftIO m) => DB m (Maybe SemVersion) +databaseVersion = do + tables <- getDatabaseTables + if null tables + then return Nothing + else + if "d_b_version" `elem` tables -- Version table was created at v0.9.0 + then Just <$> getVersion + else return $ Just V0_9_0.migrateFrom + +migrateDB :: (MonadUnliftIO m) => Ctx -> Config -> DB m () +migrateDB ctx cfg = do + resE <- runExceptT $ do + verM <- lift databaseVersion + case verM of + Nothing -> do + lift $ do + globalMigration + setVersion currentVersion + Just ver -> migrateDB_ ctx ver + return verM + case resE of + Left err -> do + transactionUndo -- Roll back the migration and exit + error err + Right verM -> unless (verM == Just currentVersion) $ migrateDB ctx cfg + +migrateDB_ :: + (MonadUnliftIO m) => Ctx -> SemVersion -> ExceptT String (DB m) () +migrateDB_ ctx dbVer + | dbVer == V0_9_0.migrateFrom = do + liftIO $ printDBMigration V0_9_0.migrateFrom V0_9_0.migrateTo + V0_9_0.migrateDB ctx + | dbVer == currentVersion = return () + -- In case we have a patch version in the database + | toMinor dbVer == currentVersion = lift $ setVersion currentVersion + | otherwise = error $ "Invalid migration version: " <> verString dbVer + +printDBMigration :: SemVersion -> SemVersion -> IO () +printDBMigration fromV toV = + putStrLn $ "Migrating from " <> verString fromV <> " to " <> verString toV diff --git a/src/Haskoin/Wallet/Migration/SemVersion.hs b/src/Haskoin/Wallet/Migration/SemVersion.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Migration/SemVersion.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Wallet.Migration.SemVersion where + +import Data.List.Split +import Data.String (IsString) +import Numeric.Natural + +-- | Version of Haskoin Wallet package. +currentVersionStr :: (IsString a) => a +#ifdef CURRENT_PACKAGE_VERSION +currentVersionStr = CURRENT_PACKAGE_VERSION +#else +currentVersionStr = error "No version string" +#endif + +data SemVersion + = VerMajor !Natural + | VerMinor !Natural !Natural + | VerPatch !Natural Natural Natural + deriving (Show) + +-- 0 == 0.9 == 0.9.0 +instance Eq SemVersion where + (VerMajor j1) == (VerMajor j2) = j1 == j2 + (VerMajor j1) == (VerMinor j2 _) = j1 == j2 + (VerMajor j1) == (VerPatch j2 _ _) = j1 == j2 + (VerMinor j1 m1) == (VerMinor j2 m2) = j1 == j2 && m1 == m2 + (VerMinor j1 m1) == (VerPatch j2 m2 _) = j1 == j2 && m1 == m2 + (VerPatch j1 m1 p1) == (VerPatch j2 m2 p2) = j1 == j2 && m1 == m2 && p1 == p2 + a == b = b == a + +toMajor :: SemVersion -> SemVersion +toMajor (VerMajor a) = VerMajor a +toMajor (VerMinor a _) = VerMajor a +toMajor (VerPatch a _ _) = VerMajor a + +toMinor :: SemVersion -> SemVersion +toMinor (VerMajor _) = error "VerMajor in toMinor" +toMinor (VerMinor a b) = VerMinor a b +toMinor (VerPatch a b _) = VerMinor a b + +parseSemVersion :: String -> SemVersion +parseSemVersion str = + case read <$> splitOn "." str of + [a] -> VerMajor a + [a, b] -> VerMinor a b + [a, b, c] -> VerPatch a b c + _ -> error $ "Bad version: " <> str + +verString :: SemVersion -> String +verString (VerMajor a) = show a +verString (VerMinor a b) = show a <> "." <> show b +verString (VerPatch a b c) = show a <> "." <> show b <> "." <> show c + +currentVersion :: SemVersion +currentVersion = + case parseSemVersion currentVersionStr of + res@(VerPatch {}) -> res + _ -> error $ "Bad version: " <> currentVersionStr diff --git a/src/Haskoin/Wallet/Migration/V0_9_0.hs b/src/Haskoin/Wallet/Migration/V0_9_0.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Migration/V0_9_0.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.Migration.V0_9_0 where + +import Conduit (MonadUnliftIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (MonadTrans (lift)) +import Data.Aeson +import qualified Data.Aeson as Json +import qualified Data.ByteString as BS +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Database.Esqueleto.Legacy as E +import qualified Database.Persist as P +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.Database +import Haskoin.Wallet.TxInfo +import Numeric.Natural (Natural) +import Haskoin.Wallet.Migration.SemVersion + +{- Migration from 0.8 to 0.9 -} + +migrateFrom :: SemVersion +migrateFrom = VerMinor 0 8 + +migrateTo :: SemVersion +migrateTo = VerMinor 0 9 + +data OldTxInfo = OldTxInfo + { oldTxInfoHash :: !TxHash, + oldTxInfoType :: !TxType, + oldTxInfoAmount :: !Integer, + oldTxInfoMyOutputs :: !(Map Address OldMyOutputs), + oldTxInfoOtherOutputs :: !(Map Address Natural), + oldTxInfoNonStdOutputs :: ![Store.StoreOutput], + oldTxInfoMyInputs :: !(Map Address OldMyInputs), + oldTxInfoOtherInputs :: !(Map Address OtherInputs), + oldTxInfoNonStdInputs :: ![Store.StoreInput], + oldTxInfoSize :: !Natural, + oldTxInfoFee :: !Natural, + oldTxInfoFeeByte :: !Natural, + oldTxInfoBlockRef :: !Store.BlockRef, + oldTxInfoConfirmations :: !Natural + } + deriving (Eq, Show) + +data OldMyOutputs = OldMyOutputs + { oldMyOutputsValue :: !Natural, + oldMyOutputsPath :: !SoftPath + } + deriving (Eq, Show) + +instance Json.ToJSON OldMyOutputs where + toJSON (OldMyOutputs i p) = + object + [ "value" .= i, + "path" .= p + ] + +instance Json.FromJSON OldMyOutputs where + parseJSON = + withObject "MyOutputs" $ \o -> do + i <- o .: "value" + p <- o .: "path" + return $ OldMyOutputs i p + +data OldMyInputs = OldMyInputs + { oldMyInputsValue :: !Natural, + oldMyInputsPath :: !SoftPath, + oldMyInputsSigInput :: [SigInput] + } + deriving (Eq, Show) + +instance MarshalJSON Ctx OldMyInputs where + marshalValue ctx (OldMyInputs i p s) = + object $ + [ "value" .= i, + "path" .= p + ] + ++ ["siginput" .= (marshalValue ctx <$> s) | not (null s)] + + unmarshalValue ctx = + withObject "MyInputs" $ \o -> do + i <- o .: "value" + p <- o .: "path" + sM <- o .:? "siginput" + s <- unmarshalValue ctx `mapM` fromMaybe [] sM + return $ OldMyInputs i p s + +instance MarshalJSON (Network, Ctx) OldTxInfo where + marshalValue (net, ctx) tx = + object + [ "txid" .= oldTxInfoHash tx, + "type" .= oldTxInfoType tx, + "amount" .= oldTxInfoAmount tx, + "myoutputs" .= mapAddrText net (oldTxInfoMyOutputs tx), + "otheroutputs" .= mapAddrText net (oldTxInfoOtherOutputs tx), + "nonstdoutputs" .= (marshalValue net <$> oldTxInfoNonStdOutputs tx), + "myinputs" .= marshalMap net ctx (oldTxInfoMyInputs tx), + "otherinputs" .= marshalMap net ctx (oldTxInfoOtherInputs tx), + "nonstdinputs" .= (marshalValue net <$> oldTxInfoNonStdInputs tx), + "size" .= oldTxInfoSize tx, + "fee" .= oldTxInfoFee tx, + "feebyte" .= oldTxInfoFeeByte tx, + "block" .= oldTxInfoBlockRef tx, + "confirmations" .= oldTxInfoConfirmations tx + ] + unmarshalValue (net, ctx) = + Json.withObject "TxInfo" $ \o -> + OldTxInfo + <$> o .: "txid" + <*> o .: "type" + <*> o .: "amount" + <*> (mapTextAddr net <$> o .: "myoutputs") + <*> (mapTextAddr net <$> o .: "otheroutputs") + <*> (mapM (unmarshalValue net) =<< o .: "nonstdoutputs") + <*> (unmarshalMap net ctx =<< o .: "myinputs") + <*> (unmarshalMap net ctx =<< o .: "otherinputs") + <*> (mapM (unmarshalValue net) =<< o .: "nonstdinputs") + <*> o .: "size" + <*> o .: "fee" + <*> o .: "feebyte" + <*> o .: "block" + <*> o .: "confirmations" + +migrateMyOutputs :: OldMyOutputs -> MyOutputs +migrateMyOutputs OldMyOutputs {..} = + MyOutputs + { myOutputsValue = oldMyOutputsValue, + myOutputsPath = oldMyOutputsPath, + myOutputsLabel = "" + } + +migrateMyInputs :: OldMyInputs -> MyInputs +migrateMyInputs OldMyInputs {..} = + MyInputs + { myInputsValue = oldMyInputsValue, + myInputsPath = oldMyInputsPath, + myInputsLabel = "", + myInputsSigInput = oldMyInputsSigInput + } + +migrateTxInfo :: OldTxInfo -> TxInfo +migrateTxInfo OldTxInfo {..} = + TxInfo + { txInfoHash = Just oldTxInfoHash, + txInfoType = oldTxInfoType, + txInfoAmount = oldTxInfoAmount, + txInfoMyOutputs = migrateMyOutputs <$> oldTxInfoMyOutputs, + txInfoOtherOutputs = oldTxInfoOtherOutputs, + txInfoNonStdOutputs = oldTxInfoNonStdOutputs, + txInfoMyInputs = migrateMyInputs <$> oldTxInfoMyInputs, + txInfoOtherInputs = oldTxInfoOtherInputs, + txInfoNonStdInputs = oldTxInfoNonStdInputs, + txInfoSize = oldTxInfoSize, + txInfoFee = oldTxInfoFee, + txInfoFeeByte = oldTxInfoFeeByte, + txInfoBlockRef = oldTxInfoBlockRef, + txInfoConfirmations = oldTxInfoConfirmations, + txInfoPending = Nothing + } + +migrateDB :: (MonadUnliftIO m) => Ctx -> ExceptT String (DB m) () +migrateDB ctx = do + accs <- lift . select $ from return + forM_ accs $ \(Entity _ acc) -> do + let net = accountNetwork acc + res <- lift . select . from $ \t -> do + where_ $ + t ^. DBTxInfoAccountWallet ==. val (dBAccountWallet acc) + &&. t ^. DBTxInfoAccountDerivation ==. val (dBAccountDerivation acc) + return $ t ^. DBTxInfoId + forM_ res $ \(Value tKey) -> do + oldDBTx <- liftMaybe "OldTxInfo" =<< lift (P.get tKey) + oldTxInfo <- + liftMaybe "OldTxInfo" $ + unmarshalJSON (net, ctx) $ + BS.fromStrict $ + dBTxInfoBlob oldDBTx + let newTxInfo = migrateTxInfo oldTxInfo + newBlob = BS.toStrict $ marshalJSON (net, ctx) newTxInfo + lift $ P.update tKey [DBTxInfoBlob P.=. newBlob] + -- This will create the missing version table + lift $ do + globalMigration + setVersion migrateTo diff --git a/src/Haskoin/Wallet/Parser.hs b/src/Haskoin/Wallet/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Parser.hs @@ -0,0 +1,1083 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Haskoin.Wallet.Parser where + +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin +import Haskoin.Wallet.Amounts (AmountUnit (..), readNatural) +import Haskoin.Wallet.Util (Page (Page)) +import Numeric.Natural (Natural) +import Options.Applicative +import Options.Applicative.Help.Pretty +import Text.RawString.QQ (r) + +{- Command Parsers -} + +data Command + = CommandMnemonic + { commandEntropy :: !Natural, + commandUseDice :: !Bool, + commandSplitIn :: !Natural + } + | CommandCreateAcc + { commandName :: !Text, + commandNetwork :: !Network, + commandDerivationMaybe :: !(Maybe Natural), + commandSplitIn :: !Natural + } + | CommandTestAcc + { commandMaybeAcc :: !(Maybe Text), + commandSplitIn :: !Natural + } + | CommandImportAcc + { commandFilePath :: !FilePath + } + | CommandExportAcc + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandRenameAcc + { commandOldName :: !Text, + commandNewName :: !Text + } + | CommandAccounts + { commandMaybeAcc :: !(Maybe Text) + } + | CommandDeleteAcc + { commandName :: !Text, + commandNetwork :: !Network, + commandDerivation :: !HardPath + } + | CommandReceive + { commandMaybeAcc :: !(Maybe Text), + commandMaybeLabel :: !(Maybe Text) + } + | CommandAddrs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandLabel + { commandMaybeAcc :: !(Maybe Text), + commandAddrIndex :: !Natural, + commandLabel :: !Text + } + | CommandTxs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandPrepareTx + { commandRecipients :: ![(Text, Text)], + commandMaybeAcc :: !(Maybe Text), + commandFeeByte :: !Natural, + commandDust :: !Natural, + commandRcptPay :: !Bool, + commandMinConf :: !Natural, + commandOutputFileMaybe :: !(Maybe FilePath) + } + | CommandPendingTxs + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandReviewTx + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandImportTx + { commandMaybeAcc :: !(Maybe Text), + commandFilePath :: !FilePath + } + | CommandExportTx + { commandNoSigHash :: !TxHash, + commandFilePath :: !FilePath + } + | CommandDeleteTx + {commandNoSigHash :: !TxHash} + | CommandSignTx + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHashMaybe :: !(Maybe TxHash), + commandInputFileMaybe :: !(Maybe FilePath), + commandOutputFileMaybe :: !(Maybe FilePath), + commandSplitIn :: !Natural + } + | CommandCoins + { commandMaybeAcc :: !(Maybe Text), + commandPage :: !Page + } + | CommandSendTx + {commandNoSigHash :: !TxHash} + | CommandSyncAcc + { commandMaybeAcc :: !(Maybe Text), + commandFull :: !Bool + } + | CommandDiscoverAcc + { commandMaybeAcc :: !(Maybe Text) + } + | CommandBackup + {commandFilePath :: !FilePath} + | CommandRestore + {commandFilePath :: !FilePath} + | CommandVersion + | CommandPrepareSweep + { commandMaybeAcc :: !(Maybe Text), + commandSecKeyPath :: !FilePath, + commandSweepTo :: ![Text], + commandOutputFileMaybe :: !(Maybe FilePath), + commandFeeByte :: !Natural, + commandDust :: !Natural + } + | CommandSignSweep + { commandMaybeAcc :: !(Maybe Text), + commandNoSigHashMaybe :: !(Maybe TxHash), + commandInputFileMaybe :: !(Maybe FilePath), + commandOutputFileMaybe :: !(Maybe FilePath), + commandSecKeyPath :: !FilePath + } + | CommandRollDice + { commandCount :: !Natural + } + deriving (Eq, Show) + +parserMain :: IO (Command, AmountUnit, Bool) +parserMain = + customExecParser + (prefs $ showHelpOnEmpty <> helpIndent 25) + programParser + +programParser :: ParserInfo (Command, AmountUnit, Bool) +programParser = do + let cmd = (,,) <$> (commandParser <**> helper) <*> unitOption <*> jsonOption + info cmd $ + fullDesc + <> progDesc + [r| +hw is a BIP-44 command-line wallet for bitcoin and bitcoin-cash. It allows +sensitive commands (!) to be run on a separate offline computer. For more +information on a command, type "hw COMMAND --help". +|] + +jsonOption :: Parser Bool +jsonOption = + switch $ + short 'j' + <> long "json" + <> help + [r| +Display the result as JSON. Specify this option at the end of your command. +|] + +unitOption :: Parser AmountUnit +unitOption = satoshiOption <|> bitOption + +satoshiOption :: Parser AmountUnit +satoshiOption = + flag UnitBitcoin UnitSatoshi $ + short 's' + <> long "satoshi" + <> help + [r| +Use satoshis for parsing and displaying amounts (default: bitcoin). Specify this +option at the end of your command. +|] + +bitOption :: Parser AmountUnit +bitOption = + flag UnitBitcoin UnitBit $ + short 'b' + <> long "bit" + <> help + [r| +Use bits for parsing and displaying amounts (default: bitcoin). Specify this +option at the end of your command. +|] + +commandParser :: Parser Command +commandParser = + asum + [ hsubparser $ + mconcat + [ commandGroup "Mnemonic and account management", + command "mnemonic" mnemonicParser, + command "createacc" createAccParser, + command "testacc" testAccParser, + command "renameacc" renameAccParser, + command "accounts" accountsParser, + command "syncacc" syncAccParser, + command "deleteacc" deleteAccParser, + metavar "COMMAND", + style (const "COMMAND --help") + ], + hsubparser $ + mconcat + [ commandGroup "Address management", + command "receive" receiveParser, + command "addrs" addrsParser, + command "label" labelParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Transaction management", + command "txs" txsParser, + command "preparetx" prepareTxParser, + command "pendingtxs" pendingTxsParser, + command "signtx" signTxParser, + command "sendtx" sendTxParser, + command "deletetx" deleteTxParser, + command "coins" coinsParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Import/export commands", + command "exportacc" exportAccParser, + command "importacc" importAccParser, + command "reviewtx" reviewTxParser, + command "exporttx" exportTxParser, + command "importtx" importTxParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Backup/restore commands", + command "backup" backupParser, + command "restore" restoreParser, + command "discoveracc" discoverAccParser, + hidden + ], + hsubparser $ + mconcat + [ commandGroup "Utilities", + command "version" versionParser, + command "preparesweep" prepareSweepParser, + command "signsweep" signSweepParser, + command "rolldice" rollDiceParser, + hidden + ] + ] + +offline :: Doc -> Maybe Doc +offline s = Just $ annotate (color Red) "! " <> s + +{- Mnemonic Parser -} + +mnemonicParser :: ParserInfo Command +mnemonicParser = do + let cmd = + CommandMnemonic + <$> entropyOption + <*> diceOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Generate a mnemonic") + <> footer + [r| +Generate a mnemonic using the systems entropy pool. By default it should be +/dev/random on linux machines. If you use the --dice option, the additional dice +entropy will be mixed with the system entropy. You should ideally run this +command on an offline (air-gapped) computer. The mnemonic will NOT be stored on +disk. It will only be printed to the screen and you should write it down and +keep it in a secure location. Make multiple copies of your mnemonic. Do not +store your mnemonic on a digital medium. If you lose your mnemonic, you lose +your funds. If you choose to use the --split option, the mnemonic will be split +into different pieces such that ALL the pieces will be required for signing. +|] + +entropyOption :: Parser Natural +entropyOption = + option (maybeReader f) $ + short 'e' + <> long "entropy" + <> metavar "BYTES" + <> value 16 + <> showDefault + <> completeWith valid + <> help + [r| +Amount of entropy to use in bytes. Valid values are 16, 20, 24, 28 or 32. +|] + where + valid = ["16", "20", "24", "28", "32"] + f s + | s `elem` valid = fromIntegral <$> readNatural (cs s) + | otherwise = Nothing + +diceOption :: Parser Bool +diceOption = + switch $ + short 'd' + <> long "dice" + <> help + [r| +Provide additional entropy using 6-sided dice. The entropy will be mixed with +the system entropy. +|] + +splitInOption :: Parser Natural +splitInOption = + option (eitherReader $ f . cs) $ + short 's' + <> long "split" + <> metavar "INT" + <> value 1 + <> help + [r| +The mnemonic is split in different pieces and reconstructed using bitwise xor. +All the pieces are required for signing. The ordering of the pieces is not +important. +|] + where + f s = + case readNatural s of + Just n -> + if n >= 2 && n <= 12 + then Right n + else Left "The --split value has to be between 2 and 12" + Nothing -> Left "Could not parse the --split option" + +{- CreateAcc Parser -} + +createAccParser :: ParserInfo Command +createAccParser = do + let cmd = + CommandCreateAcc + <$> textArg "Name of the new account" + <*> networkOption + <*> optional derivationOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Create a new account") + <> footer + [r| +An account corresponds to the BIP-32 extended key derivation +m/44'/coin'/account'. For example, the bitcoin account 0 would be m/44'/0'/0'. +An account is tied to a private key and thus to a mnemonic. The derived account +m/44'/0'/0' would be different given two different mnemonics. To help manage +your accounts in hw, they are identified by a name. The command `createacc` will +ask for a mnemonic and save the derived public key M/44'/coin'/account' on disk. +The private keys are never stored anywhere while using hw. If you are using an +offline computer, you can then export your account and import it on an online +computer. +|] + +networkOption :: Parser Network +networkOption = + option (eitherReader (f . netByName)) $ + short 'n' + <> long "network" + <> metavar "TEXT" + <> value btc + <> showDefaultWith (.name) + <> completeWith ((.name) <$> allNets) + <> help ("Specify one of the following networks to use: " <> nets) + where + nets = intercalate ", " ((.name) <$> allNets) + f :: Maybe Network -> Either String Network + f Nothing = + Left $ "Invalid network name. Select one of the following: " <> nets + f (Just res) = Right res + +derivationOption :: Parser Natural +derivationOption = + option (maybeReader $ readNatural . cs) $ + short 'd' + <> long "derivation" + <> metavar "INT" + <> help + [r| +Specify a different account derivation to use (the last part of +m/44'/coin'/account'). By default, account derivations are chosen sequentially +starting from 0. +|] + +{- DeleteAcc Parser -} + +deleteAccParser :: ParserInfo Command +deleteAccParser = do + let cmd = + CommandDeleteAcc + <$> textArg "Name of the account to delete" + <*> networkArg + <*> fullDerivationOption + info cmd $ + progDesc ("Delete an account") + <> footer + [r| +Delete an account from the wallet. You must specify the name, the network and +the full derivation path as confirmation to delete an account. +|] + +fullDerivationOption :: Parser HardPath +fullDerivationOption = + argument (maybeReader parseHard) $ + metavar "DERIVPATH" + <> help + [r| +Specify the full derivation path of the account to delete. For example: +/44'/0'/3'. +|] + +networkArg :: Parser Network +networkArg = + argument (eitherReader (f . netByName)) $ + metavar "NETWORK" + <> completeWith ((.name) <$> allNets) + <> help ("Specify the network of the account to delete: " <> nets) + where + nets = intercalate ", " ((.name) <$> allNets) + f :: Maybe Network -> Either String Network + f Nothing = + Left $ "Invalid network name. Select one of the following: " <> nets + f (Just res) = Right res + +{- TestAcc Parser -} + +testAccParser :: ParserInfo Command +testAccParser = do + let cmd = + CommandTestAcc + <$> accountOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Check the validity of your mnemonic/passphrase") + <> footer + [r| +`testacc` will prompt for your mnemonic/passphrase and check that the derived +public key M/44'/coin'/account' matches with the account stored on disk. +|] + +accountOption :: Parser (Maybe Text) +accountOption = + optional . strOption $ + short 'a' + <> long "account" + <> metavar "TEXT" + <> completer (mkCompleter accountCompleter) + <> help + [r| +Specify the account name if the wallet has more than one account. +|] + +{- ImportAcc Parser -} + +importAccParser :: ParserInfo Command +importAccParser = do + let cmd = + CommandImportAcc + <$> fileArgument "Path to the account file" + info cmd $ + progDesc "Import an account file" + <> footer importExportAccFooter + +importExportAccFooter :: String +importExportAccFooter = + [r| +When working in an online/offline environment, you can `importacc` a public key +file (on an online computer) that was exported with `exportacc` (on an offline +computer). This will allow the online computer to monitor transactions without +requiring access to the private keys. The file contains the public key +derivation M/44'/coin'/account' along with the account name, the network and a +wallet identifier. The wallet identifier is a fingerprint of the first public +account derivation M/44'/coin'/0'. +|] + +{- ExportAcc Parser -} + +exportAccParser :: ParserInfo Command +exportAccParser = do + let cmd = + CommandExportAcc + <$> accountOption + <*> fileArgument "File where the account data will be saved" + info cmd $ + progDesc "Export account data to a file" + <> footer importExportAccFooter + +{- RenameAcc Parser -} + +renameAccParser :: ParserInfo Command +renameAccParser = do + let cmd = + CommandRenameAcc + <$> accountArg "Old account name" + <*> textArg "New account name" + info cmd $ progDesc "Rename an account" + +accountArg :: String -> Parser Text +accountArg desc = + argument str $ + metavar "TEXT" + <> completer (mkCompleter accountCompleter) + <> help desc + +accountCompleter :: String -> IO [String] +accountCompleter _ = return [] + +{- TODO: Fix this +accountCompleter :: String -> IO [String] +accountCompleter pref = do + names <- runDB getAccountNames + return $ sort $ nub $ filter (pref `isPrefixOf`) (cs <$> names) +-} + +{- Accounts Parser -} + +accountsParser :: ParserInfo Command +accountsParser = do + let cmd = CommandAccounts <$> accountOption + info cmd $ progDesc "Display account information" + +{- Receive Parser -} + +receiveParser :: ParserInfo Command +receiveParser = do + let cmd = + CommandReceive <$> accountOption <*> labelOption + info cmd $ + progDesc "Get a new address for receiving a payment" + <> footer + [r| +There are two types of addresses in a BIP-44 wallet: internal and external addresses. +Internal addresses are not exposed to the user and are managed internally by the +wallet (mostly for producing change outputs in transactions). The `receive` command +produces external addresses that are meant for receiving payments. Internal addresses +are derived under the BIP-32 path M/44'/coin'/account'/1/address. External addresses +use the path M/44'/coin'/account'/0/address. +|] + +labelOption :: Parser (Maybe Text) +labelOption = + optional . strOption $ + short 'l' + <> long "label" + <> metavar "TEXT" + <> help "Specify a label for the address" + +{- Addrs Parser -} + +addrsParser :: ParserInfo Command +addrsParser = do + let cmd = + CommandAddrs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "List the receiving addresses of an account" + +offsetOption :: Parser Natural +offsetOption = + option (maybeReader $ readNatural . cs) $ + short 'o' + <> long "offset" + <> metavar "INT" + <> value 0 + <> showDefault + <> help "Offset the result set" + +limitOption :: Parser Natural +limitOption = + option (maybeReader $ readNatural . cs) $ + short 'l' + <> long "limit" + <> metavar "INT" + <> value 5 + <> showDefault + <> help + [r| +Limit the result set. If the result set is very large, you can specify the +--limit and --offset options to view the required data. For example, to skip the +first 20 values and then display the following 10, use --limit=10 and +--offset=20. +|] + +{- Label Parser-} + +labelParser :: ParserInfo Command +labelParser = do + let cmd = + CommandLabel + <$> accountOption + <*> addrIndexArg + <*> textArg "The new label for the address" + info cmd $ progDesc "Set the label of an address" + +addrIndexArg :: Parser Natural +addrIndexArg = + argument (maybeReader $ readNatural . cs) $ + metavar "INT" + <> help + [r| +The index of the external address to update. The first address has an index of +0. +|] + +{- Txs Parser -} + +txsParser :: ParserInfo Command +txsParser = do + let cmd = + CommandTxs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ progDesc "Display the transactions of an account" + +{- PrepareTx Parser -} + +prepareTxParser :: ParserInfo Command +prepareTxParser = do + let cmd = + CommandPrepareTx + <$> some recipientArg + <*> accountOption + <*> feeOption + <*> dustOption + <*> rcptPayOption + <*> minConfOption + <*> outputFileMaybeOption + info cmd $ + progDesc "Prepare an unsigned transaction for making a payment" + <> footer + [r| +In hw, sending a transaction happens in separate steps. First, an unsigned +transaction is prepared using `preparetx`. No mnemonic or private keys are +required for this step and `preparetx` can be run on an online computer. The new +transaction will be stored in the local wallet database as a "pending" +transaction but it can also be exported as a file using the --output option. The +pending transactions can be inspected either with `reviewtx` or `pendingtxs`. +The new transaction is not signed. The next step will be to sign it. Any coins +spent by it will be locked to prevent spending them twice. If you change your +mind about sending this transaction, you can call `deletetx` to remove it and +free up the locked coins. All the pending transactions are referenced by their +noSigHash (a hash of the transaction without its signatures). +|] + +recipientArg :: Parser (Text, Text) +recipientArg = (,) <$> addressArg <*> amountArg + +addressArg :: Parser Text +addressArg = + strArgument $ + metavar "ADDRESS" + <> help + [r| +Recipient address. You can provide multiple "ADDRESS AMOUNT" pairs. +|] + +amountArg :: Parser Text +amountArg = + strArgument $ + metavar "AMOUNT" + <> help + [r| +Recipient amount. By default, amounts are parsed as bitcoins. You can also use the +--satoshi or --bit option to specify amounts in satoshis or bits. For example, +"0.00001" bitcoins is equivalent to "10.00" bits or "1000" satoshi. Bitcoins can +have up to 8 decimal places, bits up to 2 and satoshi are whole numbers. +|] + +feeOption :: Parser Natural +feeOption = + option (maybeReader $ readNatural . cs) $ + short 'f' + <> long "fee" + <> metavar "INT" + <> value 200 + <> showDefault + <> help "Fee to pay in satoshi/bytes" + +dustOption :: Parser Natural +dustOption = + option (maybeReader $ readNatural . cs) $ + short 'd' + <> long "dust" + <> metavar "INT" + <> value 5430 + <> showDefault + <> help "Amount (in satoshi) below which an output is considered dust" + +rcptPayOption :: Parser Bool +rcptPayOption = + switch $ + short 'r' + <> long "recipientpay" + <> showDefault + <> help "The transaction fee will be deducted from the recipient amounts" + +minConfOption :: Parser Natural +minConfOption = + option (maybeReader $ readNatural . cs) $ + short 'c' + <> long "minconf" + <> metavar "INT" + <> value 1 + <> showDefault + <> help "Minimum number of confirmations required to spend a coin" + +outputFileMaybeOption :: Parser (Maybe FilePath) +outputFileMaybeOption = + optional . strOption $ + short 'o' + <> long "output" + <> metavar "FILENAME" + <> action "file" + <> help "Write the result to this file" + +{- PendingTxs Parser -} + +pendingTxsParser :: ParserInfo Command +pendingTxsParser = do + let cmd = + CommandPendingTxs + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "Display the pending transactions of an account" + <> footer + [r| +Pending transactions have been created with the `preparetx` command. They are +either unsigned and waiting to be signed, or signed and waiting to be sent to +the network. +|] + +{- ReviewTx Parser -} + +reviewTxParser :: ParserInfo Command +reviewTxParser = do + let cmd = + CommandReviewTx + <$> accountOption + <*> fileArgument "Path to the transaction file to review" + info cmd $ + progDesc "Review a transaction file" + <> footer + [r| +Review a pending transaction file that has been created with the --output option +of the `preparetx` command or the `exporttx` command. You can review a +transaction file this way before signing it on an offline computer for example. +|] + +{- ExportTx Parser -} + +exportTxParser :: ParserInfo Command +exportTxParser = do + let cmd = + CommandExportTx + <$> nosigHashArg + <*> fileArgument "File where the transaction data will be saved" + info cmd $ + progDesc "Export pending transaction data to a file" + <> footer importExportTxFooter + +importExportTxFooter :: String +importExportTxFooter = + [r| +A transaction that has been prepared with `preparetx` can be exported to a file +so that it can be signed on an offline computer. The transaction is identified +by its nosigHash (a hash of the transaction without its signatures) as this +identifier doesn't change when the transaction is unsigned or signed. Once +signed, you can `importtx` the transaction back into the computer that +prepared the transaction. +|] + +nosigHashArg :: Parser TxHash +nosigHashArg = + argument (maybeReader $ hexToTxHash . cs) $ + metavar "NOSIGHASH" + <> help "The nosigHash of the transaction" + +{- ImportTx Parser -} + +importTxParser :: ParserInfo Command +importTxParser = do + let cmd = + CommandImportTx + <$> accountOption + <*> fileArgument "Path to the transaction file to import" + info cmd $ + progDesc "Import a pending transaction" + <> footer importExportTxFooter + +{- DeleteTx Parser -} + +deleteTxParser :: ParserInfo Command +deleteTxParser = do + let cmd = CommandDeleteTx <$> nosigHashArg + info cmd $ + progDesc "Delete a pending transaction" + <> footer + [r| +A transaction that has been prepared with `preparetx` will lock the coins that +it has spent to prevent double-spending them. A pending transaction can be +deleted with `deletetx` to permanently remove it from the database. This will +also free any coins that have been locked by it. This will only be possible as +long as the transaction hasn't been signed and sent to the network. +|] + +{- SignTx Parser -} + +signTxParser :: ParserInfo Command +signTxParser = do + let cmd = + CommandSignTx + <$> accountOption + <*> optional nosigHashArg + <*> inputFileMaybeOption + <*> outputFileMaybeOption + <*> splitInOption + info cmd $ + progDescDoc (offline "Sign a transaction") + <> footer + [r| +The next step after preparing a transaction is to sign it. This step can happen +on an offline computer if you export the unsigned transaction to a file. If the +transaction is stored in the wallet, it can be signed by using its nosigHash. +This will sign and replace the transaction in-place. Otherwise, you must specify +the --input file of the unsigned transaction and the --output file where the +signed transaction will be saved. The transaction still hasn't been uploaded to +the network. You may inspect it using either the `reviewtx` or the `pendingtxs` +command. The transaction can then be sent to the network with `sendtx` or +deleted with `deletetx`. +|] + +inputFileMaybeOption :: Parser (Maybe FilePath) +inputFileMaybeOption = + optional . strOption $ + short 'i' + <> long "input" + <> metavar "FILENAME" + <> action "file" + <> help "Read the input from this file" + +{- Coins Parser -} + +coinsParser :: ParserInfo Command +coinsParser = do + let cmd = + CommandCoins + <$> accountOption + <*> (Page <$> limitOption <*> offsetOption) + info cmd $ + progDesc "List the account coins (unspent outputs)" + <> footer + [r| +These are all the coins in the account. Coins can be locked when preparing new +transactions. When sending those transactions to the network, the locked coins +will be spent and removed. Calling `deletetx` will remove a pending transaction +and free up any locked coins. +|] + +{- SendTx Parser -} + +sendTxParser :: ParserInfo Command +sendTxParser = do + let cmd = CommandSendTx <$> nosigHashArg + info cmd $ + progDesc "Send (upload) a signed transaction to the network" + <> footer + [r| +Once a transaction is signed, it can be sent to the network. This step is +irreversible and the transaction will become effective. Make sure everything is +correct with your transaction before sending it. You must `importtx` the +transaction before sending it if you have it in a file. +|] + +{- SyncAcc Parser -} + +syncAccParser :: ParserInfo Command +syncAccParser = do + let cmd = CommandSyncAcc <$> accountOption <*> fullOption + info cmd $ + progDesc "Download account data from the network" + <> footer + [r| +The `syncacc` command will download the latest address balances, transactions +and coins from the network. It will also update the account balances. +|] + +fullOption :: Parser Bool +fullOption = + switch $ + long "full" + <> showDefault + <> help + [r| +Force the syncacc command to re-download all the account data instead of only +the deltas (the data that has changed). This should normally not be required +unless some information is wrong, for example, when a previous syncacc was +called on a partially discovered account (the account was missing some +addresses). +|] + +{- DiscoverAcc Parser -} + +discoverAccParser :: ParserInfo Command +discoverAccParser = do + let cmd = CommandDiscoverAcc <$> accountOption + info cmd $ + progDesc "Scan the blockchain to generate missing addresses" + <> footer + [r| +`discoveracc` is typically called when restoring an account in a new wallet. +Initially, there will be no addresses stored in the account. `discoveracc` will +scan the blockchain and generate all the addresses (both external and internal) +that have received coins at some point. The search is stopped when a gap +(default = 20) of empty addresses is found. A full sync (syncacc --full) is +run automatically at the end of the `discoveracc` command. When restoring an +old wallet, it is important to discover it first before generating addresses +and receiving payments. Otherwise some addresses might be reused. +|] + +{- Backup & Restore Parsers -} + +backupParser :: ParserInfo Command +backupParser = do + let cmd = + CommandBackup + <$> fileArgument "File where the backup will be saved" + info cmd $ + progDesc "Create a wallet backup file" + <> footer + [r| +This command will backup your wallet accounts, your address labels and the +internal free addresses to an external file. This is enough to restore your +entire wallet state with some network help. It will, however, not backup any +pending transactions you might have so you should save those separately. +|] + +restoreParser :: ParserInfo Command +restoreParser = do + let cmd = + CommandRestore + <$> fileArgument "Path to the backup file" + info cmd $ + progDesc "Restore a wallet backup file" + <> footer + [r| +Restore a backup file containing your accounts, address labels and internal +free addresses. This command will connect to the network to download everything +else that is not included in the backup file like your transactions and coins. +Pending transactions are not included in the backup file. +|] + +{- Version Parser -} + +versionParser :: ParserInfo Command +versionParser = do + let cmd = pure CommandVersion + info cmd $ progDesc "Display the version of hw" + +{- PrepareSweep Parser -} + +prepareSweepParser :: ParserInfo Command +prepareSweepParser = do + let cmd = + CommandPrepareSweep + <$> accountOption + <*> prvKeyFileOption + <*> some sweepToOption -- some: optional + <*> outputFileMaybeOption + <*> feeOption + <*> dustOption + info cmd $ + progDesc "Prepare a transaction to sweep funds" + <> footer + [r| +`preparesweep` will prepare a transaction that sweeps the funds of the given +private keys. The private keys are passed in a file and can be in WIF or minikey +format. The typical use case for this command is to migrate an old wallet to a +new mnemonic. You can send the funds to 1 or multiple addresses. You can use the +shorthand format -t ADDR1 -t ADDR2 to specify the --sweepto addresses. +|] + +sweepFromOption :: Parser Text +sweepFromOption = + strOption $ + short 'w' + <> long "sweepfrom" + <> metavar "ADDRESS" + <> help "Addresses to sweep from" + +addressFileOption :: Parser (Maybe FilePath) +addressFileOption = + optional . strOption $ + long "addrfile" + <> metavar "FILENAME" + <> action "file" + <> help "File containing addresses to sweep from" + +sweepToOption :: Parser Text +sweepToOption = + strOption $ + short 't' + <> long "sweepto" + <> metavar "ADDRESS" + <> help "Addresses to sweep to" + +{- SignSweep Parser -} + +signSweepParser :: ParserInfo Command +signSweepParser = do + let cmd = + CommandSignSweep + <$> accountOption + <*> optional nosigHashArg + <*> inputFileMaybeOption + <*> outputFileMaybeOption + <*> prvKeyFileOption + info cmd $ + progDesc "Sign a sweep transaction" + <> footer + [r| +Sign a transaction that was prepared with the `preparesweep` command. As the +coins of this transaction are not from this wallet, the private keys for signing +must be passed in a separate --prvkeys file. The sweep transaction can be +referenced by its nosigHash if it exists in the wallet or you can pass it as a +file --input. +|] + +prvKeyFileOption :: Parser FilePath +prvKeyFileOption = + strOption $ + short 'k' + <> long "prvkeys" + <> metavar "FILENAME" + <> action "file" + <> help "File containing the private keys in WIF or MiniKey format" + +{- RollDice Parser -} + +rollDiceParser :: ParserInfo Command +rollDiceParser = do + let cmd = CommandRollDice <$> diceCountArg + info cmd $ + progDesc "Roll 6-sided dice using the systems internal entropy" + <> footer + [r| +By default, /dev/random is used on linux machines. The mapping from a byte to +dice rolls ensures that all dice rolls have the same probability of occuring. +Bytes 0x00 to 0xfb are used and anything above is dropped. +|] + +diceCountArg :: Parser Natural +diceCountArg = + argument (maybeReader $ readNatural . cs) $ + metavar "INT" + <> help "Number of 6-sided dice to roll" + +{- Argument parser helpers -} + +textArg :: String -> Parser Text +textArg desc = + argument str $ + metavar "TEXT" + <> help desc + +fileArgument :: String -> Parser FilePath +fileArgument desc = + strArgument $ + metavar "FILENAME" + <> action "file" + <> help desc diff --git a/src/Haskoin/Wallet/PrettyPrinter.hs b/src/Haskoin/Wallet/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/PrettyPrinter.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.PrettyPrinter where + +import Control.Monad +import Data.List (intercalate, intersperse) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Format +import Data.Word +import Haskoin +import Haskoin.Wallet.Amounts +import Haskoin.Wallet.Backup +import Haskoin.Wallet.Commands +import Haskoin.Wallet.Database +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import System.Console.ANSI +import System.Exit +import System.IO + +data Printer + = PConcat !Printer !Printer + | PNewline !Printer + | PNest !Natural !Printer + | PText [SGR] !String + | PEmpty + | PNonEmpty + +instance Semigroup Printer where + a <> PEmpty = a + PEmpty <> b = b + a <> b = PConcat a b + +instance Monoid Printer where + mempty = PEmpty + +isEmptyPrinter :: Printer -> Bool +isEmptyPrinter prt = + case prt of + PEmpty -> True + (PText _ s) -> null s + (PNest _ n) -> isEmptyPrinter n + (PNewline n) -> isEmptyPrinter n + _ -> False + +text :: String -> Printer +text = PText [] + +(<+>) :: Printer -> Printer -> Printer +p1 <+> p2 + | isEmptyPrinter p1 = p2 + | isEmptyPrinter p2 = p1 + | otherwise = p1 <> text " " <> p2 + +vcat :: [Printer] -> Printer +vcat = go . filter (not . isEmptyPrinter) + where + go [] = PEmpty + go [x] = x + go (x : xs) = x <> PNewline (go xs) + +hsep :: [Printer] -> Printer +hsep = go . filter (not . isEmptyPrinter) + where + go [] = PEmpty + go [x] = x + go (x : xs) = x <+> go xs + +nest :: Natural -> Printer -> Printer +nest = PNest + +block :: Natural -> String -> String +block n str = + case n `safeSubtract` fromIntegral (length str) of + Just missing -> str <> replicate (fromIntegral missing) ' ' + _ -> str + +rblock :: Natural -> String -> String +rblock n str = + case n `safeSubtract` fromIntegral (length str) of + Just missing -> replicate (fromIntegral missing) ' ' <> str + _ -> str + +renderIO :: Printer -> IO () +renderIO cp = go 0 0 cp >> putStrLn "" + where + go :: Natural -> Natural -> Printer -> IO Natural + go l n p + | isEmptyPrinter p = return l + | otherwise = + case p of + PConcat p1 p2 -> do + l2 <- go l n p1 + go l2 n p2 + PNewline p1 -> do + putStrLn "" + putStr $ replicate (fromIntegral n) ' ' + go n n p1 + PNest i p1 -> do + putStr $ replicate (fromIntegral i) ' ' + go (l + i) (n + i) p1 + PText xs s -> do + printFormat xs s + return $ l + fromIntegral (length s) + PEmpty -> return l + PNonEmpty -> return l + +formatTitle :: String -> Printer +formatTitle = + PText + [ SetConsoleIntensity BoldIntensity, + SetColor Foreground Vivid White + ] + +formatAccount :: String -> Printer +formatAccount = + PText + [ SetConsoleIntensity BoldIntensity, + SetColor Foreground Vivid Cyan + ] + +formatFilePath :: String -> Printer +formatFilePath = + PText + [ SetItalicized True, + SetColor Foreground Vivid White + ] + +formatKey :: String -> Printer +formatKey = PText [SetColor Foreground Dull White] + +formatValue :: String -> Printer +formatValue = PText [SetColor Foreground Vivid White] + +formatLabel :: String -> Printer +formatLabel = + PText + [ SetItalicized True, + SetColor Foreground Vivid White + ] + +formatDeriv :: String -> Printer +formatDeriv = + PText + [ SetItalicized True, + SetColor Foreground Vivid Yellow + ] + +formatMnemonic :: Bool -> String -> Printer +formatMnemonic split = + PText + [ SetConsoleIntensity BoldIntensity, + SetColor Foreground Vivid (if split then Yellow else Cyan) + ] + +formatAddress :: Bool -> String -> Printer +formatAddress False = PText [SetColor Foreground Dull White] +formatAddress True = PText [SetColor Foreground Vivid White] + +formatTxHash :: String -> Printer +formatTxHash = PText [SetColor Foreground Dull White] + +formatNoSigTxHash :: String -> Printer +formatNoSigTxHash = PText [SetColor Foreground Vivid Magenta] + +formatBlockHash :: String -> Printer +formatBlockHash = PText [SetColor Foreground Dull White] + +formatPosAmount :: String -> Printer +formatPosAmount = PText [SetColor Foreground Vivid Green] + +formatNegAmount :: String -> Printer +formatNegAmount = PText [SetColor Foreground Vivid Red] + +formatZeroAmount :: String -> Printer +formatZeroAmount = PText [SetColor Foreground Vivid White] + +formatDice :: String -> Printer +formatDice = + PText + [ SetConsoleIntensity BoldIntensity, + SetColor Foreground Vivid Yellow + ] + +formatTrue :: String -> Printer +formatTrue = PText [SetColor Foreground Vivid Green] + +formatFalse :: String -> Printer +formatFalse = PText [SetColor Foreground Vivid Red] + +formatError :: String -> Printer +formatError = PText [SetColor Foreground Vivid Red] + +printFormat :: [SGR] -> String -> IO () +printFormat sgr str = do + support <- hSupportsANSI stdout + when support $ setSGR sgr + putStr str + when support $ setSGR [] + +{- Pretty Response -} + +mnemonicPrinter :: Bool -> [Text] -> Printer +mnemonicPrinter split ws = + vcat $ + fmap (mconcat . fmap formatWord) $ + chunksOf 4 $ + zip ([1 ..] :: [Natural]) ws + where + formatWord (i, w) = + mconcat + [ formatKey $ block 4 $ show i <> ".", + formatMnemonic split $ block 10 $ cs w + ] + +partsPrinter :: [[Text]] -> [Printer] +partsPrinter [] = mempty +partsPrinter xs = + concatMap formatPart $ zip ([1 ..] :: [Natural]) xs + where + formatPart (i, ws) = + [ formatTitle $ "Private Mnemonic Part #" <> show i, + nest 2 $ mnemonicPrinter True ws + ] + +keyPrinter :: Natural -> Text -> Printer +keyPrinter n txt = formatKey (block n (cs txt)) <> text ": " + +amountPrinter :: AmountUnit -> Word64 -> Printer +amountPrinter unit = integerAmountPrinter unit . fromIntegral + +integerAmountPrinter :: AmountUnit -> Integer -> Printer +integerAmountPrinter unit amnt + | amnt == 0 = integerAmountPrinterWith formatZeroAmount unit amnt + | amnt > 0 = integerAmountPrinterWith formatPosAmount unit amnt + | otherwise = integerAmountPrinterWith formatNegAmount unit amnt + +integerAmountPrinterWith :: + (String -> Printer) -> AmountUnit -> Integer -> Printer +integerAmountPrinterWith f unit amnt = + f (cs $ showIntegerAmount unit amnt) <+> unitPrinter unit amnt + +unitPrinter :: AmountUnit -> Integer -> Printer +unitPrinter unit = text . cs . showUnit unit + +naturalPrinter :: Natural -> Printer +naturalPrinter nat + | nat == 0 = formatZeroAmount $ show nat + | otherwise = formatPosAmount $ show nat + +accountPrinter :: AmountUnit -> DBAccount -> Printer +accountPrinter unit acc = + vcat + [ keyPrinter 8 "Account" <> formatAccount (cs $ dBAccountName acc), + mconcat [keyPrinter 8 "Wallet", formatValue $ cs fp], + mconcat [keyPrinter 8 "Deriv", formatDeriv deriv], + mconcat [keyPrinter 8 "Network", formatValue net], + mconcat + [keyPrinter 8 "External", formatValue $ show $ dBAccountExternal acc], + mconcat + [keyPrinter 8 "Internal", formatValue $ show $ dBAccountInternal acc], + mconcat [keyPrinter 8 "Created", formatValue created], + formatKey "Balances:", + nest 2 $ + mconcat + [ keyPrinter 11 "Confirmed", + amountPrinter unit $ dBAccountBalanceConfirmed acc + ], + nest 2 $ + mconcat + [ keyPrinter 11 "Unconfirmed", + amountPrinter unit $ dBAccountBalanceUnconfirmed acc + ], + nest 2 $ + mconcat + [ keyPrinter 11 "Coins", + naturalPrinter $ fromIntegral $ dBAccountBalanceCoins acc + ] + ] + where + DBWalletKey fp = dBAccountWallet acc + deriv = cs $ dBAccountDerivation acc + net = (accountNetwork acc).name + utctime = dBAccountCreated acc + created = formatTime defaultTimeLocale "%d %b %Y" utctime + +addressPrinter :: AmountUnit -> Natural -> DBAddress -> Printer +addressPrinter unit pad addr = + vcat + [ mconcat + [ keyPrinter pad $ cs $ show (dBAddressIndex addr), + formatAddress True $ cs $ dBAddressAddress addr + ], + if Text.null $ dBAddressLabel addr + then PEmpty + else + nest 2 $ + mconcat + [ keyPrinter 8 "Label", + formatLabel $ cs $ dBAddressLabel addr + ], + nest 2 $ + mconcat + [ keyPrinter 8 "Txs", + naturalPrinter $ fromIntegral $ dBAddressBalanceTxs addr + ], + nest 2 $ + mconcat + [ keyPrinter 8 "Received", + amountPrinter unit $ dBAddressBalanceReceived addr + ] + ] + +txInfoPrinter :: + Network -> + AmountUnit -> + TxInfo -> + Printer +txInfoPrinter net unit TxInfo {..} = + vcat + [ formatTitle (block 9 title) <> text ": " <> total, + txid, + pending, + fee, + internal, + debit, + credit + ] + where + title = + case txInfoType of + TxDebit -> "Debit" + TxInternal -> "Internal" + TxCredit -> "Credit" + total = integerAmountPrinter unit txInfoAmount + fee = keyPrinter 9 "Fee" <> feePrinter unit txInfoFee txInfoFeeByte + txid = + case txInfoHash of + Just tid -> + keyPrinter 9 "TxHash" <> formatTxHash (cs $ txHashToHex tid) + _ -> mempty + pending = + case txInfoPending of + Just (TxInfoPending nosigH signed online) -> + vcat + [ keyPrinter 9 "NoSigHash" + <> formatNoSigTxHash (cs $ txHashToHex nosigH), + keyPrinter 9 "Signed" + <> text "This pending transaction is" + <+> if signed + then formatTrue "signed" + else formatFalse "not signed", + if online + then + keyPrinter 9 "Online" + <> text "This transaction is" + <+> formatTrue "online" + else mempty + ] + _ -> keyPrinter 9 "Confs" <> formatValue (show txInfoConfirmations) + internal + | txInfoType /= TxInternal = mempty + | otherwise = + vcat $ + [formatKey "From addresses:"] + <> ( nest 2 . addrPrinter True + <$> Map.assocs (Map.map g txInfoMyInputs) + ) + <> [formatKey "To addresses:"] + <> ( nest 2 + . addrPrinter True + <$> Map.assocs (Map.map f txInfoMyOutputs) + ) + debit + | txInfoType /= TxDebit = mempty + | otherwise = + vcat $ + [formatKey "Sending to addresses:"] + <> ( nest 2 . addrPrinter False + <$> Map.assocs + ( Map.map + (,Nothing,"") + txInfoOtherOutputs + ) + ) + credit + | txInfoType /= TxCredit = mempty + | otherwise = + vcat $ + [formatKey "My credited addresses:"] + <> ( nest 2 . addrPrinter True + <$> Map.assocs (Map.map f txInfoMyOutputs) + ) + f (MyOutputs v p l) = (v, Just p, cs l) + g (MyInputs v p l _) = (v, Just p, cs l) + addrPrinter isMine (a, (v, pathM, label)) = + vcat + [ formatAddress isMine (parseAddr net a) + <> text ":" + <+> if isMine + then integerAmountPrinterWith formatPosAmount unit (fromIntegral v) + else integerAmountPrinterWith formatZeroAmount unit (fromIntegral v), + case pathM of + Just p -> + nest 2 $ + formatKey "Path:" <+> formatDeriv (pathToStr p) + _ -> mempty, + if null label + then mempty + else nest 2 $ formatKey "Label:" <+> formatLabel label + ] + +parseAddr :: Network -> Address -> String +parseAddr net = cs . fromMaybe "Invalid Address" . addrToText net + +feePrinter :: AmountUnit -> Natural -> Natural -> Printer +feePrinter unit fee feeBytes = + integerAmountPrinterWith formatZeroAmount unit (fromIntegral fee) + <+> text "(" + <> formatValue (show feeBytes) + <+> text "sat/bytes" + <> text ")" + +coinPrinter :: Network -> AmountUnit -> JsonCoin -> Printer +coinPrinter net unit JsonCoin {..} = + vcat + [ formatKey (block 7 "TxHash") + <> text ":" + <+> formatTxHash (cs $ txHashToHex jsonCoinOutpoint.hash), + formatKey (block 7 "Index") + <> text ":" + <+> formatValue (show jsonCoinOutpoint.index), + formatKey (block 7 "Value") + <> text ":" + <+> amountPrinter unit jsonCoinValue, + formatKey (block 7 "Address") + <> text ":" + <+> formatAddress True (parseAddr net jsonCoinAddress), + formatKey (block 7 "Confs") + <> text ":" + <+> formatValue (show jsonCoinConfirmations), + formatKey (block 7 "Status") + <> text ":" + <+> if jsonCoinLocked + then formatFalse "Locked" + else formatTrue "Free" + ] + +prettyPrinter :: AmountUnit -> Response -> IO () +prettyPrinter unit = + \case + ResponseError err -> do + renderIO . mconcat $ [formatError "Error: ", text $ cs err] + exitFailure + ResponseMnemonic orig mnem parts -> + renderIO . vcat $ + [ formatTitle "System Entropy Source", + nest 2 $ formatFilePath $ cs orig, + formatTitle "Private Mnemonic", + nest 2 $ mnemonicPrinter False mnem + ] + <> partsPrinter parts + ResponseAccount acc -> renderIO $ accountPrinter unit acc + ResponseAccounts [] -> renderIO $ text "There are no accounts to display" + ResponseAccounts accs -> + renderIO . vcat $ intersperse (text " ") $ accountPrinter unit <$> accs + ResponseAccResult _ res txt -> do + let p = + if res + then formatTrue "Success" + else formatFalse "Failure" + renderIO . vcat $ [formatKey "Result:" <+> p, text $ cs txt] + ResponseFile f -> renderIO $ formatKey "File:" <+> formatFilePath f + ResponseAddress _ addr -> do + let l = length $ show $ dBAddressIndex addr + renderIO $ addressPrinter unit (fromIntegral l) addr + ResponseAddresses _ [] -> + renderIO $ text "There are no addresses to display" + ResponseAddresses _ addrs -> do + let l = length $ show $ maximum $ dBAddressIndex <$> addrs + renderIO $ vcat $ addressPrinter unit (fromIntegral l) <$> addrs + ResponseTxs _ [] -> + renderIO $ text "There are no transactions to display" + ResponseTxs acc txs -> do + let net = accountNetwork acc + renderIO $ vcat $ intersperse (text " ") $ txInfoPrinter net unit <$> txs + ResponseTx acc txInfo -> do + let net = accountNetwork acc + renderIO $ txInfoPrinter net unit txInfo + ResponseDeleteTx h c a -> + renderIO $ + vcat + [ formatKey "Deleted:" <+> formatNoSigTxHash (cs $ txHashToHex h), + nest 2 $ formatKey "Freed coins:" <+> formatValue (show c), + nest 2 $ + formatKey "Freed internal addresses:" <+> formatValue (show a) + ] + ResponseCoins _ [] -> + renderIO $ text "There are no coins to display" + ResponseCoins acc coins -> do + let net = accountNetwork acc + renderIO $ vcat $ intersperse (text " ") $ coinPrinter net unit <$> coins + ResponseSync xs -> do + let f (SyncRes acc bh h t c) = + [ accountPrinter unit acc, + formatTitle "Sync Results:", + nest 2 $ + keyPrinter 12 "Best Block" + <> formatBlockHash (cs $ blockHashToHex bh), + nest 2 $ keyPrinter 12 "Best Height" <> formatValue (show h), + nest 2 $ keyPrinter 12 "Tx updates" <> formatValue (show t), + nest 2 $ keyPrinter 12 "Coin updates" <> formatValue (show c) + ] + renderIO $ vcat $ intercalate [text " "] (f <$> xs) + ResponseRestore as -> do + let f (acc, t, c) = + [ accountPrinter unit acc, + formatTitle "Restore Results:", + nest 2 $ keyPrinter 12 "Tx updates" <> formatValue (show t), + nest 2 $ keyPrinter 12 "Coin updates" <> formatValue (show c) + ] + renderIO $ vcat $ intercalate [text " "] (f <$> as) + ResponseVersion v dbv -> + renderIO $ + vcat + [ formatKey "Software version:" <+> formatValue (cs v), + formatKey "Database version:" <+> formatValue (cs dbv) + ] + ResponseRollDice ds e -> + renderIO . vcat $ + [ formatKey "System Entropy Source:" <+> formatFilePath (cs e), + formatKey "Dice rolls:" + <+> mconcat (intersperse (text ", ") (formatDice . show <$> ds)) + ] diff --git a/src/Haskoin/Wallet/Signing.hs b/src/Haskoin/Wallet/Signing.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Signing.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.Signing where + +import Conduit (MonadUnliftIO) +import Control.Arrow (second) +import Control.Monad (unless, when, (<=<)) +import Control.Monad.Except +import Control.Monad.State +import qualified Data.ByteString as BS +import Data.Default (def) +import Data.Either (rights) +import Data.List (nub) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Word (Word64) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebClient +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) +import System.Random (Random (randomR), StdGen, initStdGen) + +{- Building Transactions -} + +buildTxSignData :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Config -> + StdGen -> + DBAccountId -> + [(Address, Natural)] -> + Natural -> + Natural -> + Bool -> + Natural -> + ExceptT String (DB m) TxSignData +buildTxSignData net ctx cfg gen accId rcpts feeByte dust rcptPay minConf + | null rcpts = throwError "No recipients provided" + | otherwise = do + -- Get all spendable coins in the account + allCoins <- getSpendableCoins net accId minConf + -- Get a change address + dbAddr <- nextFreeIntAddr ctx cfg accId + (change, changeDeriv) <- liftEither $ fromDBAddr net dbAddr + -- Build a transaction and pick the coins + (tx, pickedCoins) <- + liftEither $ + buildWalletTx net ctx gen rcpts change allCoins feeByte dust rcptPay + -- Get the derivations of our recipients and picked coins + rcptsDerivsE <- mapM (lift . getAddrDeriv net accId) $ fst <$> rcpts + let rcptsDerivs = rights rcptsDerivsE -- It's OK to fail here + inDerivs <- mapM (liftEither <=< lift . getCoinDeriv net accId) pickedCoins + -- Check if we have a change output + let noChange = length tx.outputs == length rcpts + outDerivs = + if noChange + then rcptsDerivs + else changeDeriv : rcptsDerivs + -- Get the dependent transactions + let depTxHash = (.hash) . (.outpoint) <$> tx.inputs + depTxs <- mapM getRawTx depTxHash + -- Return the result + return $ TxSignData tx depTxs (nub inDerivs) (nub outDerivs) False + +buildWalletTx :: + Network -> + Ctx -> + StdGen -> -- Randomness for coin selection and change address order + [(Address, Natural)] -> -- recipients + Address -> -- change + [Store.Unspent] -> -- Coins to choose from + Natural -> -- Fee per byte + Natural -> -- Dust + Bool -> -- Recipients Pay for Fee + Either String (Tx, [Store.Unspent]) +buildWalletTx net ctx gen rcptsN change coins feeByteN dustN rcptPay = + flip evalStateT gen $ do + rdmCoins <- randomShuffle coins + (pickedCoins, changeAmnt) <- + lift $ chooseCoins tot feeCoinSel (length rcptsN + 1) False rdmCoins + let nOuts = + if changeAmnt <= dust + then length rcptsN + else length rcptsN + 1 + totFee = + guessTxFee (fromIntegral feeByteN) nOuts (length pickedCoins) + rcptsPayN <- + if rcptPay + then lift $ makeRcptsPay (fromIntegral totFee) rcptsN + else return rcptsN + let rcpts = second fromIntegral <$> rcptsPayN + allRcpts + | changeAmnt <= dust = rcpts + | otherwise = (change, changeAmnt) : rcpts + ops = (.outpoint) <$> pickedCoins + when (any ((<= dust) . snd) allRcpts) $ + lift $ + Left "Recipient output is smaller than the dust value" + rdmRcpts <- randomShuffle allRcpts + tx <- lift $ buildAddrTx net ctx ops =<< mapM (addrToText2 net) rdmRcpts + return (tx, pickedCoins) + where + feeCoinSel = + if rcptPay + then 0 + else fromIntegral feeByteN :: Word64 + dust = fromIntegral dustN :: Word64 + tot = fromIntegral $ sum $ snd <$> rcptsN :: Word64 + +makeRcptsPay :: + Natural -> [(Address, Natural)] -> Either String [(Address, Natural)] +makeRcptsPay fee rcpts = + mapM f rcpts + where + f (a, v) = (a,) <$> maybeToEither err (v `safeSubtract` toPay) + err = "Recipients can't pay for the fee" + (q, r) = fee `quotRem` fromIntegral (length rcpts) + toPay = if r == 0 then q else q + 1 + +{- Signing Transactions -} + +data MnemonicPass = MnemonicPass + { mnemonicWords :: !Text, + mnemonicPass :: !Text + } + deriving (Eq, Show) + +-- Compute an account signing key +signingKey :: Network -> Ctx -> MnemonicPass -> Natural -> Either String XPrvKey +signingKey net ctx mnem acc = do + seed <- mnemonicToSeed (mnemonicPass mnem) (mnemonicWords mnem) + return $ derivePath ctx (bip44Deriv net acc) (makeXPrvKey seed) + +-- Compute the unique wallet fingerprint given a mnemonic +walletFingerprint :: Network -> Ctx -> MnemonicPass -> Either String Fingerprint +walletFingerprint net ctx mnem = do + xPrvKey <- signingKey net ctx mnem 0 + return $ xPubFP ctx $ deriveXPubKey ctx xPrvKey + +signWalletTx :: + Network -> + Ctx -> + TxSignData -> + XPrvKey -> + Either String (TxSignData, TxInfo) +signWalletTx net ctx tsd@TxSignData {txSignDataInputPaths = inPaths} signKey = + signTxWithKeys net ctx tsd publicKey prvKeys + where + publicKey = deriveXPubKey ctx signKey + prvKeys = (.key) . (\p -> derivePath ctx p signKey) <$> inPaths + +signTxWithKeys :: + Network -> + Ctx -> + TxSignData -> + XPubKey -> + [SecKey] -> + Either String (TxSignData, TxInfo) +signTxWithKeys net ctx tsd@(TxSignData tx _ _ _ signed) publicKey secKeys = do + when signed $ Left "The transaction is already signed" + when (null secKeys) $ Left "There are no private keys to sign" + txInfo <- parseTxSignData net ctx publicKey tsd + -- signing + let myInputs = txInfoMyInputs txInfo + othInputs = txInfoOtherInputs txInfo + mySigInputs = mconcat $ myInputsSigInput <$> Map.elems myInputs + othSigInputs = mconcat $ otherInputsSigInput <$> Map.elems othInputs + sigInputs = mySigInputs <> othSigInputs + signedTx <- signTx net ctx tx sigInputs secKeys + let txInfoS = signTxInfo signedTx txInfo + isSigned = verifyTxInfo net ctx signedTx txInfoS + unless isSigned $ Left "The transaction could not be signed" + return + ( tsd {txSignDataTx = signedTx, txSignDataSigned = True}, + txInfoS + ) + +signTxInfo :: Tx -> TxInfo -> TxInfo +signTxInfo tx txInfo = + txInfo + { txInfoHash = Just $ txHash tx, + txInfoPending = Just $ TxInfoPending (nosigTxHash tx) True False + } + +verifyTxInfo :: Network -> Ctx -> Tx -> TxInfo -> Bool +verifyTxInfo net ctx tx txInfo = + let myInputs = txInfoMyInputs txInfo + othInputs = txInfoOtherInputs txInfo + mySigInputs = mconcat $ myInputsSigInput <$> Map.elems myInputs + othSigInputs = mconcat $ otherInputsSigInput <$> Map.elems othInputs + sigInputs = mySigInputs <> othSigInputs + f i = (i.script, i.value, i.outpoint) + vDat = f <$> sigInputs + in Just (txHash tx) == txInfoHash txInfo + && noEmptyInputs tx + && verifyStdTx net ctx tx vDat + +noEmptyInputs :: Tx -> Bool +noEmptyInputs = (not . any BS.null) . fmap (.script) . (.inputs) + +{- Transaction Sweeping -} + +buildSweepSignData :: + (MonadUnliftIO m) => + Network -> + Ctx -> + Config -> + DBAccountId -> + [SecKey] -> + [Address] -> + Natural -> + Natural -> + ExceptT String (DB m) TxSignData +buildSweepSignData net ctx cfg accId prvKeys sweepTo feeByte dust + | null prvKeys = throwError "No private keys to sweep from" + | null sweepTo = throwError "No addresses to sweep to" + | otherwise = do + let host = apiHost net cfg + -- Generate the addresses to sweep from + let sweepFrom = nub $ concatMap (genPossibleAddrs net ctx) prvKeys + -- Get the unspent coins of the sweepFrom addresses + Store.SerialList coins <- + liftExcept . apiBatch ctx (configCoinBatch cfg) host $ + GetAddrsUnspent sweepFrom def {limit = Just 0} + when (null coins) $ + throwError "There are no coins to sweep in those addresses" + -- Build a set of sweep transactions + gen <- liftIO initStdGen + tx <- liftEither $ buildSweepTx net ctx gen coins sweepTo feeByte dust + -- Get the dependent transactions + let depTxHash = (.hash) . (.outpoint) <$> (.inputs) tx + Store.RawResultList depTxs <- + liftExcept . apiBatch ctx (configTxFullBatch cfg) host $ + GetTxsRaw depTxHash + -- Check if any of the coins belong to us + inDerivs <- rights <$> lift (mapM (getAddrDeriv net accId) sweepFrom) + -- Check if any of the sweepTo addrs belong to us + outDerivs <- rights <$> lift (mapM (getAddrDeriv net accId) sweepTo) + return $ TxSignData tx depTxs (nub inDerivs) (nub outDerivs) False + +genPossibleAddrs :: Network -> Ctx -> SecKey -> [Address] +genPossibleAddrs net ctx k + | net `elem` [btc, btcTest, btcRegTest] = + [ pubKeyAddr ctx pc, + pubKeyAddr ctx pu, + pubKeyWitnessAddr ctx pc, + pubKeyWitnessAddr ctx pu, + pubKeyCompatWitnessAddr ctx pc, + pubKeyCompatWitnessAddr ctx pu + ] + | otherwise = + [ pubKeyAddr ctx pc, + pubKeyAddr ctx pu + ] + where + c = wrapSecKey False k :: PrivateKey -- Compressed + u = wrapSecKey True k :: PrivateKey -- Uncompressed + pc = derivePublicKey ctx c + pu = derivePublicKey ctx u + +buildSweepTx :: + Network -> + Ctx -> + StdGen -> + [Store.Unspent] -> + [Address] -> + Natural -> + Natural -> + Either String Tx +buildSweepTx net ctx gen coins sweepTo feeByte dust = + flip evalStateT gen $ do + rdmOutpoints <- ((.outpoint) <$>) <$> randomShuffle coins + rdmSweepTo <- randomShuffle sweepTo + let coinsTot = sum $ (.value) <$> coins + fee = guessTxFee (fromIntegral feeByte) (length sweepTo) (length coins) + when (coinsTot < fee) $ + throwError "Could not find a sweep solution: fee is too large" + let (q, r) = (coinsTot - fee) `quotRem` fromIntegral (length sweepTo) + amnts = (q + r) : repeat q + when (q <= fromIntegral dust) $ + throwError "Outputs are smaller than the dust value" + addrsT <- lift $ mapM (maybeToEither "Addr" . addrToText net) rdmSweepTo + lift $ buildAddrTx net ctx rdmOutpoints (zip addrsT amnts) + +-- Utilities -- + +randomRange :: (Random a, MonadState StdGen m) => a -> a -> m a +randomRange low hi = do + gen <- get + let (res, newGen) = randomR (low, hi) gen + put newGen + return res + +randomShuffle :: (MonadState StdGen m) => [a] -> m [a] +randomShuffle [] = return [] +randomShuffle [x] = return [x] +randomShuffle xs = do + i <- randomRange 0 (length xs - 1) + case splitAt i xs of + (as, e : bs) -> (e :) <$> randomShuffle (as <> bs) + _ -> error "randomShuffle" diff --git a/src/Haskoin/Wallet/TxInfo.hs b/src/Haskoin/Wallet/TxInfo.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/TxInfo.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.TxInfo where + +import Control.Arrow ((&&&)) +import Control.Monad (unless) +import Data.Aeson (object, withObject, (.:), (.:?), (.=)) +import qualified Data.Aeson as Json +import Data.Aeson.Types (Parser) +import qualified Data.ByteString as BS +import Data.Either (partitionEithers) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Serialize as S +import Data.Text (Text) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Util +import Numeric.Natural (Natural) + +data TxType = TxDebit | TxInternal | TxCredit + deriving (Show, Eq) + +instance Json.ToJSON TxType where + toJSON = + Json.String . \case + TxDebit -> "debit" + TxInternal -> "internal" + TxCredit -> "credit" + +instance Json.FromJSON TxType where + parseJSON = + Json.withText "txtype" $ \case + "debit" -> return TxDebit + "internal" -> return TxInternal + "credit" -> return TxCredit + _ -> fail "Invalid TxType" + +data TxInfo = TxInfo + { txInfoHash :: !(Maybe TxHash), + txInfoType :: !TxType, + txInfoAmount :: !Integer, + txInfoMyOutputs :: !(Map Address MyOutputs), + txInfoOtherOutputs :: !(Map Address Natural), + txInfoNonStdOutputs :: ![Store.StoreOutput], + txInfoMyInputs :: !(Map Address MyInputs), + txInfoOtherInputs :: !(Map Address OtherInputs), + txInfoNonStdInputs :: ![Store.StoreInput], + txInfoSize :: !Natural, + txInfoFee :: !Natural, + txInfoFeeByte :: !Natural, + txInfoBlockRef :: !Store.BlockRef, + txInfoConfirmations :: !Natural, + txInfoPending :: !(Maybe TxInfoPending) + } + deriving (Eq, Show) + +data TxInfoPending = TxInfoPending + { pendingNosigHash :: !TxHash, + pendingSigned :: !Bool, + pendingOnline :: !Bool + } + deriving (Eq, Show) + +instance Json.ToJSON TxInfoPending where + toJSON (TxInfoPending h s o) = + object + [ "nosighash" .= h, + "signed" .= s, + "online" .= o + ] + +instance Json.FromJSON TxInfoPending where + parseJSON = + withObject "TxInfoPending" $ \o -> do + h <- o .: "nosighash" + s <- o .: "signed" + onl <- o .: "online" + return $ TxInfoPending h s onl + +data MyOutputs = MyOutputs + { myOutputsValue :: !Natural, + myOutputsPath :: !SoftPath, + myOutputsLabel :: !Text + } + deriving (Eq, Show) + +instance Json.ToJSON MyOutputs where + toJSON (MyOutputs i p l) = + object + [ "value" .= i, + "path" .= p, + "label" .= l + ] + +instance Json.FromJSON MyOutputs where + parseJSON = + withObject "MyOutputs" $ \o -> do + i <- o .: "value" + p <- o .: "path" + l <- o .: "label" + return $ MyOutputs i p l + +data MyInputs = MyInputs + { myInputsValue :: !Natural, + myInputsPath :: !SoftPath, + myInputsLabel :: !Text, + myInputsSigInput :: [SigInput] + } + deriving (Eq, Show) + +instance MarshalJSON Ctx MyInputs where + marshalValue ctx (MyInputs i p l s) = + object $ + [ "value" .= i, + "path" .= p, + "label" .= l + ] + ++ ["siginput" .= (marshalValue ctx <$> s) | not (null s)] + + unmarshalValue ctx = + withObject "MyInputs" $ \o -> do + i <- o .: "value" + p <- o .: "path" + l <- o .: "label" + sM <- o .:? "siginput" + s <- unmarshalValue ctx `mapM` fromMaybe [] sM + return $ MyInputs i p l s + +data OtherInputs = OtherInputs + { otherInputsValue :: !Natural, + otherInputsSigInput :: [SigInput] + } + deriving (Eq, Show) + +instance MarshalJSON Ctx OtherInputs where + marshalValue ctx (OtherInputs i s) = + object $ + ("value" .= i) + : ["siginput" .= (marshalValue ctx <$> s) | not (null s)] + + unmarshalValue ctx = + withObject "OtherInputs" $ \o -> do + i <- o .: "value" + sM <- o .:? "siginput" + s <- unmarshalValue ctx `mapM` fromMaybe [] sM + return $ OtherInputs i s + +instance MarshalJSON (Network, Ctx) TxInfo where + marshalValue (net, ctx) tx = + object + [ "txid" .= txInfoHash tx, + "type" .= txInfoType tx, + "amount" .= txInfoAmount tx, + "myoutputs" .= mapAddrText net (txInfoMyOutputs tx), + "otheroutputs" .= mapAddrText net (txInfoOtherOutputs tx), + "nonstdoutputs" .= (marshalValue net <$> txInfoNonStdOutputs tx), + "myinputs" .= marshalMap net ctx (txInfoMyInputs tx), + "otherinputs" .= marshalMap net ctx (txInfoOtherInputs tx), + "nonstdinputs" .= (marshalValue net <$> txInfoNonStdInputs tx), + "size" .= txInfoSize tx, + "fee" .= txInfoFee tx, + "feebyte" .= txInfoFeeByte tx, + "block" .= txInfoBlockRef tx, + "confirmations" .= txInfoConfirmations tx, + "pending" .= txInfoPending tx + ] + unmarshalValue (net, ctx) = + Json.withObject "TxInfo" $ \o -> + TxInfo + <$> o .: "txid" + <*> o .: "type" + <*> o .: "amount" + <*> (mapTextAddr net <$> o .: "myoutputs") + <*> (mapTextAddr net <$> o .: "otheroutputs") + <*> (mapM (unmarshalValue net) =<< o .: "nonstdoutputs") + <*> (unmarshalMap net ctx =<< o .: "myinputs") + <*> (unmarshalMap net ctx =<< o .: "otherinputs") + <*> (mapM (unmarshalValue net) =<< o .: "nonstdinputs") + <*> o .: "size" + <*> o .: "fee" + <*> o .: "feebyte" + <*> o .: "block" + <*> o .: "confirmations" + <*> o .: "pending" + +marshalMap :: + (MarshalJSON Ctx v) => + Network -> + Ctx -> + Map Address v -> + Map Text Json.Value +marshalMap net ctx m = mapAddrText net $ Map.map (marshalValue ctx) m + +unmarshalMap :: + (MarshalJSON Ctx v) => + Network -> + Ctx -> + Map Text Json.Value -> + Parser (Map Address v) +unmarshalMap net ctx m = mapTextAddr net <$> (unmarshalValue ctx `mapM` m) + +mapAddrText :: Network -> Map Address v -> Map Text v +mapAddrText net m = + either error id $ do + let f (a, v) = (,v) <$> addrToTextE net a + Map.fromList <$> mapM f (Map.assocs m) + +mapTextAddr :: Network -> Map Text v -> Map Address v +mapTextAddr net m = + either error id $ do + let f (a, v) = (,v) <$> textToAddrE net a + Map.fromList <$> mapM f (Map.assocs m) + +storeToTxInfo :: + Map Address SoftPath -> Natural -> Store.Transaction -> TxInfo +storeToTxInfo walletAddrs currHeight sTx = + TxInfo + { txInfoHash = Just sTx.txid, + txInfoType = txType amount fee, + txInfoAmount = amount, + txInfoMyOutputs = Map.map (\(v, p) -> MyOutputs v p "") myOutputsMap, + txInfoOtherOutputs = othOutputsMap, + txInfoNonStdOutputs = nonStdOut, + txInfoMyInputs = Map.map (\(v, p) -> MyInputs v p "" []) myInputsMap, + txInfoOtherInputs = Map.map (`OtherInputs` []) othInputsMap, + txInfoNonStdInputs = nonStdIn, + txInfoSize = size, + txInfoFee = fee, + txInfoFeeByte = feeByte, + txInfoBlockRef = sTx.block, + txInfoConfirmations = fromMaybe 0 confM, + txInfoPending = Nothing + } + where + size = fromIntegral sTx.size :: Natural + fee = fromIntegral sTx.fee :: Natural + feeByte = fee `div` size + (outputMap, nonStdOut) = outputAddressMap sTx.outputs + myOutputsMap = Map.intersectionWith (,) outputMap walletAddrs + othOutputsMap = Map.difference outputMap walletAddrs + (inputMap, nonStdIn) = inputAddressMap sTx.inputs + myInputsMap = Map.intersectionWith (,) inputMap walletAddrs + othInputsMap = Map.difference inputMap walletAddrs + myOutputsSum = + fromIntegral $ sum $ fst <$> Map.elems myOutputsMap :: Integer + myInputsSum = fromIntegral $ sum $ fst <$> Map.elems myInputsMap :: Integer + amount = myOutputsSum - myInputsSum + confM = + case sTx.block of + Store.MemRef _ -> Nothing + Store.BlockRef height _ -> + (+ 1) <$> currHeight `safeSubtract` fromIntegral height + +{- Helpers for building address maps -} + +outputAddressMap :: + [Store.StoreOutput] -> (Map Address Natural, [Store.StoreOutput]) +outputAddressMap outs = + (Map.fromListWith (+) rs, ls) + where + (ls, rs) = partitionEithers $ f <$> outs + f (Store.StoreOutput v _ _ (Just a)) = Right (a, fromIntegral v) + f s = Left s + +inputAddressMap :: + [Store.StoreInput] -> (Map Address Natural, [Store.StoreInput]) +inputAddressMap ins = + (Map.fromListWith (+) rs, ls) + where + (ls, rs) = partitionEithers $ f <$> ins + f (Store.StoreInput _ _ _ _ v _ (Just a)) = Right (a, fromIntegral v) + f s = Left s + +txOutAddressMap :: Ctx -> [TxOut] -> (Map Address Natural, [TxOut]) +txOutAddressMap ctx outs = + (Map.fromListWith (+) rs, ls) + where + (ls, rs) = partitionEithers $ f <$> outs + f to@(TxOut v s) = + case scriptToAddressBS ctx s of + Left _ -> Left to + Right a -> Right (a, fromIntegral v) + +txInAddressMap :: + Network -> + Ctx -> + [(OutPoint, TxOut)] -> + (Map Address (Natural, [SigInput]), [(OutPoint, TxOut)]) +txInAddressMap net ctx ins = + (Map.fromListWith (\(a, b) (c, d) -> (a + c, b <> d)) rs, mconcat ls) + where + sh = maybeSetForkId net sigHashAll + (ls, rs) = partitionEithers $ f <$> ins + f (op, to@(TxOut v s)) = + case scriptToAddressBS ctx s of + Left _ -> Left [(op, to)] + Right a -> + Right + ( a, + ( fromIntegral v, + [SigInput (addressToOutput a) v op sh Nothing] + ) + ) + +maybeSetForkId :: Network -> SigHash -> SigHash +maybeSetForkId net + | isJust net.sigHashForkId = setForkIdFlag + | otherwise = id + +parseTxSignData :: + Network -> + Ctx -> + XPubKey -> + TxSignData -> + Either String TxInfo +parseTxSignData net ctx pubkey tsd@(TxSignData tx _ inPaths outPaths signed) = do + coins <- txSignDataCoins tsd + -- Fees + let outSum = fromIntegral $ sum $ (.value) <$> tx.outputs :: Natural + inSum = fromIntegral $ sum $ (.value) . snd <$> coins :: Natural + fee <- maybeToEither "Fee is negative" $ inSum `safeSubtract` outSum + let feeByte = fee `div` fromIntegral size + -- Outputs + (outputMap, nonStdOut) = txOutAddressMap ctx tx.outputs + myOutputsMap = Map.intersectionWith (,) outputMap outPathAddrs + othOutputsMap = Map.difference outputMap outPathAddrs + -- Inputs + (inputMap, nonStdIn) = txInAddressMap net ctx coins + myInputsMap = + Map.intersectionWith (\(n, xs) p -> (n, p, xs)) inputMap inPathAddrs + othInputsMap = Map.difference inputMap inPathAddrs + -- Amounts + myOutputsSum = + fromIntegral $ sum $ fst <$> Map.elems myOutputsMap :: Integer + myInputsSum = + fromIntegral $ sum $ fst3 <$> Map.elems myInputsMap :: Integer + amount = myOutputsSum - myInputsSum + -- Sanity checks + unless (null nonStdOut) $ + Left "There are non-standard outputs in the transaction" + unless (null nonStdIn) $ + Left "There are non-standard inputs in the transaction" + unless (length coins == length tx.inputs) $ + Left "Referenced input transactions are missing" + unless (length inPaths == Map.size myInputsMap) $ + Left "Input derivations don't match the transaction inputs" + unless (length outPaths == Map.size myOutputsMap) $ + Left "Output derivations don't match the transaction outputs" + return $ + TxInfo + { txInfoHash = if signed then Just $ txHash tx else Nothing, + txInfoType = txType amount fee, + txInfoAmount = amount, + txInfoMyOutputs = + Map.map (\(v, p) -> MyOutputs v p "") myOutputsMap, + txInfoOtherOutputs = othOutputsMap, + txInfoNonStdOutputs = [], + txInfoMyInputs = + Map.map (\(i, p, s) -> MyInputs i p "" s) myInputsMap, + txInfoOtherInputs = Map.map (uncurry OtherInputs) othInputsMap, + txInfoNonStdInputs = [], + txInfoSize = fromIntegral size, + txInfoFee = fee, + txInfoFeeByte = feeByte, + txInfoBlockRef = Store.MemRef 0, + txInfoConfirmations = 0, + txInfoPending = Just $ TxInfoPending (nosigTxHash tx) signed False + } + where + inPathAddrs = Map.fromList $ (pathToAddr ctx pubkey &&& id) <$> inPaths + outPathAddrs = Map.fromList $ (pathToAddr ctx pubkey &&& id) <$> outPaths + size + | signed = BS.length $ S.encode tx + | otherwise = guessTxSize (length tx.inputs) [] (length tx.outputs) 0 + +txSignDataCoins :: TxSignData -> Either String [(OutPoint, TxOut)] +txSignDataCoins (TxSignData tx depTxs _ _ _) = + maybeToEither "Referenced input transactions are missing" $ mapM f ops + where + ops = (.outpoint) <$> tx.inputs :: [OutPoint] + txMap = + Map.fromList $ (txHash &&& (.outputs)) <$> depTxs :: Map TxHash [TxOut] + f :: OutPoint -> Maybe (OutPoint, TxOut) + f op@(OutPoint h i) = + (op,) <$> ((!!? fromIntegral i) =<< Map.lookup h txMap) + +txType :: Integer -> Natural -> TxType +txType amount fee + | amount > 0 = TxCredit + | abs amount == fromIntegral fee = TxInternal + | otherwise = TxDebit + +pathToAddr :: Ctx -> XPubKey -> SoftPath -> Address +pathToAddr ctx pk path = xPubAddr ctx $ derivePubPath ctx path pk diff --git a/src/Haskoin/Wallet/Util.hs b/src/Haskoin/Wallet/Util.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Wallet/Util.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Wallet.Util where + +import Control.Arrow (second) +import Control.Monad.Except +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Encode.Pretty as Pretty +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.List (sortBy) +import Data.Maybe (fromMaybe) +import qualified Data.Serialize as S +import Data.Text (Text) +import qualified Data.Text as Text +import Haskoin +import qualified Haskoin.Store.Data as Store +import Numeric.Natural (Natural) + +{- Data.Aeson Compatibility -} + +encodeJsonPretty :: (JSON.ToJSON a) => a -> BS.ByteString +encodeJsonPretty = + BL.toStrict + . Pretty.encodePretty' Pretty.defConfig {Pretty.confIndent = Pretty.Spaces 2} + +encodeJsonPrettyLn :: (JSON.ToJSON a) => a -> BS.ByteString +encodeJsonPrettyLn = + BL.toStrict + . Pretty.encodePretty' + Pretty.defConfig + { Pretty.confIndent = Pretty.Spaces 2, + Pretty.confTrailingNewline = True + } + +{- Haskoin helper functions -} + +data Page = Page + { pageLimit :: !Natural, + pageOffset :: !Natural + } + deriving (Eq, Show) + +toPage :: Page -> [a] -> [a] +toPage (Page limit offset) xs = + take (fromIntegral limit) $ drop (fromIntegral offset) xs + +liftExcept :: (MonadError String m) => ExceptT Store.Except m a -> m a +liftExcept action = do + e <- runExceptT action + case e of + Right a -> return a + Left err -> throwError $ show (err :: Store.Except) + +addrToTextE :: Network -> Address -> Either String Text +addrToTextE net a = + maybeToEither "Invalid Address in addrToTextE" (addrToText net a) + +textToAddrE :: Network -> Text -> Either String Address +textToAddrE net a = + maybeToEither "Invalid Address in textToAddrE" (textToAddr net a) + +addrToText2 :: Network -> (Address, v) -> Either String (Text, v) +addrToText2 net (a, v) = (,v) <$> addrToTextE net a + +textToAddr2 :: Network -> (Text, v) -> Either String (Address, v) +textToAddr2 net (a, v) = (,v) <$> textToAddrE net a + +addrToText3 :: Network -> (Address, v, w) -> Either String (Text, v, w) +addrToText3 net (a, v, w) = (,v,w) <$> addrToTextE net a + +textToAddr3 :: Network -> (Text, v, w) -> Either String (Address, v, w) +textToAddr3 net (a, v, w) = (,v,w) <$> textToAddrE net a + +lastList :: Natural -> [a] -> [a] +lastList count xs = drop (max 0 $ length xs - fromIntegral count) xs + +xPubChecksum :: Ctx -> XPubKey -> Text +xPubChecksum ctx = encodeHex . S.encode . xPubFP ctx + +() :: String -> String -> String +a b = a <> "/" <> b + +(!!?) :: [a] -> Natural -> Maybe a +xs !!? i + | fromIntegral i < length xs = Just $ xs !! fromIntegral i + | otherwise = Nothing + +chunksOf :: Natural -> [a] -> [[a]] +chunksOf n xs + | null xs = [] + | otherwise = + uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs + +sortDesc :: (Ord a) => [a] -> [a] +sortDesc = sortBy (flip compare) + +padStart :: Int -> Text -> Text -> Text +padStart n c t = + Text.replicate (fromMaybe 0 $ n `safeSubtract` Text.length t) c <> t + +padEnd :: Int -> Text -> Text -> Text +padEnd n c t = + t <> Text.replicate (fromMaybe 0 $ n `safeSubtract` Text.length t) c + +dropPatternEnd :: Text -> Text -> Text +dropPatternEnd p t = fromMaybe t $ Text.stripSuffix p t + +chunksOfEnd :: Int -> Text -> [Text] +chunksOfEnd n t = reverse $ Text.reverse <$> Text.chunksOf n (Text.reverse t) + +safeSubtract :: (Integral a) => a -> a -> Maybe a +safeSubtract a b + | b > a = Nothing + | otherwise = Just $ a - b diff --git a/test/Haskoin/Wallet/AmountsSpec.hs b/test/Haskoin/Wallet/AmountsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/AmountsSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.AmountsSpec where + +import Haskoin.Wallet.Amounts +import Haskoin.Wallet.TestUtils (genNatural) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (arbitrary), elements, forAll) + +spec :: Spec +spec = + describe "Amount parser" $ do + prop "readAmount . showAmount identity" $ + forAll genNatural $ \n unit -> + readAmount unit (showAmount unit n) `shouldBe` Just n + prop "readIntegerAmount . showIntegerAmount identity" $ \i unit -> + readIntegerAmount unit (showIntegerAmount unit i) `shouldBe` Just i + it "Satoshi amounts vectors" $ do + readAmount UnitSatoshi "0" `shouldBe` Just 0 + readAmount UnitSatoshi "0000" `shouldBe` Just 0 + readAmount UnitSatoshi "0.0" `shouldBe` Nothing + readAmount UnitSatoshi "8" `shouldBe` Just 8 + readAmount UnitSatoshi "100" `shouldBe` Just 100 + readAmount UnitSatoshi "1234567890" `shouldBe` Just 1234567890 + readAmount UnitSatoshi "1'234'567'890" `shouldBe` Just 1234567890 + readAmount UnitSatoshi "1 234 567 890" `shouldBe` Just 1234567890 + readAmount UnitSatoshi "1_234_567_890" `shouldBe` Just 1234567890 + it "Bit amounts vectors" $ do + readAmount UnitBit "0" `shouldBe` Just 0 + readAmount UnitBit "0000" `shouldBe` Just 0 + readAmount UnitBit "0.0" `shouldBe` Just 0 + readAmount UnitBit "0.00" `shouldBe` Just 0 + readAmount UnitBit "0.000" `shouldBe` Nothing + readAmount UnitBit "0.10" `shouldBe` Just 10 + readAmount UnitBit "0.1" `shouldBe` Just 10 + readAmount UnitBit "0.01" `shouldBe` Just 1 + readAmount UnitBit "1" `shouldBe` Just 100 + readAmount UnitBit "100" `shouldBe` Just 10000 + readAmount UnitBit "100.00" `shouldBe` Just 10000 + readAmount UnitBit "100.01" `shouldBe` Just 10001 + readAmount UnitBit "1234567890.9" `shouldBe` Just 123456789090 + readAmount UnitBit "1'234'567'890.90" `shouldBe` Just 123456789090 + readAmount UnitBit "1 234 567 890.90" `shouldBe` Just 123456789090 + readAmount UnitBit "1_234_567_890.90" `shouldBe` Just 123456789090 + it "Bitcoin amounts vectors" $ do + readAmount UnitBitcoin "0" `shouldBe` Just 0 + readAmount UnitBitcoin "0000" `shouldBe` Just 0 + readAmount UnitBitcoin "0.0" `shouldBe` Just 0 + readAmount UnitBitcoin "0.00000000" `shouldBe` Just 0 + readAmount UnitBitcoin "0.000000000" `shouldBe` Nothing + readAmount UnitBitcoin "0.1" `shouldBe` Just 10000000 + readAmount UnitBitcoin "0.1000" `shouldBe` Just 10000000 + readAmount UnitBitcoin "0.10000000" `shouldBe` Just 10000000 + readAmount UnitBitcoin "0.100000000" `shouldBe` Nothing + readAmount UnitBitcoin "1" `shouldBe` Just 100000000 + readAmount UnitBitcoin "100" `shouldBe` Just 10000000000 + readAmount UnitBitcoin "1234567890.9" `shouldBe` Just 123456789090000000 + readAmount UnitBitcoin "1'234'567'890.9009" + `shouldBe` Just 123456789090090000 + readAmount UnitBitcoin "1 234 567 890.9009" + `shouldBe` Just 123456789090090000 + readAmount UnitBitcoin "1_234_567_890.9009" + `shouldBe` Just 123456789090090000 + +instance Arbitrary AmountUnit where + arbitrary = elements [UnitBitcoin, UnitBit, UnitSatoshi] diff --git a/test/Haskoin/Wallet/CommandsSpec.hs b/test/Haskoin/Wallet/CommandsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/CommandsSpec.hs @@ -0,0 +1,811 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields -fno-warn-orphans #-} + +module Haskoin.Wallet.CommandsSpec where + +import Conduit (MonadIO, liftIO) +import Control.Arrow (second) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans (lift) +import Data.Default (def) +import Data.Either +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Serialize as S +import Data.Text (Text) +import Database.Esqueleto.Legacy hiding (isNothing) +import qualified Database.Persist as P +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Signing +import Haskoin.Wallet.SigningSpec +import Haskoin.Wallet.TestUtils +import Haskoin.Wallet.TxInfo +import Haskoin.Wallet.Util +import Test.Hspec + +identityTests :: Ctx -> IdentityTests +identityTests ctx = + def + { jsonTests = + [ JsonBox $ arbitraryDBAccount btc ctx, + JsonBox $ arbitraryDBAddress btc, + JsonBox arbitraryAddressBalance, + JsonBox $ arbitraryTxSignData btc ctx, + JsonBox arbitraryConfig + ], + marshalJsonTests = + [ MarshalJsonBox ((btc,) <$> arbitraryJsonCoin), + MarshalJsonBox ((ctx,) <$> arbitraryPubKeyDoc ctx), + MarshalJsonBox (((btc, ctx),) <$> arbitraryTxInfo btc ctx), + MarshalJsonBox ((ctx,) <$> arbitraryResponse btc ctx), + MarshalJsonBox ((ctx,) <$> arbitraryAccountBackup ctx) + ] + } + +spec :: Spec +spec = do + let cfg = def :: Config + prepareContext $ \ctx -> do + testIdentity $ identityTests ctx + describe "Database" $ do + bestSpec + accountSpec ctx + extAddressSpec ctx cfg + intAddressSpec ctx cfg + txsSpec ctx + coinSpec ctx + pendingTxsSpec ctx cfg + +liftTest :: (MonadIO m) => Expectation -> m () +liftTest = liftIO + +shouldBeLeft :: (Show a) => ExceptT String (DB IO) a -> DB IO () +shouldBeLeft action = liftTest . (`shouldSatisfy` isLeft) =<< runExceptT action + +shouldBeLeft' :: + (Show a, Eq a) => String -> ExceptT String (DB IO) a -> DB IO () +shouldBeLeft' err action = + liftTest . (`shouldBe` Left err) =<< runExceptT action + +dbShouldBe :: (Show a, Eq a) => DB IO a -> a -> DB IO () +dbShouldBe action a = liftTest . (`shouldBe` a) =<< action + +dbShouldBeE :: + (Show a, Eq a) => + ExceptT String (DB IO) a -> + a -> + ExceptT String (DB IO) () +dbShouldBeE action a = liftTest . (`shouldBe` a) =<< action + +dbShouldSatisfy :: (Show a) => DB IO a -> (a -> Bool) -> DB IO () +dbShouldSatisfy action f = liftTest . (`shouldSatisfy` f) =<< action + +testNewAcc :: Ctx -> Text -> ExceptT String (DB IO) (DBAccountId, DBAccount) +testNewAcc ctx name = do + let fp = forceRight $ walletFingerprint btc ctx mnemPass + d <- lift $ nextAccountDeriv fp btc + let prv = forceRight $ signingKey btc ctx mnemPass d + pub = deriveXPubKey ctx prv + insertAccount btc ctx fp name pub + +testNewAcc2 :: Ctx -> Text -> ExceptT String (DB IO) (DBAccountId, DBAccount) +testNewAcc2 ctx name = do + let fp = forceRight $ walletFingerprint btc ctx mnemPass2 + d <- lift $ nextAccountDeriv fp btc + let prv = forceRight $ signingKey btc ctx mnemPass2 d + pub = deriveXPubKey ctx prv + insertAccount btc ctx fp name pub + +bestSpec :: Spec +bestSpec = + it "can insert and get the best block" $ + runDBMemory $ do + res1 <- getBest btcTest + liftTest $ res1 `shouldBe` Nothing + updateBest + btc + "00000000000000000004727b3cc0946dc2054f59e362369e0437325c0a992efb" + 814037 + updateBest + btcTest + "000000000000001400d91785c92efc15ccfc1949e8581f06db7914a707c3f81d" + 2535443 + res2 <- getBest btc + res3 <- getBest btcTest + liftTest $ do + res2 + `shouldBe` Just + ( "00000000000000000004727b3cc0946dc2054f59e362369e0437325c0a992efb", + 814037 + ) + res3 + `shouldBe` Just + ( "000000000000001400d91785c92efc15ccfc1949e8581f06db7914a707c3f81d", + 2535443 + ) + +accountSpec :: Ctx -> Spec +accountSpec ctx = do + it "can find the correct account derivations with smallestUnused" $ do + smallestUnused [] `shouldBe` 0 + smallestUnused [0] `shouldBe` 1 + smallestUnused [1] `shouldBe` 0 + smallestUnused [2] `shouldBe` 0 + smallestUnused [1,2,3] `shouldBe` 0 + smallestUnused [1,3,4] `shouldBe` 0 + smallestUnused [0,2] `shouldBe` 1 + smallestUnused [0,1,3,4] `shouldBe` 2 + smallestUnused [0,1,3,4,6,7] `shouldBe` 2 + smallestUnused [0,1,2,3,4,5] `shouldBe` 6 + it "can create and rename accounts" $ do + runDBMemoryE $ do + -- No accounts + lift $ shouldBeLeft $ getAccountByName $ Just "acc1" + lift $ shouldBeLeft $ getAccountByName Nothing + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 0 + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 0 -- Still 0 + lift $ getAccounts `dbShouldBe` [] + -- Check basic account properties + (accId, acc) <- testNewAcc ctx "acc1" + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 1 + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 1 -- Still 1 + liftTest $ do + dBAccountName acc `shouldBe` "acc1" + dBAccountWallet acc `shouldBe` DBWalletKey walletFPText + dBAccountIndex acc `shouldBe` 0 + dBAccountNetwork acc `shouldBe` "btc" + dBAccountDerivation acc `shouldBe` "/44'/0'/0'" + dBAccountExternal acc `shouldBe` 0 + dBAccountInternal acc `shouldBe` 0 + dBAccountXPubKey acc `shouldBe` snd keysT + dBAccountBalanceConfirmed acc `shouldBe` 0 + dBAccountBalanceUnconfirmed acc `shouldBe` 0 + dBAccountBalanceCoins acc `shouldBe` 0 + -- Check account retrieval + lift $ getAccounts `dbShouldBe` [(accId, acc)] + getAccountByName (Just "acc1") `dbShouldBeE` (accId, acc) + getAccountByName Nothing `dbShouldBeE` (accId, acc) -- There is just 1 account + getAccountById accId `dbShouldBeE` acc + lift $ getAccounts `dbShouldBe` [(accId, acc)] + -- Check the creation of a second account + (accId2, acc2) <- testNewAcc ctx "acc2" + lift $ nextAccountDeriv walletFP btc `dbShouldBe` 2 + getAccountByName (Just "acc2") `dbShouldBeE` (accId2, acc2) + lift $ getAccounts `dbShouldBe` [(accId, acc), (accId2, acc2)] + lift $ shouldBeLeft $ getAccountByName Nothing -- There are > 1 accounts + liftTest $ do + dBAccountWallet acc2 `shouldBe` DBWalletKey walletFPText + dBAccountDerivation acc2 `shouldBe` "/44'/0'/1'" + dBAccountIndex acc2 `shouldBe` 1 + -- Create an account in a new wallet + (accId3, acc3) <- testNewAcc2 ctx "acc3" + liftTest $ do + dBAccountName acc3 `shouldBe` "acc3" + dBAccountWallet acc3 `shouldBe` DBWalletKey walletFPText2 + dBAccountIndex acc3 `shouldBe` 0 + dBAccountNetwork acc3 `shouldBe` "btc" + dBAccountDerivation acc3 `shouldBe` "/44'/0'/0'" + dBAccountXPubKey acc3 `shouldBe` snd keysT2 + lift $ nextAccountDeriv walletFP2 btc `dbShouldBe` 1 + lift $ + getAccounts `dbShouldBe` [(accId3, acc3), (accId, acc), (accId2, acc2)] + getAccountByName (Just "acc3") `dbShouldBeE` (accId3, acc3) + lift $ shouldBeLeft $ getAccountByName Nothing -- There are > 1 accounts + getAccountById accId3 `dbShouldBeE` acc3 + -- Rename an account + lift $ shouldBeLeft $ renameAccount "acc2" "acc2" + lift $ shouldBeLeft $ renameAccount "acc2" "acc3" + lift $ shouldBeLeft $ renameAccount "doesnotexist" "hello world" + acc2' <- renameAccount "acc2" "hello world" + liftIO $ acc2' `shouldBe` acc2 {dBAccountName = "hello world"} + lift $ getAccountNames `dbShouldBe` ["acc1", "hello world", "acc3"] + _ <- renameAccount "hello world" "acc2" + lift $ getAccountNames `dbShouldBe` ["acc1", "acc2", "acc3"] + +extAddressSpec :: Ctx -> Config -> Spec +extAddressSpec ctx cfg = + it "can generate external addresses" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- No addresses yet + lift $ bestAddrWithFunds accId AddrInternal `dbShouldBe` Nothing + lift $ bestAddrWithFunds accId AddrExternal `dbShouldBe` Nothing + lift $ addressPage accId (Page 5 0) `dbShouldBe` [] + -- Generate external addresses + ext1 <- genExtAddress ctx cfg accId "Address 1" + liftTest $ do + dBAddressIndex ext1 `shouldBe` 0 + dBAddressAccountWallet ext1 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation ext1 `shouldBe` "/44'/0'/0'" + dBAddressDerivation ext1 `shouldBe` "/0/0" + dBAddressAddress ext1 `shouldBe` head extAddrsT + dBAddressLabel ext1 `shouldBe` "Address 1" + dBAddressInternal ext1 `shouldBe` False + dBAddressFree ext1 `shouldBe` False + lift $ addressPage accId (Page 5 0) `dbShouldBe` [ext1] + ext2 <- genExtAddress ctx cfg accId "Address 2" + liftTest $ do + dBAddressIndex ext2 `shouldBe` 1 + dBAddressAccountWallet ext2 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation ext2 `shouldBe` "/44'/0'/0'" + dBAddressDerivation ext2 `shouldBe` "/0/1" + dBAddressAddress ext2 `shouldBe` extAddrsT !! 1 + dBAddressLabel ext2 `shouldBe` "Address 2" + dBAddressInternal ext2 `shouldBe` False + dBAddressFree ext2 `shouldBe` False + -- Test Paging + lift $ addressPage accId (Page 5 0) `dbShouldBe` [ext2, ext1] + lift $ addressPage accId (Page 1 0) `dbShouldBe` [ext2] + lift $ addressPage accId (Page 1 1) `dbShouldBe` [ext1] + lift $ addressPage accId (Page 1 2) `dbShouldBe` [] + -- Set address labels + _ <- setAddrLabel accId 0 "test address" + lift $ + addressPage accId (Page 5 0) + `dbShouldBe` [ext2, ext1 {dBAddressLabel = "test address"}] + -- Test the gap + replicateM_ 18 $ genExtAddress ctx cfg accId "" -- We have 20 addresses + lift $ shouldBeLeft $ genExtAddress ctx cfg accId "" -- fail gap + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 20) . length) + updateAddressBalances btc [Store.Balance (extAddrs !! 2) 0 0 0 1 1] + updateAddressBalances btc [Store.Balance (extAddrs !! 4) 0 0 0 1 1] + lift $ bestAddrWithFunds accId AddrExternal `dbShouldBe` Just 4 + replicateM_ 5 $ genExtAddress ctx cfg accId "" -- We have 25 addresses + lift $ shouldBeLeft $ genExtAddress ctx cfg accId "" -- fail gap + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + -- Test discoverAccGenAddrs + updateAddressBalances btc [Store.Balance (extAddrs !! 9) 0 0 0 1 1] + discoverAccGenAddrs ctx cfg accId AddrExternal 0 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + discoverAccGenAddrs ctx cfg accId AddrExternal 25 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 25) . length) + discoverAccGenAddrs ctx cfg accId AddrExternal 26 + lift $ addressPage accId (Page 100 0) `dbShouldSatisfy` ((== 26) . length) + -- Test getAddrDeriv + lift $ + getAddrDeriv btc accId (head extAddrs) + `dbShouldBe` Right (Deriv :/ 0 :/ 0) + lift $ + getAddrDeriv btc accId (extAddrs !! 7) + `dbShouldBe` Right (Deriv :/ 0 :/ 7) + -- Test accound balances + acc1 <- lift $ updateAccountBalances accId + liftTest $ do + dBAccountBalanceConfirmed acc1 `shouldBe` 0 + dBAccountBalanceUnconfirmed acc1 `shouldBe` 0 + dBAccountBalanceCoins acc1 `shouldBe` 0 + updateAddressBalances btc [Store.Balance (extAddrs !! 1) 2 0 1 1 2] + updateAddressBalances btc [Store.Balance (extAddrs !! 4) 2 8 2 2 10] + _ <- nextFreeIntAddr ctx cfg accId + updateAddressBalances btc [Store.Balance (head intAddrs) 3 2 1 1 5] + acc1' <- lift $ updateAccountBalances accId + liftTest $ do + dBAccountBalanceConfirmed acc1' `shouldBe` 7 + dBAccountBalanceUnconfirmed acc1' `shouldBe` 10 + dBAccountBalanceCoins acc1' `shouldBe` 4 + -- Test account indices + liftTest $ do + dBAccountInternal acc1' `shouldBe` 1 + dBAccountExternal acc1' `shouldBe` 26 + +intAddressSpec :: Ctx -> Config -> Spec +intAddressSpec ctx cfg = + it "can generate internal addresses" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Generate internal addresses + int1 <- nextFreeIntAddr ctx cfg accId + liftTest $ do + dBAddressIndex int1 `shouldBe` 0 + dBAddressAccountWallet int1 `shouldBe` DBWalletKey walletFPText + dBAddressAccountDerivation int1 `shouldBe` "/44'/0'/0'" + dBAddressDerivation int1 `shouldBe` "/1/0" + dBAddressAddress int1 `shouldBe` head intAddrsT + dBAddressLabel int1 `shouldBe` "Internal Address" + dBAddressInternal int1 `shouldBe` True + dBAddressFree int1 `shouldBe` True + -- Test the Free status + nextFreeIntAddr ctx cfg accId `dbShouldBeE` int1 -- Should return the same address + lift $ setAddrsFree AddrBusy [head intAddrsT] `dbShouldBe` 1 + lift $ setAddrsFree AddrBusy [intAddrsT !! 1] `dbShouldBe` 0 + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + _ <- lift $ setAddrsFree AddrFree [head intAddrsT] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 0 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 1] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 0 + _ <- lift $ setAddrsFree AddrBusy [head intAddrsT] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 2] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 3 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 3] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 4 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 5 + _ <- lift $ setAddrsFree AddrFree [intAddrsT !! 2] + _ <- lift $ setAddrsFree AddrFree [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 2] + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 5] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 4 + _ <- lift $ setAddrsFree AddrBusy [intAddrsT !! 4] + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 6 + -- Test account indices + acc <- getAccountById accId + liftTest $ do + dBAccountInternal acc `shouldBe` 7 + dBAccountExternal acc `shouldBe` 0 + +emptyTxInfo :: TxInfo +emptyTxInfo = + TxInfo + (Just $ txid' 0) + TxInternal + 0 + Map.empty + Map.empty + [] + Map.empty + Map.empty + [] + 0 + 0 + 0 + (Store.MemRef 0) + 0 + Nothing + +txsSpec :: Ctx -> Spec +txsSpec ctx = + it "can manage transactions" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Simple insert and retrieval + (dbInfo, change) <- repsertTxInfo btc ctx accId emptyTxInfo + liftTest $ do + change `shouldBe` True + dBTxInfoAccountWallet dbInfo `shouldBe` DBWalletKey walletFPText + dBTxInfoAccountDerivation dbInfo `shouldBe` "/44'/0'/0'" + dBTxInfoBlockRef dbInfo `shouldBe` S.encode (Store.MemRef 0) + dBTxInfoConfirmed dbInfo `shouldBe` False + -- Reinserting should produce no change + (dbInfo2, change2) <- repsertTxInfo btc ctx accId emptyTxInfo + liftTest $ do + change2 `shouldBe` False + dbInfo2 `shouldBe` dbInfo + txsPage ctx accId (Page 5 0) `dbShouldBeE` [emptyTxInfo] + -- Check that confirmations are updated correctly + lift $ updateBest btc (bid' 0) 0 + getConfirmedTxs accId True `dbShouldBeE` [] + getConfirmedTxs accId False `dbShouldBeE` [txid' 0] + txsPage ctx accId (Page 5 0) `dbShouldBeE` [emptyTxInfo] + (dbInfo', change') <- + repsertTxInfo + btc + ctx + accId + emptyTxInfo {txInfoBlockRef = Store.BlockRef 0 0} + liftTest $ do + change' `shouldBe` True + dBTxInfoBlockRef dbInfo' `shouldBe` S.encode (Store.BlockRef 0 0) + dBTxInfoConfirmed dbInfo' `shouldBe` True + dBTxInfoCreated dbInfo' `shouldBe` dBTxInfoCreated dbInfo + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 0 0, + txInfoConfirmations = 1 + } + ] + getConfirmedTxs accId True `dbShouldBeE` [txid' 0] + getConfirmedTxs accId False `dbShouldBeE` [] + lift $ updateBest btcTest (bid' 0) 10 + lift $ updateBest btc (bid' 0) 20 + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 0 0, + txInfoConfirmations = 21 + } + ] + (dbInfo'', change'') <- + repsertTxInfo + btc + ctx + accId + emptyTxInfo {txInfoBlockRef = Store.BlockRef 10 0} + liftTest $ do + change'' `shouldBe` True + dBTxInfoBlockRef dbInfo'' `shouldBe` S.encode (Store.BlockRef 10 0) + dBTxInfoConfirmed dbInfo'' `shouldBe` True + txsPage ctx accId (Page 5 0) + `dbShouldBeE` [ emptyTxInfo + { txInfoBlockRef = Store.BlockRef 10 0, + txInfoConfirmations = 11 + } + ] + +coinSpec :: Ctx -> Spec +coinSpec ctx = + it "can manage coins" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + -- Insert a single coin + let coin1 = coin' ctx (txid' 0, 0) Nothing (head extAddrs) 10 + (c, dbCoin) <- second head <$> refreshCoins btc accId extAddrs [coin1] + liftTest $ do + c `shouldBe` 1 + dBCoinAccountWallet dbCoin `shouldBe` DBWalletKey walletFPText + dBCoinAccountDerivation dbCoin `shouldBe` "/44'/0'/0'" + dBCoinAddress dbCoin `shouldBe` head extAddrsT + dBCoinConfirmed dbCoin `shouldBe` False + dBCoinLocked dbCoin `shouldBe` False + -- Test JSON coins + let jsonCoin1 = forceRight $ toJsonCoin btc Nothing dbCoin + liftTest $ + jsonCoin1 + `shouldBe` JsonCoin + { jsonCoinOutpoint = OutPoint (txid' 0) 0, + jsonCoinAddress = head extAddrs, + jsonCoinValue = 10, + jsonCoinBlock = Store.MemRef 0, + jsonCoinConfirmations = 0, + jsonCoinLocked = False + } + coinPage btc accId (Page 5 0) `dbShouldBeE` [jsonCoin1] + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1] + getSpendableCoins btc accId 1 `dbShouldBeE` [] + -- Nothing should happen when refreshing the same data + refreshCoins btc accId extAddrs [coin1] `dbShouldBeE` (0, []) + -- Confirm and update the coin + let coin1' = coin1 {Store.block = Store.BlockRef 1 0} :: Store.Unspent + refreshCoins btc accId extAddrs [coin1'] `dbShouldBeE` (1, []) + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 1 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 2 `dbShouldBeE` [] + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + -- Best = 0 + lift $ updateBest btc (bid' 0) 0 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 1 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 2 `dbShouldBeE` [] + -- Best = 1 + lift $ updateBest btc (bid' 0) 1 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 1 + } + ] + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 1 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 2 `dbShouldBeE` [] + -- Best = 10 + lift $ updateBest btc (bid' 0) 10 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 1 0, + jsonCoinConfirmations = 10 + } + ] + getSpendableCoins btc accId 9 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 10 `dbShouldBeE` [coin1'] + getSpendableCoins btc accId 11 `dbShouldBeE` [] + let coin1'' = coin1 {Store.block = Store.BlockRef 10 0} :: Store.Unspent + refreshCoins btc accId extAddrs [coin1''] `dbShouldBeE` (1, []) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1 + } + ] + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1''] + getSpendableCoins btc accId 1 `dbShouldBeE` [coin1''] + getSpendableCoins btc accId 2 `dbShouldBeE` [] + -- Lock the coin + lift $ setLockCoin (OutPoint (txid' 0) 0) True `dbShouldBe` 1 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1, + jsonCoinLocked = True + } + ] + getSpendableCoins btc accId 0 `dbShouldBeE` [] + lift $ setLockCoin (OutPoint (txid' 0) 0) True `dbShouldBe` 0 + lift $ setLockCoin (OutPoint (txid' 0) 0) False `dbShouldBe` 1 + lift $ setLockCoin (OutPoint (txid' 0) 0) False `dbShouldBe` 0 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin1 + { jsonCoinBlock = Store.BlockRef 10 0, + jsonCoinConfirmations = 1, + jsonCoinLocked = False + } + ] + getSpendableCoins btc accId 0 `dbShouldBeE` [coin1''] + getSpendableCoins btc accId 1 `dbShouldBeE` [coin1''] + getSpendableCoins btc accId 2 `dbShouldBeE` [] + -- Delete the coin + refreshCoins btc accId extAddrs [] `dbShouldBeE` (1, []) + getSpendableCoins btc accId 0 `dbShouldBeE` [] + coinPage btc accId (Page 5 0) `dbShouldBeE` [] + +checkFree :: Int -> Bool -> ExceptT String (DB IO) () +checkFree i free = + lift $ + ( dBAddressFree . entityVal . fromJust + <$> P.getBy (UniqueAddress (intAddrsT !! i)) + ) + `dbShouldBe` free + +pendingTxsSpec :: Ctx -> Config -> Spec +pendingTxsSpec ctx cfg = + it "can manage pending transactions" $ do + runDBMemoryE $ do + (accId, _) <- testNewAcc ctx "test" + lift $ updateBest btc (bid' 0) 0 + -- Build some test data coins/txs + (dBAddressAddress <$> genExtAddress ctx cfg accId "") + `dbShouldBeE` head extAddrsT + (dBAddressAddress <$> nextFreeIntAddr ctx cfg accId) + `dbShouldBeE` head intAddrsT + checkFree 0 True + lift $ setAddrsFree AddrBusy [head intAddrsT] `dbShouldBe` 1 + checkFree 0 False + let fundTx1 = tx' ctx [(txid' 1, 0)] [(addr' 0, 20)] + fundTx2 = tx' ctx [(txid' 1, 1)] [(iAddr' 0, 10)] + coin1 = coin' ctx (txHash fundTx1, 0) (Just 0) (addr' 0) 20 + coin2 = coin' ctx (txHash fundTx2, 0) (Just 0) (iAddr' 0) 10 + -- Insert the dependent transactions + lift $ insertRawTx fundTx1 + lift $ insertRawTx fundTx2 + -- Insert two coins in the database + (c, dbCoins) <- refreshCoins btc accId (extAddrs <> intAddrs) [coin1, coin2] + liftTest $ c `shouldBe` 2 + let jsonCoin1 = forceRight $ toJsonCoin btc Nothing (head dbCoins) + jsonCoin2 = forceRight $ toJsonCoin btc Nothing (dbCoins !! 1) + tsd <- buildTxSignData btc ctx cfg gen accId [(oAddr' 0, 8)] 0 0 False 1 + liftTest $ + tsd + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(iAddr' 1, 12), (oAddr' 0, 8)], + txSignDataInputs = [fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [Deriv :/ 1 :/ 1], + txSignDataSigned = False + } + -- Import the pending transaction + checkFree 0 False + checkFree 1 True + let h1 = "db1085753d1d9b14005dd2951ff643803d4fa7ffa3bde6841dbb817958cb74e1" + importPendingTx btc ctx accId tsd `dbShouldBeE` h1 + liftTest $ nosigTxHash (txSignDataTx tsd) `shouldBe` h1 + -- Check locked coins + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [Just $ TxInfoPending h1 False False] + -- Check address free status + checkFree 0 False + checkFree 1 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 2 + lift $ + shouldBeLeft' "chooseCoins: No solution found" $ + buildTxSignData btc ctx cfg gen accId [(oAddr' 1, 12)] 0 0 False 1 + lift $ + shouldBeLeft' "The transaction already exists" $ + importPendingTx btc ctx accId tsd + -- Create second pending transaction + tsd2 <- buildTxSignData btc ctx cfg gen accId [(oAddr' 1, 7)] 0 0 False 1 + liftTest $ + tsd2 + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx2, 0)] + [(iAddr' 2, 3), (oAddr' 1, 7)], + txSignDataInputs = [fundTx2], + txSignDataInputPaths = [Deriv :/ 1 :/ 0], + txSignDataOutputPaths = [Deriv :/ 1 :/ 2], + txSignDataSigned = False + } + -- Import the second transaction + checkFree 2 True + let h2 = "bb0e46f95f90bf0d2b0805655a77e632a0bd5088d5722d0055bc2862158ba747" + importPendingTx btc ctx accId tsd2 `dbShouldBeE` h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [ Just $ TxInfoPending h2 False False, + Just $ TxInfoPending h1 False False + ] + checkFree 0 False + checkFree 1 False + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 3 + lift $ + shouldBeLeft' "chooseCoins: No solution found" $ + buildTxSignData btc ctx cfg gen accId [(oAddr' 2, 1)] 0 0 False 1 + -- Delete first transaction + deletePendingTx ctx h1 `dbShouldBeE` (1, 1) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = False} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [Just $ TxInfoPending h2 False False] + checkFree 0 False + checkFree 1 True + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + -- Create transaction with no change + tsd3 <- buildTxSignData btc ctx cfg gen accId [(oAddr' 2, 20)] 0 0 False 1 + liftTest $ + tsd3 + `shouldBe` TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(oAddr' 2, 20)], + txSignDataInputs = [fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + let h3 = "abe82b09dddb8abdb5490c3d404d34f2ff3c8f7b893bbe80f0af4018576e1f9e" + importPendingTx btc ctx accId tsd3 `dbShouldBeE` h3 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [ Just $ TxInfoPending h3 False False, + Just $ TxInfoPending h2 False False + ] + checkFree 0 False + checkFree 1 True + checkFree 2 False + (dBAddressIndex <$> nextFreeIntAddr ctx cfg accId) `dbShouldBeE` 1 + -- Import a signed transaction + let resE = signWalletTx btc ctx tsd2 (fst $ keys ctx) + liftTest $ resE `shouldSatisfy` isRight + let tsd2' = fst $ forceRight resE + liftTest $ txSignDataSigned tsd2' `shouldBe` True + importPendingTx btc ctx accId tsd2' `dbShouldBeE` h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [ Just $ TxInfoPending h3 False False, + Just $ TxInfoPending h2 True False + ] + checkFree 0 False + checkFree 1 True + checkFree 2 False + lift $ do + shouldBeLeft' "The transaction already exists" $ + importPendingTx btc ctx accId tsd2' + shouldBeLeft' "Can not replace a signed transaction with an unsigned one" $ + importPendingTx btc ctx accId tsd2 + -- Set tsd2 to online + lift $ do + setPendingTxOnline h2 `dbShouldBe` 1 + shouldBeLeft' "The transaction is already online" $ + importPendingTx btc ctx accId tsd2' + -- Can not delete an online transaction + shouldBeLeft $ deletePendingTx ctx h2 + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [ Just $ TxInfoPending h3 False False, + Just $ TxInfoPending h2 True True + ] + lift $ deletePendingTxOnline $ DBPendingTxKey $ txHashToHex h2 + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin2 {jsonCoinLocked = True}, + jsonCoin1 {jsonCoinLocked = True} + ] + ((txInfoPending <$>) <$> pendingTxPage ctx accId (Page 5 0)) + `dbShouldBeE` [Just $ TxInfoPending h3 False False] + checkFree 0 False + checkFree 1 True + checkFree 2 False + -- Check for other errors + let fundTx3 = tx' ctx [(txid' 2, 0)] [(addr' 8, 30)] + coin3 = coin' ctx (txHash fundTx3, 0) (Just 0) (addr' 8) 30 + lift $ do + shouldBeLeft' "A coin referenced by the transaction is locked" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx1, 0)] + [(oAddr' 3, 20)], + txSignDataInputs = [fundTx3, fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 0], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + shouldBeLeft' "A coin referenced by the transaction does not exist" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(oAddr' 3, 20)], + txSignDataInputs = [fundTx3, fundTx1], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [], + txSignDataSigned = False + } + (_, dbCoins3) <- refreshCoins btc accId (extAddrs <> intAddrs) [coin1, coin3] + let jsonCoin3 = forceRight $ toJsonCoin btc Nothing (head dbCoins3) + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin3 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + lift $ + shouldBeLeft' "Some referenced addresses do not exist" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(iAddr' 1, 5), (oAddr' 3, 25)], + txSignDataInputs = [fundTx3], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [Deriv :/ 1 :/ 1], + txSignDataSigned = False + } + -- The transaction is not being rolled back so we roll it back manually + replicateM_ 10 $ genExtAddress ctx cfg accId "" + _ <- lift $ setLockCoin (jsonCoinOutpoint jsonCoin3) False + coinPage btc accId (Page 5 0) + `dbShouldBeE` [ jsonCoin3 {jsonCoinLocked = False}, + jsonCoin1 {jsonCoinLocked = True} + ] + checkFree 0 False + checkFree 1 True + checkFree 2 False + lift $ + shouldBeLeft' "Some of the internal output addresses are not free" $ + importPendingTx btc ctx accId $ + TxSignData + { txSignDataTx = + tx' + ctx + [(txHash fundTx3, 0)] + [(iAddr' 2, 1), (oAddr' 3, 25)], + txSignDataInputs = [fundTx3], + txSignDataInputPaths = [Deriv :/ 0 :/ 8], + txSignDataOutputPaths = [Deriv :/ 1 :/ 2], + txSignDataSigned = False + } diff --git a/test/Haskoin/Wallet/EntropySpec.hs b/test/Haskoin/Wallet/EntropySpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/EntropySpec.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.EntropySpec where + +import Control.Exception (evaluate) +import Control.Monad +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString as BS +import Data.Default (def) +import Data.Maybe +import Data.Text (Text) +import Haskoin +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.Entropy +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TestUtils +import Test.HUnit +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +spec :: Spec +spec = do + let cfg = def :: Config + prepareContext $ \ctx -> do + diceSpec + entropySpec + mnemonicSpec ctx cfg + +diceSpec :: Spec +diceSpec = + describe "Base6 Encoding" $ do + it "can encode a Word8 to Base6" $ do + let vs = [6, 1, 2, 3, 4, 5] + xs = [[a, b, c] | a <- vs, b <- vs, c <- vs] + ys = [[a, b] | a <- vs, b <- vs] + as = [0x00 .. 0xd7] + bs = [0xd8 .. 0xfb] + cs = [0xfc .. 0xff] + forM_ (zip as xs) $ \(a, b) -> word8ToBase6 a `shouldBe` b + forM_ (zip bs ys) $ \(a, b) -> word8ToBase6 a `shouldBe` b + forM_ cs $ \c -> word8ToBase6 c `shouldBe` [] + -- Checking a few fixed values + word8ToBase6 0x00 `shouldBe` [6, 6, 6] + word8ToBase6 0x01 `shouldBe` [6, 6, 1] + word8ToBase6 0xd7 `shouldBe` [5, 5, 5] + word8ToBase6 0xd8 `shouldBe` [6, 6] + word8ToBase6 0xd9 `shouldBe` [6, 1] + word8ToBase6 0xfb `shouldBe` [5, 5] + it "can decode base6 to Word8" $ do + base6ToWord8 [6] [] `shouldBe` ([], [False, False]) + base6ToWord8 [1] [] `shouldBe` ([], [False, True]) + base6ToWord8 [2] [] `shouldBe` ([], [True, False]) + base6ToWord8 [3] [] `shouldBe` ([], [True, True]) + base6ToWord8 [4] [] `shouldBe` ([], [False]) + base6ToWord8 [5] [] `shouldBe` ([], [True]) + base6ToWord8 [5, 6] [] `shouldBe` ([], [True, False, False]) + base6ToWord8 [6, 6, 6, 5] [] + `shouldBe` ([], [False, False, False, False, False, False, True]) + base6ToWord8 [6, 6, 6, 6] [] `shouldBe` ([0x00], []) + base6ToWord8 [6, 6, 6, 1] [] `shouldBe` ([0x01], []) + base6ToWord8 [3, 3, 3, 3] [] `shouldBe` ([0xff], []) + base6ToWord8 [4, 3, 3, 3, 3] [] `shouldBe` ([0xff], [False]) + base6ToWord8 [1, 1, 1, 1, 3, 3, 3, 3] [] `shouldBe` ([0x55, 0xff], []) + +entropySpec :: Spec +entropySpec = do + it "can mix entropy" $ do + evaluate (xorBytes BS.empty $ BS.pack [0x00]) `shouldThrow` anyException + evaluate (xorBytes (BS.pack [0x00]) BS.empty) `shouldThrow` anyException + evaluate (xorBytes (BS.pack [0x00, 0x00]) (BS.pack [0x00])) + `shouldThrow` anyException + evaluate (xorBytes (BS.pack [0x00]) (BS.pack [0x00, 0x00])) + `shouldThrow` anyException + xorBytes (BS.pack [0x00]) (BS.pack [0x00]) `shouldBe` BS.pack [0x00] + xorBytes (BS.pack [0x00]) (BS.pack [0xff]) `shouldBe` BS.pack [0xff] + xorBytes (BS.pack [0xff]) (BS.pack [0x00]) `shouldBe` BS.pack [0xff] + xorBytes (BS.pack [0xff]) (BS.pack [0xff]) `shouldBe` BS.pack [0x00] + xorBytes (BS.pack [0xaa]) (BS.pack [0x55]) `shouldBe` BS.pack [0xff] + xorBytes (BS.pack [0x55, 0xaa]) (BS.pack [0xaa, 0x55]) + `shouldBe` BS.pack [0xff, 0xff] + xorBytes (BS.pack [0x7a, 0x54]) (BS.pack [0xd3, 0x8e]) + `shouldBe` BS.pack [0xa9, 0xda] + it "can split entropy" $ do + splitEntropyWith (BS.pack [0x00]) [] `shouldBe` [BS.pack [0x00]] + splitEntropyWith (BS.pack [0x00]) [BS.pack [0x00]] + `shouldBe` [BS.pack [0x00], BS.pack [0x00]] + splitEntropyWith (BS.pack [0x55]) [BS.pack [0xaa]] + `shouldBe` [BS.pack [0xff], BS.pack [0xaa]] + splitEntropyWith (BS.pack [0x55, 0xaa]) [BS.pack [0xaa, 0x55]] + `shouldBe` [BS.pack [0xff, 0xff], BS.pack [0xaa, 0x55]] + prop "prop: can split entropy x2" $ + forAll (arbitraryBSn 32) $ \s -> + forAll (arbitraryBSn 32) $ \k -> + splitEntropyWith s [k] `shouldBe` [s `xorBytes` k, k] + prop "prop: can split entropy x3" $ + forAll (arbitraryBSn 32) $ \s -> + forAll (arbitraryBSn 32) $ \k1 -> + forAll (arbitraryBSn 32) $ \k2 -> + splitEntropyWith s [k1, k2] + `shouldBe` [s `xorBytes` k1 `xorBytes` k2, k1, k2] + prop "prop: can reconstruct entropy" $ + forAll (arbitraryBSn 32) $ \s -> + forAll (arbitraryBSn 32) $ \k1 -> + forAll (arbitraryBSn 32) $ \k2 -> do + case splitEntropyWith s [k1, k2] of + [a, b, c] -> (a `xorBytes` b `xorBytes` c) `shouldBe` s + _ -> expectationFailure "Invalid splitEntropyWith" + prop "prop: can reconstruct original mnemonic" $ + forAll (arbitraryBSn 32) $ \s -> + forAll (arbitraryBSn 32) $ \k1 -> + case splitEntropyWith s [k1] of + [a, b] -> + let mnem = toMnemonic s + splitMnems = mapM toMnemonic [a, b] + unsplitMnem = mergeMnemonicParts $ forceRight splitMnems + in unsplitMnem `shouldBe` mnem + _ -> expectationFailure "Invalid splitEntropyWith" + +mnemonicSpec :: Ctx -> Config -> Spec +mnemonicSpec ctx cfg = + describe "Mnemonic API" $ do + -- https://github.com/iancoleman/bip39/issues/58 + it "Can derive iancoleman issue 58" $ do + let m = "fruit wave dwarf banana earth journey tattoo true farm silk olive fence" + p = "banana" + mnemPass = MnemonicPass m p + xpub = forceRight $ deriveXPubKey ctx <$> signingKey btc ctx mnemPass 0 + (addr0, _) = derivePathAddr ctx xpub extDeriv 0 + addrToText btc addr0 `shouldBe` Just "17rxURoF96VhmkcEGCj5LNQkmN9HVhWb7F" + it "Passes the test vectors 3 (zero padding)" $ + mapM_ (testVector ctx) testVectors3 + it "Passes the test vectors 4 (zero padding)" $ + mapM_ (testVector ctx) testVectors4 + it "Passes the BIP-44 test vectors" $ + mapM_ (testBip44Vector ctx cfg) bip44Vectors + +testVector :: Ctx -> (Text, HardPath, Text, Text) -> Assertion +testVector ctx (seedT, deriv, pubT, prvT) = do + xPrvExport btc xPrv `shouldBe` prvT + xPubExport btc ctx xPub `shouldBe` pubT + where + seed = fromJust $ decodeHex seedT + xPrv = derivePath ctx deriv (makeXPrvKey seed) + xPub = deriveXPubKey ctx xPrv + +-- bitpay/bitcore-lib#47 and iancoleman/bip39#58 +-- https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki#test-vector-3 +testVectors3 :: [(Text, HardPath, Text, Text)] +testVectors3 = + [ ( "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be", + Deriv, -- m/ + "xpub661MyMwAqRbcEZVB4dScxMAdx6d4nFc9nvyvH3v4gJL378CSRZiYmhRoP7mBy6gSPSCYk6SzXPTf3ND1cZAceL7SfJ1Z3GC8vBgp2epUt13", + "xprv9s21ZrQH143K25QhxbucbDDuQ4naNntJRi4KUfWT7xo4EKsHt2QJDu7KXp1A3u7Bi1j8ph3EGsZ9Xvz9dGuVrtHHs7pXeTzjuxBrCmmhgC6" + ), + ( "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be", + Deriv :| 0, -- m/0' + "xpub68NZiKmJWnxxS6aaHmn81bvJeTESw724CRDs6HbuccFQN9Ku14VQrADWgqbhhTHBaohPX4CjNLf9fq9MYo6oDaPPLPxSb7gwQN3ih19Zm4Y", + "xprv9uPDJpEQgRQfDcW7BkF7eTya6RPxXeJCqCJGHuCJ4GiRVLzkTXBAJMu2qaMWPrS7AANYqdq6vcBcBUdJCVVFceUvJFjaPdGZ2y9WACViL4L" + ) + ] + +-- btcsuite/btcutil#172 +-- https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki#test-vector-4 +testVectors4 :: [(Text, HardPath, Text, Text)] +testVectors4 = + [ ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv, -- m/ + "xpub661MyMwAqRbcGczjuMoRm6dXaLDEhW1u34gKenbeYqAix21mdUKJyuyu5F1rzYGVxyL6tmgBUAEPrEz92mBXjByMRiJdba9wpnN37RLLAXa", + "xprv9s21ZrQH143K48vGoLGRPxgo2JNkJ3J3fqkirQC2zVdk5Dgd5w14S7fRDyHH4dWNHUgkvsvNDCkvAwcSHNAQwhwgNMgZhLtQC63zxwhQmRv" + ), + ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv :| 0, -- m/0' + "xpub69AUMk3qDBi3uW1sXgjCmVjJ2G6WQoYSnNHyzkmdCHEhSZ4tBok37xfFEqHd2AddP56Tqp4o56AePAgCjYdvpW2PU2jbUPFKsav5ut6Ch1m", + "xprv9vB7xEWwNp9kh1wQRfCCQMnZUEG21LpbR9NPCNN1dwhiZkjjeGRnaALmPXCX7SgjFTiCTT6bXes17boXtjq3xLpcDjzEuGLQBM5ohqkao9G" + ), + ( "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678", + Deriv :| 0 :| 1, -- m/0'/1' + "xpub6BJA1jSqiukeaesWfxe6sNK9CCGaujFFSJLomWHprUL9DePQ4JDkM5d88n49sMGJxrhpjazuXYWdMf17C9T5XnxkopaeS7jGk1GyyVziaMt", + "xprv9xJocDuwtYCMNAo3Zw76WENQeAS6WGXQ55RCy7tDJ8oALr4FWkuVoHJeHVAcAqiZLE7Je3vZJHxspZdFHfnBEjHqU5hG1Jaj32dVoS6XLT1" + ) + ] + +testBip44Vector :: Ctx -> Config -> (Text, Text, Text, Text) -> Assertion +testBip44Vector ctx cfg (mnem, pass, addr0, addr1) = do + runDBMemoryE $ do + (accId, _) <- insertAccount btc ctx walletFP "test" pub + extAddr <- genExtAddress ctx cfg accId "" + intAddr <- nextFreeIntAddr ctx cfg accId + liftIO $ addr0 `shouldBe` dBAddressAddress extAddr + liftIO $ addr1 `shouldBe` dBAddressAddress intAddr + where + mnemPass = MnemonicPass mnem pass + walletFP = forceRight $ walletFingerprint btc ctx mnemPass + prv = forceRight $ signingKey btc ctx mnemPass 0 + pub = deriveXPubKey ctx prv + +-- (Mnemonic, BIP38 password, external 0/0, internal 1/0) +bip44Vectors :: [(Text, Text, Text, Text)] +bip44Vectors = + [ ( "modify truck lens identify brief coffee \ + \gather volcano fatal together muscle elephant", + "", + "1KiWbwzHhwH2KdLyreGuJq36SP2pPeGeim", + "1BY9FShyC6rnEUdPAVQTX37TFZqEkR1enQ" + ), + ( "modify truck lens identify brief coffee \ + \gather volcano fatal together muscle elephant", + "password", + "1Ha18XQ74YfCnuUAjGTF9rnbS7pm1aCzW4", + "17SounFZ11k8urp9Pee2FNYjzGU5qwLUfT" + ), + ( "modify truck lens identify brief coffee \ + \gather volcano fatal together muscle elephant", + "Hello world", + "1KpHPSa9eMohQznkddzmHT9AeMAscYe29Y", + "16WJrKzdik1HgnoiNiLUW2uGDqry2fSGVx" + ), + ( "fiscal gadget drastic coconut awful crime \ + \during common salmon manage random cost \ + \evil owner city", + "", + "131dALC6WxwTZzTsHUsifAJ8bkQdDEeeqJ", + "1JHCmBLzDARCdDgn2WwJQr88tGW8V3EyKj" + ), + ( "host mind elephant tone sound apple \ + \service tomato subject attend motion stick \ + \fuel fan rail bamboo tree build", + "", + "15nbJ6oHvYiapKu1vBYmyQzVSTjiJNcfuV", + "12rMvadbhRxFaUP4FoRUmABa1JEPLrrqHL" + ), + ( "flight skill wisdom mixture patch dirt \ + \trouble behind chair glad detect swarm \ + \swap truly cruise medal walnut glide \ + \wrestle route defy", + "", + "12uDDJU7BJUxJomzbFt5BW3GnukGZz6Y5t", + "1Gv62T4UkLxJ6dnsmNXENMgjBhLzEzJ1Sc" + ), + ( "use turtle trap pause spin venue \ + \hazard hope slot april cattle fork \ + \stand finish arrest nasty acoustic clog \ + \entire course universe evil desert produce", + "", + "19fJdt5HjJUrmnvKM8fTS43o9aK3NmFZMT", + "17Kmofo8651DdydBS7zVVy9JLkixkxj6SK" + ), + ( "use turtle trap pause spin venue \ + \hazard hope slot april cattle fork \ + \stand finish arrest nasty acoustic clog \ + \entire course universe evil desert produce", + "nMCm#Qe7u-*LG^99KS%hSNZJh6w&e&w4S&7HA-22^7vDE#F\ + \@=hNZZZ$M=ZSYG42J8P+U+3sf$xS6YpJf7DemaU#fLEVBW8\ + \!FmugPj=K=E*KDmUuQh_2%7K2W8@RJ4?Pua2HFCb8$@ZB^p\ + \s=T=PNFy5APBBdaz_eTq&r&v3hp6P-tTfvNP9J+xfQ-FKZS\ + \7_?g+P*9MTkpjy*K5=8y+y9db#Sv+b*5bfmV8?@YKrf#AEH\ + \7!ARqBXMhS7d%GYAxB%RG", + "1L1oKPYJ9j3EFX5CcFXz1d3kkAW9Hoh5ic", + "1J7jpmP7NVoryofiVSCKMMvMitkCP3U6Qj" + ) + ] diff --git a/test/Haskoin/Wallet/SigningSpec.hs b/test/Haskoin/Wallet/SigningSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/SigningSpec.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.SigningSpec where + +import Control.Arrow (second) +import qualified Data.ByteString as BS +import Data.Either (fromRight) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Serialize as S +import Data.Text (Text) +import Data.Word (Word32, Word8) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.Signing +import Haskoin.Wallet.TestUtils +import Haskoin.Wallet.TxInfo +import Numeric.Natural (Natural) +import System.Random (StdGen, mkStdGen) +import Test.Hspec + +spec :: Spec +spec = + prepareContext $ \ctx -> do + buildWalletTxSpec ctx + signWalletTxSpec ctx + +buildWalletTxSpec :: Ctx -> Spec +buildWalletTxSpec ctx = + describe "Transaction builder" $ do + it "can build a transaction" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] + resE = buildWalletTx btc ctx gen rcps change coins 314 10000 False + (fst <$> resE) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] -- Greedy algorithm + ((rcps !! 1) : (change, 199825416) : [head rcps]) + ) + (snd <$> resE) + `shouldBe` Right [coins !! 2, coins !! 1, head coins] + it "can fail to build a transaction if funds are insufficient" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 500000000)] + resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False + resE `shouldBe` Left "chooseCoins: No solution found" + it "will drop the change output if it is dust" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 499990000)] + resE1 = buildWalletTx btc ctx gen rcps change coins 0 9999 False + resE2 = buildWalletTx btc ctx gen rcps change coins 0 10000 False + resE3 = buildWalletTx btc ctx gen rcps change coins 1 9999 False + (fst <$> resE1) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : (change, 10000) : [head rcps]) + ) + (fst <$> resE2) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : [head rcps]) + ) + (fst <$> resE3) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 3), (txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((rcps !! 1) : [head rcps]) + ) + it "will fail if sending dust" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 500000000), (oAddr' 1, 10000)] + resE = buildWalletTx btc ctx gen rcps change coins 1 10000 False + resE `shouldBe` Left "Recipient output is smaller than the dust value" + it "can make the recipient pay for the fees" $ do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps = [(oAddr' 0, 200000000), (oAddr' 1, 200000000)] + resE = buildWalletTx btc ctx gen rcps change coins 314 10000 True + (fst <$> resE) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ( (oAddr' 1, 199912708) + : (change, 200000000) + : [(oAddr' 0, 199912708)] + ) + ) + it "fails when recipients cannot pay" $ + do + let coins = + [ coin' ctx (txid' 1, 0) Nothing (addr' 0) 100000000, + coin' ctx (txid' 1, 1) Nothing (addr' 1) 200000000, + coin' ctx (txid' 1, 2) Nothing (addr' 1) 300000000, + coin' ctx (txid' 1, 3) Nothing (addr' 2) 400000000 + ] + change = iAddr' 0 + rcps1 = [(oAddr' 0, 400000000), (oAddr' 1, 87291)] -- fee is 2*87292 + rcps2 = [(oAddr' 0, 400000000), (oAddr' 1, 87292)] + rcps3 = [(oAddr' 0, 400000000), (oAddr' 1, 97293)] + resE1 = buildWalletTx btc ctx gen rcps1 change coins 314 10000 True + resE2 = buildWalletTx btc ctx gen rcps2 change coins 314 10000 True + resE3 = buildWalletTx btc ctx gen rcps3 change coins 314 10000 True + resE1 `shouldBe` Left "Recipients can't pay for the fee" + resE2 `shouldBe` Left "Recipient output is smaller than the dust value" + (fst <$> resE3) + `shouldBe` Right + ( tx' + ctx + [(txid' 1, 2), (txid' 1, 1), (txid' 1, 0)] + ((oAddr' 1, 10001) : (change, 199902707) : [(oAddr' 0, 399912708)]) + ) + +signWalletTxSpec :: Ctx -> Spec +signWalletTxSpec ctx = + describe "Transaction signer" $ do + it "can derive private signing keys" $ do + let xPrvE = signingKey btc ctx mnemPass 0 + xPubE = deriveXPubKey ctx <$> xPrvE + xPrvE `shouldBe` Right (fst $ keys ctx) + xPubE `shouldBe` Right (snd $ keys ctx) + it "can sign a simple transaction" $ do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + (resDat, resTxInfo) = fromRight (error "fromRight") resE + signedTx = txSignDataTx resDat + txSignDataSigned resDat `shouldBe` True + resTxInfo + `shouldBe` TxInfo + { txInfoHash = + Just "e66b790c73d4e72fe13a07e247e4439bdea210cac2f947040e901f1e0ce59ac2", + txInfoType = TxDebit, + txInfoAmount = -60000000, + txInfoMyOutputs = + Map.fromList [(iAddr' 0, MyOutputs 40000000 (intDeriv :/ 0) "")], + txInfoOtherOutputs = Map.fromList [(oAddr' 0, 50000000)], + txInfoNonStdOutputs = [], + txInfoMyInputs = + Map.fromList + [ ( addr' 0, + MyInputs + 100000000 + (extDeriv :/ 0) + "" + [ SigInput + (PayPKHash (addr' 0).hash160) + 100000000 + (OutPoint (txHash fundTx) 0) + sigHashAll + Nothing + ] + ) + ], + txInfoOtherInputs = Map.empty, + txInfoNonStdInputs = [], + txInfoSize = fromIntegral $ BS.length $ S.encode signedTx, + txInfoFee = 10000000, + txInfoFeeByte = 44247, + txInfoBlockRef = Store.MemRef 0, + txInfoConfirmations = 0, + txInfoPending = + Just $ + TxInfoPending + "9b41b3cb7b10bfd1dc3f7f1885ce3623789b1b946d206fd59fb432ad4fdb6d70" + True + False + } + it "can set the correct TxInternal transaction types" $ do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 200000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(iAddr' 0, 50000000), (addr' 2, 200000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0, extDeriv :/ 1] + [intDeriv :/ 0, extDeriv :/ 2] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + (txInfoType . snd <$> resE) `shouldBe` Right TxInternal + it "fails when an input is not signed" $ do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] -- We omit derivation 1 + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "The transaction could not be signed" + it "fails when referenced input transactions are missing" $ do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0, extDeriv :/ 1] -- 1 is missing in fundTx + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Referenced input transactions are missing" + it "fails when private key derivations don't match the Tx inputs" $ + do + let fundTx = + tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000), (addr' 1, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0), (txHash fundTx, 1)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 1, extDeriv :/ 2] -- 1 and 2 instead of 0 and 1 + [intDeriv :/ 0] + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Input derivations don't match the transaction inputs" + it "fails when output derivations don't match the Tx outputs" $ + do + let fundTx = tx' ctx [(txid' 1, 0)] [(addr' 0, 100000000)] + newTx = + tx' + ctx + [(txHash fundTx, 0)] + [(oAddr' 0, 50000000), (iAddr' 0, 40000000)] + dat = + TxSignData + newTx + [fundTx] + [extDeriv :/ 0] + [intDeriv :/ 1] -- 1 instead of 0 + False + xPrv = fst $ keys ctx + let resE = signWalletTx btc ctx dat xPrv + resE `shouldBe` Left "Output derivations don't match the transaction outputs" + +-- Test Helpers -- + +tx' :: Ctx -> [(TxHash, Word32)] -> [(Address, Natural)] -> Tx +tx' ctx xs ys = Tx 1 txi txo [] 0 + where + txi = + fmap + (\(h, p) -> TxIn (OutPoint h p) BS.empty maxBound) + xs + f = marshal ctx . PayPKHash . (.hash160) + txo = fmap (\(a, v) -> TxOut v $ f a) (Control.Arrow.second fromIntegral <$> ys) + +txid' :: Word8 -> TxHash +txid' w = + fromRight (error "Could not decode txhash") $ + S.decode $ + w `BS.cons` BS.replicate 31 0x00 + +bid' :: Word8 -> BlockHash +bid' w = + fromRight (error "Could not decode block hash") $ + S.decode $ + w `BS.cons` BS.replicate 31 0x00 + +coin' :: + Ctx -> + (TxHash, Word32) -> + Maybe Natural -> + Address -> + Natural -> + Store.Unspent +coin' ctx (h, p) hM a v = + Store.Unspent + { Store.block = + maybe (Store.MemRef 0) ((`Store.BlockRef` 0) . fromIntegral) hM, + Store.outpoint = OutPoint h p, + Store.value = fromIntegral v, + Store.script = marshal ctx $ PayPKHash $ (.hash160) a, + Store.address = Just a + } + +addr' :: Int -> Address +addr' i = extAddrs !! i + +iAddr' :: Int -> Address +iAddr' i = intAddrs !! i + +oAddr' :: Int -> Address +oAddr' i = othAddrs !! i + +-- Test Constants + +-- Use a predictable seed for tests +gen :: StdGen +gen = mkStdGen 0 + +mnemPass :: MnemonicPass +mnemPass = + MnemonicPass + "snow senior nerve virus fabric now \ + \fringe clip marble interest analyst can" + "correct horse battery staple" + +mnemPass2 :: MnemonicPass +mnemPass2 = + MnemonicPass + "boring auction demand filter frog accuse \ + \company exchange rely slogan trim typical" + "correct horse battery staple" + +walletFPText :: Text +walletFPText = "892eb8e4" + +walletFPText2 :: Text +walletFPText2 = "807a5cfb" + +walletFP :: Fingerprint +walletFP = forceRight $ textToFingerprint walletFPText + +walletFP2 :: Fingerprint +walletFP2 = forceRight $ textToFingerprint walletFPText2 + +-- Keys for account 0 +keys :: Ctx -> (XPrvKey, XPubKey) +keys ctx = + ( fromJust $ + xPrvImport + btc + (fst keysT), + fromJust $ + xPubImport + btc + ctx + (snd keysT) + ) + +-- Account /44'/0'/0' mnemonic 1 +keysT :: (Text, Text) +keysT = + ( "xprv9yHxeaLAZvxXb9VtJNesqk8avfN8misGAW9DUW9eacZJNqsfZxqKLmK5jfmvFideQqGesviJeagzSQYCuQySjgvt7TdfowKja5aJqbgyuNh", + "xpub6CHK45s4QJWpodaMQQBtCt5KUhCdBBb7Xj4pGtZG8x6HFeCp7W9ZtZdZaxA34YtFAhuebiKqLqHLYoB8HDadGutW8kEH4HeMdeS1KJz8Uah" + ) + +-- Account /44'/0'/0' mnemonic 2 +keysT2 :: (Text, Text) +keysT2 = + ( "xprv9yXnZpEVdonEtT3strknsAgso5qq1cwRooo6susmzVmB5E2vvNw1KKRBgvwvNLxXdBHnkEN5R5uXi2QDs3tpkoBbL61NE6bnSbcrvH6keGa", + "xpub6CX8yKmPUBLY6w8LztHoEJdcM7gKR5fHB2ihgJHPYqJ9x2N5TvFFs7jfYCX6So9oYyu6eLDTG5dbQWPncv1PYJtXLJ4cwymhoCpeTEmnZFZ" + ) + +extAddrs :: [Address] +extAddrs = fromMaybe (error "extAddrs no parse") . textToAddr btc <$> extAddrsT + +extAddrsT :: [Text] +extAddrsT = + [ "1KEn7jEXa7KCLeZy59dka5qRJBLnPMmrLj", + "1AVj9WSYayTwUd8rS1mTTo4A6CPsS83VTg", + "1Dg6Kg7kQuyiZz41HRWXKUWKRu6ZyEf1Nr", + "1yQZuJjA6w7hXpc3C2LRiCv22rKCas7F1", + "1cWcYiGK7NwjPBJuKRqZxV4aymUnPu1mx", + "1MZuimSXigp8oqxkVUvZofqHNtVjdcdAqc", + "1JReTkpFnsrMqhSEJwUNZXPAyeTo2HQfnE", + "1Hx9xWAHhcjea5uJnyADktCfcLbuBnRnwA", + "1HXJhfiD7JFCGMFZnhKRsZxoPF7xDTqWXP", + "1MZpAt1FofY69B6fzooFxZqe6SdrVrC3Yw" + ] + +intAddrs :: [Address] +intAddrs = fromMaybe (error "intAddrs no parse") . textToAddr btc <$> intAddrsT + +intAddrsT :: [Text] +intAddrsT = + [ "17KiDLpE3r92gWR8kFGkYDtgHqEVJrznvn", + "1NqNFsuS7K3dfF8RnAVr9YYCMvJuF9GCn6", + "1MZNPWwFwy2CqVgWBq6unPWBWrZTQ7WTnr", + "19XbPiR98wmoJQZ42K8pVMzdCwSXZBh7iz", + "1Gkn7EsphiaYuv6XXvG4Kyg3LSfqFMeXHX", + "14VkCGcLkNqUwRMVjpLEyodAhXvzUWLqPM", + "1PkyVUxPMGTLzUWNFNraMagACA1x3eD4CF", + "1M2mmDhWTjEuqPfUdaQH6XPsr5i29gx581", + "184JdZjasQUmNo2AimkbKAW2sxXMF9BAvK", + "13b1QVnWFRwCrjvhthj4JabpnJ4nyxbBqm" + ] + +othAddrs :: [Address] +othAddrs = + fromMaybe (error "othAddrs no parse") . textToAddr btc + <$> [ "1JCq8Aa9d9rg4T4XV93RV3DMxd5u7GkSSU", + "1PxH6Yutj49mRAabGvcTxnLkFZCuXDXvRJ", + "191J7K3FaXXyM7C9ceSMRsJNF6aWCvvf1Q", + "1FVnYNLRdR5vQkynApupUez6ZfcDqsLHdj", + "1PmNJHnbk7Kct5FMqbEVRxqqR2mXVQKK5P", + "18CaQNcVwzUkE9KvwmMd6a5UWNgqJFEAh1", + "1M2Cv69B7LRud8su2wdd7HV2i6MrXqzdKP", + "19xYPmoJ2XV1vJnSkzsrXUJXCgKvPE3ri4", + "1N2JAKWVFAoKFEUci3tY3kvrGFY6poRgvm", + "15EANoYyJoo1J51ERdQzNwZCyhEtPfcP8g" + ] diff --git a/test/Haskoin/Wallet/TestUtils.hs b/test/Haskoin/Wallet/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/TestUtils.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Wallet.TestUtils where + +import Control.Monad +import Control.Monad.Except (ExceptT) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Except (runExceptT) +import Data.Either +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word +import Database.Persist.Sql (runMigrationQuiet) +import Database.Persist.Sqlite (runSqlite) +import Haskoin +import qualified Haskoin.Store.Data as Store +import Haskoin.Util.Arbitrary +import Haskoin.Wallet.Backup +import Haskoin.Wallet.Commands +import Haskoin.Wallet.Config +import Haskoin.Wallet.Database +import Haskoin.Wallet.FileIO +import Haskoin.Wallet.TxInfo +import Numeric.Natural +import Test.HUnit +import Test.Hspec +import Test.QuickCheck + +genNatural :: Test.QuickCheck.Gen Natural +genNatural = arbitrarySizedNatural + +forceRight :: Either a b -> b +forceRight = fromRight (error "fromRight") + +runDBMemory :: DB IO a -> Assertion +runDBMemory action = do + runSqlite ":memory:" $ do + _ <- runMigrationQuiet migrateAll + void action + +runDBMemoryE :: (Show a) => ExceptT String (DB IO) a -> Assertion +runDBMemoryE action = do + runSqlite ":memory:" $ do + _ <- runMigrationQuiet migrateAll + resE <- runExceptT action + liftIO $ resE `shouldSatisfy` isRight + +arbitraryText :: Gen Text +arbitraryText = cs <$> (arbitrary :: Gen String) + +arbitraryPositive :: (Arbitrary a, Integral a) => Gen a +arbitraryPositive = abs <$> arbitrary + +arbitraryNatural :: Gen Natural +arbitraryNatural = fromIntegral <$> (arbitraryPositive :: Gen Word64) + +arbitraryBlockRef :: Gen Store.BlockRef +arbitraryBlockRef = + oneof [a, b] + where + a = Store.BlockRef <$> arbitraryPositive <*> arbitraryPositive + b = Store.MemRef <$> arbitrary + +arbitraryDBAccount :: Network -> Ctx -> Gen DBAccount +arbitraryDBAccount net ctx = + DBAccount + <$> arbitraryText + <*> (DBWalletKey . fingerprintToText <$> arbitraryFingerprint) + <*> arbitraryPositive + <*> (cs . (.name) <$> arbitraryNetwork) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> arbitraryPositive + <*> arbitraryPositive + <*> (xPubExport net ctx <$> arbitraryXPubKey ctx) + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryUTCTime + +arbitraryDBAddress :: Network -> Gen DBAddress +arbitraryDBAddress net = + DBAddress + <$> arbitraryPositive + <*> (DBWalletKey . fingerprintToText <$> arbitraryFingerprint) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> (cs . pathToStr <$> arbitraryDerivPath) + <*> (fromJust . addrToText net <$> arbitraryAddress) + <*> arbitraryText + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitrary + <*> arbitrary + <*> arbitraryUTCTime + +arbitraryAddressBalance :: Gen AddressBalance +arbitraryAddressBalance = + AddressBalance + <$> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + <*> arbitraryPositive + +arbitraryJsonCoin :: Gen JsonCoin +arbitraryJsonCoin = + JsonCoin + <$> arbitraryOutPoint + <*> arbitraryAddress + <*> arbitraryPositive + <*> arbitraryBlockRef + <*> arbitraryNatural + <*> arbitrary + +arbitraryPubKeyDoc :: Ctx -> Gen PubKeyDoc +arbitraryPubKeyDoc ctx = + PubKeyDoc + <$> arbitraryXPubKey ctx + <*> arbitraryNetwork + <*> arbitraryText + <*> arbitraryFingerprint + +arbitraryTxSignData :: Network -> Ctx -> Gen TxSignData +arbitraryTxSignData net ctx = + TxSignData + <$> arbitraryTx net ctx + <*> resize 10 (listOf (arbitraryTx net ctx)) + <*> resize 10 (listOf arbitrarySoftPath) + <*> resize 10 (listOf arbitrarySoftPath) + <*> arbitrary + +arbitraryMyOutputs :: Gen MyOutputs +arbitraryMyOutputs = + MyOutputs + <$> arbitraryNatural + <*> arbitrarySoftPath + <*> arbitraryText + +arbitraryMyInputs :: Network -> Ctx -> Gen MyInputs +arbitraryMyInputs net ctx = + MyInputs + <$> arbitraryNatural + <*> arbitrarySoftPath + <*> arbitraryText + <*> resize 10 (listOf $ fst <$> arbitrarySigInput net ctx) + +arbitraryOtherInputs :: Network -> Ctx -> Gen OtherInputs +arbitraryOtherInputs net ctx = + OtherInputs + <$> arbitraryNatural + <*> resize 10 (listOf $ fst <$> arbitrarySigInput net ctx) + +arbitraryTxType :: Gen TxType +arbitraryTxType = oneof [pure TxDebit, pure TxInternal, pure TxCredit] + +arbitraryStoreOutput :: Gen Store.StoreOutput +arbitraryStoreOutput = + Store.StoreOutput + <$> arbitrary + <*> arbitraryBS1 + <*> arbitraryMaybe arbitrarySpender + <*> arbitraryMaybe arbitraryAddress + +arbitrarySpender :: Gen Store.Spender +arbitrarySpender = Store.Spender <$> arbitraryTxHash <*> arbitrary + +arbitraryStoreInput :: Gen Store.StoreInput +arbitraryStoreInput = + oneof + [ Store.StoreCoinbase + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> listOf arbitraryBS1, + Store.StoreInput + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryBS1 + <*> arbitrary + <*> listOf arbitraryBS1 + <*> arbitraryMaybe arbitraryAddress + ] + +arbitraryTxInfo :: Network -> Ctx -> Gen TxInfo +arbitraryTxInfo net ctx = + TxInfo + <$> arbitraryMaybe arbitraryTxHash + <*> arbitraryTxType + <*> arbitrary + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyOutputs) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryNatural) + ) + <*> resize 10 (listOf arbitraryStoreOutput) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryMyInputs net ctx) + ) + <*> ( Map.fromList + <$> resize + 10 + (listOf $ (,) <$> arbitraryAddress <*> arbitraryOtherInputs net ctx) + ) + <*> resize 10 (listOf arbitraryStoreInput) + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryBlockRef + <*> arbitraryNatural + <*> arbitraryMaybe arbitraryTxInfoPending + +arbitraryTxInfoPending :: Gen TxInfoPending +arbitraryTxInfoPending = + TxInfoPending + <$> arbitraryTxHash + <*> arbitrary + <*> arbitrary + +arbitraryAccountBackup :: Ctx -> Gen AccountBackup +arbitraryAccountBackup ctx = + AccountBackup + <$> arbitraryText + <*> arbitraryFingerprint + <*> arbitraryXPubKey ctx + <*> arbitraryNetwork + <*> arbitraryNatural + <*> arbitraryNatural + <*> ( Map.fromList + <$> resize 20 (listOf $ (,) <$> arbitraryAddress <*> arbitraryText) + ) + <*> resize 20 (listOf arbitraryAddress) + <*> arbitraryUTCTime + +arbitrarySyncRes :: Network -> Ctx -> Gen SyncRes +arbitrarySyncRes net ctx = + SyncRes + <$> arbitraryDBAccount net ctx + <*> arbitraryBlockHash + <*> arbitrary + <*> arbitraryNatural + <*> arbitraryNatural + +arbitraryResponse :: Network -> Ctx -> Gen Response +arbitraryResponse net ctx = + oneof + [ ResponseError <$> arbitraryText, + ResponseMnemonic + <$> arbitraryText + <*> resize 12 (listOf arbitraryText) + <*> resize 12 (listOf $ resize 12 $ listOf arbitraryText), + ResponseAccount <$> arbitraryDBAccount net ctx, + ResponseAccResult + <$> arbitraryDBAccount net ctx + <*> arbitrary + <*> arbitraryText, + ResponseFile <$> (cs <$> arbitraryText), + ResponseAccounts <$> resize 20 (listOf $ arbitraryDBAccount net ctx), + ResponseAddress <$> arbitraryDBAccount net ctx <*> arbitraryDBAddress net, + ResponseAddresses + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf $ arbitraryDBAddress net), + ResponseTxs + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf $ arbitraryTxInfo net ctx), + ResponseTx <$> arbitraryDBAccount net ctx <*> arbitraryTxInfo net ctx, + ResponseDeleteTx + <$> arbitraryTxHash + <*> arbitraryNatural + <*> arbitraryNatural, + ResponseCoins + <$> arbitraryDBAccount net ctx + <*> resize 20 (listOf arbitraryJsonCoin), + ResponseSync + <$> (resize 10 $ listOf $ arbitrarySyncRes net ctx), + ResponseRestore + <$> resize + 20 + ( listOf $ + (,,) + <$> arbitraryDBAccount net ctx + <*> arbitraryNatural + <*> arbitraryNatural + ), + ResponseVersion + <$> arbitraryText + <*> arbitraryText, + ResponseRollDice <$> resize 20 (listOf arbitraryNatural) <*> arbitraryText + ] + +arbitraryConfig :: Gen Config +arbitraryConfig = + Config + <$> arbitraryText + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitraryNatural + <*> arbitrary diff --git a/test/Haskoin/Wallet/VersionSpec.hs b/test/Haskoin/Wallet/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Wallet/VersionSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields -fno-warn-orphans #-} + +module Haskoin.Wallet.VersionSpec where + +import Haskoin.Wallet.TestUtils +import Haskoin.Wallet.Migration.SemVersion +import Test.Hspec +import Test.QuickCheck +import Test.Hspec.QuickCheck (prop) + +instance Arbitrary SemVersion where + arbitrary = + oneof + [ VerMajor <$> arbitraryNatural + , VerMinor <$> arbitraryNatural <*> arbitraryNatural + , VerPatch <$> arbitraryNatural <*> arbitraryNatural <*> arbitraryNatural + ] + +spec :: Spec +spec = + describe "Semantic Version" $ do + prop "parseSemVersion . verString identity" $ + forAll (arbitrary :: Gen SemVersion) $ \v -> + parseSemVersion (verString v) `shouldBe` v + it "passes equality tests" $ do + parseSemVersion "0" == parseSemVersion "0" `shouldBe` True + parseSemVersion "0" == parseSemVersion "0.9" `shouldBe` True + parseSemVersion "0" == parseSemVersion "0.9.0" `shouldBe` True + parseSemVersion "0.9" == parseSemVersion "0" `shouldBe` True + parseSemVersion "0.9.0" == parseSemVersion "0" `shouldBe` True + parseSemVersion "0.9" == parseSemVersion "0.9" `shouldBe` True + parseSemVersion "0.9" == parseSemVersion "0.9.1" `shouldBe` True + parseSemVersion "0.9.1" == parseSemVersion "0.9" `shouldBe` True + parseSemVersion "0.9.1" == parseSemVersion "0.9.1" `shouldBe` True + parseSemVersion "0" == parseSemVersion "1" `shouldBe` False + parseSemVersion "0.9" == parseSemVersion "1" `shouldBe` False + parseSemVersion "0.9.1" == parseSemVersion "1" `shouldBe` False + parseSemVersion "1" == parseSemVersion "0.9" `shouldBe` False + parseSemVersion "1" == parseSemVersion "0.9.1" `shouldBe` False + parseSemVersion "0.9" == parseSemVersion "0.8" `shouldBe` False + parseSemVersion "0.9" == parseSemVersion "0.8.1" `shouldBe` False + parseSemVersion "0.8.1" == parseSemVersion "0.9" `shouldBe` False + parseSemVersion "0.8.1" == parseSemVersion "0.8.2" `shouldBe` False + it "passes toMajor and toMinor tests" $ do + toMajor (parseSemVersion "0") `shouldBe` VerMajor 0 + toMajor (parseSemVersion "0.8") `shouldBe` VerMajor 0 + toMajor (parseSemVersion "0.8.1") `shouldBe` VerMajor 0 + toMinor (parseSemVersion "0.8") `shouldBe` VerMinor 0 8 + toMinor (parseSemVersion "0.8.1") `shouldBe` VerMinor 0 8 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main where - -import Test.Framework (defaultMain) - -import qualified Network.Haskoin.Wallet.Units (tests) -import qualified Network.Haskoin.Wallet.Tests (tests) - -import Network.Haskoin.Constants - -main :: IO () -main | networkName == "prodnet" = defaultMain - ( Network.Haskoin.Wallet.Tests.tests - ++ Network.Haskoin.Wallet.Units.tests - ) - | otherwise = error "Tests are only available on prodnet" - diff --git a/tests/Network/Haskoin/Wallet/Arbitrary.hs b/tests/Network/Haskoin/Wallet/Arbitrary.hs deleted file mode 100644 --- a/tests/Network/Haskoin/Wallet/Arbitrary.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.Haskoin.Wallet.Arbitrary where - -import Test.QuickCheck (Arbitrary, arbitrary, oneof) - -import Network.Haskoin.Test -import Network.Haskoin.Wallet - -instance Arbitrary AccountType where - arbitrary = oneof - [ return AccountRegular - , do - ArbitraryMSParam m n <- arbitrary - return $ AccountMultisig m n - ] - -instance Arbitrary NodeAction where - arbitrary = oneof [ NodeActionRescan <$> arbitrary - , return NodeActionStatus - ] - -instance Arbitrary TxAction where - arbitrary = oneof - [ do - as' <- arbitrary - let as = map (\(ArbitraryAddress a, x) -> (a, x)) as' - fee <- arbitrary - rcptFee <- arbitrary - minConf <- arbitrary - sign <- arbitrary - return $ CreateTx as fee rcptFee minConf sign - , do - ArbitraryTx tx <- arbitrary - return (ImportTx tx) - , SignTx <$> (arbitrary >>= \(ArbitraryTxHash h) -> return h) - ] - diff --git a/tests/Network/Haskoin/Wallet/Tests.hs b/tests/Network/Haskoin/Wallet/Tests.hs deleted file mode 100644 --- a/tests/Network/Haskoin/Wallet/Tests.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Network.Haskoin.Wallet.Tests (tests) where - -import Test.Framework (Test, testGroup) -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 - -tests :: [Test] -tests = - [ testGroup "Serialize & de-serialize types to JSON" - [ testProperty "AccountType" (metaID :: AccountType -> Bool) - , testProperty "TxAction" (metaID :: TxAction -> Bool) - , testProperty "NodeAction" (metaID :: NodeAction -> Bool) - ] - ] - -metaID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -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 deleted file mode 100644 --- a/tests/Network/Haskoin/Wallet/Units.hs +++ /dev/null @@ -1,1524 +0,0 @@ -{-# 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 = createBlockHeader - (blockVersion $ nodeHeader parent) - (nodeHash parent) - (if null tids then z else buildMerkleRoot tids) - (nodeTimestamp parent + 600) - (blockBits $ nodeHeader parent) - 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 = - createTx 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 = createTx - 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 <$> createWalletTx 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 = createTx - 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 <$> createWalletTx 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) -