{-# 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
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 -> WitnessStackItem
runPutS (forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize XOnlyPubKey
k1) forall a. Eq a => a -> a -> Bool
== Put -> WitnessStackItem
runPutS (forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize XOnlyPubKey
k2)

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

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

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

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

-- | Hex encoding
instance ToJSON XOnlyPubKey where
    toJSON :: XOnlyPubKey -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. WitnessStackItem -> Text
encodeHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> WitnessStackItem
runPutS forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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 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 ->
            (forall {a} {a} {b}. [a] -> a -> (a, b, [a]) -> (a, b, [a])
updateProof [Digest SHA256]
proof (MAST -> Digest SHA256
mastCommitment MAST
branchR) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MAST -> [(Word8, Script, [Digest SHA256])]
getMerkleProofs MAST
branchL)
                forall a. Semigroup a => a -> a -> a
<> (forall {a} {a} {b}. [a] -> a -> (a, b, [a]) -> (a, b, [a])
updateProof [Digest SHA256]
proof (MAST -> Digest SHA256
mastCommitment MAST
branchL) 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{} -> 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, forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [a]
proofInit forall a. Semigroup a => a -> a -> a
<> (a
branchCommitment 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 =
    forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize forall a b. (a -> b) -> a -> b
$
        forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates
            (WitnessStackItem -> Context SHA256
initTaggedHash WitnessStackItem
"TapBranch")
            [ forall a. Ord a => a -> a -> a
min Digest SHA256
hashA Digest SHA256
hashB
            , 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 =
    forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (WitnessStackItem -> Context SHA256
initTaggedHash WitnessStackItem
"TapLeaf")
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> WitnessStackItem
runPutS
        forall a b. (a -> b) -> a -> b
$ do
            forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Word8
leafVersion
            forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall a b. (a -> b) -> a -> b
$ forall n. n -> VarInt n
VarInt (WitnessStackItem -> Int
BS.length WitnessStackItem
scriptBytes)
            forall (m :: * -> *). MonadPut m => WitnessStackItem -> m ()
putByteString WitnessStackItem
scriptBytes
  where
    scriptBytes :: WitnessStackItem
scriptBytes = Put -> WitnessStackItem
runPutS forall a b. (a -> b) -> a -> b
$ 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
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} =
    forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
keyFail forall a b. (a -> b) -> a -> b
$ WitnessStackItem -> Maybe Tweak
tweak WitnessStackItem
commitment forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PubKey -> Tweak -> Maybe PubKey
tweakAddPubKey PubKey
taprootInternalKey
  where
    commitment :: WitnessStackItem
commitment = PubKey -> Maybe (Digest SHA256) -> WitnessStackItem
taprootCommitment PubKey
taprootInternalKey forall a b. (a -> b) -> a -> b
$ MAST -> Digest SHA256
mastCommitment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MAST
taprootMAST
    keyFail :: a
keyFail = forall a. HasCallStack => String -> a
error String
"haskoin-core taprootOutputKey: key derivation failed"

taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> WitnessStackItem
taprootCommitment PubKey
internalKey Maybe (Digest SHA256)
merkleRoot =
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate) Maybe (Digest SHA256)
merkleRoot
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
`hashUpdate` WitnessStackItem
keyBytes)
        forall a b. (a -> b) -> a -> b
$ WitnessStackItem -> Context SHA256
initTaggedHash WitnessStackItem
"TapTweak"
  where
    keyBytes :: WitnessStackItem
keyBytes = Put -> WitnessStackItem
runPutS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize 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 -> WitnessStackItem -> ScriptOutput
PayWitness Word8
0x01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> WitnessStackItem
runPutS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
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
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
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 WitnessStackItem
scriptPathAnnex :: Maybe ByteString
    , ScriptPathData -> WitnessStack
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 -> WitnessStack
scriptPathControl :: [ByteString]
    }
    deriving (ScriptPathData -> ScriptPathData -> Bool
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
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 :: WitnessStack -> Maybe TaprootWitness
viewTaprootWitness WitnessStack
witnessStack = case forall a. [a] -> [a]
reverse WitnessStack
witnessStack of
    [WitnessStackItem
sig] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WitnessStackItem -> TaprootWitness
KeyPathSpend WitnessStackItem
sig
    WitnessStackItem
annexA : WitnessStack
remainingStack
        | Word8
0x50 : [Word8]
_ <- WitnessStackItem -> [Word8]
BS.unpack WitnessStackItem
annexA ->
            Maybe WitnessStackItem -> WitnessStack -> Maybe TaprootWitness
parseSpendPathData (forall a. a -> Maybe a
Just WitnessStackItem
annexA) WitnessStack
remainingStack
    WitnessStack
remainingStack -> Maybe WitnessStackItem -> WitnessStack -> Maybe TaprootWitness
parseSpendPathData forall a. Maybe a
Nothing WitnessStack
remainingStack
  where
    parseSpendPathData :: Maybe WitnessStackItem -> WitnessStack -> Maybe TaprootWitness
parseSpendPathData Maybe WitnessStackItem
scriptPathAnnex = \case
        WitnessStackItem
scriptBytes : WitnessStackItem
controlBytes : WitnessStack
scriptPathStack -> do
            Script
scriptPathScript <- forall a b. Either a b -> Maybe b
eitherToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Get a -> WitnessStackItem -> Either String a
runGetS forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize WitnessStackItem
scriptBytes
            (Word8
v, PubKey
scriptPathInternalKey, WitnessStack
scriptPathControl) <- WitnessStackItem -> Maybe (Word8, PubKey, WitnessStack)
deconstructControl WitnessStackItem
controlBytes
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptPathData -> TaprootWitness
ScriptPathSpend forall a b. (a -> b) -> a -> b
$
                ScriptPathData
                    { Maybe WitnessStackItem
scriptPathAnnex :: Maybe WitnessStackItem
scriptPathAnnex :: Maybe WitnessStackItem
scriptPathAnnex
                    , WitnessStack
scriptPathStack :: WitnessStack
scriptPathStack :: WitnessStack
scriptPathStack
                    , Script
scriptPathScript :: Script
scriptPathScript :: Script
scriptPathScript
                    , scriptPathExternalIsOdd :: Bool
scriptPathExternalIsOdd = forall a. Integral a => a -> Bool
odd Word8
v
                    , scriptPathLeafVersion :: Word8
scriptPathLeafVersion = Word8
v forall a. Bits a => a -> a -> a
.&. Word8
0xFE
                    , PubKey
scriptPathInternalKey :: PubKey
scriptPathInternalKey :: PubKey
scriptPathInternalKey
                    , WitnessStack
scriptPathControl :: WitnessStack
scriptPathControl :: WitnessStack
scriptPathControl
                    }
        WitnessStack
_ -> forall a. Maybe a
Nothing
    deconstructControl :: WitnessStackItem -> Maybe (Word8, PubKey, WitnessStack)
deconstructControl = forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> WitnessStackItem -> Either String a
runGetS Get (Word8, PubKey, WitnessStack)
deserializeControl
    deserializeControl :: Get (Word8, PubKey, WitnessStack)
deserializeControl = do
        Word8
v <- Get Word8
getWord8
        PubKey
k <- XOnlyPubKey -> PubKey
xOnlyPubKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        WitnessStack
proof <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ Int -> Get WitnessStackItem
getByteString Int
32
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8
v, PubKey
k, WitnessStack
proof)

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

