{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

{- |
Module      : Haskoin.Transaction.Taproot
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

This module provides support for reperesenting full taproot outputs and parsing
taproot witnesses.  For reference see BIPS 340, 341, and 342.
-}
module Haskoin.Transaction.Taproot (
    XOnlyPubKey (..),
    TapLeafVersion,
    MAST (..),
    mastCommitment,
    getMerkleProofs,
    TaprootOutput (..),
    taprootOutputKey,
    taprootScriptOutput,
    TaprootWitness (..),
    ScriptPathData (..),
    viewTaprootWitness,
    encodeTaprootWitness,
    verifyScriptPathData,
) where

import Control.Applicative (many)
import Control.Monad ((<=<))
import Crypto.Hash (
    Digest,
    SHA256,
    digestFromByteString,
    hashFinalize,
    hashUpdate,
    hashUpdates,
 )
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText)
import Data.Binary (Binary (..))
import Data.Bits ((.&.), (.|.))
import Data.Bool (bool)
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Bytes.Get (getBytes, runGetS)
import Data.Bytes.Put (putByteString, runPutS)
import Data.Bytes.Serial (Serial (..), deserialize, serialize)
import Data.Bytes.VarInt (VarInt (VarInt))
import Data.Foldable (foldl')
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Serialize (Serialize, get, getByteString, getWord8, put)
import Data.Word (Word8)
import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey)
import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint)
import Haskoin.Script.Common (Script)
import Haskoin.Script.Standard (ScriptOutput (PayWitness))
import Haskoin.Transaction.Common (WitnessStack)
import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex)

{- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@.  The
equality test only checks the x-coordinate.  An x-only pubkey serializes to 32
bytes.

@since 0.21.0
-}
newtype XOnlyPubKey = XOnlyPubKey {XOnlyPubKey -> PubKey
xOnlyPubKey :: PubKey}
    deriving (Int -> XOnlyPubKey -> ShowS
[XOnlyPubKey] -> ShowS
XOnlyPubKey -> String
(Int -> XOnlyPubKey -> ShowS)
-> (XOnlyPubKey -> String)
-> ([XOnlyPubKey] -> ShowS)
-> Show XOnlyPubKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XOnlyPubKey] -> ShowS
$cshowList :: [XOnlyPubKey] -> ShowS
show :: XOnlyPubKey -> String
$cshow :: XOnlyPubKey -> String
showsPrec :: Int -> XOnlyPubKey -> ShowS
$cshowsPrec :: Int -> XOnlyPubKey -> ShowS
Show)

instance Eq XOnlyPubKey where
    XOnlyPubKey
k1 == :: XOnlyPubKey -> XOnlyPubKey -> Bool
== XOnlyPubKey
k2 = Put -> ByteString
runPutS (XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize XOnlyPubKey
k1) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Put -> ByteString
runPutS (XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize XOnlyPubKey
k2)

instance Serial XOnlyPubKey where
    serialize :: XOnlyPubKey -> m ()
serialize (XOnlyPubKey PubKey
pk) =
        ByteString -> m ()
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString
            (ByteString -> m ()) -> (PubKeyI -> ByteString) -> PubKeyI -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop Int
1
            (ByteString -> ByteString)
-> (PubKeyI -> ByteString) -> PubKeyI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS
            (Put -> ByteString) -> (PubKeyI -> Put) -> PubKeyI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
            (PubKeyI -> m ()) -> PubKeyI -> m ()
forall a b. (a -> b) -> a -> b
$ PubKey -> Bool -> PubKeyI
PubKeyI PubKey
pk Bool
True
    deserialize :: m XOnlyPubKey
deserialize =
        (String -> m XOnlyPubKey)
-> (PubKeyI -> m XOnlyPubKey)
-> Either String PubKeyI
-> m XOnlyPubKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m XOnlyPubKey
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (XOnlyPubKey -> m XOnlyPubKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XOnlyPubKey -> m XOnlyPubKey)
-> (PubKeyI -> XOnlyPubKey) -> PubKeyI -> m XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey (PubKey -> XOnlyPubKey)
-> (PubKeyI -> PubKey) -> PubKeyI -> XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> PubKey
pubKeyPoint)
            (Either String PubKeyI -> m XOnlyPubKey)
-> (ByteString -> Either String PubKeyI)
-> ByteString
-> m XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get PubKeyI -> ByteString -> Either String PubKeyI
forall a. Get a -> ByteString -> Either String a
runGetS Get PubKeyI
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
            (ByteString -> Either String PubKeyI)
-> (ByteString -> ByteString)
-> ByteString
-> Either String PubKeyI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> ByteString
BS.cons Word8
0x02
            (ByteString -> m XOnlyPubKey) -> m ByteString -> m XOnlyPubKey
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> m ByteString
forall (m :: * -> *). MonadGet m => Int -> m ByteString
getBytes Int
32

instance Serialize XOnlyPubKey where
    put :: XOnlyPubKey -> Put
put = XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get XOnlyPubKey
get = Get XOnlyPubKey
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance Binary XOnlyPubKey where
    put :: XOnlyPubKey -> Put
put = XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get XOnlyPubKey
get = Get XOnlyPubKey
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

-- | Hex encoding
instance FromJSON XOnlyPubKey where
    parseJSON :: Value -> Parser XOnlyPubKey
parseJSON =
        String
-> (Text -> Parser XOnlyPubKey) -> Value -> Parser XOnlyPubKey
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"XOnlyPubKey" ((Text -> Parser XOnlyPubKey) -> Value -> Parser XOnlyPubKey)
-> (Text -> Parser XOnlyPubKey) -> Value -> Parser XOnlyPubKey
forall a b. (a -> b) -> a -> b
$
            (String -> Parser XOnlyPubKey)
-> (XOnlyPubKey -> Parser XOnlyPubKey)
-> Either String XOnlyPubKey
-> Parser XOnlyPubKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser XOnlyPubKey
forall (m :: * -> *) a. MonadFail m => String -> m a
fail XOnlyPubKey -> Parser XOnlyPubKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Either String XOnlyPubKey -> Parser XOnlyPubKey)
-> (Text -> Either String XOnlyPubKey)
-> Text
-> Parser XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Get XOnlyPubKey -> ByteString -> Either String XOnlyPubKey
forall a. Get a -> ByteString -> Either String a
runGetS Get XOnlyPubKey
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize (ByteString -> Either String XOnlyPubKey)
-> (Text -> Either String ByteString)
-> Text
-> Either String XOnlyPubKey
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Unable to decode hex") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> (Text -> Maybe ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex)

-- | Hex encoding
instance ToJSON XOnlyPubKey where
    toJSON :: XOnlyPubKey -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (XOnlyPubKey -> Text) -> XOnlyPubKey -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeHex (ByteString -> Text)
-> (XOnlyPubKey -> ByteString) -> XOnlyPubKey -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (XOnlyPubKey -> Put) -> XOnlyPubKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize

-- | @since 0.21.0
type TapLeafVersion = Word8

{- | Merklized Abstract Syntax Tree.  This type can represent trees where only a
subset of the leaves are known.  Note that the tree is invariant under swapping
branches at an internal node.

@since 0.21.0
-}
data MAST
    = MASTBranch MAST MAST
    | MASTLeaf TapLeafVersion Script
    | MASTCommitment (Digest SHA256)
    deriving (Int -> MAST -> ShowS
[MAST] -> ShowS
MAST -> String
(Int -> MAST -> ShowS)
-> (MAST -> String) -> ([MAST] -> ShowS) -> Show MAST
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MAST] -> ShowS
$cshowList :: [MAST] -> ShowS
show :: MAST -> String
$cshow :: MAST -> String
showsPrec :: Int -> MAST -> ShowS
$cshowsPrec :: Int -> MAST -> ShowS
Show)

{- | Get the inclusion proofs for the leaves in the tree.  The proof is ordered
leaf-to-root.

@since 0.21.0
-}
getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])]
getMerkleProofs :: MAST -> [(Word8, Script, [Digest SHA256])]
getMerkleProofs = [Digest SHA256] -> MAST -> [(Word8, Script, [Digest SHA256])]
getProofs [Digest SHA256]
forall a. Monoid a => a
mempty
  where
    getProofs :: [Digest SHA256] -> MAST -> [(Word8, Script, [Digest SHA256])]
getProofs [Digest SHA256]
proof = \case
        MASTBranch MAST
branchL MAST
branchR ->
            ([Digest SHA256]
-> Digest SHA256
-> (Word8, Script, [Digest SHA256])
-> (Word8, Script, [Digest SHA256])
forall a a b. [a] -> a -> (a, b, [a]) -> (a, b, [a])
updateProof [Digest SHA256]
proof (MAST -> Digest SHA256
mastCommitment MAST
branchR) ((Word8, Script, [Digest SHA256])
 -> (Word8, Script, [Digest SHA256]))
-> [(Word8, Script, [Digest SHA256])]
-> [(Word8, Script, [Digest SHA256])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MAST -> [(Word8, Script, [Digest SHA256])]
getMerkleProofs MAST
branchL)
                [(Word8, Script, [Digest SHA256])]
-> [(Word8, Script, [Digest SHA256])]
-> [(Word8, Script, [Digest SHA256])]
forall a. Semigroup a => a -> a -> a
<> ([Digest SHA256]
-> Digest SHA256
-> (Word8, Script, [Digest SHA256])
-> (Word8, Script, [Digest SHA256])
forall a a b. [a] -> a -> (a, b, [a]) -> (a, b, [a])
updateProof [Digest SHA256]
proof (MAST -> Digest SHA256
mastCommitment MAST
branchL) ((Word8, Script, [Digest SHA256])
 -> (Word8, Script, [Digest SHA256]))
-> [(Word8, Script, [Digest SHA256])]
-> [(Word8, Script, [Digest SHA256])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MAST -> [(Word8, Script, [Digest SHA256])]
getMerkleProofs MAST
branchR)
        MASTLeaf Word8
v Script
s -> [(Word8
v, Script
s, [Digest SHA256]
proof)]
        MASTCommitment{} -> [(Word8, Script, [Digest SHA256])]
forall a. Monoid a => a
mempty
    updateProof :: [a] -> a -> (a, b, [a]) -> (a, b, [a])
updateProof [a]
proofInit a
branchCommitment (a
v, b
s, [a]
proofTail) =
        (a
v, b
s, [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
proofInit [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> (a
branchCommitment a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
proofTail))

{- | Calculate the root hash for this tree.

@since 0.21.0
-}
mastCommitment :: MAST -> Digest SHA256
mastCommitment :: MAST -> Digest SHA256
mastCommitment = \case
    MASTBranch MAST
leftBranch MAST
rightBranch ->
        Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch (MAST -> Digest SHA256
mastCommitment MAST
leftBranch) (MAST -> Digest SHA256
mastCommitment MAST
rightBranch)
    MASTLeaf Word8
leafVersion Script
leafScript -> Word8 -> Script -> Digest SHA256
leafHash Word8
leafVersion Script
leafScript
    MASTCommitment Digest SHA256
theCommitment -> Digest SHA256
theCommitment

hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch Digest SHA256
hashA Digest SHA256
hashB =
    Context SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context SHA256 -> Digest SHA256)
-> Context SHA256 -> Digest SHA256
forall a b. (a -> b) -> a -> b
$
        Context SHA256 -> [Digest SHA256] -> Context SHA256
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates
            (ByteString -> Context SHA256
initTaggedHash ByteString
"TapBranch")
            [ Digest SHA256 -> Digest SHA256 -> Digest SHA256
forall a. Ord a => a -> a -> a
min Digest SHA256
hashA Digest SHA256
hashB
            , Digest SHA256 -> Digest SHA256 -> Digest SHA256
forall a. Ord a => a -> a -> a
max Digest SHA256
hashA Digest SHA256
hashB
            ]

leafHash :: TapLeafVersion -> Script -> Digest SHA256
leafHash :: Word8 -> Script -> Digest SHA256
leafHash Word8
leafVersion Script
leafScript =
    Context SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize
        (Context SHA256 -> Digest SHA256)
-> (Put -> Context SHA256) -> Put -> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context SHA256 -> ByteString -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString -> Context SHA256
initTaggedHash ByteString
"TapLeaf")
        (ByteString -> Context SHA256)
-> (Put -> ByteString) -> Put -> Context SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS
        (Put -> Digest SHA256) -> Put -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ do
            Word8 -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Word8
leafVersion
            VarInt Int -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (VarInt Int -> Put) -> VarInt Int -> Put
forall a b. (a -> b) -> a -> b
$ Int -> VarInt Int
forall n. n -> VarInt n
VarInt (ByteString -> Int
BS.length ByteString
scriptBytes)
            ByteString -> Put
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString ByteString
scriptBytes
  where
    scriptBytes :: ByteString
scriptBytes = Put -> ByteString
runPutS (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Script -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Script
leafScript

{- | Representation of a full taproot output.

@since 0.21.0
-}
data TaprootOutput = TaprootOutput
    { TaprootOutput -> PubKey
taprootInternalKey :: PubKey
    , TaprootOutput -> Maybe MAST
taprootMAST :: Maybe MAST
    }
    deriving (Int -> TaprootOutput -> ShowS
[TaprootOutput] -> ShowS
TaprootOutput -> String
(Int -> TaprootOutput -> ShowS)
-> (TaprootOutput -> String)
-> ([TaprootOutput] -> ShowS)
-> Show TaprootOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TaprootOutput] -> ShowS
$cshowList :: [TaprootOutput] -> ShowS
show :: TaprootOutput -> String
$cshow :: TaprootOutput -> String
showsPrec :: Int -> TaprootOutput -> ShowS
$cshowsPrec :: Int -> TaprootOutput -> ShowS
Show)

-- | @since 0.21.0
taprootOutputKey :: TaprootOutput -> PubKey
taprootOutputKey :: TaprootOutput -> PubKey
taprootOutputKey TaprootOutput{PubKey
taprootInternalKey :: PubKey
taprootInternalKey :: TaprootOutput -> PubKey
taprootInternalKey, Maybe MAST
taprootMAST :: Maybe MAST
taprootMAST :: TaprootOutput -> Maybe MAST
taprootMAST} =
    PubKey -> Maybe PubKey -> PubKey
forall a. a -> Maybe a -> a
fromMaybe PubKey
forall a. a
keyFail (Maybe PubKey -> PubKey) -> Maybe PubKey -> PubKey
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Tweak
tweak ByteString
commitment Maybe Tweak -> (Tweak -> Maybe PubKey) -> Maybe PubKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PubKey -> Tweak -> Maybe PubKey
tweakAddPubKey PubKey
taprootInternalKey
  where
    commitment :: ByteString
commitment = PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment PubKey
taprootInternalKey (Maybe (Digest SHA256) -> ByteString)
-> Maybe (Digest SHA256) -> ByteString
forall a b. (a -> b) -> a -> b
$ MAST -> Digest SHA256
mastCommitment (MAST -> Digest SHA256) -> Maybe MAST -> Maybe (Digest SHA256)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MAST
taprootMAST
    keyFail :: a
keyFail = String -> a
forall a. HasCallStack => String -> a
error String
"haskoin-core taprootOutputKey: key derivation failed"

taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment PubKey
internalKey Maybe (Digest SHA256)
merkleRoot =
    Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA256 -> ByteString)
-> (Context SHA256 -> Digest SHA256)
-> Context SHA256
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize
        (Context SHA256 -> Digest SHA256)
-> (Context SHA256 -> Context SHA256)
-> Context SHA256
-> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context SHA256 -> Context SHA256)
-> (Digest SHA256 -> Context SHA256 -> Context SHA256)
-> Maybe (Digest SHA256)
-> Context SHA256
-> Context SHA256
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Context SHA256 -> Context SHA256
forall a. a -> a
id ((Context SHA256 -> Digest SHA256 -> Context SHA256)
-> Digest SHA256 -> Context SHA256 -> Context SHA256
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Digest SHA256 -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate) Maybe (Digest SHA256)
merkleRoot
        (Context SHA256 -> Context SHA256)
