haskoin-wallet 0.4.2 → 0.9.4

raw patch · 49 files changed

+8179/−8052 lines, 49 filesdep +Decimaldep +ansi-terminaldep +base16-bytestringdep −daemonsdep −deepseqdep −exceptionsdep ~HUnitdep ~QuickCheckdep ~aesonnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: Decimal, ansi-terminal, base16-bytestring, base64-bytestring, entropy, haskoin-store-data, hspec, http-types, lens, lens-aeson, optparse-applicative, pretty, random, raw-strings-qq, secp256k1-haskell, transformers, wreq

Dependencies removed: daemons, deepseq, exceptions, file-embed, filepath, haskoin-node, lifted-async, lifted-base, monad-control, persistent-template, resourcet, semigroups, stm, stm-chans, stm-conduit, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers-base, unix, yaml, zeromq4-haskell

Dependency ranges changed: HUnit, QuickCheck, aeson, aeson-pretty, base, bytestring, cereal, conduit, containers, data-default, directory, esqueleto, haskeline, haskoin-core, monad-logger, mtl, persistent, persistent-sqlite, split, string-conversions, text, time, unordered-containers

API changes (from Hackage documentation)

Files

• Network/Haskoin/Wallet.hs +0/−108
• Network/Haskoin/Wallet/Accounts.hs +0/−709
• Network/Haskoin/Wallet/Block.hs +0/−59
• Network/Haskoin/Wallet/Client.hs +0/−252
• Network/Haskoin/Wallet/Client/Commands.hs +0/−970
• Network/Haskoin/Wallet/Client/PrettyJson.hs +0/−23
• Network/Haskoin/Wallet/Database.hs +0/−17
• Network/Haskoin/Wallet/Internals.hs +0/−31
• Network/Haskoin/Wallet/Model.hs +0/−134
• Network/Haskoin/Wallet/Server.hs +0/−510
• Network/Haskoin/Wallet/Server/Handler.hs +0/−604
• Network/Haskoin/Wallet/Settings.hs +0/−196
• Network/Haskoin/Wallet/Transaction.hs +0/−1358
• Network/Haskoin/Wallet/Types.hs +0/−790
• Network/Haskoin/Wallet/Types/BlockInfo.hs +0/−77
• app/Main.hs +1/−3
• config/config.yml +0/−118
• config/help +0/−52
• config/models +0/−84
• examples/embedded-inproc-wallet-server/Main.hs +0/−183
• haskoin-wallet.cabal +188/−173
• src/Haskoin/Wallet.hs +24/−0
• src/Haskoin/Wallet/Amounts.hs +88/−0
• src/Haskoin/Wallet/Backup.hs +358/−0
• src/Haskoin/Wallet/Commands.hs +833/−0
• src/Haskoin/Wallet/Config.hs +114/−0
• src/Haskoin/Wallet/Database.hs +1424/−0
• src/Haskoin/Wallet/Entropy.hs +221/−0
• src/Haskoin/Wallet/FileIO.hs +131/−0
• src/Haskoin/Wallet/Main.hs +25/−0
• src/Haskoin/Wallet/Migration.hs +67/−0
• src/Haskoin/Wallet/Migration/SemVersion.hs +64/−0
• src/Haskoin/Wallet/Migration/V0_9_0.hs +198/−0
• src/Haskoin/Wallet/Parser.hs +1083/−0
• src/Haskoin/Wallet/PrettyPrinter.hs +547/−0
• src/Haskoin/Wallet/Signing.hs +310/−0
• src/Haskoin/Wallet/TxInfo.hs +403/−0
• src/Haskoin/Wallet/Util.hs +117/−0
• test/Haskoin/Wallet/AmountsSpec.hs +68/−0
• test/Haskoin/Wallet/CommandsSpec.hs +811/−0
• test/Haskoin/Wallet/EntropySpec.hs +265/−0
• test/Haskoin/Wallet/SigningSpec.hs +471/−0
• test/Haskoin/Wallet/TestUtils.hs +315/−0
• test/Haskoin/Wallet/VersionSpec.hs +52/−0
• test/Spec.hs +1/−0
• tests/Main.hs +0/−16
• tests/Network/Haskoin/Wallet/Arbitrary.hs +0/−37
• tests/Network/Haskoin/Wallet/Tests.hs +0/−24
• tests/Network/Haskoin/Wallet/Units.hs +0/−1524

@@ -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-

@@ -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-

@@ -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)

@@ -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 [<options>] <command> [<args>]"--cmdHelp :: [String]-cmdHelp = lines $ cs $ $(embedFile "config/help")--warningMsg :: String-warningMsg = unwords-    [ "!!!", "This software is experimental."-    , "Use only small amounts of Bitcoins.", "!!!"-    ]--usage :: [String]-usage = warningMsg : usageInfo usageHeader options : cmdHelp--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 "."-

@@ -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 "<no pubkey available>" (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 "<no pubkey available>" (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)"

@@ -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 }

@@ -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-

@@ -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-

@@ -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-    }-

@@ -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"

@@ -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-

@@ -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

@@ -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-

@@ -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-

@@ -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-

@@ -1,6 +1,4 @@-module Main where--import Network.Haskoin.Wallet.Client+import Haskoin.Wallet.Main  main :: IO () main = clientMain

@@ -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: