{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoFieldSelectors #-}

-- |
-- 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 Crypto.Secp256k1
import Data.Aeson
  ( FromJSON (parseJSON),
    ToJSON (toJSON),
    Value (String),
    withText,
  )
import Data.Aeson.Types (Parser, Value)
import Data.Binary (Binary (..))
import Data.Bits ((.&.), (.|.))
import Data.Bool (bool)
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Bytes.Get (MonadGet, getBytes, runGetS)
import Data.Bytes.Put (MonadPut, putByteString, runPutL, 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.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Keys.Extended
import Haskoin.Script.Common
import Haskoin.Script.Standard
import Haskoin.Transaction.Common
import Haskoin.Util

-- | 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
point :: PubKey}
  deriving (ReadPrec [XOnlyPubKey]
ReadPrec XOnlyPubKey
Int -> ReadS XOnlyPubKey
ReadS [XOnlyPubKey]
(Int -> ReadS XOnlyPubKey)
-> ReadS [XOnlyPubKey]
-> ReadPrec XOnlyPubKey
-> ReadPrec [XOnlyPubKey]
-> Read XOnlyPubKey
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XOnlyPubKey
readsPrec :: Int -> ReadS XOnlyPubKey
$creadList :: ReadS [XOnlyPubKey]
readList :: ReadS [XOnlyPubKey]
$creadPrec :: ReadPrec XOnlyPubKey
readPrec :: ReadPrec XOnlyPubKey
$creadListPrec :: ReadPrec [XOnlyPubKey]
readListPrec :: ReadPrec [XOnlyPubKey]
Read, 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
$cshowsPrec :: Int -> XOnlyPubKey -> ShowS
showsPrec :: Int -> XOnlyPubKey -> ShowS
$cshow :: XOnlyPubKey -> String
show :: XOnlyPubKey -> String
$cshowList :: [XOnlyPubKey] -> ShowS
showList :: [XOnlyPubKey] -> ShowS
Show)

instance Eq XOnlyPubKey where
  XOnlyPubKey PubKey
k1 == :: XOnlyPubKey -> XOnlyPubKey -> Bool
== XOnlyPubKey PubKey
k2 = PubKey -> ByteString
f PubKey
k1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== PubKey -> ByteString
f PubKey
k2
    where
      f :: PubKey -> ByteString
f = Int -> ByteString -> ByteString
BS.take Int
32 (ByteString -> ByteString)
-> (PubKey -> ByteString) -> PubKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.get)

instance Marshal Ctx XOnlyPubKey where
  marshalPut :: forall (m :: * -> *). MonadPut m => Ctx -> XOnlyPubKey -> m ()
marshalPut Ctx
ctx (XOnlyPubKey PubKey
pk) =
    ByteString -> m ()
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString
      (ByteString -> m ())
-> (PublicKey -> ByteString) -> PublicKey -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop Int
1
      (ByteString -> ByteString)
-> (PublicKey -> ByteString) -> PublicKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> PublicKey -> ByteString
forall s a. Marshal s a => s -> a -> ByteString
marshal Ctx
ctx
      (PublicKey -> m ()) -> PublicKey -> m ()
forall a b. (a -> b) -> a -> b
$ PubKey -> Bool -> PublicKey
PublicKey PubKey
pk Bool
True

  marshalGet :: forall (m :: * -> *). MonadGet m => Ctx -> m XOnlyPubKey
marshalGet Ctx
ctx =
    (String -> m XOnlyPubKey)
-> (PublicKey -> m XOnlyPubKey)
-> Either String PublicKey
-> m XOnlyPubKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m XOnlyPubKey
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (XOnlyPubKey -> m XOnlyPubKey
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XOnlyPubKey -> m XOnlyPubKey)
-> (PublicKey -> XOnlyPubKey) -> PublicKey -> m XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey (PubKey -> XOnlyPubKey)
-> (PublicKey -> PubKey) -> PublicKey -> XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\PublicKey {PubKey
point :: PubKey
$sel:point:PublicKey :: PublicKey -> PubKey
point} -> PubKey
point))
      (Either String PublicKey -> m XOnlyPubKey)
-> (ByteString -> Either String PublicKey)
-> ByteString
-> m XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString -> Either String PublicKey
forall s a. Marshal s a => s -> ByteString -> Either String a
unmarshal Ctx
ctx
      (ByteString -> Either String PublicKey)
-> (ByteString -> ByteString)
-> ByteString
-> Either String PublicKey
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 MarshalJSON Ctx XOnlyPubKey where
  unmarshalValue :: Ctx -> Value -> Parser XOnlyPubKey
unmarshalValue Ctx
ctx =
    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 a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail XOnlyPubKey -> Parser XOnlyPubKey
forall a. a -> Parser a
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
. (ByteString -> Either String XOnlyPubKey
des (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
<=< Text -> Either String ByteString
hex)
    where
      hex :: Text -> Either String ByteString
hex = 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
      des :: ByteString -> Either String XOnlyPubKey
des = Get XOnlyPubKey -> ByteString -> Either String XOnlyPubKey
forall a. Get a -> ByteString -> Either String a
runGetS (Get XOnlyPubKey -> ByteString -> Either String XOnlyPubKey)
-> Get XOnlyPubKey -> ByteString -> Either String XOnlyPubKey
forall a b. (a -> b) -> a -> b
$ Ctx -> Get XOnlyPubKey
forall s a (m :: * -> *). (Marshal s a, MonadGet m) => s -> m a
forall (m :: * -> *). MonadGet m => Ctx -> m XOnlyPubKey
marshalGet Ctx
ctx

  marshalValue :: Ctx -> XOnlyPubKey -> Value
marshalValue Ctx
ctx =
    Text -> Value
String (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
. Ctx -> XOnlyPubKey -> ByteString
forall s a. Marshal s a => s -> a -> ByteString
marshal Ctx
ctx

  marshalEncoding :: Ctx -> XOnlyPubKey -> Encoding
marshalEncoding Ctx
ctx =
    ByteString -> Encoding
hexEncoding (ByteString -> Encoding)
-> (XOnlyPubKey -> ByteString) -> XOnlyPubKey -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutL (Put -> ByteString)
-> (XOnlyPubKey -> Put) -> XOnlyPubKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> XOnlyPubKey -> Put
forall s a (m :: * -> *).
(Marshal s a, MonadPut m) =>
s -> a -> m ()
forall (m :: * -> *). MonadPut m => Ctx -> XOnlyPubKey -> m ()
marshalPut Ctx
ctx

-- | @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
$cshowsPrec :: Int -> MAST -> ShowS
showsPrec :: Int -> MAST -> ShowS
$cshow :: MAST -> String
show :: MAST -> String
$cshowList :: [MAST] -> ShowS
showList :: [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 ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
serialize Word8
leafVersion
      VarInt Int -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => VarInt Int -> 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 ()
forall (m :: * -> *). MonadPut m => Script -> m ()
serialize Script
leafScript

-- | Representation of a full taproot output.
--
-- @since 0.21.0
data TaprootOutput = TaprootOutput
  { TaprootOutput -> PubKey
internalKey :: PubKey,
    TaprootOutput -> Maybe MAST
mast :: Maybe MAST
  }

-- | @since 0.21.0
taprootOutputKey :: Ctx -> TaprootOutput -> PubKey
taprootOutputKey :: Ctx -> TaprootOutput -> PubKey
taprootOutputKey Ctx
ctx TaprootOutput {Maybe MAST
PubKey
$sel:internalKey:TaprootOutput :: TaprootOutput -> PubKey
$sel:mast:TaprootOutput :: TaprootOutput -> Maybe MAST
internalKey :: PubKey
mast :: Maybe MAST
..} =
  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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ctx -> PubKey -> Tweak -> Maybe PubKey
tweakAddPubKey Ctx
ctx PubKey
internalKey
  where
    commitment :: ByteString
commitment =
      Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment Ctx
ctx PubKey
internalKey (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
mast
    keyFail :: a
keyFail = String -> a
forall a. HasCallStack => String -> a
error String
"haskoin-core taprootOutputKey: key derivation failed"

taprootCommitment :: Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment :: Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment Ctx
ctx 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
. Ctx -> XOnlyPubKey -> Put
forall s a (m :: * -> *).
(Marshal s a, MonadPut m) =>
s -> a -> m ()
forall (m :: * -> *). MonadPut m => Ctx -> XOnlyPubKey -> m ()
marshalPut Ctx
ctx (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 :: Ctx -> TaprootOutput -> ScriptOutput
taprootScriptOutput :: Ctx -> TaprootOutput -> ScriptOutput
taprootScriptOutput Ctx
ctx =
  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
. Ctx -> XOnlyPubKey -> Put
forall s a (m :: * -> *).
(Marshal s a, MonadPut m) =>
s -> a -> m ()
forall (m :: * -> *). MonadPut m => Ctx -> XOnlyPubKey -> m ()
marshalPut Ctx
ctx
    (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
. Ctx -> TaprootOutput -> PubKey
taprootOutputKey Ctx
ctx

-- | 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
$c== :: TaprootWitness -> TaprootWitness -> Bool
== :: TaprootWitness -> TaprootWitness -> Bool
$c/= :: TaprootWitness -> TaprootWitness -> Bool
/= :: TaprootWitness -> TaprootWitness -> Bool
Eq)

-- | @since 0.21.0
data ScriptPathData = ScriptPathData
  { ScriptPathData -> Maybe ByteString
annex :: Maybe ByteString,
    ScriptPathData -> [ByteString]
stack :: [ByteString],
    ScriptPathData -> Script
script :: Script,
    ScriptPathData -> Bool
extIsOdd :: Bool,
    -- | This value is masked by 0xFE
    ScriptPathData -> Word8
leafVersion :: Word8,
    ScriptPathData -> PubKey
internalKey :: PubKey,
    ScriptPathData -> [ByteString]
control :: [ByteString]
  }
  deriving (ScriptPathData -> ScriptPathData -> Bool
(ScriptPathData -> ScriptPathData -> Bool)
-> (ScriptPathData -> ScriptPathData -> Bool) -> Eq ScriptPathData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptPathData -> ScriptPathData -> Bool
== :: ScriptPathData -> ScriptPathData -> Bool
$c/= :: ScriptPathData -> ScriptPathData -> Bool
/= :: ScriptPathData -> ScriptPathData -> Bool
Eq)

-- | Try to interpret a 'WitnessStack' as taproot witness data.
--
-- @since 0.21.0
viewTaprootWitness :: Ctx -> WitnessStack -> Maybe TaprootWitness
viewTaprootWitness :: Ctx -> [ByteString] -> Maybe TaprootWitness
viewTaprootWitness Ctx
ctx [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
annex = \case
      ByteString
scriptBytes : ByteString
controlBytes : [ByteString]
stack -> do
        Script
script <- 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
forall (m :: * -> *). MonadGet m => m Script
deserialize ByteString
scriptBytes
        (Word8
v, PubKey
internalKey, [ByteString]
control) <- ByteString -> Maybe (Word8, PubKey, [ByteString])
deconstructControl ByteString
controlBytes
        let extIsOdd :: Bool
extIsOdd = Word8 -> Bool
forall a. Integral a => a -> Bool
odd Word8
v
            leafVersion :: Word8
leafVersion = Word8
v Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xFE
        TaprootWitness -> Maybe TaprootWitness
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaprootWitness -> Maybe TaprootWitness)
-> TaprootWitness -> Maybe TaprootWitness
forall a b. (a -> b) -> a -> b
$ ScriptPathData -> TaprootWitness
ScriptPathSpend ScriptPathData {Bool
[ByteString]
Maybe ByteString
Word8
PubKey
Script
$sel:annex:ScriptPathData :: Maybe ByteString
$sel:stack:ScriptPathData :: [ByteString]
$sel:script:ScriptPathData :: Script
$sel:extIsOdd:ScriptPathData :: Bool
$sel:leafVersion:ScriptPathData :: Word8
$sel:internalKey:ScriptPathData :: PubKey
$sel:control:ScriptPathData :: [ByteString]
annex :: Maybe ByteString
stack :: [ByteString]
script :: Script
internalKey :: PubKey
control :: [ByteString]
extIsOdd :: Bool
leafVersion :: Word8
..}
      [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
      XOnlyPubKey PubKey
k <- Ctx -> Get XOnlyPubKey
forall s a (m :: * -> *). (Marshal s a, MonadGet m) => s -> m a
forall (m :: * -> *). MonadGet m => Ctx -> m XOnlyPubKey
marshalGet Ctx
ctx
      [ByteString]
proof <- Get ByteString -> Get [ByteString]
forall a. Get a -> Get [a]
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 a. a -> Get a
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 :: Ctx -> TaprootWitness -> WitnessStack
encodeTaprootWitness :: Ctx -> TaprootWitness -> [ByteString]
encodeTaprootWitness Ctx
ctx = \case
  KeyPathSpend ByteString
signature -> ByteString -> [ByteString]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
signature
  ScriptPathSpend ScriptPathData
scriptPathData -> ScriptPathData -> [ByteString]
wit ScriptPathData
scriptPathData
  where
    wit :: ScriptPathData -> [ByteString]
wit ScriptPathData
d = (.stack) ScriptPathData
d [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ScriptPathData -> ByteString
script ScriptPathData
d, ScriptPathData -> ByteString
keys ScriptPathData
d, ScriptPathData -> ByteString
annex ScriptPathData
d]
    keys :: ScriptPathData -> ByteString
keys ScriptPathData
d = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ScriptPathData -> ByteString
verpar ScriptPathData
d, ScriptPathData -> ByteString
xonlyk ScriptPathData
d, ScriptPathData -> ByteString
ctrl ScriptPathData
d]
    script :: ScriptPathData -> ByteString
script = Put -> ByteString
runPutS (Put -> ByteString)
-> (ScriptPathData -> Put) -> ScriptPathData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Script -> m ()
serialize (Script -> Put)
-> (ScriptPathData -> Script) -> ScriptPathData -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.script)
    verpar :: ScriptPathData -> ByteString
verpar ScriptPathData
d = [Word8] -> ByteString
BS.pack [(.leafVersion) ScriptPathData
d Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ScriptPathData -> Word8
parity ScriptPathData
d]
    xonlyk :: ScriptPathData -> ByteString
xonlyk = Put -> ByteString
runPutS (Put -> ByteString)
-> (ScriptPathData -> Put) -> ScriptPathData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> XOnlyPubKey -> Put
forall s a (m :: * -> *).
(Marshal s a, MonadPut m) =>
s -> a -> m ()
forall (m :: * -> *). MonadPut m => Ctx -> XOnlyPubKey -> m ()
marshalPut Ctx
ctx (XOnlyPubKey -> Put)
-> (ScriptPathData -> XOnlyPubKey) -> ScriptPathData -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKey -> XOnlyPubKey
XOnlyPubKey (PubKey -> XOnlyPubKey)
-> (ScriptPathData -> PubKey) -> ScriptPathData -> XOnlyPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.internalKey)
    annex :: ScriptPathData -> ByteString
annex = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty (Maybe ByteString -> ByteString)
-> (ScriptPathData -> Maybe ByteString)
-> ScriptPathData
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.annex)
    ctrl :: ScriptPathData -> ByteString
ctrl = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> (ScriptPathData -> [ByteString]) -> ScriptPathData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.control)
    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
. (.extIsOdd)

-- | Verify that the script path spend is valid, except for script execution.
--
-- @since 0.21.0
verifyScriptPathData ::
  Ctx ->
  -- | Output key
  PubKey ->
  ScriptPathData ->
  Bool
verifyScriptPathData :: Ctx -> PubKey -> ScriptPathData -> Bool
verifyScriptPathData Ctx
ctx PubKey
outkey ScriptPathData
spd = 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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PubKey -> Bool) -> Maybe PubKey -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
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
. Ctx -> PubKey -> Tweak -> Maybe PubKey
tweakAddPubKey Ctx
ctx ScriptPathData
spd.internalKey
  where
    onComputedKey :: PubKey -> Bool