-> (Context SHA256 -> Context SHA256)
-> Context SHA256
-> Context SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context SHA256 -> ByteString -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
`hashUpdate` ByteString
keyBytes)
        (Context SHA256 -> ByteString) -> Context SHA256 -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Context SHA256
initTaggedHash ByteString
"TapTweak"
  where
    keyBytes :: ByteString
keyBytes = Put -> ByteString
runPutS (Put -> ByteString)
-> (XOnlyPubKey -> Put) -> XOnlyPubKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (XOnlyPubKey -> ByteString) -> XOnlyPubKey -> ByteString
forall a b. (a -> b) -> a -> b
$ PubKey -> XOnlyPubKey
XOnlyPubKey PubKey
internalKey

{- | Generate the output script for a taproot output

@since 0.21.0
-}
taprootScriptOutput :: TaprootOutput -> ScriptOutput
taprootScriptOutput :: TaprootOutput -> ScriptOutput
taprootScriptOutput = Word8 -> ByteString -> ScriptOutput
PayWitness Word8
0x01 (ByteString -> ScriptOutput)
-> (TaprootOutput -> ByteString) -> TaprootOutput -> ScriptOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (TaprootOutput -> Put) -> TaprootOutput -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (XOnlyPubKey -> Put)
-> (TaprootOutput -> XOnlyPubKey) -> TaprootOutput -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey (PubKey -> XOnlyPubKey)
-> (TaprootOutput -> PubKey) -> TaprootOutput -> XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaprootOutput -> PubKey
taprootOutputKey

