{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}

module Bitcoin.Core.Regtest (
    -- * Run an ephemeral regtest node
    NodeHandle (..),
    runBitcoind,
    withBitcoind,

    -- * Funding
    oneBitcoin,
    createOutput,
    generate,
    spendPackageOutputs,

    -- * Internal wallet

    --
    -- In the following lists, entries correspond to each other e.g. the p2pkh
    -- address for @keys !! 1@ is @addrs !! 1@.
    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 needed to connect to a @bitcoind-regtest@ ephemeral node
data NodeHandle = NodeHandle
    { NodeHandle -> Int
nodePort :: Int
    , NodeHandle -> BasicAuthData
nodeAuth :: BasicAuthData
    , NodeHandle -> FilePath
nodeRawTx :: FilePath
    , NodeHandle -> FilePath
nodeRawBlock :: FilePath
    }

-- | Run an RPC computation with an ephemeral node
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

-- | Provide bracketed access to a fresh ephemeral node
withBitcoind ::
    -- | node port
    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

-- | Funds an output with the minimum of the given amount and 100 blocks of subsidies
createOutput ::
    -- | address for the newly created output
    Address ->
    -- | target amount
    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
    -- Make mined outputs spendable
    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)

{- | A simplified block generator which does not require the tester to manage a
 wallet.  Use 'spendPackageOutputs' to spend.
-}
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)

-- | Spend outputs created by 'generate'
spendPackageOutputs ::
    -- | outputs produced by 'generate'
    [(OutPoint, Word64)] ->
    -- | recipient address
    Address ->
    -- | amount to spend
    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)

-- | Root key for the package wallet
xprv :: XPrvKey
xprv :: XPrvKey
xprv = ByteString -> XPrvKey
makeXPrvKey "bitcoind-regtest key seed"

-- | Example secret keys
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

-- | Example public keys
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

-- | Example p2pkh addresses
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

-- | Text versions of the example addresses
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