{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module Bitcoin.Core.Regtest
(
NodeHandle (..)
, runBitcoind
, withBitcoind
, oneBitcoin
, createOutput
, generate
, spendPackageOutputs
, xprv
, keys
, pubKeys
, addrs
, textAddrs
) where
import Control.Concurrent (threadDelay)
import Control.Exception (bracket)
import Control.Monad (void)
import qualified Data.Serialize as S
import Data.Text (Text)
import Data.Word (Word64)
import Network.Haskoin.Address (Address, addrToString,
addressToOutput)
import Network.Haskoin.Block (blockTxns)
import Network.Haskoin.Constants (btcTest)
import Network.Haskoin.Crypto (SecKey)
import Network.Haskoin.Keys (PubKeyI, XPrvKey (..),
deriveAddrs, derivePubKeyI,
deriveXPubKey, makeXPrvKey,
prvSubKeys, wrapSecKey)
import Network.Haskoin.Script (sigHashAll)
import Network.Haskoin.Transaction (OutPoint (..), SigInput (..),
Tx (..), TxOut (..), buildAddrTx,
signTx, txHash)
import Network.Haskoin.Util (encodeHex, maybeToEither)
import Network.HTTP.Client (Manager)
import Servant.API (BasicAuthData)
import System.IO (Handle, IOMode (..), openFile)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (CreateProcess (..), ProcessHandle,
StdStream (..), createProcess,
proc, terminateProcess,
waitForProcess)
import Bitcoin.Core.RPC (BitcoindClient, BitcoindException,
basicAuthFromCookie)
import qualified Bitcoin.Core.RPC as RPC
data NodeHandle = NodeHandle
{ nodePort :: Int
, nodeAuth :: BasicAuthData
}
runBitcoind :: Manager -> NodeHandle -> BitcoindClient r -> IO (Either BitcoindException r)
runBitcoind mgr (NodeHandle port auth) = RPC.runBitcoind mgr "127.0.0.1" port auth
withBitcoind
:: Int
-> (NodeHandle -> IO r)
-> IO r
withBitcoind port k = withSystemTempDirectory "bitcoind-rpc-tests" $ \dd ->
bracket (initBitcoind dd port) stopBitcoind . const $ do
auth <- basicAuthFromCookie $ dd <> "/regtest/.cookie"
k $ NodeHandle port auth
initBitcoind :: FilePath -> Int -> IO ProcessHandle
initBitcoind ddir port = do
logH <- openFile "/tmp/bitcoind-rpc.log" WriteMode
(_, _, _, h) <- createProcess $ bitcoind ddir port logH
h <$ threadDelay 1_000_000
stopBitcoind :: ProcessHandle -> IO ()
stopBitcoind h = terminateProcess h >> void (waitForProcess h)
bitcoind :: FilePath -> Int -> Handle -> CreateProcess
bitcoind ddir port output
= (proc "bitcoind" args)
{ std_out = UseHandle output
, std_err = UseHandle output
}
where
args = ["-regtest", "-txindex", "-disablewallet", "-datadir=" <> ddir, "-rpcport=" <> show port]
oneBitcoin :: Word64
oneBitcoin = 100_000_000
createOutput
:: Address
-> Word64
-> BitcoindClient (OutPoint, Word64)
createOutput addr vTarget = do
inputs <- generateEnoughBlocks vTarget
RPC.generateToAddress 100 textAddr2 Nothing
let Right (tx, vFund) = spendPackageOutputs inputs addr vTarget
h <- RPC.sendRawTransaction (encodeHex $ S.encode tx) Nothing
RPC.generateToAddress 6 textAddr2 Nothing
return (OutPoint h 0, vFund)
generateEnoughBlocks :: Word64 -> BitcoindClient [(OutPoint, Word64)]
generateEnoughBlocks vTarget = go ([], 0, 0 :: Int)
where
go (xs, v, n)
| n >= 100 = return xs
| otherwise = do
x@(_, v0) <- generate
let xs' = x : xs
if v + v0 >= vTarget
then return xs'
else go (xs', v + v0, n+1)
generate :: BitcoindClient (OutPoint, Word64)
generate
= fmap (processCoinbase . head . blockTxns)
$ RPC.generateToAddress 1 textAddr0 Nothing >>= RPC.getBlock . head
where
processCoinbase tx0 = (OutPoint (txHash tx0) 0 , outValue . head $ txOut tx0)
spendPackageOutputs
:: [(OutPoint, Word64)]
-> Address
-> Word64
-> Either String (Tx, Word64)
spendPackageOutputs inputs addr vTarget = do
addrText <- maybeToEither "Addr conversion failed" $ addrToString btcTest addr
let outSpec | vTarget + 10_000 < vAvail
= Right ([(addrText, vTarget), (textAddr1, vAvail - vTarget - 10_000)], vTarget)
| vAvail > 10_000
= Right ([(addrText, vAvail - 10_000)], vAvail - 10_000)
| otherwise
= Left "Insufficient funds"
vAvail = sum $ snd <$> inputs
sigIn (op, val) = SigInput (addressToOutput addr0) val op sigHashAll Nothing
(outs, vFund) <- outSpec
txSpec <- buildAddrTx btcTest (fst <$> inputs) outs
tx <- signTx btcTest txSpec (sigIn <$> inputs) [key0]
return (tx, vFund)
xprv :: XPrvKey
xprv = makeXPrvKey "bitcoind-regtest key seed"
keys :: [SecKey]
keys = xPrvKey . fst <$> prvSubKeys xprv 0
pubKeys :: [PubKeyI]
pubKeys = derivePubKeyI . wrapSecKey True <$> keys
key0 :: SecKey
key0 : _ = keys
addrs :: [Address]
addrs = repack <$> deriveAddrs (deriveXPubKey xprv) 0
where repack (x, _, _) = x
addr0 :: Address
addr0 : _ = addrs
textAddrs :: [Text]
textAddrs = addrToString' <$> addrs
where addrToString' a = let Just x = addrToString btcTest a in x
textAddr0, textAddr1, textAddr2 :: Text
textAddr0 : textAddr1 : textAddr2 : _ = textAddrs