{- | Comprehension of taproot witness data

@since 0.21.0
-}
data TaprootWitness
    = -- | Signature
      KeyPathSpend ByteString
    | ScriptPathSpend ScriptPathData
    deriving (TaprootWitness -> TaprootWitness -> Bool
(TaprootWitness -> TaprootWitness -> Bool)
-> (TaprootWitness -> TaprootWitness -> Bool) -> Eq TaprootWitness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TaprootWitness -> TaprootWitness -> Bool
$c/= :: TaprootWitness -> TaprootWitness -> Bool
== :: TaprootWitness -> TaprootWitness -> Bool
$c== :: TaprootWitness -> TaprootWitness -> Bool
Eq, Int -> TaprootWitness -> ShowS
[TaprootWitness] -> ShowS
TaprootWitness -> String
(Int -> TaprootWitness -> ShowS)
-> (TaprootWitness -> String)
-> ([TaprootWitness] -> ShowS)
-> Show TaprootWitness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TaprootWitness] -> ShowS
$cshowList :: [TaprootWitness] -> ShowS
show :: TaprootWitness -> String
$cshow :: TaprootWitness -> String
showsPrec :: Int -> TaprootWitness -> ShowS
$cshowsPrec :: Int -> TaprootWitness -> ShowS
Show)