@since 0.21.0
-}
encodeTaprootWitness :: TaprootWitness -> WitnessStack
encodeTaprootWitness :: TaprootWitness -> WitnessStack
encodeTaprootWitness = \case
    KeyPathSpend WitnessStackItem
signature -> forall (f :: * -> *) a. Applicative f => a -> f a
pure WitnessStackItem
signature
    ScriptPathSpend ScriptPathData
scriptPathData ->
        ScriptPathData -> WitnessStack
scriptPathStack ScriptPathData
scriptPathData
            forall a. Semigroup a => a -> a -> a
<> [ Put -> WitnessStackItem
runPutS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Script
scriptPathScript ScriptPathData
scriptPathData
               , forall a. Monoid a => [a] -> a
mconcat
                    [ [Word8] -> WitnessStackItem
BS.pack [ScriptPathData -> Word8
scriptPathLeafVersion ScriptPathData
scriptPathData forall a. Bits a => a -> a -> a
.|. ScriptPathData -> Word8
parity ScriptPathData
scriptPathData]
                    , Put -> WitnessStackItem
runPutS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey forall a b. (a -> b) -> a -> b
$ ScriptPathData -> PubKey
scriptPathInternalKey ScriptPathData
scriptPathData
                    , forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ScriptPathData -> WitnessStack
scriptPathControl ScriptPathData
scriptPathData
                    ]
               , forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Maybe WitnessStackItem
scriptPathAnnex ScriptPathData
scriptPathData
               ]
  where
    parity :: ScriptPathData -> Word8
parity = forall a. a -> a -> Bool -> a
bool Word8
0 Word8
1 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 = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
    WitnessStackItem -> Maybe Tweak
tweak WitnessStackItem
commitment forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PubKey -> Bool
onComputedKey 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 forall a. Eq a => a -> a -> Bool
== PubKey -> XOnlyPubKey
XOnlyPubKey PubKey
computedKey
            Bool -> Bool -> Bool
&& Word8
expectedParity forall a. Eq a => a -> a -> Bool
== PubKey -> Word8
keyParity PubKey
computedKey
    commitment :: WitnessStackItem
commitment = PubKey -> Maybe (Digest SHA256) -> WitnessStackItem
taprootCommitment (ScriptPathData -> PubKey
scriptPathInternalKey ScriptPathData
scriptPathData) (forall a. a -> Maybe a
Just Digest SHA256
merkleRoot)
    merkleRoot :: Digest SHA256
merkleRoot =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch Digest SHA256
theLeafHash
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA256)
            forall a b. (a -> b) -> a -> b
$ ScriptPathData -> WitnessStack
scriptPathControl ScriptPathData
scriptPathData
    theLeafHash :: Digest SHA256
theLeafHash = (Word8 -> Script -> Digest SHA256
leafHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Bits a => a -> a -> a
.&. Word8
0xFE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptPathData -> Word8
scriptPathLeafVersion forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScriptPathData -> Script
scriptPathScript) ScriptPathData
scriptPathData
    expectedParity :: Word8
expectedParity = forall a. a -> a -> Bool -> a
bool Word8
0 Word8
1 forall a b. (a -> b) -> a -> b
$ ScriptPathData -> Bool
scriptPathExternalIsOdd ScriptPathData
scriptPathData

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