onComputedKey PubKey
computedKey =
      PubKey -> XOnlyPubKey
XOnlyPubKey PubKey
outkey 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
== Ctx -> PubKey -> Word8
keyParity Ctx
ctx PubKey
computedKey
    commitment :: ByteString
commitment =
      Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment Ctx
ctx ScriptPathData
spd.internalKey (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 b a. (b -> a -> b) -> b -> [a] -> b
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)
-> [Digest SHA256] -> Digest SHA256
forall a b. (a -> b) -> a -> b
$
        (ByteString -> Maybe (Digest SHA256))
-> [ByteString] -> [Digest SHA256]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA256) ScriptPathData
spd.control
    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
. (.leafVersion) (ScriptPathData -> Script -> Digest SHA256)
-> (ScriptPathData -> Script) -> ScriptPathData -> Digest SHA256
forall a b.
(ScriptPathData -> a -> b)
-> (ScriptPathData -> a) -> ScriptPathData -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (.script))
        ScriptPathData
spd
    expectedParity :: Word8
expectedParity = Word8 -> Word8 -> Bool -> Word8
forall a. a -> a -> Bool -> a
bool Word8
0 Word8
1 ScriptPathData
spd.extIsOdd

keyParity :: Ctx -> PubKey -> Word8
keyParity :: Ctx -> PubKey -> Word8
keyParity Ctx
ctx PubKey
key =
  case ByteString -> [Word8]
BS.unpack (ByteString -> [Word8])
-> (PublicKey -> ByteString) -> PublicKey -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> PublicKey -> ByteString
forall s a. Marshal s a => s -> a -> ByteString
marshal Ctx
ctx (PublicKey -> [Word8]) -> PublicKey -> [Word8]
forall a b. (a -> b) -> a -> b
$ PubKey -> Bool -> PublicKey
PublicKey PubKey
key Bool
True of
    Word8
0x02 : [Word8]
_ -> Word8
0x00
    [Word8]
_ -> Word8
0x01