-- | @since 0.21.0
data ScriptPathData = ScriptPathData
    { ScriptPathData -> Maybe ByteString
scriptPathAnnex :: Maybe ByteString
    , ScriptPathData -> [ByteString]
scriptPathStack :: [ByteString]
    , ScriptPathData -> Script
scriptPathScript :: Script
    , ScriptPathData -> Bool
scriptPathExternalIsOdd :: Bool
    , -- | This value is masked by 0xFE
      ScriptPathData -> Word8
scriptPathLeafVersion :: Word8
    , ScriptPathData -> PubKey
scriptPathInternalKey :: PubKey
    , ScriptPathData -> [ByteString]
scriptPathControl :: [ByteString]
    }
    deriving (ScriptPathData -> ScriptPathData -> Bool
(ScriptPathData -> ScriptPathData -> Bool)
-> (ScriptPathData -> ScriptPathData -> Bool) -> Eq ScriptPathData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptPathData -> ScriptPathData -> Bool
$c/= :: ScriptPathData -> ScriptPathData -> Bool
== :: ScriptPathData -> ScriptPathData -> Bool
$c== :: ScriptPathData -> ScriptPathData -> Bool
Eq, Int -> ScriptPathData -> ShowS
[ScriptPathData] -> ShowS
ScriptPathData -> String
(Int -> ScriptPathData -> ShowS)
-> (ScriptPathData -> String)
-> ([ScriptPathData] -> ShowS)
-> Show ScriptPathData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptPathData] -> ShowS
$cshowList :: [ScriptPathData] -> ShowS
show :: ScriptPathData -> String
$cshow :: ScriptPathData -> String
showsPrec :: Int -> ScriptPathData -> ShowS
$cshowsPrec :: Int -> ScriptPathData -> ShowS
Show)

{- | Try to interpret a 'WitnessStack' as taproot witness data.

@since 0.21.0
-}
viewTaprootWitness :: WitnessStack -> Maybe TaprootWitness
viewTaprootWitness :: [ByteString] -> Maybe TaprootWitness
viewTaprootWitness [ByteString]
witnessStack = case [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
witnessStack of
    [ByteString
sig] -> TaprootWitness -> Maybe TaprootWitness
forall a. a -> Maybe a
Just (TaprootWitness -> Maybe TaprootWitness)
-> TaprootWitness -> Maybe TaprootWitness
forall a b. (a -> b) -> a -> b
$ ByteString -> TaprootWitness
KeyPathSpend ByteString
sig
    ByteString
annexA : [ByteString]
remainingStack
        | Word8
0x50 : [Word8]
_ <- ByteString -> [Word8]
BS.unpack ByteString
annexA ->
            Maybe ByteString -> [ByteString] -> Maybe TaprootWitness
parseSpendPathData (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
annexA) [ByteString]
remainingStack
    [ByteString]
remainingStack -> Maybe ByteString -> [ByteString] -> Maybe TaprootWitness
parseSpendPathData Maybe ByteString
forall a. Maybe a
Nothing [ByteString]
remainingStack
  where
    parseSpendPathData :: Maybe ByteString -> [ByteString] -> Maybe TaprootWitness
parseSpendPathData Maybe ByteString
scriptPathAnnex = \case
        ByteString
scriptBytes : ByteString
controlBytes : [ByteString]
scriptPathStack -> do
            Script
scriptPathScript <- Either String Script -> Maybe Script
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String Script -> Maybe Script)
-> Either String Script -> Maybe Script
forall a b. (a -> b) -> a -> b
$ Get Script -> ByteString -> Either String Script
forall a. Get a -> ByteString -> Either String a
runGetS Get Script
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize ByteString
scriptBytes
            (Word8
v, PubKey
scriptPathInternalKey, [ByteString]
scriptPathControl) <- ByteString -> Maybe (Word8, PubKey, [ByteString])
deconstructControl ByteString
controlBytes
            TaprootWitness -> Maybe TaprootWitness
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaprootWitness -> Maybe TaprootWitness)
-> (ScriptPathData -> TaprootWitness)
-> ScriptPathData
-> Maybe TaprootWitness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptPathData -> TaprootWitness
ScriptPathSpend (ScriptPathData -> Maybe TaprootWitness)
-> ScriptPathData -> Maybe TaprootWitness
forall a b. (a -> b) -> a -> b
$
                ScriptPathData :: Maybe ByteString
