burnt-explorer-0.1.0.0: Main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Bitcoin.Script (Script)
import qualified Bitcoin.Script as BS
import Data.Aeson
import Data.ByteString.Lazy.Char8 (pack)
import Data.List
import Data.Scientific (Scientific)
import GHC.Generics
import System.Environment
import System.IO
import System.Process

execCommand :: String -> [String] -> IO String
execCommand command args = readProcess "blackcoind" ([command] ++ args) ""

data Block = Block {
  tx :: [String]
  } deriving (Generic, Show)
instance FromJSON Block

data Tx = Tx {
  txid :: String,
  vout :: [VOut],
  time :: Int
  } deriving (Generic, Show)
instance FromJSON Tx

data VOut = VOut {
  n :: Int,
  scriptHex :: String,
  value :: Scientific,
  script :: Script
  } deriving (Show)
instance FromJSON VOut where
  parseJSON (Object o) = do
    n <- o .: "n"
    hex <- ((o .: "scriptPubKey") >>= (.: "hex"))
    value <- o .: "value"
    return (VOut n hex value (BS.decode (pack hex)))

getBlockByNumber :: Int -> IO Block
getBlockByNumber n = do
  -- hPutStr stderr ("\rFetching block " ++ (show n) ++ "…")
  blockJSON <- execCommand "getblockbynumber" [(show n)]
  case decode (pack blockJSON) of
    Just block -> return block

getTxsFromBlock :: Block -> IO [Tx]
getTxsFromBlock block =
  sequence (map getTx (tx block))

getTx :: String -> IO Tx
getTx idx = do
  -- hPutStr stderr ("\rFetching transaction " ++ idx ++ "…")
  txJSON <- execCommand "gettransaction" [idx]
  case decode (pack txJSON) of
    Just tx -> return tx

show_tx_vout :: (Tx, VOut) -> String
show_tx_vout (tx, vout) =
  intercalate " " [txid tx,
                   show (n vout),
                   show (value vout),
                   scriptHex vout,
                   show (BS.scriptOps (script vout))]

processTxs :: [Int] -> IO ()
processTxs [] = return ()
processTxs (height:heights) = do
  block <- getBlockByNumber height
  txs <- getTxsFromBlock block
  let txs_vouts = concat [zip (repeat tx) (vout tx) | tx <- txs]
  let interesting = filter ((elem BS.OP_RETURN) . BS.scriptOps . script . snd) txs_vouts
  mapM_ (putStrLn . show_tx_vout) interesting
  processTxs heights

main :: IO ()
main = do
  hSetBuffering stdout LineBuffering
  args <- getArgs
  let [start, stop] = map read (take 2 args) :: [Int]
  processTxs [start..stop]