diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Network/BitcoinRPC.hs b/Network/BitcoinRPC.hs
new file mode 100644
--- /dev/null
+++ b/Network/BitcoinRPC.hs
@@ -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 ( ).
+-- These patches can be found here:
+-- . 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
diff --git a/Network/BitcoinRPC/Events.hs b/Network/BitcoinRPC/Events.hs
new file mode 100644
--- /dev/null
+++ b/Network/BitcoinRPC/Events.hs
@@ -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 (
+-- ) 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 ++ " "
+-- > 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)
diff --git a/Network/BitcoinRPC/Events/MarkerAddresses.hs b/Network/BitcoinRPC/Events/MarkerAddresses.hs
new file mode 100644
--- /dev/null
+++ b/Network/BitcoinRPC/Events/MarkerAddresses.hs
@@ -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)
diff --git a/Network/BitcoinRPC/MarkerAddresses.hs b/Network/BitcoinRPC/MarkerAddresses.hs
new file mode 100644
--- /dev/null
+++ b/Network/BitcoinRPC/MarkerAddresses.hs
@@ -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
diff --git a/Network/BitcoinRPC/Types.hs b/Network/BitcoinRPC/Types.hs
new file mode 100644
--- /dev/null
+++ b/Network/BitcoinRPC/Types.hs
@@ -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
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/TestSuite.hs b/TestSuite.hs
new file mode 100644
--- /dev/null
+++ b/TestSuite.hs
@@ -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 ]
diff --git a/bitcoin-rpc.cabal b/bitcoin-rpc.cabal
new file mode 100644
--- /dev/null
+++ b/bitcoin-rpc.cabal
@@ -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
+copyright: (c) 2012 - 2014 Jan Vornberger
+maintainer: Jan Vornberger
+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