module Bitcoin.RPC.API where
import Data.Word
import Data.Bits
import Data.Maybe
import Control.Applicative
import Text.JSON
import Text.JSON.Types
import qualified Data.ByteString as B
import Bitcoin.Misc.HexString
import Bitcoin.Misc.OctetStream
import Bitcoin.Misc.UnixTime
import Bitcoin.Protocol.Address
import Bitcoin.Protocol.Amount
import Bitcoin.Protocol.Base64
import Bitcoin.Protocol.Hash
import Bitcoin.Protocol.Key
import Bitcoin.Protocol.Signature
import Bitcoin.Script.Base
import Bitcoin.BlockChain.Base
import Bitcoin.RPC.JSON
import Bitcoin.RPC.Call
type Account = String
type Node = String
type TxId = Hash256
type Key = Either PubKey Address
type MinConf = Maybe Int
type MaxConf = Maybe Int
type RedeemScript = RawScript
type PassPhrase = String
data AddNodeCmd
= NodeAdd
| NodeRemove
| NodeOneTry
deriving (Eq,Show)
data ClientInfo = ClientInfo
{ _cliClientVersion :: (Int,Int,Int)
, _cliProtocolVersion :: (Int,Int,Int)
, _cliWalletVersion :: (Int,Int,Int)
, _cliTotalBalance :: Amount
, _cliNumberOfBlocks :: Int
, _cliTimeOffset :: Double
, _cliNoConnections :: Int
, _cliProxy :: String
, _cliCurrentDifficulty :: Double
, _cliOnTestnet :: Bool
, _cliKeyPoolOldest :: UnixTimeStamp
, _cliKeyPoolSize :: Int
, _cliPayTxFee :: Amount
}
deriving Show
getClientInfo :: Call ClientInfo
getClientInfo = makeCall "getinfo" () $ \js -> case js of
JSObject obj ->
case obj of
_ | Just cver <- lkp "version"
, Just pver <- lkp "protocolversion"
, Just wver <- lkp "walletversion"
, Just bal <- lkp "balance"
, Just nblk <- lkp "blocks"
, Just tofs <- lkp "timeoffset"
, Just ncon <- lkp "connections"
, Just prxy <- lkp "proxy"
, Just diff <- lkp "difficulty"
, Just test <- lkp "testnet"
, Just old <- lkp "keypoololdest"
, Just pool <- lkp "keypoolsize"
, Just fee <- lkp "paytxfee"
-> Just $ ClientInfo
(parseVer cver)
(parseVer pver)
(parseVer wver)
bal
nblk
tofs
ncon
prxy
diff
test
old
pool
fee
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
parseVer :: Int -> (Int,Int,Int)
parseVer n = (a,b,c) where
(a,tmp) = divMod n 10000
(b,c) = divMod tmp 100
_ -> Nothing
getConnectionCount :: Call Int
getConnectionCount = makeCall "getconnectioncount" () myReadJSON
stopClient :: Call ()
stopClient = makeCall "stop" () $ \_ -> Just ()
data BlockInfo = BlockInfo
{ _bliHash :: Hash256
, _bliConfirmations :: Int
, _bliSize :: Int
, _bliHeight :: Int
, _bliVersion :: Int
, _bliMerkleRoot :: Hash256
, _bliTxHashes :: [Hash256]
, _bliTime :: UnixTimeStamp
, _bliNonce :: Word32
, _bliDifficultyBits :: Word32
, _bliDifficulty :: Double
, _bliPrevHash :: Maybe Hash256
, _bliNextHash :: Maybe Hash256
}
deriving Show
getDifficulty :: Call Double
getDifficulty = makeCall "getdifficulty" () myReadJSON
getBlockCount :: Call Int
getBlockCount = makeCall "getblockcount" () myReadJSON
getBlockHash :: Int -> Call Hash256
getBlockHash n = makeCall "getblockhash" [n] myReadJSON
getBlockInfo :: Hash256 -> Call BlockInfo
getBlockInfo blockhash = makeCall "getblock" [blockhash] $ \js -> case js of
JSObject obj ->
case obj of
_ | Just hash <- lkp "hash"
, Just conf <- lkp "confirmations"
, Just size <- lkp "size"
, Just hght <- lkp "height"
, Just ver <- lkp "version"
, Just root <- lkp "merkleroot"
, Just txs <- lkp "tx"
, Just time <- lkp "time"
, Just nonc <- lkp "nonce"
, Just bstr <- lkp "bits" , Just bits <- parseBits bstr
, Just diff <- lkp "difficulty"
, mbprev <- lkp "previousblockhash"
, mbnext <- lkp "nextblockhash"
-> Just $ BlockInfo
hash
conf
size
hght
ver
root
txs
time
nonc
bits
diff
mbprev
mbnext
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
parseBits bitstring = case safeHexDecode bitstring of
Just [a,b,c,d] -> Just $ shiftL (fromIntegral a) 24
+ shiftL (fromIntegral b) 16
+ shiftL (fromIntegral c) 8
+ (fromIntegral d)
Nothing -> Nothing
_ -> Nothing
data TxDetail = TxDetail
{ _txdAccount :: Account
, _txdAddress :: Address
, _txdCategory :: String
, _txdAmount :: Amount
, _txdFee :: Amount
}
deriving Show
data TxInfo = TxInfo
{ _txiAmount :: Amount
, _txiConfirmations :: Int
, _txiId :: TxId
, _txiTime :: UnixTimeStamp
, _txiDetails :: [TxDetail]
}
deriving Show
instance JSON TxDetail where
readJSON jsv = case parseTxDetail jsv of
Nothing -> Error "TxDetail/readJSON: cannot parse"
Just x -> Ok x
showJSON = error "TxDetail/showJSON: not implemented"
parseTxDetail :: JSValue -> Maybe TxDetail
parseTxDetail jsv = case jsv of
JSObject obj ->
case obj of
_ | Just acc <- lkp "account"
, Just addr <- lkp "address"
, Just cat <- lkp "category"
, Just amt <- lkp "amount"
, Just fee <- lkp "fee"
-> Just $ TxDetail acc addr cat amt fee
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
parseTxInfo :: JSValue -> Maybe TxInfo
parseTxInfo jsv = case jsv of
JSObject obj ->
case obj of
_ | Just amt <- lkp "amount"
, Just conf <- lkp "confirmations"
, Just txid <- lkp "txid"
, Just time <- lkp "time"
, Just (JSArray dets) <- lkp "details"
, mbdetails <- map parseTxDetail dets
, all isJust mbdetails
-> Just $ TxInfo amt conf txid time (catMaybes mbdetails)
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
getWalletTransaction :: TxId -> Call TxInfo
getWalletTransaction txid = makeCall "getrawtransaction" (txid, (0::Int)) parseTxInfo
data ScriptSigVerbose = ScriptSigVerbose
{ _scriptSigAsm :: String
, _scriptSigHex :: !RawScript
}
deriving (Eq,Show)
parseScriptSigVerbose :: JSValue -> Maybe ScriptSigVerbose
parseScriptSigVerbose jsv = case jsv of
JSObject obj ->
case obj of
_ | Just asm <- lkp "asm"
, Just hex <- lkp "hex"
-> Just $ ScriptSigVerbose asm hex
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
data TxVIn = TxVIn
{ _vinTxId :: !TxId
, _vinVOut :: !Int
, _vinScriptSig :: !ScriptSigVerbose
, _vinSequence :: !Word32
}
deriving (Eq,Show)
parseTxVIn :: JSValue -> Maybe TxVIn
parseTxVIn jsv = case jsv of
JSObject obj ->
case obj of
_ | Just txid <- lkp "txid"
, Just vout <- lkp "vout"
, Just ssig <- lkp "scriptSig" , Just scriptSig <- parseScriptSigVerbose ssig
, Just seqn <- lkp "sequence"
-> Just $ TxVIn txid vout scriptSig seqn
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
data ScriptPubKeyVerbose = ScriptPubKeyVerbose
{ _scriptPubKeyAsm :: String
, _scriptPubKeyHex :: !RawScript
, _scriptPubKeyReqSigs :: !Int
, _scriptPubKeyType :: String
, _scriptPubKeyAddresses :: [Address]
}
deriving (Eq,Show)
parseScriptPubKeyVerbose :: JSValue -> Maybe ScriptPubKeyVerbose
parseScriptPubKeyVerbose jsv = case jsv of
JSObject obj ->
case obj of
_ | Just asm <- lkp "asm"
, Just hex <- lkp "hex"
, Just req <- lkp "reqSigs"
, Just typ <- lkp "type"
, Just (JSArray adrs) <- lkp "addresses"
, let mbaddresses = map myReadJSON adrs
, all isJust mbaddresses
-> Just $ ScriptPubKeyVerbose asm hex req typ (catMaybes mbaddresses)
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
data TxVOut = TxVOut
{ _voutValue :: !Amount
, _voutN :: !Int
, _voutScriptPubKey :: !ScriptPubKeyVerbose
}
deriving (Eq,Show)
parseTxVOut :: JSValue -> Maybe TxVOut
parseTxVOut jsv = case jsv of
JSObject obj ->
case obj of
_ | Just amt <- lkp "value"
, Just n <- lkp "n"
, Just spub <- lkp "scriptPubKey" , Just scriptPubKey <- parseScriptPubKeyVerbose spub
-> Just $ TxVOut amt n scriptPubKey
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
data TxVerbose = TxVerbose
{ _txvTxId :: !TxId
, _txvVersion :: !Int
, _txvLockTime :: !LockTime
, _txvVIn :: [TxVIn]
, _txvVOut :: [TxVOut]
}
deriving (Eq,Show)
parseTxVerbose :: JSValue -> Maybe TxVerbose
parseTxVerbose jsv = case jsv of
JSObject obj ->
case obj of
_ | Just txid <- lkp "txid"
, Just ver <- lkp "version"
, Just lock <- lkp "locktime"
, Just (JSArray vins) <- lkp "vin"
, Just (JSArray vouts) <- lkp "vout"
, let mbins = map parseTxVIn vins
, all isJust mbins
, let mbouts = map parseTxVOut vouts
, all isJust mbouts
-> Just $ TxVerbose txid ver (parseLockTime lock) (catMaybes mbins) (catMaybes mbouts)
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
data TxVerboseEx = TxVerboseEx
{ _txeHex :: !RawTx
, _txeTxVerbose :: !TxVerbose
, _txeBlockHash :: !Hash256
, _txeConfirmations :: !Int
, _txeTime :: !UnixTimeStamp
, _txeBlockTime :: !UnixTimeStamp
}
deriving (Eq,Show)
parseTxVerboseEx :: JSValue -> Maybe TxVerboseEx
parseTxVerboseEx jsv = case jsv of
JSObject obj ->
case obj of
_ | Just hex <- lkp "hex"
, Just txid <- lkp "txid"
, Just ver <- lkp "version"
, Just lock <- lkp "locktime"
, Just (JSArray vins) <- lkp "vin"
, Just (JSArray vouts) <- lkp "vout"
, let mbins = map parseTxVIn vins
, all isJust mbins
, let mbouts = map parseTxVOut vouts
, all isJust mbouts
, Just bhsh <- lkp "blockhash"
, Just conf <- lkp "confirmations"
, Just time <- lkp "time"
, Just btim <- lkp "blocktime"
-> Just $ TxVerboseEx hex (TxVerbose txid ver (parseLockTime lock) (catMaybes mbins) (catMaybes mbouts)) bhsh conf time btim
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
getRawTransaction :: TxId -> Call RawTx
getRawTransaction txid = makeCall "getrawtransaction" (txid, (0::Int)) $ \js -> myReadJSON js
getTransactionInfo :: TxId -> Call TxVerboseEx
getTransactionInfo txid = makeCall "getrawtransaction" (txid, (1::Int)) parseTxVerboseEx
decodeRawTransaction :: RawTx -> Call TxVerbose
decodeRawTransaction rawtx = makeCall "decoderawtransaction" [rawtx] parseTxVerbose
validateAddress :: Address -> Call (JSObject JSValue)
validateAddress address = makeCall "validateaddress" [address] mbJSObject
dumpPrivKeyWIF :: Address -> Call WIF
dumpPrivKeyWIF address = makeCall "dumpprivkey" [address] $ myReadJSON
dumpPrivPubKey :: Address -> Call (PrivKey,PubKey)
dumpPrivPubKey address = makeCall "dumpprivkey" [address] $ \js -> myReadJSON js >>= \s -> (f <$> privKeyWIFDecode (WIF s)) where
f (pfmt,priv) = (priv, computePubKey pfmt priv)
getBalance :: Maybe Account -> MinConf -> Call Amount
getBalance mbacc minconf = makeCall "getbalance" (maybe "" id mbacc , maybe 1 id minconf) myReadJSON
getAccountAddress :: Account -> Call Address
getAccountAddress account = makeCall "getaccountaddress" [account] myReadJSON
getAddressesByAccount :: Account -> Call [Address]
getAddressesByAccount account = makeCall "getaddressesbyaccount" [account] myReadJSON
getAccount :: Address -> Call Account
getAccount address = makeCall "getaccount" [address] myReadJSON
listAccounts :: MinConf -> Call [(Account,Amount)]
listAccounts minconf = makeCall "listaccounts" [maybe 1 id minconf] $ \jsv -> (g . map f . fromJSObject) =<< mbJSObject jsv where
f :: (String,JSValue) -> (String, Maybe Amount)
f (s,x) = (s,amountFromDouble <$> myReadJSON x)
g ambs = if all (isJust . snd) ambs
then Just $ map (\(s,mb) -> (s,fromJust mb)) ambs
else Nothing
listAddressGroupings :: Call JSValue
listAddressGroupings = makeCall "listaddressgroupings" () Just
data Received = Received
{ _rcvAddress :: Maybe Address
, _rcvAccount :: Account
, _rcvAmount :: Amount
, _rcvConfirmations :: Int
}
deriving Show
parseReceived :: JSValue -> Maybe Received
parseReceived jsv = case jsv of
JSObject obj ->
case obj of
_ | mbaddr <- lkp "address"
, Just acc <- lkp "account"
, Just amt <- lkp "amount"
, Just conf <- lkp "confirmations"
-> Just $ Received mbaddr acc amt conf
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
listReceivedByAccount :: MinConf -> Bool -> Call [Received]
listReceivedByAccount minconf includeempty =
makeCall "listreceivedbyaccount" (maybe 1 id minconf, includeempty) $ \jsv -> case jsv of
JSArray arr ->
if all isJust mbs
then Just (catMaybes mbs)
else Nothing
where
mbs = map parseReceived arr
_ -> Nothing
listReceivedByAddress :: MinConf -> Bool -> Call [Received]
listReceivedByAddress minconf includeempty =
makeCall "listreceivedbyaddress" (maybe 1 id minconf, includeempty) $ \jsv -> case jsv of
JSArray arr ->
if all isJust mbs
then Just (catMaybes mbs)
else Nothing
where
mbs = map parseReceived arr
_ -> Nothing
data Unspent = Unspent
{ _unsTxId :: !TxId
, _unsOutput :: !Int
, _unsScriptPubKey :: !RawScript
, _unsAmount :: !Amount
, _unsConfirmations :: !Int
}
deriving (Eq, Show)
listUnspent :: MinConf -> MaxConf -> Call [Unspent]
listUnspent minconf maxconf =
makeCall "listunspent" [maybe 1 id minconf, maybe 999999 id maxconf] $ \jsv -> case jsv of
JSArray arr ->
if all isJust mbs
then Just (catMaybes mbs)
else Nothing
where
mbs = map parseUnspent arr
_ -> Nothing
where
parseUnspent :: JSValue -> Maybe Unspent
parseUnspent jsv = case jsv of
JSObject obj ->
case obj of
_ | Just txid <- lkp "txid"
, Just out <- lkp "output"
, Just script <- lkp "scriptPubKey"
, Just amt <- lkp "amount"
, Just conf <- lkp "confirmations"
-> Just $ Unspent txid out script amt conf
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
getRawMemPool :: Call [TxId]
getRawMemPool = makeCall "getrawmempool" () myReadJSON
addMultiSigAddress :: Int -> [Key] -> Maybe Account -> Call Address
addMultiSigAddress n keys mbacc =
if n > length keys || n < 1
then error "addMultiSigAddress: <nrequired> must be least 1 and at most the number of keys"
else makeCall "addmultisigaddress" ( n , jskeys , maybe "" id mbacc ) myReadJSON
where
jskeys = map eiShowJSON keys
createMultiSig :: Int -> [Key] -> Call (Address,RedeemScript)
createMultiSig n keys =
if n > length keys || n < 1
then error "createMultiSig: <nrequired> must be least 1 and at most the number of keys"
else makeCall "createmultisig" ( n , jskeys ) $ \jsv -> case jsv of
JSObject obj ->
case obj of
_ | Just addr <- lkp "address"
, Just script <- lkp "redeemScript"
-> Just (addr,script)
_ -> Nothing
where
lkp :: JSON a => String -> Maybe a
lkp fld = get_field obj fld >>= myReadJSON
_ -> Nothing
where
jskeys = map eiShowJSON keys
sendFrom :: Account -> Address -> Amount -> MinConf -> Maybe String -> Maybe String -> Call TxId
sendFrom account address amount minconf comment comment_to =
makeCall "sendfrom" (account, address, amount, maybe 1 id minconf, maybe "" id comment, maybe "" id comment_to) myReadJSON
sendMany :: Account -> [(Address,Amount)] -> MinConf -> Maybe String -> Call TxId
sendMany account destinations minconf comment =
makeCall "sendmany" (account,destinations,maybe 1 id minconf, maybe "" id comment) myReadJSON
sendRawTransaction :: RawTx -> Call ()
sendRawTransaction rawtx = makeCall "sendrawtransaction" [rawtx] $ \_ -> Just ()
sendToAddress :: Address -> Amount -> Maybe String -> Maybe String -> Call TxId
sendToAddress address amount comment comment_to =
makeCall "sendtoaddress" (address,amount,maybe "" id comment, maybe "" id comment_to) myReadJSON
moveCoins :: Account -> Account -> Amount -> MinConf -> Maybe String -> Call ()
moveCoins accfrom accto amount minconf comment =
makeCall "move" (accfrom, accto, amount, maybe 1 id minconf, maybe "" id comment) $ \_ -> Just ()
setTxFee :: Amount -> Call ()
setTxFee amount = makeCall "settxfee" [amount] $ \_ -> Just ()
importPrivKey :: (PubKeyFormat,PrivKey) -> Maybe String -> Bool -> Call ()
importPrivKey (pkfmt,privkey) mblabel rescan =
makeCall "importprivkey" ( privKeyWIFEncode pkfmt privkey , maybe "" id mblabel , rescan ) $ \_ -> Just ()
importPrivKeyWIF :: WIF -> Maybe String -> Bool -> Call ()
importPrivKeyWIF wif mblabel rescan =
makeCall "importprivkey" ( wif , maybe "" id mblabel , rescan ) $ \_ -> Just ()
getNewAddress :: Maybe Account -> Call Address
getNewAddress mbacc =
makeCall "getnewaddress" [ maybe "" id mbacc ] myReadJSON
setAccount :: Address -> Account -> Call ()
setAccount address account = makeCall "setaccount" (address,account) $ \_ -> Just ()
keyPoolRefill :: Call ()
keyPoolRefill = makeCall "keypoolrefill" () $ \_ -> Just ()
backupWallet :: FilePath -> Call ()
backupWallet fpath = makeCall "backupwallet" [fpath] $ \_ -> Just ()
walletLock :: Call ()
walletLock = makeCall "walletlock" () $ \_ -> Just ()
walletPassPhrase :: PassPhrase -> Int -> Call ()
walletPassPhrase pw seconds = makeCall "walletpassphrase" (pw,seconds) $ \_ -> Just ()
walletPassPhraseChange :: PassPhrase -> PassPhrase -> Call ()
walletPassPhraseChange old new = makeCall "walletpassphrasechange" (old,new) $ \_ -> Just ()
encryptWallet :: PassPhrase -> Call ()
encryptWallet pw = makeCall "encryptwallet" [pw] $ \_ -> Just ()