{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
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)
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
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)
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
type TapLeafVersion = Word8
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)
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))
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
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)
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
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
data TaprootWitness
=
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)
data ScriptPathData = ScriptPathData
{ ScriptPathData -> Maybe ByteString
scriptPathAnnex :: Maybe ByteString
, ScriptPathData -> [ByteString]
scriptPathStack :: [ByteString]
, ScriptPathData -> Script
scriptPathScript :: Script
, ScriptPathData -> Bool
scriptPathExternalIsOdd :: Bool
,
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)
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)
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
verifyScriptPathData ::
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