bitcoin-rpc-0.5.0.0: Network/BitcoinRPC.hs

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