-> [ByteString]
-> Script
-> Bool
-> Word8
-> PubKey
-> [ByteString]
-> ScriptPathData
ScriptPathData
                    { Maybe ByteString
scriptPathAnnex :: Maybe ByteString
scriptPathAnnex :: Maybe ByteString
scriptPathAnnex
                    , [ByteString]
scriptPathStack :: [ByteString]
scriptPathStack :: [ByteString]
scriptPathStack
                    , Script
scriptPathScript :: Script
scriptPathScript :: Script
scriptPathScript
                    , scriptPathExternalIsOdd :: Bool
scriptPathExternalIsOdd = Word8 -> Bool
forall a. Integral a => a -> Bool
odd Word8
v
                    , scriptPathLeafVersion :: Word8
scriptPathLeafVersion = Word8
v Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xFE
                    , PubKey
scriptPathInternalKey :: PubKey
scriptPathInternalKey :: PubKey
scriptPathInternalKey
                    , [ByteString]
scriptPathControl :: [ByteString]
scriptPathControl :: [ByteString]
scriptPathControl
                    }
        [ByteString]
_ -> Maybe TaprootWitness
forall a. Maybe a
Nothing
    deconstructControl :: ByteString -> Maybe (Word8, PubKey, [ByteString])
deconstructControl = Either String (Word8, PubKey, [ByteString])
-> Maybe (Word8, PubKey, [ByteString])
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String (Word8, PubKey, [ByteString])
 -> Maybe (Word8, PubKey, [ByteString]))
