Adds taproot signing support

haskoin-core.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           haskoin-core
-version:        0.21.2
+version:        0.22.0
 synopsis:       Bitcoin & Bitcoin Cash library for Haskell
 description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
 category:       Bitcoin, Finance, Network
@@ -40,6 +40,11 @@ source-repository head
   type: git
   location: git://github.com/haskoin/haskoin.git
 
+flag bip340
+  description: Enable support for taproot signing
+  manual: True
+  default: False
+
 library
   exposed-modules:
       Haskoin
@@ -123,6 +128,8 @@ library
     , unordered-containers >=0.2.10.0
     , vector >=0.12.1.2
   default-language: Haskell2010
+  if flag(bip340)
+    cpp-options: -DBIP340
 
 test-suite spec
   type: exitcode-stdio-1.0

package.yaml

@@ -1,5 +1,5 @@
 name: haskoin-core
-version: 0.21.2
+version: 0.22.0
 synopsis: Bitcoin & Bitcoin Cash library for Haskell
 description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
 category: Bitcoin, Finance, Network
@@ -17,6 +17,11 @@ extra-source-files:
   - data/*.json
   - README.md
   - CHANGELOG.md
+flags:
+  bip340:
+     description: Enable support for taproot signing
+     manual: true
+     default: false
 dependencies:
   - aeson >= 1.4.6.0
   - array >= 0.5.4.0
@@ -51,10 +56,12 @@ dependencies:
 library:
   source-dirs: src
   other-modules:
-    Haskoin.Keys.Extended.Internal
+    - Haskoin.Keys.Extended.Internal
   when:
     - condition: false
       other-modules: Paths_haskoin_core
+    - condition: flag(bip340)
+      cpp-options: -DBIP340
 tests:
   spec:
     main: Spec.hs

src/Haskoin/Transaction/Taproot.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 {- |
 Module      : Haskoin.Transaction.Taproot
@@ -15,7 +17,6 @@ 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,
@@ -28,83 +29,84 @@ module Haskoin.Transaction.Taproot (
     viewTaprootWitness,
     encodeTaprootWitness,
     verifyScriptPathData,
+    getByXCoord,
+    toXCoord,
+
+#ifdef BIP340
+    ExtFlag,
+    signTaprootInput,
+    taprootSignatureDigest,
+    taprootKeyPathWitness,
+#endif
 ) where
 
 import Control.Applicative (many)
-import Control.Monad ((<=<))
+import Control.Monad (unless, when, zipWithM_)
 import Crypto.Hash (
     Digest,
-    SHA256,
+    SHA256 (SHA256),
     digestFromByteString,
     hashFinalize,
     hashUpdate,
     hashUpdates,
+    hashWith,
  )
-import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText)
-import Data.Binary (Binary (..))
+import Crypto.Secp256k1 (SecKey, Rand32)
+#ifdef BIP340
+import Crypto.Secp256k1 (Bip340Sig, signBip340)
+#endif
+import qualified Crypto.Secp256k1 as C
+import Data.Binary (Binary (put), Put)
+import Data.Binary.Put (runPut, putWord32le, putWord64le)
 import Data.Bits ((.&.), (.|.))
 import Data.Bool (bool)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
 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.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
+import Data.Serialize (Get, getByteString, getWord8)
+import qualified Data.Serialize as S
 import Data.Word (Word8)
 import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey)
 import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint)
+import Haskoin.Network.Common (VarString (VarString))
 import Haskoin.Script.Common (Script)
+import Haskoin.Script.SigHash (
+    SigHash (SigHash),
+    hasAnyoneCanPayFlag,
+    isSigHashNone,
+    isSigHashSingle,
+ )
 import Haskoin.Script.Standard (ScriptOutput (PayWitness))
-import Haskoin.Transaction.Common (WitnessStack)
-import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex)
+import Haskoin.Transaction.Common (
+    Tx (..),
+    TxIn,
+    TxOut,
+    WitnessStack,
+    outValue,
+    prevOutput,
+    scriptOutput,
+    txInSequence,
+ )
+import Haskoin.Util (eitherToMaybe)
 
-{- | 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.22.0
+toXCoord :: PubKey -> ByteString
+toXCoord pk = BS.drop 1 . runPutS . serialize $ PubKeyI pk True
 
-@since 0.21.0
--}
-newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey}
-    deriving (Show)
-
-instance Eq XOnlyPubKey where
-    k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2)
-
-instance Serial XOnlyPubKey where
-    serialize (XOnlyPubKey pk) =
-        putByteString
-            . BS.drop 1
-            . runPutS
-            . serialize
-            $ PubKeyI pk True
-    deserialize =
-        either fail (pure . XOnlyPubKey . pubKeyPoint)
-            . runGetS deserialize
-            . BS.cons 0x02
-            =<< getBytes 32
-
-instance Serialize XOnlyPubKey where
-    put = serialize
-    get = deserialize
-
-instance Binary XOnlyPubKey where
-    put = serialize
-    get = deserialize
-
--- | Hex encoding
-instance FromJSON XOnlyPubKey where
-    parseJSON =
-        withText "XOnlyPubKey" $
-            either fail pure
-                . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex)
-
--- | Hex encoding
-instance ToJSON XOnlyPubKey where
-    toJSON = toJSON . encodeHex . runPutS . serialize
+-- | @since 0.22.0
+getByXCoord :: Get PubKey
+getByXCoord =
+    either fail (pure . pubKeyPoint)
+        . runGetS deserialize
+        . BS.cons 0x02
+        =<< getBytes 32
 
 -- | @since 0.21.0
 type TapLeafVersion = Word8
@@ -195,14 +197,14 @@ taprootCommitment internalKey merkleRoot =
         . (`hashUpdate` keyBytes)
         $ initTaggedHash "TapTweak"
   where
-    keyBytes = runPutS . serialize $ XOnlyPubKey internalKey
+    keyBytes = toXCoord internalKey
 
 {- | Generate the output script for a taproot output
 
 @since 0.21.0
 -}
 taprootScriptOutput :: TaprootOutput -> ScriptOutput
-taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey
+taprootScriptOutput = PayWitness 0x01 . toXCoord . taprootOutputKey
 
 {- | Comprehension of taproot witness data
 
@@ -220,8 +222,8 @@ data ScriptPathData = ScriptPathData
     , scriptPathStack :: [ByteString]
     , scriptPathScript :: Script
     , scriptPathExternalIsOdd :: Bool
-    , -- | This value is masked by 0xFE
-      scriptPathLeafVersion :: Word8
+    , scriptPathLeafVersion :: Word8
+    -- ^ This value is masked by 0xFE
     , scriptPathInternalKey :: PubKey
     , scriptPathControl :: [ByteString]
     }
@@ -257,7 +259,7 @@ viewTaprootWitness witnessStack = case reverse witnessStack of
     deconstructControl = eitherToMaybe . runGetS deserializeControl
     deserializeControl = do
         v <- getWord8
-        k <- xOnlyPubKey <$> deserialize
+        k <- getByXCoord
         proof <- many $ getByteString 32
         pure (v, k, proof)
 
@@ -273,7 +275,7 @@ encodeTaprootWitness = \case
             <> [ runPutS . serialize $ scriptPathScript scriptPathData
                , mconcat
                     [ BS.pack [scriptPathLeafVersion scriptPathData .|. parity scriptPathData]
-                    , runPutS . serialize . XOnlyPubKey $ scriptPathInternalKey scriptPathData
+                    , toXCoord $ scriptPathInternalKey scriptPathData
                     , mconcat $ scriptPathControl scriptPathData
                     ]
                , fromMaybe mempty $ scriptPathAnnex scriptPathData
@@ -294,7 +296,7 @@ verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do
     tweak commitment >>= fmap onComputedKey . tweakAddPubKey (scriptPathInternalKey scriptPathData)
   where
     onComputedKey computedKey =
-        XOnlyPubKey outputKey == XOnlyPubKey computedKey
+        toXCoord outputKey == toXCoord computedKey
             && expectedParity == keyParity computedKey
     commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot)
     merkleRoot =
@@ -308,3 +310,107 @@ keyParity :: PubKey -> Word8
 keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of
     0x02 : _ -> 0x00
     _ -> 0x01
+
+
+#ifdef BIP340
+
+type ExtFlag = Word8
+
+signTaprootInput ::
+    ExtFlag ->
+    -- | Outputs being spent
+    [TxOut] ->
+    Tx ->
+    -- | Input index
+    Int ->
+    SigHash ->
+    -- | Annex
+    Maybe ByteString ->
+    -- | Secret key
+    SecKey ->
+    -- | Extra randomness
+    Maybe Rand32 ->
+    Maybe (Bip340Sig, SigHash)
+signTaprootInput extFlag spentTxOuts tx inputIndex sigHash annex secKey rand32 =
+    (,) <$> signBip340 secKey message rand32 <*> pure sigHash
+  where
+    Just message =
+        C.msg
+            . BA.convert
+            . hashFinalize
+            $ hashUpdates (initTaggedHash "TapSighash") ["\x00", sigMsg]
+
+    sigMsg =
+        BSL.toStrict $
+            taprootSignatureDigest
+                extFlag
+                spentTxOuts
+                tx
+                inputIndex
+                sigHash
+                annex
+
+-- | Create a witness datum for a taproot keypath spend
+taprootKeyPathWitness :: Bip340Sig -> SigHash -> ByteString
+taprootKeyPathWitness sig (SigHash sigHash) =
+    mconcat $
+        catMaybes
+            [ Just $ S.encode sig
+            , if sigHash /= 0x00
+                then Just $ (BS.pack . pure . fromIntegral) sigHash
+                else Nothing
+            ]
+
+-- | Calculate the signature digest for a taproot output
+taprootSignatureDigest ::
+    ExtFlag ->
+    [TxOut] ->
+    Tx ->
+    -- | Input index for which we sign
+    Int ->
+    SigHash ->
+    -- | Taproot annex
+    Maybe ByteString ->
+    BSL.ByteString
+taprootSignatureDigest extFlag spentTxOuts tx inputIndex sigHash@(SigHash sigHashValue) annexM = runPut $ do
+    put $ fromIntegral @_ @Word8 sigHashValue
+    putWord32le $ txVersion tx
+    putWord32le $ txLockTime tx
+    unless (hasAnyoneCanPayFlag sigHash) $ do
+        putSpent $ \_ txIn -> put (prevOutput txIn)
+        putSpent $ \txOut _ -> putWord64le (outValue txOut)
+        putSpent $ \txOut _ -> (put . VarString) (scriptOutput txOut)
+        putSpent $ \_ txIn -> putWord32le (txInSequence txIn)
+    unless (isSigHashNone sigHash || isSigHashSingle sigHash) . putSha256 $
+        mapM_ put (txOut tx)
+    put spendType
+    if hasAnyoneCanPayFlag sigHash
+        then do
+            put spentOutPoint
+            putWord64le $ outValue spentTxOut
+            put . VarString $ scriptOutput spentTxOut
+            putWord32le $ txInSequence thisTxIn
+        else putWord32le $ fromIntegral inputIndex
+    mapM_ (putSha256 . put . VarString) annexM
+    when (isSigHashSingle sigHash) . putSha256 . put $ txOut tx !! fromIntegral inputIndex
+  where
+    spendType = extFlag * 2 + bool 0 1 hasAnnex
+    hasAnnex = isJust annexM
+
+    thisTxIn = txIn tx !! inputIndex
+
+    spentOutPoint = prevOutput thisTxIn
+    spentTxOut = spentTxOuts !! inputIndex
+
+    putSpent :: (TxOut -> TxIn -> Put) -> Put
+    putSpent f = putSha256 $ zipWithM_ f spentTxOuts (txIn tx)
+
+putSha256 :: Put -> Put
+putSha256 =
+    putByteString
+        . BA.convert
+        . hashWith SHA256
+        . BSL.toStrict
+        . runPut
+
+#endif