bitcoin-rpc (empty) → 0.5.0.0
raw patch · 9 files changed
+1450/−0 lines, 9 filesdep +HTTPdep +HUnitdep +QuickChecksetup-changed
Dependencies added: HTTP, HUnit, QuickCheck, aeson, attoparsec, base, bytestring, cereal, containers, ghc-prim, mtl, network, test-framework, test-framework-hunit, test-framework-quickcheck2, text, unix, unordered-containers, watchdog
Files
- LICENSE +29/−0
- Network/BitcoinRPC.hs +282/−0
- Network/BitcoinRPC/Events.hs +283/−0
- Network/BitcoinRPC/Events/MarkerAddresses.hs +97/−0
- Network/BitcoinRPC/MarkerAddresses.hs +259/−0
- Network/BitcoinRPC/Types.hs +252/−0
- Setup.hs +2/−0
- TestSuite.hs +152/−0
- bitcoin-rpc.cabal +94/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2012 - 2014, Jan Vornberger+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/BitcoinRPC.hs view
@@ -0,0 +1,282 @@+-- |+-- This library offers a wrapper around the RPC api of the Satoshi Bitcoin+-- daemon. It focuses on reliability and will automatically retry many of the+-- actions (indicated by the R suffix) if that can be done safely.+--+-- This library is written against a slightly modified version of the Satoshi+-- Bitcoin daemon which contains extra functionality required as part of the+-- operation of the Bridgewalker server ( <https://www.bridgewalkerapp.com/> ).+-- These patches can be found here:+-- <https://github.com/javgh/bitcoin/tree/bw-deployment> . For the most part it+-- should be compatible with a release version of the Satoshi Bitcoin daemon,+-- but some of the tests of the test suite might fail.+--+-- The library contains a mechanism by which a client of the library can+-- subscribe to new incoming Bitcoin transactions. See+-- "Network.BitcoinRPC.Events" for details.+--+-- Example usage:+--+-- > module Main where+-- >+-- > import Network.BitcoinRPC+-- >+-- > rpcAuth :: RPCAuth+-- > rpcAuth = RPCAuth "http://127.0.0.1:8332" "rpcuser" "localaccessonly"+-- >+-- > main :: IO ()+-- > main = getBlockCountR Nothing rpcAuth >>= print+--+-- Example output:+--+-- @+-- 278456+-- @+--++{-# LANGUAGE OverloadedStrings #-}+module Network.BitcoinRPC+ ( getBlockCountR+ , getBlockHashR+ , listSinceBlockR+ , getTransactionR+ , getRawTransactionR+ , getOriginsR+ , getNewAddressR+ , getBalanceR+ , validateAddressR+ , sendToAddress+ , module Network.BitcoinRPC.Types+ )+ where++import Control.Applicative+import Control.Watchdog+import Data.Aeson+import Data.Maybe+import Network.Browser+import Network.HTTP+import Network.URI+import Text.Printf++import qualified Control.Exception as E+import qualified Data.Attoparsec as AP+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8++import Network.BitcoinRPC.Types++errorCodeInvalidTransactionID :: Integer+errorCodeInvalidTransactionID = -5++errorCodeInvalidAddress :: Integer+errorCodeInvalidAddress = -5++errorCodeInsufficientFunds :: Integer+errorCodeInsufficientFunds = -4++errorCodeInvalidAmount :: Integer+errorCodeInvalidAmount = -3++ioTry :: IO a -> IO (Either E.IOException a)+ioTry = E.try++reliableApiCall :: Maybe WatchdogLogger -> IO (Either String a) -> IO a+reliableApiCall mLogger f = watchdog $ do+ case mLogger of+ Just logger -> setLoggingAction logger+ Nothing -> return ()+ watch f++-- | Make a call to the Bitcoin daemon, expecting that there will+-- be no RPC error. Network and other parse errors are signaled by a 'Left'+callApi :: RPCAuth-> B.ByteString -> B.ByteString -> IO (Either String Value)+callApi auth method params = do+ result <- callApiHelper auth method params+ return $ case result of+ Left e -> Left e+ Right (RPCSuccess v) -> Right v+ Right (RPCError {}) ->+ error $ "Unexpected RPC error when calling method "+ ++ B8.unpack method ++ ": " ++ show result++-- | Make a call to the Bitcoin daemon, expecting that there will+-- be only one specific type of RPC error possible. Network and+-- other parse errors are signaled by a 'Left', whereas the occurence+-- of that specific error code is signaled by 'Right Nothing'.+callApiFiltered :: RPCAuth-> B.ByteString-> B.ByteString-> Integer-> IO (Either String (Maybe Value))+callApiFiltered auth method params conceivableError = do+ result <- callApiHelper auth method params+ return $ case result of+ Left e -> Left e+ Right (RPCSuccess v) -> Right (Just v)+ Right (RPCError { rpcErrorCode = errCode }) ->+ if errCode == conceivableError+ then Right Nothing+ else error $ "Unexpected RPC error when calling method "+ ++ B8.unpack method ++ ": " ++ show result++-- | Make a call to the Bitcoin daemon and report all types of RPC errors.+-- Network and other parse errors are signaled by a 'Left', whereas the+-- occurence of RPC errors are signaled by 'Right Left errorCode'.+callApiCarefully :: RPCAuth-> B8.ByteString-> B8.ByteString-> IO (Either String (Either Integer Value))+callApiCarefully auth method params = do+ result <- callApiHelper auth method params+ return $ case result of+ Left e -> Left e+ Right (RPCSuccess v) -> Right (Right v)+ Right (RPCError { rpcErrorCode = errCode }) -> Right (Left errCode)++-- | Make a call to the Bitcoin daemon. 'Left' is returned when either+-- a network error occured or the response is not valid JSON or the JSON+-- structure is not in the expected format.+callApiHelper :: RPCAuth -> B.ByteString -> B.ByteString -> IO (Either String RPCResult)+callApiHelper auth method params = do+ let (+++) = B.append+ cmdStr =+ "{ \"id\": 0 " +++ ", \"method\": \"" +++ method +++ "\" " ++++ ", \"params\": " +++ params +++ " " ++++ "}"+ requestPayload = compileRequest uri cmdStr+ result <- ioTry . browse $ do+ setOutHandler $ const (return ())+ addAuthority rpcAuthority+ setAllowBasicAuth True+ request requestPayload+ return $ case result of+ Left e -> Left $ "IOException: " ++ show e+ Right (_, response) ->+ case jsonParse (rspBody response) of+ Left e' -> Left $ "JSON parse error: " ++ e'+ Right v -> case fromJSON v of+ (Error e'') -> Left $ "RPC parse error: " ++ e''+ (Success s) -> Right (s :: RPCResult)+ where+ rpcAuthority = AuthBasic { auRealm = "jsonrpc"+ , auUsername = rpcUser auth+ , auPassword = rpcPassword auth+ , auSite = uri+ }+ uri = fromMaybe (error "RPC-URL is malformed") $ parseURI (rpcUrl auth)+ jsonParse = AP.parseOnly json++compileRequest :: URI -> B.ByteString -> Request B.ByteString+compileRequest uri body =+ Request { rqURI = uri+ , rqMethod = POST+ , rqHeaders = [ Header HdrContentType "application/json"+ , Header HdrContentLength (show . B.length $ body)+ ]+ , rqBody = body+ }++parseReply :: (Monad m, FromJSON a) => String -> Value -> m a+parseReply method v =+ case fromJSON v of+ Success r -> return r+ Error _ -> error ("Unexpected result when calling method " ++ method)++getBlockCountR :: Maybe WatchdogLogger -> RPCAuth -> IO Integer+getBlockCountR mLogger auth = do+ v <- reliableApiCall mLogger $ callApi auth "getblockcount" "[]"+ parseReply "getblockcount" v :: IO Integer++getBlockHashR :: Maybe WatchdogLogger -> RPCAuth -> Integer -> IO BlockHash+getBlockHashR mLogger auth idx = do+ let params = "[" `B.append` (B8.pack . show) idx `B.append` "]"+ v <- reliableApiCall mLogger $ callApi auth "getblockhash" params+ parseReply "getblockhash" v :: IO BlockHash++listSinceBlockR :: Maybe WatchdogLogger-> RPCAuth -> Maybe BlockHash -> IO SinceBlockInfo+listSinceBlockR mLogger auth mBlockHash = do+ let params = case mBlockHash of+ Nothing -> "[]"+ Just hash -> "[\"" `B.append` blockHashAsByteString hash+ `B.append` "\"]"+ v <- reliableApiCall mLogger $ callApi auth "listsinceblock" params+ parseReply "listsinceblock" v :: IO SinceBlockInfo++getTransactionR :: Maybe WatchdogLogger-> RPCAuth -> TransactionID -> IO (Maybe TransactionHeader)+getTransactionR mLogger auth txid = do+ let params = "[\"" `B.append` txidAsByteString txid `B.append` "\"]"+ conceivableError = errorCodeInvalidTransactionID+ v <- reliableApiCall mLogger $+ callApiFiltered auth "gettransaction" params conceivableError+ case v of+ Just v' -> Just <$> parseReply "gettransaction" v'+ :: IO (Maybe TransactionHeader)+ Nothing -> return Nothing++getRawTransactionR :: Maybe WatchdogLogger-> RPCAuth -> TransactionID -> IO (Maybe SerializedTransaction)+getRawTransactionR mLogger auth txid = do+ let params = "[\"" `B.append` txidAsByteString txid `B.append` "\"]"+ conceivableError = errorCodeInvalidTransactionID+ v <- reliableApiCall mLogger $+ callApiFiltered auth "getrawtransaction" params conceivableError+ case v of+ Just v' -> Just <$> parseReply "getrawtransaction" v'+ :: IO (Maybe SerializedTransaction)+ Nothing -> return Nothing++getOriginsR :: Maybe WatchdogLogger-> RPCAuth -> TransactionID -> IO (Maybe TransactionOrigins)+getOriginsR mLogger auth txid = do+ let params = "[\"" `B.append` txidAsByteString txid `B.append` "\"]"+ conceivableError = errorCodeInvalidTransactionID+ v <- reliableApiCall mLogger $+ callApiFiltered auth "getorigins" params conceivableError+ case v of+ Just v' -> Just <$> parseReply "getorigins" v'+ :: IO (Maybe TransactionOrigins)+ Nothing -> return Nothing++getNewAddressR :: Maybe WatchdogLogger -> RPCAuth -> IO BitcoinAddress+getNewAddressR mLogger auth = do+ v <- reliableApiCall mLogger $ callApi auth "getnewaddress" "[]"+ parseReply "getnewaddress" v :: IO BitcoinAddress++getBalanceR :: Maybe WatchdogLogger -> RPCAuth -> Integer -> Bool -> IO BitcoinAmount+getBalanceR mLogger auth minconf filterGreenCoins = do+ let params = "[\"*\", " `B.append` (B8.pack . show) minconf `B.append`+ if filterGreenCoins+ then ", true]"+ else "]"+ v <- reliableApiCall mLogger $ callApi auth "getbalance" params+ parseReply "getbalance" v :: IO BitcoinAmount++validateAddressR :: Maybe WatchdogLogger-> RPCAuth -> BitcoinAddress -> IO BitcoinAddressInfo+validateAddressR mLogger auth addr = do+ let params = "[\"" `B.append` addressAsByteString addr `B.append` "\"]"+ v <- reliableApiCall mLogger $ callApi auth "validateaddress" params+ parseReply "validateaddress" v :: IO BitcoinAddressInfo++-- | Send Bitcoins to an address. This is not available in a reliable+-- version, because of the risk of ending up in some type of loop and sending+-- funds multiple types. Instead, network and parse errors are signaled with+-- a 'Left' whereas a successful call will produce a 'Right' which contains+-- another 'Either'. This one differentiates between 'SendError' and a+-- successful transaction resulting in a 'TransactionID'.+--+-- It is recommended to call a reliable function like 'validateAddressR' shortly+-- before attempting to use 'sendToAddress'. The former will only return when a+-- connection to the Bitcoin daemon exists, therefore minimizing the risk that+-- 'sendToAddress' will encounter any network problems afterwards.+sendToAddress :: RPCAuth-> BitcoinAddress-> BitcoinAmount-> IO (Either String (Either SendError TransactionID))+sendToAddress auth addr amount = do+ let intAmount = btcAmount amount+ doubleAmount = fromInteger intAmount / 10 ^ (8 :: Integer)+ strAmount = printf "%.8f" (doubleAmount :: Double)+ params = "[\"" `B.append` addressAsByteString addr `B.append`+ "\"," `B.append` B8.pack strAmount `B.append` "]"+ v <- callApiCarefully auth "sendtoaddress" params+ case v of+ Left e -> return $ Left e+ Right (Left errCode) -> return $ Right (Left (translateError errCode))+ Right (Right v') -> do+ r <- parseReply "sendtoaddress" v' :: IO TransactionID+ return $ Right (Right r)+ where+ translateError code+ | code == errorCodeInvalidAddress = InvalidAddress+ | code == errorCodeInsufficientFunds = InsufficientFunds+ | code == errorCodeInvalidAmount = InvalidAmount+ | otherwise = OtherError
+ Network/BitcoinRPC/Events.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DeriveGeneric #-}+-- |+-- This module provides a mechanism by which a client of the library can+-- subscribe to new incoming Bitcoin transactions. To facilitate this, the+-- library requires an external tool to send USR1 or USR2 signals whenever+-- wallet activity takes place. The library will write its process id to a+-- provided file for this purpose. An external tool like PidNotifier (+-- <https://github.com/javgh/PidNotifier> ) can then be used in combination with+-- the -walletnotify feature of the Satoshi Bitcoin daemon to notify the+-- library. The library will then use commands like listsinceblock and an+-- internal state to figure out which transactions are new, if any, and provide+-- those to the subscribed client.+--+-- How to use:+--+-- 1. Use 'initBitcoinEventTask' to start a thread which will listen for Bitcoin+-- events.+--+-- 2. Use 'waitForBitcoinEvents' to listen for event updates. Every batch of+-- updates will also include a new state description, which can be passed to+-- 'initBitcoinEventTask' when it needs to be restarted.+--+-- Note: For every new transaction you are guaranteed to receive a+-- 'NewTransaction' as well as either a 'TransactionAccepted' or+-- 'TransactionDisappeared'. Usually you will also receive 'TransactionUpdate'+-- when the number of confirmations change, but these events might not be+-- generated if you are catching up from an old state.+--+-- Example usage:+--+-- > module Main where+-- >+-- > import Control.Monad+-- > import System.Environment+-- > import System.Exit+-- >+-- > import Network.BitcoinRPC+-- > import Network.BitcoinRPC.Events+-- >+-- > acceptTest :: TransactionHeader -> Bool+-- > acceptTest txHeader = thConfirmations txHeader >= 3+-- >+-- > rpcAuth :: RPCAuth+-- > rpcAuth = RPCAuth "http://127.0.0.1:8332" "rpcuser" "localaccessonly"+-- >+-- > main :: IO ()+-- > main = do+-- > args <- getArgs+-- > progName <- getProgName+-- > when (null args) $ do+-- > putStrLn $ "Usage: " ++ progName ++ " <path to notify pid file>"+-- > exitFailure+-- > let pidfile = head args+-- >+-- > betHandle <- initBitcoinEventTask Nothing rpcAuth pidfile+-- > acceptTest initialEventTaskState+-- > forever $ do+-- > (_, events) <- waitForBitcoinEvents betHandle+-- > mapM print events+--+-- Example output:+--+-- @+-- NewTransaction {beUTxID = UniqueTransactionID {uTxID = TransactionID {btcTxID =+-- "fc96f113e87a031de7d6e066613f216cfb18f37da9cade0c78cfd7a81272124e"}, uEntry =+-- 0}, beTx = ReceiveTx {tEntry = 0, tAmount = BitcoinAmount {btcAmount = 20741},+-- tAddress = BitcoinAddress {btcAddress = "1ATeVDCQHjEePi7R66ivSTpz3SdkbyCV2a"},+-- tConfirmations = 1867, tTxid = TransactionID {btcTxID =+-- "fc96f113e87a031de7d6e066613f216cfb18f37da9cade0c78cfd7a81272124e"}, tTime =+-- 1387825867}, beOrigins = [BitcoinAddress {btcAddress =+-- "1NhPxwJ6mCr5auoQzzqr4qVd1w65zzJw8r"}]}+-- TransactionAccepted {beUTxID = UniqueTransactionID {uTxID = TransactionID+-- {btcTxID = "fc96f113e87a031de7d6e066613f216cfb18f37da9cade0c78cfd7a81272124e"},+-- uEntry = 0}}+-- @+--++{-# LANGUAGE OverloadedStrings, CPP #-}+module Network.BitcoinRPC.Events+ ( initialEventTaskState+ , initBitcoinEventTask+ , waitForBitcoinEvents+ , killBitcoinEventTask+ , BitcoinEvent(..)+ , UniqueTransactionID(..)+ , EventTaskState+ , BitcoinEventTaskHandle+#if !PRODUCTION+ , LSBCheckpoint(..)+ , determineNewTransactions+#endif+ ) where++import Control.Concurrent+import Control.Watchdog+import Data.Serialize+import GHC.Generics+import System.Posix.Process+import System.Posix.Signals++import qualified Data.Map as M++import Network.BitcoinRPC++-- | How deep in the block chain does a block need to be so that it+-- is considered final - i.e. will not change because of a re-org.+lsbBlockDepth :: Integer+lsbBlockDepth = 100++data BitcoinEventTaskHandle = BitcoinEventTaskHandle+ { bethChan ::+ Chan (EventTaskState, [BitcoinEvent])+ , bethThreadId :: ThreadId+ }++-- | Create identifier that can differentiate between the outgoing and incoming+-- side of the same transaction id. Slightly confusing as this means that a+-- single Bitcoin transaction can result in multiple unique transactions.+data UniqueTransactionID = UniqueTransactionID { uTxID :: TransactionID+ , uEntry :: Integer+ }+ deriving (Eq, Ord, Show, Read, Generic)++-- | Keep track on how we need to call 'listsinceblock' next to get+-- everything new that happened.+data LSBCheckpoint = LSBCheckpoint { lsbBlockHash :: Maybe BlockHash+ , lsbKnownTxIDs :: [TransactionID]+ }+ deriving (Eq,Show,Read,Generic)++-- | Keeps track of confirmation count for recent unique transactions.+type UTXPool = M.Map UniqueTransactionID Integer++data EventTaskState = EventTaskState { etsLSBCheckpoint :: LSBCheckpoint+ , etsPool :: UTXPool+ }+ deriving (Show,Generic)++data BitcoinEvent = NewTransaction { beUTxID :: UniqueTransactionID+ , beTx :: Transaction+ , beOrigins :: [BitcoinAddress]+ }+ | TransactionUpdate { beUTxID :: UniqueTransactionID+ , beConfirmations :: Integer+ }+ | TransactionAccepted { beUTxID :: UniqueTransactionID }+ | TransactionDisappeared { beUTxID :: UniqueTransactionID }+ deriving (Show)++instance Serialize UniqueTransactionID++instance Serialize LSBCheckpoint++instance Serialize EventTaskState++initialEventTaskState :: EventTaskState+initialEventTaskState = EventTaskState { etsLSBCheckpoint =+ LSBCheckpoint Nothing []+ , etsPool = M.empty+ }++getUniqueTransactionID :: Transaction -> UniqueTransactionID+getUniqueTransactionID tx = UniqueTransactionID (tTxid tx) (tEntry tx)++onlyReceive :: Transaction -> Bool+onlyReceive ReceiveTx{} = True+onlyReceive _ = False++getNewBitcoinEvents :: Maybe WatchdogLogger-> RPCAuth-> (TransactionHeader -> Bool)-> EventTaskState-> IO (EventTaskState, [BitcoinEvent])+getNewBitcoinEvents mLogger auth acceptTest (EventTaskState lsbCheckpoint utxPool) = do+ (lsbCheckpoint', newTxs) <- getNewTransactions mLogger auth lsbCheckpoint+ let newReceiveTxs = filter onlyReceive newTxs+ newPoolEntries = map (\tx -> (getUniqueTransactionID tx, 0)) newReceiveTxs+ utxPool' = utxPool `M.union` M.fromList newPoolEntries+ appearingEvents <- mapM (augmentNewTransaction mLogger auth) newReceiveTxs+ (utxPool'', updateEvents) <- updatePool mLogger auth acceptTest utxPool'+ let newState = EventTaskState lsbCheckpoint' utxPool''+ return (newState, appearingEvents ++ updateEvents)++updatePool :: Maybe WatchdogLogger-> RPCAuth-> (TransactionHeader -> Bool)-> M.Map UniqueTransactionID Integer-> IO (M.Map UniqueTransactionID Integer, [BitcoinEvent])+updatePool mLogger auth acceptTest utxPool = go utxPool (M.toList utxPool)+ where+ go pool [] = return (pool, [])+ go pool ((utxid, confs):entries) = do+ -- Note: This will sometimes make redundant calls to gettransaction,+ -- but keeps things a little simpler.+ probe <- getTransactionR mLogger auth (uTxID utxid)+ let (pool', events) = checkUpdate acceptTest pool utxid confs probe+ (pool'', moreEvents) <- go pool' entries+ return (pool'', events ++ moreEvents)++checkUpdate :: (TransactionHeader -> Bool)-> M.Map UniqueTransactionID Integer-> UniqueTransactionID-> Integer-> Maybe TransactionHeader-> (M.Map UniqueTransactionID Integer, [BitcoinEvent])+checkUpdate acceptTest pool utxid confs (Just updatedTxHeader)+ | thConfirmations updatedTxHeader == confs = (pool, [])+ | otherwise = if acceptTest updatedTxHeader+ then (M.delete utxid pool, [TransactionAccepted utxid])+ else let updatedConfs = thConfirmations updatedTxHeader+ in (M.insert utxid updatedConfs pool,+ [TransactionUpdate utxid updatedConfs])+checkUpdate _ pool utxid _ Nothing =+ (M.delete utxid pool, [TransactionDisappeared utxid])++augmentNewTransaction :: Maybe WatchdogLogger -> RPCAuth -> Transaction -> IO BitcoinEvent+augmentNewTransaction mLogger auth tx = do+ let txid = tTxid tx+ utxid = getUniqueTransactionID tx+ probe <- getOriginsR mLogger auth txid+ return $ case probe of+ Just txOrigins -> NewTransaction utxid tx (toOrigins txOrigins)+ Nothing -> NewTransaction utxid tx []++getNewTransactions :: Maybe WatchdogLogger -> RPCAuth -> LSBCheckpoint -> IO (LSBCheckpoint, [Transaction])+getNewTransactions mLogger auth lsbCheckpoint = do+ -- get (possibly) new transactions+ SinceBlockInfo txs _ <- listSinceBlockR mLogger auth (lsbBlockHash lsbCheckpoint)+ -- pick a block somewhat deep in the blockchain for the next query+ blockCount <- getBlockCountR mLogger auth+ let safeBlockHeight = max 0 (blockCount - lsbBlockDepth)+ safeBlockHash <- getBlockHashR mLogger auth safeBlockHeight+ let lsbCheckpoint' = lsbCheckpoint { lsbBlockHash = Just safeBlockHash }+ return $ determineNewTransactions lsbCheckpoint' txs++-- | Figure out which are actual new transactions and update+-- pool of known transaction ids. We simply keep the current list of+-- transactions returned by listsinceblock and check against it the next time.+-- This should work, as long as transactions never reappear after the have+-- dropped of the list. This should be true, as long as blockcount is always+-- increasing.+determineNewTransactions :: LSBCheckpoint -> [Transaction] -> (LSBCheckpoint, [Transaction])+determineNewTransactions (LSBCheckpoint mBlockHash knownTxIDs) txList =+ let newTransactions = filter (\tx -> tTxid tx `notElem` knownTxIDs) txList+ knownTxIDs' = map tTxid txList+ in ((LSBCheckpoint mBlockHash knownTxIDs'), newTransactions)++setupBitcoinNotifcation :: FilePath -> IO (MVar ())+setupBitcoinNotifcation path = do+ pid <- getProcessID+ writeFile path (show pid ++ "\n")+ installSignalHandlers++installSignalHandlers :: IO (MVar ())+installSignalHandlers = do+ semaphore <- newMVar ()+ _ <- installHandler userDefinedSignal1 (Catch $ signalHandler semaphore) Nothing+ _ <- installHandler userDefinedSignal2 (Catch $ signalHandler semaphore) Nothing+ return semaphore+ where+ signalHandler semaphore = putMVar semaphore ()++notifiedPollLoop :: MVar ()-> Maybe WatchdogLogger-> RPCAuth-> (TransactionHeader -> Bool)-> EventTaskState-> Chan (EventTaskState, [BitcoinEvent])-> IO ()+notifiedPollLoop semaphore mLogger auth acceptTest firstState chan = go firstState+ where+ go state = do+ _ <- takeMVar semaphore -- Will succeed right away the first time,+ -- then later only after signals have been+ -- received.+ (state', events) <- getNewBitcoinEvents mLogger auth acceptTest state+ writeChan chan (state', events)+ go state'++initBitcoinEventTask :: Maybe WatchdogLogger+ -> RPCAuth+ -> FilePath -- ^ PID will be written here to get+ -- notifications from Bitcoin daemon+ -> (TransactionHeader -> Bool)+ -- ^ test to decide whether a transaction+ -- can be accepted+ -> EventTaskState -- ^ state from which to resume+ -> IO (BitcoinEventTaskHandle)+initBitcoinEventTask mLogger auth pidfile acceptTest state = do+ chan <- newChan+ semaphore <- setupBitcoinNotifcation pidfile+ threadId <-+ forkIO $ notifiedPollLoop semaphore mLogger auth acceptTest state chan+ return $ BitcoinEventTaskHandle chan threadId++-- | Wait for new Bitcoin Events. This might sometimes return an empty list of+-- events.+waitForBitcoinEvents :: BitcoinEventTaskHandle -> IO (EventTaskState, [BitcoinEvent])+waitForBitcoinEvents betHandle = readChan (bethChan betHandle)++killBitcoinEventTask :: BitcoinEventTaskHandle -> IO ()+killBitcoinEventTask betHandle = killThread (bethThreadId betHandle)
+ Network/BitcoinRPC/Events/MarkerAddresses.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric #-}++-- | Provides some glue code to use the module 'Network.BitcoinRPC.MarkerAddresses'+-- in combination with 'Network.BitcoinRPC.Events' and automatically filter+-- everything based on the marker address settings.++module Network.BitcoinRPC.Events.MarkerAddresses+ ( initialFilteredEventTaskState+ , initFilteredBitcoinEventTask+ , waitForFilteredBitcoinEvents+ , killFilteredBitcoinEventTask+ , updateMarkerAddresses+ , listPendingTransactions+ , listMarkerAdressStatus+ , FilteredBitcoinEventTaskHandle+ , FilteredEventTaskState+ , MA.PendingReason(..)+ , MA.FilteredBitcoinEvent(..)+ ) where++import Control.Concurrent+import Control.Watchdog+import Data.Serialize+import GHC.Generics++import Network.BitcoinRPC+import Network.BitcoinRPC.Events++import qualified Network.BitcoinRPC.MarkerAddresses as MA++data FilteredBitcoinEventTaskHandle = FilteredBitcoinEventTaskHandle+ { fbetBetHandle :: BitcoinEventTaskHandle+ , fbetWrappedMAStore :: MVar MA.MAStore+ }++data FilteredEventTaskState = FilteredEventTaskState+ { fetsMAStore :: MA.MAStore+ , fetsEventTaskState :: EventTaskState+ }+ deriving (Show, Generic)++instance Serialize FilteredEventTaskState++-- | Returns an initial 'FilteredEventTaskState' with no marker addresses+-- configured. Use 'updateMarkerAddresses' to add marker addresses.+initialFilteredEventTaskState :: FilteredEventTaskState+initialFilteredEventTaskState =+ FilteredEventTaskState { fetsMAStore = MA.initMarkerAddressStore []+ , fetsEventTaskState = initialEventTaskState+ }++updateMarkerAddresses :: FilteredEventTaskState-> [(BitcoinAddress, BitcoinAmount)] -> FilteredEventTaskState+updateMarkerAddresses state markerAddresses =+ let maStore' = MA.updateMarkerAddresses (fetsMAStore state) markerAddresses+ in state { fetsMAStore = maStore' }++listPendingTransactions :: FilteredEventTaskState -> [(Transaction, MA.PendingReason)]+listPendingTransactions state = MA.listPendingTransactions (fetsMAStore state)++listMarkerAdressStatus :: FilteredEventTaskState-> [(BitcoinAddress, Bool, BitcoinAmount, BitcoinAmount)]+listMarkerAdressStatus state = MA.listMarkerAdressStatus (fetsMAStore state)++initFilteredBitcoinEventTask :: Maybe WatchdogLogger+ -> RPCAuth+ -> FilePath -- ^ PID will be written here to get+ -- notifications from Bitcoin daemon+ -> (TransactionHeader -> Bool)+ -- ^ test to decide whether a+ -- transaction can be accepted+ -> FilteredEventTaskState -- ^ state from+ -- which to resume+ -> IO (FilteredBitcoinEventTaskHandle)+initFilteredBitcoinEventTask mLogger auth pidfile acceptTest state = do+ betHandle <- initBitcoinEventTask mLogger auth pidfile+ acceptTest (fetsEventTaskState state)+ wrappedMAStore <- newMVar $ fetsMAStore state+ return $ FilteredBitcoinEventTaskHandle betHandle wrappedMAStore++-- | Wait for new Bitcoin events, but already filter them based on the+-- marker address configuration. This might sometimes return an empty list of+-- events.+waitForFilteredBitcoinEvents :: FilteredBitcoinEventTaskHandle-> IO (FilteredEventTaskState, [MA.FilteredBitcoinEvent])+waitForFilteredBitcoinEvents fbetHandle = do+ let betHandle = fbetBetHandle fbetHandle+ maStore <- readMVar $ fbetWrappedMAStore fbetHandle+ (etState', events) <- waitForBitcoinEvents betHandle+ let (maStore', fEvents) = MA.processEvents maStore events+ _ <- swapMVar (fbetWrappedMAStore fbetHandle) maStore'+ let fbetState = FilteredEventTaskState+ { fetsMAStore = maStore'+ , fetsEventTaskState = etState'+ }+ return (fbetState, fEvents)++killFilteredBitcoinEventTask :: FilteredBitcoinEventTaskHandle -> IO ()+killFilteredBitcoinEventTask fbetHandle =+ killBitcoinEventTask (fbetBetHandle fbetHandle)
+ Network/BitcoinRPC/MarkerAddresses.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings #-}+module Network.BitcoinRPC.MarkerAddresses+ ( initMarkerAddressStore+ , updateMarkerAddresses+ , processEvents+ , listPendingTransactions+ , listMarkerAdressStatus+ , MAStore+ , PendingReason(..)+ , FilteredBitcoinEvent(..)+#if !PRODUCTION+ , sumAcceptedMarkerAmounts+#endif+ ) where++import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import Data.Serialize+import GHC.Generics++import qualified Data.Map as M++import Network.BitcoinRPC+import Network.BitcoinRPC.Events++data FilteredBitcoinEvent = FilteredNewTransaction { fntTx :: Transaction+ , fntConfs :: Integer+ , fntMarkerAddress ::+ Maybe BitcoinAddress+ }+ | MarkerAddressBreached { fntTx :: Transaction+ , fntBreachedMarkerAddress ::+ BitcoinAddress+ }+ deriving (Show)++data PendingReason = TooFewConfirmations { prConfs :: Integer }+ | MarkerAddressLimitReached { prMarkerAddress :: BitcoinAddress }+ deriving (Show)++data MarkerAddressDetails = MarkerAddressDetails { madActive :: Bool+ , madLimit :: BitcoinAmount+ , madPendingAmount :: BitcoinAmount+ }+ deriving (Show, Generic)++type MarkerAddressesConf = M.Map BitcoinAddress MarkerAddressDetails++data PendingStatus = StandardTransaction+ | PendingMarkerTransaction { _psMarkerAddress :: BitcoinAddress }+ | AcceptedMarkerTransaction { _psMarkerAddress :: BitcoinAddress }+ deriving (Show, Generic)++data PendingTransaction = PendingTransaction { ptTx :: Transaction+ , ptConfs :: Integer+ , ptStatus :: PendingStatus+ }+ deriving (Show, Generic)++type PendingTransactions = M.Map UniqueTransactionID PendingTransaction++data MAStore = MAStore { masConf :: MarkerAddressesConf+ , masPending :: PendingTransactions+ }+ deriving (Show, Generic)++instance Serialize MarkerAddressDetails++instance Serialize PendingTransaction++instance Serialize PendingStatus++instance Serialize MAStore++initMarkerAddressStore :: [(BitcoinAddress, BitcoinAmount)] -> MAStore+initMarkerAddressStore markerAddresses =+ let confList = map transformMarkerAddresses markerAddresses+ in MAStore (M.fromList confList) M.empty++updateMarkerAddresses :: MAStore -> [(BitcoinAddress, BitcoinAmount)] -> MAStore+updateMarkerAddresses store markerAddresses =+ let confList = map transformMarkerAddresses markerAddresses+ in store { masConf = M.fromList confList }++transformMarkerAddresses :: (BitcoinAddress, BitcoinAmount) -> (BitcoinAddress, MarkerAddressDetails)+transformMarkerAddresses (addr, limit) =+ (addr, MarkerAddressDetails True limit 0)++listMarkerAdressStatus :: MAStore -> [(BitcoinAddress, Bool, BitcoinAmount, BitcoinAmount)]+listMarkerAdressStatus store = map format $ M.toList (masConf store)+ where+ format (ma, MarkerAddressDetails active limit pendingAmount) =+ (ma, active, limit, pendingAmount)++listPendingTransactions :: MAStore -> [(Transaction, PendingReason)]+listPendingTransactions store =+ let pendingTransactions = concatMap format $ M.toList (masPending store)+ in sortBy (comparing (tTime . fst)) pendingTransactions+ where+ format (_, PendingTransaction tx confs status) =+ case status of+ StandardTransaction -> [(tx, TooFewConfirmations confs)]+ PendingMarkerTransaction ma -> [(tx, MarkerAddressLimitReached ma)]+ AcceptedMarkerTransaction _ -> []++processEvents :: MAStore -> [BitcoinEvent] -> (MAStore, [FilteredBitcoinEvent])+processEvents store events =+ let (store', fEventsA) = foldl' updateStore (store, []) events+ amountList = sumAcceptedMarkerAmounts . listAcceptedMarkerAmounts $ store'+ store'' = setPendingMarkerAmounts store' amountList+ (store''', fEventsB) = checkPendingMarkerTransactions store''+ in (store''', fEventsA ++ fEventsB)++checkPendingMarkerTransactions :: MAStore -> (MAStore, [FilteredBitcoinEvent])+checkPendingMarkerTransactions store =+ let txs = M.toList (masPending store)+ in foldl' checkPendingMarkerTransaction (store, []) txs++checkPendingMarkerTransaction :: (MAStore, [FilteredBitcoinEvent])-> (UniqueTransactionID, PendingTransaction)-> (MAStore, [FilteredBitcoinEvent])+checkPendingMarkerTransaction (store, fevents) (utxid, pendingTransaction) =+ case ptStatus pendingTransaction of+ StandardTransaction -> (store, fevents)+ AcceptedMarkerTransaction _ -> (store, fevents)+ PendingMarkerTransaction ma ->+ let tx = ptTx pendingTransaction+ amount = tAmount tx+ in if isWithinLimit store ma amount+ then let store' = adjustPendingAmount store ma (+ amount)+ pendingTransaction' =+ pendingTransaction { ptStatus =+ AcceptedMarkerTransaction ma }+ masPending' = M.insert utxid pendingTransaction'+ (masPending store')+ confs = ptConfs pendingTransaction+ fEvent = FilteredNewTransaction tx confs (Just ma)+ in (store' { masPending = masPending' }, fevents ++ [fEvent])+ else (store, fevents)++isWithinLimit :: MAStore -> BitcoinAddress -> BitcoinAmount -> Bool+isWithinLimit store markerAddress amount =+ case M.lookup markerAddress (masConf store) of+ Nothing -> False+ Just details ->+ madActive details && madPendingAmount details + amount <= madLimit details++setPendingMarkerAmounts :: MAStore -> [(BitcoinAddress, BitcoinAmount)] -> MAStore+setPendingMarkerAmounts = foldl' go+ where+ go store (ma, amount) = adjustPendingAmount store ma (\_ -> amount)++adjustPendingAmount :: MAStore-> BitcoinAddress -> (BitcoinAmount -> BitcoinAmount) -> MAStore+adjustPendingAmount store ma f =+ let mDetails = M.lookup ma (masConf store)+ in case mDetails of+ Nothing -> store+ Just details ->+ let pendingAmount = madPendingAmount details+ details' = details { madPendingAmount = f pendingAmount }+ masConf' = M.insert ma details' (masConf store)+ in store { masConf = masConf' }++listAcceptedMarkerAmounts :: MAStore -> [(BitcoinAddress, BitcoinAmount)]+listAcceptedMarkerAmounts store =+ let zeroes = map (\(ma, _) -> (ma, 0)) $ M.toList (masConf store)+ amounts = concatMap extract $ M.toList (masPending store)+ in zeroes ++ amounts+ where+ extract (_, pendingTransaction) =+ case ptStatus pendingTransaction of+ StandardTransaction -> []+ PendingMarkerTransaction _ -> []+ AcceptedMarkerTransaction ma ->+ [(ma, tAmount (ptTx pendingTransaction))]++sumAcceptedMarkerAmounts :: [(BitcoinAddress, BitcoinAmount)] -> [(BitcoinAddress, BitcoinAmount)]+sumAcceptedMarkerAmounts =+ map (foldl1' sumAmounts) . filter (not . null) .+ groupBy ((==) `on` fst) . sortBy (comparing fst)+ where+ sumAmounts :: (BitcoinAddress, BitcoinAmount) -> (BitcoinAddress, BitcoinAmount) -> (BitcoinAddress, BitcoinAmount)+ sumAmounts (ma1, x) (ma2, y) =+ if ma1 == ma2+ then (ma1, x + y)+ else error ("Implementation error: Expected to be summing"+ ++ " data for the same marker address.")++updateStore :: (MAStore, [FilteredBitcoinEvent])-> BitcoinEvent -> (MAStore, [FilteredBitcoinEvent])+updateStore (store, fEvents) (NewTransaction utxid tx origins) =+ let pendingTransaction =+ case isFromMarkerAddress (masConf store) origins of+ Nothing -> PendingTransaction tx 0 StandardTransaction+ Just origin -> PendingTransaction tx 0+ (PendingMarkerTransaction origin)+ masPending' = M.insert utxid pendingTransaction (masPending store)+ in (store { masPending = masPending' }, fEvents)+updateStore (store, fEvents) (TransactionUpdate utxid confs) =+ let pendingTransaction = lookupPendingTransaction store utxid+ pendingTransaction' = pendingTransaction { ptConfs = confs }+ masPending' = M.insert utxid pendingTransaction' (masPending store)+ in (store { masPending = masPending' }, fEvents)+updateStore (store, fEvents) (TransactionAccepted utxid) =+ let pendingTransaction = lookupPendingTransaction store utxid+ tx = ptTx pendingTransaction+ confs = ptConfs pendingTransaction+ masPending' = M.delete utxid (masPending store)+ maybeFEvents = case ptStatus pendingTransaction of+ StandardTransaction ->+ [FilteredNewTransaction tx confs Nothing]+ PendingMarkerTransaction psMA ->+ [FilteredNewTransaction tx confs (Just psMA)]+ AcceptedMarkerTransaction _ ->+ [] -- has already been returned earlier+ in (store { masPending = masPending' }, fEvents ++ maybeFEvents)+updateStore (store, _) (TransactionDisappeared utxid) =+ let pendingTransaction = lookupPendingTransaction store utxid+ (store', maybeFEvents) =+ case ptStatus pendingTransaction of+ StandardTransaction -> (store, [])+ PendingMarkerTransaction address ->+ ( disableMarkerAddress store address+ , [MarkerAddressBreached+ (ptTx pendingTransaction) address]+ )+ AcceptedMarkerTransaction address ->+ ( disableMarkerAddress store address+ , [MarkerAddressBreached+ (ptTx pendingTransaction) address]+ )+ masPending' = M.delete utxid (masPending store')+ in (store' { masPending = masPending' }, maybeFEvents)++disableMarkerAddress :: MAStore -> BitcoinAddress -> MAStore+disableMarkerAddress store address =+ let details = lookupMarkerAddressDetails store address+ details' = details { madActive = False }+ masConf' = M.insert address details' (masConf store)+ in store { masConf = masConf' }++lookupMarkerAddressDetails :: MAStore -> BitcoinAddress -> MarkerAddressDetails+lookupMarkerAddressDetails store address =+ fromMaybe (error ("Inconsistency: Failed to lookup details"+ ++ " for a marker address that is in use."))+ (M.lookup address (masConf store))++lookupPendingTransaction :: MAStore -> UniqueTransactionID -> PendingTransaction+lookupPendingTransaction store utxid =+ fromMaybe (error ("Inconsistency: Received an update for a"+ ++ " transaction that I have not seen before."))+ (M.lookup utxid (masPending store))++isFromMarkerAddress :: Ord a => M.Map a b -> [a] -> Maybe a+isFromMarkerAddress conf = go+ where+ go [] = Nothing+ go (o:os) = if M.member o conf+ then Just o+ else go os
+ Network/BitcoinRPC/Types.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Network.BitcoinRPC.Types+ ( BitcoinAmount(..)+ , BitcoinAddress(..)+ , TransactionID(..)+ , BlockHash(..)+ , RPCAuth(..)+ , Transaction(..)+ , TransactionHeader(..)+ , TransactionOrigins(..)+ , SerializedTransaction(..)+ , BitcoinAddressInfo(..)+ , SinceBlockInfo(..)+ , RPCResult(..)+ , SendError(..)+ , txidAsByteString+ , addressAsByteString+ , blockHashAsByteString+ )+ where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Aeson.Types+import Data.Maybe+import Data.Serialize+import GHC.Generics++import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Text.Encoding as E++newtype BitcoinAmount = BitcoinAmount { btcAmount :: Integer }+ deriving (Eq,Ord,Show,Read,Generic)++newtype BitcoinAddress = BitcoinAddress { btcAddress :: T.Text }+ deriving (Eq,Ord,Show,Read)++newtype TransactionID = TransactionID { btcTxID :: T.Text }+ deriving (Eq,Ord,Show,Read)++newtype SerializedTransaction = SerializedTransaction+ { btcSerializedTx :: T.Text }+ deriving (Eq,Ord,Show,Read)++newtype BlockHash = BlockHash { btcBlockHash :: T.Text }+ deriving (Eq,Ord,Show,Read)++data RPCAuth = RPCAuth { rpcUrl :: String+ , rpcUser :: String+ , rpcPassword :: String+ }+ deriving (Show)++data Transaction = ReceiveTx { tEntry :: Integer+ , tAmount :: BitcoinAmount+ , tAddress :: BitcoinAddress+ , tConfirmations :: Integer+ , tTxid :: TransactionID+ , tTime :: Integer+ }+ | SendTx { tEntry :: Integer+ , tAmount :: BitcoinAmount+ , tAddress :: BitcoinAddress+ , tFee :: BitcoinAmount+ , tConfirmations :: Integer+ , tTxid :: TransactionID+ , tTime :: Integer+ }+ | MoveTx { tTime :: Integer }+ | GenerateTx { tEntry :: Integer+ , tAmount :: BitcoinAmount+ , tConfirmations :: Integer+ , tTxid :: TransactionID+ , tTime :: Integer+ }+ deriving (Eq,Show,Read,Generic)+++data TransactionHeader = TransactionHeader { thAmount :: BitcoinAmount+ , thConfirmations :: Integer+ , thTxid :: TransactionID+ , thTime :: Integer+ }+ deriving (Show)++data TransactionOrigins = TransactionOrigins { toConfirmations :: Integer+ , toTxid :: TransactionID+ , toTime :: Integer+ , toOrigins :: [BitcoinAddress]+ }+ deriving (Show)++data RPCResult = RPCSuccess Value+ | RPCError { rpcErrorCode :: Integer+ , rpcErrorMessage :: T.Text+ }+ deriving (Show)++data BitcoinAddressInfo = BitcoinAddressInfo { baiIsValid :: Bool+ , baiIsMine :: Bool+ }+ deriving (Show)++data SinceBlockInfo = SinceBlockInfo { sbiTransactions :: [Transaction]+ , sbiLastBlock :: BlockHash+ }+ deriving (Show)++data SendError = InvalidAddress | InsufficientFunds | InvalidAmount | OtherError+ deriving (Show)++instance Serialize BitcoinAmount++instance Serialize BitcoinAddress where+ put = put . T.unpack . btcAddress+ get = BitcoinAddress . T.pack <$> get++instance Serialize TransactionID where+ put = put . T.unpack . btcTxID+ get = TransactionID . T.pack <$> get++instance Serialize SerializedTransaction where+ put = put . T.unpack . btcSerializedTx+ get = SerializedTransaction . T.pack <$> get++instance Serialize Transaction++instance Serialize BlockHash where+ put = put . T.unpack . btcBlockHash+ get = BlockHash . T.pack <$> get++instance Num BitcoinAmount+ where+ (+) (BitcoinAmount x) (BitcoinAmount y) = BitcoinAmount (x + y)+ (*) (BitcoinAmount _) (BitcoinAmount _) = error "not supported"+ (-) (BitcoinAmount x) (BitcoinAmount y) = BitcoinAmount (x - y)+ abs (BitcoinAmount x) = BitcoinAmount (abs x)+ signum (BitcoinAmount x) = BitcoinAmount (signum x)+ fromInteger x = BitcoinAmount (fromInteger x)++instance FromJSON BitcoinAmount+ where+ parseJSON v = do+ amount <- parseJSON v :: Parser Double+ let inSatoshis = round $ amount * 10 ^ (8 :: Integer)+ return $ BitcoinAmount inSatoshis++instance FromJSON BitcoinAddress+ where+ parseJSON (String addr) = return $ BitcoinAddress addr+ parseJSON _ = mzero++instance FromJSON TransactionID+ where+ parseJSON (String txid) = return $ TransactionID txid+ parseJSON _ = mzero++instance FromJSON SerializedTransaction+ where+ parseJSON (String tx) = return $ SerializedTransaction tx+ parseJSON _ = mzero++instance FromJSON BlockHash+ where+ parseJSON (String hash) = return $ BlockHash hash+ parseJSON _ = mzero++instance FromJSON Transaction+ where+ parseJSON (Object o) = case H.lookup "category" o of+ Just "send" -> SendTx <$>+ o .: "entry" <*>+ (abs <$> o .: "amount") <*>+ o .: "address" <*>+ o .: "fee" <*>+ o .: "confirmations" <*>+ o .: "txid" <*>+ o .: "time"+ Just "receive" -> ReceiveTx <$>+ o .: "entry" <*>+ o .: "amount" <*>+ o .: "address" <*>+ o .: "confirmations" <*>+ o .: "txid" <*>+ o .: "time"+ Just "move" -> MoveTx <$>+ o .: "time"+ Just "generate" -> GenerateTx <$>+ o .: "entry" <*>+ o .: "amount" <*>+ o .: "confirmations" <*>+ o .: "txid" <*>+ o .: "time"+ Just _ -> mzero+ Nothing -> mzero+ parseJSON _ = mzero++instance FromJSON TransactionHeader+ where+ parseJSON (Object o) = TransactionHeader <$>+ o .: "amount" <*>+ o .: "confirmations" <*>+ o .: "txid" <*>+ o .: "time"+ parseJSON _ = mzero++instance FromJSON TransactionOrigins+ where+ parseJSON (Object o) = TransactionOrigins <$>+ o .: "confirmations" <*>+ o .: "txid" <*>+ o .: "time" <*>+ o .: "origins"+ parseJSON _ = mzero++instance FromJSON BitcoinAddressInfo+ where+ parseJSON (Object o) = BitcoinAddressInfo <$>+ o .: "isvalid" <*>+ (fromMaybe False <$> o .:? "ismine")+ parseJSON _ = mzero++instance FromJSON SinceBlockInfo+ where+ parseJSON (Object o) = SinceBlockInfo <$>+ o .: "transactions" <*>+ o .: "lastblock"+ parseJSON _ = mzero++instance FromJSON RPCResult+ where+ parseJSON (Object o) = case H.lookup "result" o of+ Just Null -> case H.lookup "error" o of+ Just (Object errInfo) -> RPCError <$> errInfo .: "code"+ <*> errInfo .: "message"+ Just Null -> mzero+ _ -> mzero+ Just result -> return $ RPCSuccess result+ _ -> mzero+ parseJSON _ = mzero++txidAsByteString :: TransactionID -> B.ByteString+txidAsByteString = E.encodeUtf8 . btcTxID++addressAsByteString :: BitcoinAddress -> B.ByteString+addressAsByteString = E.encodeUtf8 . btcAddress++blockHashAsByteString :: BlockHash -> B.ByteString+blockHashAsByteString = E.encodeUtf8 . btcBlockHash
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TestSuite.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad+import System.Environment+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import Network.BitcoinRPC+import Network.BitcoinRPC.EventsTest+import Network.BitcoinRPC.MarkerAddressesTest++includeMoneyTests = False++auth :: RPCAuth+auth = RPCAuth "http://127.0.0.1:8332" "rpcuser" "localaccessonly"++genesisBlockHash = BlockHash "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f"++test1 :: Test+test1 = testCase "getblockcount" $ do+ _ <- getBlockCountR Nothing auth+ return ()++test2 :: Test+test2 = testCase "getblockhash" $ do+ hash <- getBlockHashR Nothing auth 0+ assertEqual "Hash of genesis block is not returned correctly."+ genesisBlockHash hash+ return ()++test3 :: Test+test3 = testCase "gettransaction" $ do+ r <- getTransactionR Nothing auth (TransactionID "invalidtransactionid")+ case r of+ Just _ -> assertFailure "invalid transaction id was not rejected"+ Nothing -> return ()++test4 :: Test+test4 = testCase "getorigins" $ do+ r <- getOriginsR Nothing auth (TransactionID "invalidtransactionid")+ case r of+ Just _ -> assertFailure "invalid transaction id was not rejected"+ Nothing -> return ()++test5 :: Test+test5 = testCase "getnewaddress" $ do+ _ <- getNewAddressR Nothing auth+ return ()++test6 :: Test+test6 = testCase "getbalance" $ do+ b1 <- getBalanceR Nothing auth 0 True+ b2 <- getBalanceR Nothing auth 6 True+ when (b1 < b2) $+ assertFailure "getbalance reports less unconfirmed funds\+ \ than confirmed ones (?)"++test7 :: Test+test7 = testCase "validateaddress" $ do+ c1 <- validateAddressR Nothing auth (BitcoinAddress "invalidaddress")+ when (baiIsValid c1) $+ assertFailure "invalid address is not rejected"+ c2 <-validateAddressR Nothing auth+ (BitcoinAddress "14Z1mazY4HfysZyMaKudFr63EwHqQT2njz")+ unless (baiIsValid c2) $+ assertFailure "valid address is rejected"+ myAddr <- getNewAddressR Nothing auth+ c3 <- validateAddressR Nothing auth myAddr+ unless (baiIsMine c3) $+ assertFailure "newly created address is not recognized as own"++test8 :: Test+test8 = testCase "sendtoaddress (1)" $ do+ let nullAmount = BitcoinAmount 0+ largeAmount = BitcoinAmount $ 21000000 * 10 ^ (6::Integer)+ s1 <- sendToAddress auth (BitcoinAddress "invalidaddress") largeAmount+ case s1 of+ Right (Left InvalidAddress) -> return ()+ _ -> assertFailure "invalid address is not rejected"++ myAddr <- getNewAddressR Nothing auth+ s2 <- sendToAddress auth myAddr nullAmount+ case s2 of+ Right (Left InvalidAmount) -> return ()+ _ -> assertFailure "amount of zero is not rejected"++ s3 <- sendToAddress auth myAddr largeAmount+ case s3 of+ Right (Left InsufficientFunds) -> return ()+ _ -> assertFailure "insufficient funds are not detected"++test9 :: Test+test9 = testCase "listsinceblock (1)" $ do+ _ <- listSinceBlockR Nothing auth Nothing+ return ()++test10 :: Test+test10 = testCase "getrawtransaction" $ do+ r <- getRawTransactionR Nothing auth (TransactionID "deadc0de")+ case r of+ Just _ -> assertFailure "invalid transaction id was not rejected"+ Nothing -> return ()++test11 :: Test+test11 = testCase "getbalance, filtered green coins" $ do+ b1 <- getBalanceR Nothing auth 0 False+ b2 <- getBalanceR Nothing auth 0 True+ when (b1 < b2) $+ assertFailure "the balance without green coins is\+ \ less than the total balance (?)"++testA :: Test+testA = testCase "sendtoaddress (2)" $ do+ let smallAmount = BitcoinAmount 10000+ fee = BitcoinAmount 10000+ b <- getBalanceR Nothing auth 1 True+ myAddr <- getNewAddressR Nothing auth+ when (b >= smallAmount + fee) $ do+ s <- sendToAddress auth myAddr smallAmount+ case s of+ Right (Right _) -> return ()+ _ -> assertFailure "sendtoaddress failed, even though\+ \ sufficient funds should be available"++main :: IO ()+main = do+ tests <- if includeMoneyTests+ then return $ freeTests ++ moneyTests+ else putStrLn "Omitting some tests - set includeMoneyTests\+ \ in TestSuite.hs for full test suite."+ >> return freeTests+ defaultMain tests++freeTests :: [Test]+freeTests = [ test1+ , test2+ , test3+ , test4+ , test5+ , test6+ , test7+ , test8+ , test9+ , test10+ , test11+ ] +++ eventsTests+ ++ markerAdressesTests++moneyTests = [ testA ]
+ bitcoin-rpc.cabal view
@@ -0,0 +1,94 @@+name: bitcoin-rpc+version: 0.5.0.0+synopsis: Library to communicate with the Satoshi Bitcoin daemon+description: See Network.BitcoinRPC for documentation.+category: Network, Bitcoin+author: Jan Vornberger <jan@uos.de>+copyright: (c) 2012 - 2014 Jan Vornberger+maintainer: Jan Vornberger <jan@uos.de>+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.8+bug-reports: https://github.com/javgh/bitcoin-rpc/issues++source-repository head+ type: git+ location: https://github.com/javgh/bitcoin-rpc++library+ build-depends: base == 4.*+ -- Wheezy: 4.5.0.0 (ghc)+ , ghc-prim+ -- Wheezy: 0.2.0.0 (ghc)+ , bytestring == 0.9.*+ -- Wheezy: 0.9.2.1 (ghc)+ , containers == 0.4.*+ -- Wheezy: 0.4.2.1 (ghc)+ , unix == 2.5.*+ -- Wheezy: 2.5.1.0 (ghc)+ , text == 0.11.*+ -- Wheezy: 0.11.2.0 (libghc-text-dev)+ , unordered-containers == 0.2.*+ -- Wheezy: 0.2.1.0 (libghc-unordered-containers-dev)+ , aeson == 0.6.*+ -- Wheezy: 0.6.0.2 (libghc-aeson-dev)+ , attoparsec == 0.10.*+ -- Wheezy: 0.10.1.1 (libghc-attoparsec-dev)+ , network == 2.3.*+ -- Wheezy: 2.3.0.13 (libghc-network-dev)+ , HTTP == 4000.2.*+ -- Wheezy: 4000.2.3 (libghc-http-dev)+ , mtl == 2.1.*+ -- Wheezy: 2.1.1 (libghc-mtl-dev)+ , cereal == 0.3.*+ -- Wheezy: 0.3.5.2 (libghc-cereal-dev)+ , watchdog == 0.2.*+ exposed-modules: Network.BitcoinRPC+ , Network.BitcoinRPC.Events+ , Network.BitcoinRPC.Events.MarkerAddresses+ , Network.BitcoinRPC.Types+ , Network.BitcoinRPC.MarkerAddresses+ ghc-options: -Wall++test-suite testsuite+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ build-depends: base == 4.*+ -- Wheezy: 4.5.0.0 (ghc)+ , ghc-prim+ -- Wheezy: 0.2.0.0 (ghc)+ , bytestring == 0.9.*+ -- Wheezy: 0.9.2.1 (ghc)+ , containers == 0.4.*+ -- Wheezy: 0.4.2.1 (ghc)+ , unix == 2.5.*+ -- Wheezy: 2.5.1.0 (ghc)+ , text == 0.11.*+ -- Wheezy: 0.11.2.0 (libghc-text-dev)+ , unordered-containers == 0.2.*+ -- Wheezy: 0.2.1.0 (libghc-unordered-containers-dev)+ , aeson == 0.6.*+ -- Wheezy: 0.6.0.2 (libghc-aeson-dev)+ , attoparsec == 0.10.*+ -- Wheezy: 0.10.1.1 (libghc-attoparsec-dev)+ , network == 2.3.*+ -- Wheezy: 2.3.0.13 (libghc-network-dev)+ , HTTP == 4000.2.*+ -- Wheezy: 4000.2.3 (libghc-http-dev)+ , mtl == 2.1.*+ -- Wheezy: 2.1.1 (libghc-mtl-dev)+ , cereal == 0.3.*+ -- Wheezy: 0.3.5.2 (libghc-cereal-dev)+ , watchdog == 0.2.*+ , HUnit == 1.2.*+ -- Wheezy: 1.2.4.2 (libghc-hunit-dev)+ , QuickCheck == 2.4.*+ -- Wheezy: 2.4.2 (libghc-quickcheck2-dev)+ , test-framework == 0.6.*+ -- Wheezy: 0.6 (libghc-test-framework-dev)+ , test-framework-hunit == 0.2.*+ -- Wheezy: 0.2.7 (libghc-test-framework-hunit-dev)+ , test-framework-quickcheck2 == 0.2.*+ -- Wheezy: 0.2.12.1 (libghc-test-framework-quickcheck2-dev)+ ghc-options: -Wall