{-# 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 Haskoin.Address (
Address,
addrToText,
addressToOutput,
)
import Haskoin.Block (blockTxns)
import Haskoin.Constants (btcTest)
import Haskoin.Crypto (SecKey)
import Haskoin.Keys (
PubKeyI,
XPrvKey (..),
deriveAddrs,
derivePubKeyI,
deriveXPubKey,
makeXPrvKey,
prvSubKeys,
wrapSecKey,
)
import Haskoin.Script (sigHashAll)
import Haskoin.Transaction (
OutPoint (..),
SigInput (..),
Tx (..),
TxOut (..),
buildAddrTx,
signTx,
txHash,
)
import Haskoin.Util (encodeHex, maybeToEither)
import Network.HTTP.Client (Manager)
import Servant.API (BasicAuthData)
import System.IO (Handle, IOMode (..), openFile)
import System.IO.Temp (getCanonicalTemporaryDirectory, 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
{ NodeHandle -> Int
nodePort :: Int
, NodeHandle -> BasicAuthData
nodeAuth :: BasicAuthData
, NodeHandle -> FilePath
nodeRawTx :: FilePath
, NodeHandle -> FilePath
nodeRawBlock :: FilePath
}
runBitcoind :: Manager -> NodeHandle -> BitcoindClient r -> IO (Either BitcoindException r)
runBitcoind :: Manager
-> NodeHandle
-> BitcoindClient r
-> IO (Either BitcoindException r)
runBitcoind mgr :: Manager
mgr (NodeHandle port :: Int
port auth :: BasicAuthData
auth _ _) = Manager
-> FilePath
-> Int
-> BasicAuthData
-> BitcoindClient r
-> IO (Either BitcoindException r)
forall a.
Manager
-> FilePath
-> Int
-> BasicAuthData
-> BitcoindClient a
-> IO (Either BitcoindException a)
RPC.runBitcoind Manager
mgr "127.0.0.1" Int
port BasicAuthData
auth
withBitcoind ::
Int ->
(NodeHandle -> IO r) ->
IO r
withBitcoind :: Int -> (NodeHandle -> IO r) -> IO r
withBitcoind port :: Int
port k :: NodeHandle -> IO r
k = FilePath -> (FilePath -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory "bitcoind-rpc-tests" ((FilePath -> IO r) -> IO r) -> (FilePath -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \dd :: FilePath
dd -> do
FilePath
tmp <- IO FilePath
getCanonicalTemporaryDirectory
IO ProcessHandle
-> (ProcessHandle -> IO ()) -> (ProcessHandle -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> FilePath -> Int -> IO ProcessHandle
initBitcoind FilePath
tmp FilePath
dd Int
port) ProcessHandle -> IO ()
stopBitcoind ((ProcessHandle -> IO r) -> IO r)
-> (IO r -> ProcessHandle -> IO r) -> IO r -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO r -> ProcessHandle -> IO r
forall a b. a -> b -> a
const (IO r -> IO r) -> IO r -> IO r
forall a b. (a -> b) -> a -> b
$ do
BasicAuthData
auth <- FilePath -> IO BasicAuthData
basicAuthFromCookie (FilePath -> IO BasicAuthData) -> FilePath -> IO BasicAuthData
forall a b. (a -> b) -> a -> b
$ FilePath
dd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "/regtest/.cookie"
NodeHandle -> IO r
k (NodeHandle -> IO r) -> NodeHandle -> IO r
forall a b. (a -> b) -> a -> b
$ Int -> BasicAuthData -> FilePath -> FilePath -> NodeHandle
NodeHandle Int
port BasicAuthData
auth (FilePath -> FilePath
rawTxSocket FilePath
tmp) (FilePath -> FilePath
rawBlockSocket FilePath
tmp)
initBitcoind :: FilePath -> FilePath -> Int -> IO ProcessHandle
initBitcoind :: FilePath -> FilePath -> Int -> IO ProcessHandle
initBitcoind tmp :: FilePath
tmp ddir :: FilePath
ddir port :: Int
port = do
Handle
logH <- FilePath -> IOMode -> IO Handle
openFile (FilePath
tmp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "/bitcoind-rpc.log") IOMode
WriteMode
(_, _, _, h :: ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Int -> Handle -> CreateProcess
bitcoind FilePath
tmp FilePath
ddir Int
port Handle
logH
ProcessHandle
h ProcessHandle -> IO () -> IO ProcessHandle
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> IO ()
threadDelay 1_000_000
stopBitcoind :: ProcessHandle -> IO ()
stopBitcoind :: ProcessHandle -> IO ()
stopBitcoind h :: ProcessHandle
h = ProcessHandle -> IO ()
terminateProcess ProcessHandle
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h)
bitcoind :: FilePath -> FilePath -> Int -> Handle -> CreateProcess
bitcoind :: FilePath -> FilePath -> Int -> Handle -> CreateProcess
bitcoind tmp :: FilePath
tmp ddir :: FilePath
ddir port :: Int
port output :: Handle
output =
(FilePath -> [FilePath] -> CreateProcess
proc "bitcoind" [FilePath]
args)
{ std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
output
, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
output
}
where
args :: [FilePath]
args =
[ "-regtest"
, "-txindex"
, "-blockfilterindex=1"
, "-disablewallet"
, "-datadir=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
ddir
, "-rpcport=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
port
, "-zmqpubrawblock=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
rawBlockSocket FilePath
tmp
, "-zmqpubrawtx=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
rawTxSocket FilePath
tmp
]
rawTxSocket :: FilePath -> String
rawTxSocket :: FilePath -> FilePath
rawTxSocket tmp :: FilePath
tmp = "ipc://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
tmp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "/bitcoind-rpc.tx.raw"
rawBlockSocket :: FilePath -> String
rawBlockSocket :: FilePath -> FilePath
rawBlockSocket tmp :: FilePath
tmp = "ipc://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
tmp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "/bitcoind-rpc.block.raw"
oneBitcoin :: Word64
oneBitcoin :: Word64
oneBitcoin = 100_000_000
createOutput ::
Address ->
Word64 ->
BitcoindClient (OutPoint, Word64)
createOutput :: Address -> Word64 -> BitcoindClient (OutPoint, Word64)
createOutput addr :: Address
addr vTarget :: Word64
vTarget = do
[(OutPoint, Word64)]
inputs <- Word64 -> BitcoindClient [(OutPoint, Word64)]
generateEnoughBlocks Word64
vTarget
Word32 -> Text -> Maybe Word32 -> BitcoindClient [BlockHash]
RPC.generateToAddress 100 Text
textAddr2 Maybe Word32
forall a. Maybe a
Nothing
let Right (tx :: Tx
tx, vFund :: Word64
vFund) = [(OutPoint, Word64)]
-> Address -> Word64 -> Either FilePath (Tx, Word64)
spendPackageOutputs [(OutPoint, Word64)]
inputs Address
addr Word64
vTarget
TxHash
h <- Text -> Maybe Double -> BitcoindClient TxHash
RPC.sendRawTransaction (ByteString -> Text
encodeHex (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. Serialize a => a -> ByteString
S.encode Tx
tx) Maybe Double
forall a. Maybe a
Nothing
Word32 -> Text -> Maybe Word32 -> BitcoindClient [BlockHash]
RPC.generateToAddress 6 Text
textAddr2 Maybe Word32
forall a. Maybe a
Nothing
(OutPoint, Word64) -> BitcoindClient (OutPoint, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxHash -> Word32 -> OutPoint
OutPoint TxHash
h 0, Word64
vFund)
generateEnoughBlocks :: Word64 -> BitcoindClient [(OutPoint, Word64)]
generateEnoughBlocks :: Word64 -> BitcoindClient [(OutPoint, Word64)]
generateEnoughBlocks vTarget :: Word64
vTarget = ([(OutPoint, Word64)], Word64, Int)
-> BitcoindClient [(OutPoint, Word64)]
forall c.
(Ord c, Num c) =>
([(OutPoint, Word64)], Word64, c)
-> BitcoindClient [(OutPoint, Word64)]
go ([], 0, 0 :: Int)
where
go :: ([(OutPoint, Word64)], Word64, c)
-> BitcoindClient [(OutPoint, Word64)]
go (xs :: [(OutPoint, Word64)]
xs, v :: Word64
v, n :: c
n)
| c
n c -> c -> Bool
forall a. Ord a => a -> a -> Bool
>= 100 = [(OutPoint, Word64)] -> BitcoindClient [(OutPoint, Word64)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(OutPoint, Word64)]
xs
| Bool
otherwise = do
x :: (OutPoint, Word64)
x@(_, v0 :: Word64
v0) <- BitcoindClient (OutPoint, Word64)
generate
let xs' :: [(OutPoint, Word64)]
xs' = (OutPoint, Word64)
x (OutPoint, Word64) -> [(OutPoint, Word64)] -> [(OutPoint, Word64)]
forall a. a -> [a] -> [a]
: [(OutPoint, Word64)]
xs
if Word64
v Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v0 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
vTarget
then [(OutPoint, Word64)] -> BitcoindClient [(OutPoint, Word64)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(OutPoint, Word64)]
xs'
else ([(OutPoint, Word64)], Word64, c)
-> BitcoindClient [(OutPoint, Word64)]
go ([(OutPoint, Word64)]
xs', Word64
v Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v0, c
n c -> c -> c
forall a. Num a => a -> a -> a
+ 1)
generate :: BitcoindClient (OutPoint, Word64)
generate :: BitcoindClient (OutPoint, Word64)
generate =
(Block -> (OutPoint, Word64))
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
-> BitcoindClient (OutPoint, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx -> (OutPoint, Word64)
processCoinbase (Tx -> (OutPoint, Word64))
-> (Block -> Tx) -> Block -> (OutPoint, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tx] -> Tx
forall a. [a] -> a
head ([Tx] -> Tx) -> (Block -> [Tx]) -> Block -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Tx]
blockTxns) (ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
-> BitcoindClient (OutPoint, Word64))
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
-> BitcoindClient (OutPoint, Word64)
forall a b. (a -> b) -> a -> b
$
Word32 -> Text -> Maybe Word32 -> BitcoindClient [BlockHash]
RPC.generateToAddress 1 Text
textAddr0 Maybe Word32
forall a. Maybe a
Nothing BitcoindClient [BlockHash]
-> ([BlockHash]
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block)
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BlockHash
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
RPC.getBlock (BlockHash
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block)
-> ([BlockHash] -> BlockHash)
-> [BlockHash]
-> ReaderT BasicAuthData (ExceptT BitcoindException ClientM) Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockHash] -> BlockHash
forall a. [a] -> a
head
where
processCoinbase :: Tx -> (OutPoint, Word64)
processCoinbase tx0 :: Tx
tx0 = (TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash Tx
tx0) 0, TxOut -> Word64
outValue (TxOut -> Word64) -> ([TxOut] -> TxOut) -> [TxOut] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> TxOut
forall a. [a] -> a
head ([TxOut] -> Word64) -> [TxOut] -> Word64
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut]
txOut Tx
tx0)
spendPackageOutputs ::
[(OutPoint, Word64)] ->
Address ->
Word64 ->
Either String (Tx, Word64)
spendPackageOutputs :: [(OutPoint, Word64)]
-> Address -> Word64 -> Either FilePath (Tx, Word64)
spendPackageOutputs inputs :: [(OutPoint, Word64)]
inputs addr :: Address
addr vTarget :: Word64
vTarget = do
Text
addrText <- FilePath -> Maybe Text -> Either FilePath Text
forall b a. b -> Maybe a -> Either b a
maybeToEither "Addr conversion failed" (Maybe Text -> Either FilePath Text)
-> Maybe Text -> Either FilePath Text
forall a b. (a -> b) -> a -> b
$ Network -> Address -> Maybe Text
addrToText Network
btcTest Address
addr
let outSpec :: Either FilePath ([(Text, Word64)], Word64)
outSpec
| Word64
vTarget Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ 10_000 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
vAvail =
([(Text, Word64)], Word64)
-> Either FilePath ([(Text, Word64)], Word64)
forall a b. b -> Either a b
Right ([(Text
addrText, Word64
vTarget), (Text
textAddr1, Word64
vAvail Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
vTarget Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- 10_000)], Word64
vTarget)
| Word64
vAvail Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> 10_000 =
([(Text, Word64)], Word64)
-> Either FilePath ([(Text, Word64)], Word64)
forall a b. b -> Either a b
Right ([(Text
addrText, Word64
vAvail Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- 10_000)], Word64
vAvail Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- 10_000)
| Bool
otherwise =
FilePath -> Either FilePath ([(Text, Word64)], Word64)
forall a b. a -> Either a b
Left "Insufficient funds"
vAvail :: Word64
vAvail = [Word64] -> Word64
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word64] -> Word64) -> [Word64] -> Word64
forall a b. (a -> b) -> a -> b
$ (OutPoint, Word64) -> Word64
forall a b. (a, b) -> b
snd ((OutPoint, Word64) -> Word64) -> [(OutPoint, Word64)] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(OutPoint, Word64)]
inputs
sigIn :: (OutPoint, Word64) -> SigInput
sigIn (op :: OutPoint
op, val :: Word64
val) = ScriptOutput
-> Word64 -> OutPoint -> SigHash -> Maybe ScriptOutput -> SigInput
SigInput (Address -> ScriptOutput
addressToOutput Address
addr0) Word64
val OutPoint
op SigHash
sigHashAll Maybe ScriptOutput
forall a. Maybe a
Nothing
(outs :: [(Text, Word64)]
outs, vFund :: Word64
vFund) <- Either FilePath ([(Text, Word64)], Word64)
outSpec
Tx
txSpec <- Network -> [OutPoint] -> [(Text, Word64)] -> Either FilePath Tx
buildAddrTx Network
btcTest ((OutPoint, Word64) -> OutPoint
forall a b. (a, b) -> a
fst ((OutPoint, Word64) -> OutPoint)
-> [(OutPoint, Word64)] -> [OutPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(OutPoint, Word64)]
inputs) [(Text, Word64)]
outs
Tx
tx <- Network -> Tx -> [SigInput] -> [SecKey] -> Either FilePath Tx
signTx Network
btcTest Tx
txSpec ((OutPoint, Word64) -> SigInput
sigIn ((OutPoint, Word64) -> SigInput)
-> [(OutPoint, Word64)] -> [SigInput]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(OutPoint, Word64)]
inputs) [SecKey
key0]
(Tx, Word64) -> Either FilePath (Tx, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tx
tx, Word64
vFund)
xprv :: XPrvKey
xprv :: XPrvKey
xprv = ByteString -> XPrvKey
makeXPrvKey "bitcoind-regtest key seed"
keys :: [SecKey]
keys :: [SecKey]
keys = XPrvKey -> SecKey
xPrvKey (XPrvKey -> SecKey)
-> ((XPrvKey, Word32) -> XPrvKey) -> (XPrvKey, Word32) -> SecKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XPrvKey, Word32) -> XPrvKey
forall a b. (a, b) -> a
fst ((XPrvKey, Word32) -> SecKey) -> [(XPrvKey, Word32)] -> [SecKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XPrvKey -> Word32 -> [(XPrvKey, Word32)]
prvSubKeys XPrvKey
xprv 0
pubKeys :: [PubKeyI]
pubKeys :: [PubKeyI]
pubKeys = SecKeyI -> PubKeyI
derivePubKeyI (SecKeyI -> PubKeyI) -> (SecKey -> SecKeyI) -> SecKey -> PubKeyI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SecKey -> SecKeyI
wrapSecKey Bool
True (SecKey -> PubKeyI) -> [SecKey] -> [PubKeyI]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SecKey]
keys
key0 :: SecKey
key0 :: SecKey
key0 : _ = [SecKey]
keys
addrs :: [Address]
addrs :: [Address]
addrs = (Address, PubKey, Word32) -> Address
forall a b c. (a, b, c) -> a
repack ((Address, PubKey, Word32) -> Address)
-> [(Address, PubKey, Word32)] -> [Address]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XPubKey -> Word32 -> [(Address, PubKey, Word32)]
deriveAddrs (XPrvKey -> XPubKey
deriveXPubKey XPrvKey
xprv) 0
where
repack :: (a, b, c) -> a
repack (x :: a
x, _, _) = a
x
addr0 :: Address
addr0 :: Address
addr0 : _ = [Address]
addrs
textAddrs :: [Text]
textAddrs :: [Text]
textAddrs = Address -> Text
addrToText' (Address -> Text) -> [Address] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Address]
addrs
where
addrToText' :: Address -> Text
addrToText' a :: Address
a = let Just x :: Text
x = Network -> Address -> Maybe Text
addrToText Network
btcTest Address
a in Text
x
textAddr0, textAddr1, textAddr2 :: Text
textAddr0 :: Text
textAddr0 : textAddr1 :: Text
textAddr1 : textAddr2 :: Text
textAddr2 : _ = [Text]
textAddrs