-> (ByteString -> Either String (Word8, PubKey, [ByteString]))
-> ByteString
-> Maybe (Word8, PubKey, [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get (Word8, PubKey, [ByteString])
-> ByteString -> Either String (Word8, PubKey, [ByteString])
forall a. Get a -> ByteString -> Either String a
runGetS Get (Word8, PubKey, [ByteString])
deserializeControl
    deserializeControl :: Get (Word8, PubKey, [ByteString])
deserializeControl = do
        Word8
v <- Get Word8
getWord8
        PubKey
k <- XOnlyPubKey -> PubKey
xOnlyPubKey (XOnlyPubKey -> PubKey) -> Get XOnlyPubKey -> Get PubKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get XOnlyPubKey
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        [ByteString]
proof <- Get ByteString -> Get [ByteString]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Get ByteString -> Get [ByteString])
-> Get ByteString -> Get [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString Int
32
        (Word8, PubKey, [ByteString]) -> Get (Word8, PubKey, [ByteString])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8
v, PubKey
k, [ByteString]
proof)

{- | Transform the high-level representation of taproot witness data into a witness stack

@since 0.21.0
-}
encodeTaprootWitness :: TaprootWitness -> WitnessStack
encodeTaprootWitness :: TaprootWitness -> [ByteString]
encodeTaprootWitness = \case
    KeyPathSpend ByteString
signature -> ByteString -> [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
signature
    ScriptPathSpend ScriptPathData
scriptPathData ->
        ScriptPathData -> [ByteString]
scriptPathStack ScriptPathData
scriptPathData
            [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ Put -> ByteString
runPutS (Put -> ByteString) -> (Script -> Put) -> Script -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (Script -> ByteString) -> Script -> ByteString
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Script
scriptPathScript ScriptPathData
scriptPathData
               , [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
                    [ [Word8] -> ByteString
BS.pack [ScriptPathData -> Word8
scriptPathLeafVersion ScriptPathData
scriptPathData Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ScriptPathData -> Word8
parity ScriptPathData
scriptPathData]
                    , Put -> ByteString
runPutS (Put -> ByteString) -> (PubKey -> Put) -> PubKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOnlyPubKey -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (XOnlyPubKey -> Put) -> (PubKey -> XOnlyPubKey) -> PubKey -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey (PubKey -> ByteString) -> PubKey -> ByteString
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> PubKey
scriptPathInternalKey ScriptPathData
scriptPathData
                    , [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> [ByteString]
scriptPathControl ScriptPathData
scriptPathData
                    ]
               , ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Maybe ByteString
scriptPathAnnex ScriptPathData
scriptPathData
               ]
  where
    parity :: ScriptPathData -> Word8
parity = Word8 -> Word8 -> Bool -> Word8
forall a. a -> a -> Bool -> a
bool Word8
0 Word8
1 (Bool -> Word8)
-> (ScriptPathData -> Bool) -> ScriptPathData -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptPathData -> Bool
scriptPathExternalIsOdd

{- | Verify that the script path spend is valid, except for script execution.

@since 0.21.0
-}
verifyScriptPathData ::
    -- | Output key
    PubKey ->
    ScriptPathData ->
    Bool
verifyScriptPathData :: PubKey -> ScriptPathData -> Bool
verifyScriptPathData PubKey
outputKey ScriptPathData
scriptPathData = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Maybe Tweak
tweak ByteString
commitment Maybe Tweak -> (Tweak -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PubKey -> Bool) -> Maybe PubKey -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PubKey -> Bool
onComputedKey (Maybe PubKey -> Maybe Bool)
-> (Tweak -> Maybe PubKey) -> Tweak -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> Tweak -> Maybe PubKey
tweakAddPubKey (ScriptPathData -> PubKey
scriptPathInternalKey ScriptPathData
scriptPathData)
  where
    onComputedKey :: PubKey -> Bool
onComputedKey PubKey
computedKey =
        PubKey -> XOnlyPubKey
XOnlyPubKey PubKey
outputKey XOnlyPubKey -> XOnlyPubKey -> Bool
forall a. Eq a => a -> a -> Bool
== PubKey -> XOnlyPubKey
XOnlyPubKey PubKey
computedKey
            Bool -> Bool -> Bool
&& Word8
expectedParity Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== PubKey -> Word8
keyParity PubKey
computedKey
    commitment :: ByteString
commitment = PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment (ScriptPathData -> PubKey
scriptPathInternalKey ScriptPathData
scriptPathData) (Digest SHA256 -> Maybe (Digest SHA256)
forall a. a -> Maybe a
Just Digest SHA256
merkleRoot)
    merkleRoot :: Digest SHA256
merkleRoot =
        (Digest SHA256 -> Digest SHA256 -> Digest SHA256)
-> Digest SHA256 -> [Digest SHA256] -> Digest SHA256
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch Digest SHA256
theLeafHash
            ([Digest SHA256] -> Digest SHA256)
-> ([ByteString] -> [Digest SHA256])
-> [ByteString]
-> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Digest SHA256))
-> [ByteString] -> [Digest SHA256]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall ba.
(HashAlgorithm SHA256, ByteArrayAccess ba) =>
ba -> Maybe (Digest SHA256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA256)
            ([ByteString] -> Digest SHA256) -> [ByteString] -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> [ByteString]
scriptPathControl ScriptPathData
scriptPathData
    theLeafHash :: Digest SHA256
theLeafHash = (Word8 -> Script -> Digest SHA256
leafHash (Word8 -> Script -> Digest SHA256)
-> (ScriptPathData -> Word8)
-> ScriptPathData
-> Script
-> Digest SHA256
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xFE) (Word8 -> Word8)
-> (ScriptPathData -> Word8) -> ScriptPathData -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptPathData -> Word8
scriptPathLeafVersion (ScriptPathData -> Script -> Digest SHA256)
-> (ScriptPathData -> Script) -> ScriptPathData -> Digest SHA256
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScriptPathData -> Script
scriptPathScript) ScriptPathData
scriptPathData
    expectedParity :: Word8
expectedParity = Word8 -> Word8 -> Bool -> Word8
forall a. a -> a -> Bool -> a
bool Word8
0 Word8
1 (Bool -> Word8) -> Bool -> Word8
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Bool
scriptPathExternalIsOdd ScriptPathData
scriptPathData

keyParity :: PubKey -> Word8
keyParity :: PubKey -> Word8
keyParity PubKey
key = case ByteString -> [Word8]
BS.unpack (ByteString -> [Word8])
-> (PubKeyI -> ByteString) -> PubKeyI -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString) -> (PubKeyI -> Put) -> PubKeyI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (PubKeyI -> [Word8]) -> PubKeyI -> [Word8]
forall a b. (a -> b) -> a -> b
$ PubKey -> Bool -> PubKeyI
PubKeyI PubKey
key Bool
True of
    Word8
0x02 : [Word8]
_ -> Word8
0x00
    [Word8]
_ -> Word8
0x01