bitcoin-scripting 0.2.0 → 0.3.0

raw patch · 10 files changed

+784/−55 lines, 10 filesdep +bytesdep +unordered-containersdep +vectordep ~basedep ~haskoin-coredep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: bytes, unordered-containers, vector

Dependency ranges changed: base, haskoin-core, text, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• bitcoin-scripting.cabal +12/−8
• src/Language/Bitcoin/Script/Descriptors.hs +19/−0
• src/Language/Bitcoin/Script/Descriptors/Checksum.hs +100/−0
• src/Language/Bitcoin/Script/Descriptors/Parser.hs +67/−17
• src/Language/Bitcoin/Script/Descriptors/Syntax.hs +0/−12
• src/Language/Bitcoin/Script/Descriptors/Text.hs +14/−12
• src/Language/Bitcoin/Script/Descriptors/Utils.hs +311/−2
• test/Test/Descriptors.hs +67/−2
• test/Test/Descriptors/Utils.hs +184/−2

@@ -1,5 +1,15 @@ # Revision history for bitcoin-scripting  +## 0.3.0++* Adds ability to parse, compute, and verify checksums++## 0.2.1++* Adds functions to specialize key family descriptors in output (and script) descriptors to a particular index+* Adds function for building a PSBT input+* Adds function for calculating various script fragments associated with a descriptor+ ## 0.2.0  * Refactors script descriptors module in order to make invalid descriptors unrepresentable.

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                bitcoin-scripting-version:             0.2.0+version:             0.3.0 synopsis:            Resources for working with miniscript, and script descriptors homepage:            https://github.com/bitnomial/bitcoin-scripting copyright:           2020 Bitnomial, Inc.@@ -28,11 +28,12 @@     -Wno-unused-do-bind     -funbox-strict-fields   build-depends:-      base >=4.12 && <4.16+      base >=4.12 && <5     , bytestring >=0.10 && <0.12     , cereal ^>=0.5-    , haskoin-core >=0.18 && <0.21-    , text >=1.2 && <1.3+    , haskoin-core ^>=0.21+    , text >=1.2 && <2.1+    , unordered-containers ^>=0.2  library   import:          base@@ -55,13 +56,15 @@     Language.Bitcoin.Script.Descriptors.Syntax     Language.Bitcoin.Script.Descriptors.Text     Language.Bitcoin.Script.Descriptors.Utils+    Language.Bitcoin.Script.Descriptors.Checksum      Language.Bitcoin.Utils    build-depends:       attoparsec >=0.13 && <0.15     , containers ^>=0.6-    , transformers ^>=0.5+    , transformers >=0.5 && <0.7+    , vector >=0.12.1.2 && <0.14  test-suite bitcoin-scripting-tests   import:          base@@ -82,6 +85,7 @@    build-depends:       bitcoin-scripting-    , tasty                    >=1.0   && <1.5-    , tasty-hunit              >=0.9   && <0.11-    , tasty-quickcheck         >=0.8.1 && <0.11+    , bytes ^>=0.17+    , tasty >=1.0 && <1.5+    , tasty-hunit >=0.9 && <0.11+    , tasty-quickcheck >=0.8.1 && <0.11

@@ -4,7 +4,9 @@ module Language.Bitcoin.Script.Descriptors (     -- * Descriptors     OutputDescriptor (..),+    outputDescriptorAtIndex,     ScriptDescriptor (..),+    scriptDescriptorAtIndex,      -- * Keys     KeyDescriptor (..),@@ -13,16 +15,22 @@     KeyCollection (..),     isDefinite,     keyAtIndex,+    keyDescriptorAtIndex,     keyDescPubKey,     pubKey,     secKey,     keyBytes,+    outputDescriptorPubKeys,+    scriptDescriptorPubKeys,      -- * Text representation     descriptorToText,+    descriptorToTextWithChecksum,     keyDescriptorToText,      -- * Parsing+    ChecksumDescriptor (..),+    ChecksumStatus (..),     parseDescriptor,     outputDescriptorParser,     parseKeyDescriptor,@@ -31,9 +39,20 @@     -- * Conversions     descriptorAddresses,     compile,+    TransactionScripts (..),+    outputDescriptorScripts,++    -- * PSBT+    toPsbtInput,+    PsbtInputError (..),++    -- * Checksums+    descriptorChecksum,+    validDescriptorChecksum, ) where  import Language.Bitcoin.Script.Descriptors.Parser import Language.Bitcoin.Script.Descriptors.Syntax import Language.Bitcoin.Script.Descriptors.Text import Language.Bitcoin.Script.Descriptors.Utils+import Language.Bitcoin.Script.Descriptors.Checksum

@@ -0,0 +1,100 @@+{-# LANGUAGE ParallelListComp #-}++module Language.Bitcoin.Script.Descriptors.Checksum (+  validDescriptorChecksum,+  descriptorChecksum,+) where++import Data.Bifunctor (first)+import Data.Bits (Bits (shiftL, shiftR, testBit, xor, (.&.)))+import Data.Char (ord)+import Data.Foldable (foldl')+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as Vector++{- | Test whether the textual representation of an output descriptor has the+ given checksum.+-}+validDescriptorChecksum :: Text -> Text -> Bool+validDescriptorChecksum desc checksum =+  case mapM (charsetFind checksumCharset) (Text.unpack checksum) of+    Nothing -> False+    Just checkSymbols ->+      1 == polymodChecksum (expandChecksum desc <> checkSymbols)++{- | Compute the checksum of the textual representation of an output descriptor+ if possible.+-}+descriptorChecksum :: Text -> Maybe Text+descriptorChecksum desc = Text.pack <$> sequenceA checksumChars+ where+  checksumChars = [checksumCharset `charsetGet` charsetIndex i | i <- [0 .. 7]]+  charsetIndex i = (checksum `shiftR` (5 * (7 - i))) .&. 31+  symbols = expandChecksum desc <> replicate 8 0+  checksum = 1 `xor` polymodChecksum symbols++expandChecksum :: Text -> [Word]+expandChecksum =+  reverse . end+    . foldl'+      ( \(gs, s) v -> case (v `shiftR` 5 : gs, v .&. 31 : s) of+          ([g2, g1, g0], s') -> ([], 9 * g0 + 3 * g1 + g2 : s')+          x -> x+      )+      mempty+    . fromMaybe []+    . mapM (charsetFind inputCharset)+    . Text.unpack+ where+  end ([g0], s) = g0 : s+  end ([g1, g0], s) = 3 * g0 + g1 : s+  end (_, s) = s++polymodChecksum :: [Word] -> Word+polymodChecksum =+  foldl'+    ( \chk value ->+        foldl'+          xor+          ((chk .&. 0x7ffffffff) `shiftL` 5 `xor` value)+          [if chk `testBit` i then g else 0 | i <- [35 ..] | g <- generator]+    )+    1+ where+  generator =+    [ 0xf5dee51989+    , 0xa9fdca3312+    , 0x1bab10e32d+    , 0x3706b1677a+    , 0x644d626ffd+    ]++data Charset = Charset+  { charToIndex :: IntMap Word+  , indexToChar :: Vector Char+  }++charsetFromString :: String -> Charset+charsetFromString s =+  let xs = [(c, i) | c <- s | i <- [0 ..]]+   in Charset+        { charToIndex = IntMap.fromList $ first ord <$> xs+        , indexToChar = Vector.fromList $ fst <$> xs+        }++charsetFind :: Charset -> Char -> Maybe Word+charsetFind set c = IntMap.lookup (ord c) $ charToIndex set++charsetGet :: Charset -> Word -> Maybe Char+charsetGet set i = indexToChar set Vector.!? fromInteger (toInteger i)++inputCharset :: Charset+inputCharset = charsetFromString "0123456789()[],'/*abcdefgh@:$%{}IJKLMNOPQRSTUVWXYZ&+-.;<=>?!^_|~ijklmnopqrstuvwxyzABCDEFGH`#\"\\ "++checksumCharset :: Charset+checksumCharset = charsetFromString "qpzry9x8gf2tvdw0s3jn54khce6mua7l"

@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}  module Language.Bitcoin.Script.Descriptors.Parser (+    ChecksumDescriptor (..),+    ChecksumStatus (..),     parseDescriptor,     outputDescriptorParser,     parseKeyDescriptor,@@ -8,23 +10,29 @@ ) where  import Control.Applicative (optional, (<|>))-import Data.Attoparsec.Text (Parser)+import Data.Attoparsec.Text (Parser, char, count, match) import qualified Data.Attoparsec.Text as A import Data.Bool (bool) import qualified Data.ByteString as BS-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, isJust) import Data.Text (Text, pack)-import Haskoin.Address (textToAddr)-import Haskoin.Constants (Network)-import Haskoin.Keys (+import Haskoin (     DerivPath,     DerivPathI (..),+    Network,     fromWif,     importPubKey,+    textToAddr,+    textToFingerprint,     wrapPubKey,     xPubImport,  ) +import qualified Data.Text as Text+import Language.Bitcoin.Script.Descriptors.Checksum (+    descriptorChecksum,+    validDescriptorChecksum,+ ) import Language.Bitcoin.Script.Descriptors.Syntax import Language.Bitcoin.Utils (     alphanum,@@ -36,19 +44,43 @@     maybeFail,  ) -parseDescriptor :: Network -> Text -> Either String OutputDescriptor-parseDescriptor net = A.parseOnly $ outputDescriptorParser net+-- | An 'OutputDescriptor' with checksum details+data ChecksumDescriptor = ChecksumDescriptor+    { descriptor :: OutputDescriptor+    -- ^ The output descriptor+    , checksumStatus :: ChecksumStatus+    -- ^ The status of the output descriptor's checksum+    , expectedChecksum :: Text+    -- ^ The expected checksum for the output descriptor+    }+    deriving (Eq, Show) -outputDescriptorParser :: Network -> Parser OutputDescriptor+-- | The status of an output descriptor's checksum+data ChecksumStatus+    = -- | Checksum provided is valid+      Valid+    | -- | Checksum provided is invalid+      Invalid+        Text+        -- ^ The invalid checksum+    | -- | Checksum is not provided+      Absent+    deriving (Eq, Show)++parseDescriptor :: Network -> Text -> Either String ChecksumDescriptor+parseDescriptor = A.parseOnly . outputDescriptorParser++outputDescriptorParser :: Network -> Parser ChecksumDescriptor outputDescriptorParser net =-    spkP-        <|> shP-        <|> wpkhP-        <|> wshP-        <|> shwpkhP-        <|> shwshP-        <|> comboP-        <|> addrP+    checksumParser $+        spkP+            <|> shP+            <|> wpkhP+            <|> wshP+            <|> shwpkhP+            <|> shwshP+            <|> comboP+            <|> addrP   where     sdP = scriptDescriptorParser net     keyP = keyDescriptorParser net@@ -85,8 +117,12 @@ keyDescriptorParser :: Network -> Parser KeyDescriptor keyDescriptorParser net = KeyDescriptor <$> originP <*> keyP   where-    originP = optional . brackets $ Origin <$> A.hexadecimal <*> pathP+    originP = optional . brackets $ Origin <$> fingerprintP <*> pathP +    fingerprintP =+        A.take 8+            >>= either fail pure . textToFingerprint+     keyP = pubP <|> wifP <|> XPub <$> xpubP <*> pathP <*> famP      pubP = do@@ -111,3 +147,17 @@         n <- A.decimal         isHard <- isJust <$> optional (A.char '\'' <|> A.char 'h')         return $ bool (d :/) (d :|) isHard n++checksumParser :: Parser OutputDescriptor -> Parser ChecksumDescriptor+checksumParser p = do+    (input, desc) <- match p+    actual <- fmap (fromMaybe "") . optional $ do+        _ <- char '#'+        Text.pack <$> count 8 alphanum+    let status = case actual of+            "" -> Absent+            _+                | input `validDescriptorChecksum` actual -> Valid+                | otherwise -> Invalid actual+        expected = fromMaybe "" $ descriptorChecksum input+    return $ ChecksumDescriptor desc status expected

@@ -1,11 +1,8 @@-{-# LANGUAGE LambdaCase #-}- module Language.Bitcoin.Script.Descriptors.Syntax (     OutputDescriptor (..),     ScriptDescriptor (..),     KeyDescriptor (..),     isDefinite,-    keyAtIndex,     keyDescPubKey,     keyBytes,     Origin (..),@@ -16,11 +13,9 @@ ) where  import Data.ByteString (ByteString)-import Data.Word (Word32) import Haskoin (     Address,     DerivPath,-    DerivPathI ((:/), (:|)),     Fingerprint,     PubKeyI (..),     SecKeyI,@@ -93,13 +88,6 @@ -- | Simple explicit secret key with no origin information secKey :: SecKeyI -> KeyDescriptor secKey = KeyDescriptor Nothing . SecretKey---- | For key families, get the key at the given index.  Otherwise, return the input key.-keyAtIndex :: Word32 -> Key -> Key-keyAtIndex ix = \case-    XPub xpub path HardKeys -> XPub xpub (path :| ix) Single-    XPub xpub path SoftKeys -> XPub xpub (path :/ ix) Single-    key -> key  -- | Represent whether the key corresponds to a collection (and how) or a single key. data KeyCollection

@@ -4,31 +4,29 @@ -- | Convert descriptors to text module Language.Bitcoin.Script.Descriptors.Text (     descriptorToText,+    descriptorToTextWithChecksum,     keyDescriptorToText, ) where -import Data.ByteString.Builder (-    toLazyByteString,-    word32BE,- )-import Data.ByteString.Lazy (toStrict) import Data.Maybe (fromMaybe) import Data.Text (     Text,     intercalate,     pack,  )-import Haskoin.Address (addrToText)-import Haskoin.Constants (Network)-import Haskoin.Keys (+import Haskoin (+    Network,     PubKeyI (..),+    addrToText,+    encodeHex,     exportPubKey,+    fingerprintToText,     pathToStr,     toWif,     xPubExport,  )-import Haskoin.Util (encodeHex) +import Language.Bitcoin.Script.Descriptors.Checksum (descriptorChecksum) import Language.Bitcoin.Script.Descriptors.Syntax import Language.Bitcoin.Utils (     applicationText,@@ -51,6 +49,12 @@      addrErr = error "Unable to parse address" +descriptorToTextWithChecksum :: Network -> OutputDescriptor -> Text+descriptorToTextWithChecksum net desc =+    descText <> maybe "" ("#" <>) (descriptorChecksum descText)+  where+    descText = descriptorToText net desc+ scriptDescriptorToText :: Network -> ScriptDescriptor -> Text scriptDescriptorToText net = \case     Pk k -> applicationText "pk" $ keyToText k@@ -66,7 +70,7 @@ keyDescriptorToText :: Network -> KeyDescriptor -> Text keyDescriptorToText net (KeyDescriptor o k) = maybe mempty originText o <> definitionText   where-    originText (Origin fp path) = "[" <> fingerprintText fp <> pack (pathToStr path) <> "]"+    originText (Origin fp path) = "[" <> fingerprintToText fp <> pack (pathToStr path) <> "]"      definitionText = case k of         Pubkey (PubKeyI key c) -> encodeHex $ exportPubKey c key@@ -77,5 +81,3 @@         Single -> ""         HardKeys -> "/*'"         SoftKeys -> "/*"--    fingerprintText = encodeHex . toStrict . toLazyByteString . word32BE

@@ -1,19 +1,64 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-} +{- |+Module: Language.Bitcoin.Script.Descriptors.Utils+Stability: experimental+-} module Language.Bitcoin.Script.Descriptors.Utils (+    -- * Conversions     descriptorAddresses,     compile,++    -- * Transaction pieces+    TransactionScripts (..),+    outputDescriptorScripts,++    -- * Script families+    keyAtIndex,+    keyDescriptorAtIndex,+    scriptDescriptorAtIndex,+    outputDescriptorAtIndex,++    -- * Pub keys+    outputDescriptorPubKeys,+    scriptDescriptorPubKeys,++    -- * PSBT+    toPsbtInput,+    PsbtInputError (..), ) where +import Control.Applicative ((<|>))+import Control.Exception (Exception)+import Data.Functor ((<&>))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM import Data.List (sortOn)-import Data.Maybe (maybeToList)+import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Serialize (decode, encode)+import qualified Data.Serialize as S+import Data.Word (Word32) import Haskoin (     Address,+    DerivPath,+    DerivPathI ((:/), (:|)),+    Fingerprint,+    Input,+    KeyIndex,+    PubKeyI (..),     Script,     ScriptOutput (..),+    Tx,     addressHash,     eitherToMaybe,+    emptyInput,+    encodeOutput,+    inputHDKeypaths,+    inputRedeemScript,+    inputWitnessScript,+    nonWitnessUtxo,+    pathToList,     payToNestedScriptAddress,     payToScriptAddress,     payToWitnessScriptAddress,@@ -22,12 +67,30 @@     pubKeyCompressed,     pubKeyWitnessAddr,     sortMulSig,+    toP2SH,+    toP2WSH,+    txOut,+    witnessUtxo,+    xPubFP,+    (++/),  ) -import qualified Language.Bitcoin.Miniscript as M+import qualified Language.Bitcoin.Miniscript.Compiler as M (+    compile,+ )+import qualified Language.Bitcoin.Miniscript.Syntax as M (+    key,+    keyH,+    multi,+ ) import Language.Bitcoin.Script.Descriptors.Syntax (+    Key (XPub),+    KeyCollection (..),+    KeyDescriptor (KeyDescriptor, keyDef),     OutputDescriptor (..),     ScriptDescriptor (..),+    derivation,+    fingerprint,     keyBytes,     keyDescPubKey,  )@@ -76,3 +139,249 @@     Raw bs -> eitherToMaybe (decode bs)   where     compileMaybe = eitherToMaybe . M.compile++data TransactionScripts = TransactionScripts+    { txScriptPubKey :: Script+    , txRedeemScript :: Maybe Script+    , txWitnessScript :: Maybe Script+    }+    deriving (Eq, Show)++outputDescriptorScripts :: OutputDescriptor -> Maybe TransactionScripts+outputDescriptorScripts =+    \case+        ScriptPubKey sd ->+            compile sd <&> \theScriptPubKey ->+                TransactionScripts+                    { txScriptPubKey = theScriptPubKey+                    , txRedeemScript = Nothing+                    , txWitnessScript = Nothing+                    }+        P2SH sd ->+            compile sd <&> \theScript ->+                TransactionScripts+                    { txScriptPubKey = encodeOutput $ toP2SH theScript+                    , txRedeemScript = Just theScript+                    , txWitnessScript = Nothing+                    }+        P2WPKH kd -> do+            theScriptPubKey <- encodeOutput . PayWitnessPKHash . addressHash . S.encode <$> keyDescPubKey kd+            pure+                TransactionScripts+                    { txScriptPubKey = theScriptPubKey+                    , txRedeemScript = Nothing+                    , txWitnessScript = Nothing+                    }+        P2WSH sd ->+            compile sd <&> \theScript ->+                TransactionScripts+                    { txScriptPubKey = encodeOutput $ toP2WSH theScript+                    , txRedeemScript = Nothing+                    , txWitnessScript = Just theScript+                    }+        WrappedWPkh kd -> do+            theRedeemScript <- encodeOutput . PayWitnessPKHash . addressHash . S.encode <$> keyDescPubKey kd+            pure+                TransactionScripts+                    { txScriptPubKey = encodeOutput $ toP2SH theRedeemScript+                    , txRedeemScript = Just theRedeemScript+                    , txWitnessScript = Nothing+                    }+        WrappedWSh sd ->+            compile sd <&> \theScript ->+                let theRedeemScript = encodeOutput $ toP2WSH theScript+                 in TransactionScripts+                        { txScriptPubKey = encodeOutput $ toP2SH theRedeemScript+                        , txRedeemScript = Just theRedeemScript+                        , txWitnessScript = Just theScript+                        }+        Combo _kd -> Nothing+        Addr _ad -> Nothing++{- | For key families, get the key at the given index.  Otherwise, return the input key.++  @since 0.2.1+-}+keyAtIndex :: Word32 -> Key -> Key+keyAtIndex ix = \case+    XPub xpub path HardKeys -> XPub xpub (path :| ix) Single+    XPub xpub path SoftKeys -> XPub xpub (path :/ ix) Single+    key -> key++{- | Specialize key families occurring in the descriptor to the given index++ @since 0.2.1+-}+outputDescriptorAtIndex :: KeyIndex -> OutputDescriptor -> OutputDescriptor+outputDescriptorAtIndex ix = \case+    o@ScriptPubKey{} -> o+    P2SH sd -> P2SH $ scriptDescriptorAtIndex ix sd+    P2WPKH kd -> P2WPKH $ keyDescriptorAtIndex ix kd+    P2WSH sd -> P2WSH $ scriptDescriptorAtIndex ix sd+    WrappedWPkh kd -> WrappedWPkh $ keyDescriptorAtIndex ix kd+    WrappedWSh sd -> WrappedWSh $ scriptDescriptorAtIndex ix sd+    Combo kd -> Combo $ keyDescriptorAtIndex ix kd+    a@Addr{} -> a++{- | Specialize key families occurring in the descriptor to the given index++ @since 0.2.1+-}+scriptDescriptorAtIndex :: KeyIndex -> ScriptDescriptor -> ScriptDescriptor+scriptDescriptorAtIndex ix = \case+    Pk kd -> Pk $ specialize kd+    Pkh kd -> Pkh $ specialize kd+    Multi k ks -> Multi k $ specialize <$> ks+    SortedMulti k ks -> SortedMulti k $ specialize <$> ks+    r@Raw{} -> r+  where+    specialize = keyDescriptorAtIndex ix++{- | Specialize key families occurring in the descriptor to the given index++ @since 0.2.1+-}+keyDescriptorAtIndex :: KeyIndex -> KeyDescriptor -> KeyDescriptor+keyDescriptorAtIndex ix keyDescriptor = keyDescriptor{keyDef = keyAtIndex ix $ keyDef keyDescriptor}++{- | Produce the psbt input parameters needed to spend an output from the+descriptor.  Caveat: This construction fails on `Combo` and `Addr` outputs.++ @since 0.2.1+-}+toPsbtInput ::+    -- | Transaction being spent+    Tx ->+    -- | Output being spent+    Int ->+    -- | Descriptor for output being spent+    OutputDescriptor ->+    Either PsbtInputError Input+toPsbtInput tx ix descriptor = case descriptor of+    ScriptPubKey sd ->+        pure+            emptyInput+                { nonWitnessUtxo = Just tx+                , inputHDKeypaths = hdPaths sd+                }+    P2SH sd -> do+        script <- compileForInput sd+        pure+            emptyInput+                { nonWitnessUtxo = Just tx+                , inputRedeemScript = Just script+                , inputHDKeypaths = hdPaths sd+                }+    P2WPKH kd -> do+        output <- txOut tx `safeIndex` ix+        pure+            emptyInput+                { witnessUtxo = Just output+                , inputHDKeypaths = hdPath kd+                }+    P2WSH sd -> do+        output <- txOut tx `safeIndex` ix+        script <- compileForInput sd+        pure+            emptyInput+                { witnessUtxo = Just output+                , inputWitnessScript = Just script+                , inputHDKeypaths = hdPaths sd+                }+    WrappedWPkh kd -> do+        output <- txOut tx `safeIndex` ix+        k <- maybe (Left $ KeyNotAvailable kd) pure $ keyDescPubKey kd+        pure+            emptyInput+                { witnessUtxo = Just output+                , inputRedeemScript =+                    Just+                        . encodeOutput+                        . PayWitnessPKHash+                        . addressHash+                        $ encode k+                , inputHDKeypaths = hdPath kd+                }+    WrappedWSh sd -> do+        output <- txOut tx `safeIndex` ix+        script <- compileForInput sd+        pure+            emptyInput+                { witnessUtxo = Just output+                , inputRedeemScript = Just . encodeOutput $ toP2WSH script+                , inputWitnessScript = Just script+                , inputHDKeypaths = hdPaths sd+                }+    o@Combo{} -> Left $ InvalidOutput o+    o@Addr{} -> Left $ InvalidOutput o+  where+    hdPaths = foldMap hdPath . scriptKeys+    compileForInput sd = maybe (Left $ CompileError sd) pure $ compile sd++    safeIndex (x : xs) n+        | n == 0 = pure x+        | n > 0 = safeIndex xs (n - 1)+    safeIndex _ _ = Left $ OutputIndexOOB tx ix++data PsbtInputError+    = OutputIndexOOB Tx Int+    | CompileError ScriptDescriptor+    | KeyNotAvailable KeyDescriptor+    | InvalidOutput OutputDescriptor+    deriving (Eq, Show)++instance Exception PsbtInputError++hdPath :: KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])+hdPath k@(KeyDescriptor origin theKeyDef) = fromMaybe mempty $ do+    pubKey <- keyDescPubKey k+    fromOrigin pubKey <|> fromKey pubKey+  where+    fromOrigin pubKey = do+        theOrigin <- origin+        theKeyPath <- keyPath theKeyDef+        pure $+            HM.singleton+                pubKey+                ( fingerprint theOrigin+                , pathToList $ derivation theOrigin ++/ theKeyPath+                )+    fromKey pubKey =+        case theKeyDef of+            XPub xpub path Single ->+                pure $+                    HM.singleton+                        pubKey+                        ( xPubFP xpub+                        , pathToList path+                        )+            _ -> Nothing++keyPath :: Key -> Maybe DerivPath+keyPath = \case+    XPub _ path Single -> Just path+    _ -> Nothing++scriptKeys :: ScriptDescriptor -> [KeyDescriptor]+scriptKeys = \case+    Pk k -> [k]+    Pkh k -> [k]+    Multi _ ks -> ks+    SortedMulti _ ks -> ks+    Raw{} -> mempty++-- | Extract pubkeys from an 'OutputDescriptor' where possible+outputDescriptorPubKeys :: OutputDescriptor -> [PubKeyI]+outputDescriptorPubKeys = \case+    ScriptPubKey sd -> scriptDescriptorPubKeys sd+    P2SH sd -> scriptDescriptorPubKeys sd+    P2WPKH kd -> foldMap pure $ keyDescPubKey kd+    P2WSH sd -> scriptDescriptorPubKeys sd+    WrappedWPkh kd -> foldMap pure $ keyDescPubKey kd+    WrappedWSh sd -> scriptDescriptorPubKeys sd+    Combo kd -> foldMap pure $ keyDescPubKey kd+    Addr _ad -> mempty++-- | Extract pubkeys from a 'ScriptDescriptor' where possible+scriptDescriptorPubKeys :: ScriptDescriptor -> [PubKeyI]+scriptDescriptorPubKeys = mapMaybe keyDescPubKey . scriptKeys

@@ -17,14 +17,19 @@ import Haskoin.Util (decodeHex) import Test.Tasty (TestTree, testGroup) +import Data.Maybe (fromMaybe) import Language.Bitcoin.Script.Descriptors (+    ChecksumDescriptor (..),+    ChecksumStatus (..),     Key (..),     KeyCollection (..),     KeyDescriptor (..),     Origin (..),     OutputDescriptor (..),     ScriptDescriptor (..),+    descriptorChecksum,     descriptorToText,+    descriptorToTextWithChecksum,     parseDescriptor,  ) import Test.Descriptors.Utils (testDescriptorUtils)@@ -33,7 +38,19 @@ descriptorTests :: TestTree descriptorTests =     testGroup "descriptor tests" $-        (testTextRep (parseDescriptor btc) (descriptorToText btc) <$> examples)+        [ testGroup "absent checksum" $+            ( testTextRep+                (parseDescriptor btc)+                (descriptorToText btc . descriptor)+                <$> absentChecksumExamples+            )+        , testGroup "valid checksum" $+            ( testTextRep+                (parseDescriptor btc)+                (descriptorToTextWithChecksum btc . descriptor)+                <$> validChecksumExamples+            )+        ]             <> [testDescriptorUtils]   where     examples =@@ -54,6 +71,28 @@         , example15         , example16         ]+    absentChecksumExamples = withAbsentChecksum <$> examples+    validChecksumExamples =+        zipWith+            withValidChecksum+            examples+            [ "gn28ywm7"+            , "8fhd9pwu"+            , "8zl0zxma"+            , "qkrrc7je"+            , "lq9sf04s"+            , "2wtr0ej5"+            , "hzhjw406"+            , "y9zthqta"+            , "qwx6n9lh"+            , "en3tu306"+            , "ks05yr6p"+            , "axav5m0j"+            , "h69t6zk4"+            , "ml40v0wf"+            , "t2zpj2eu"+            , "v66cvalc"+            ]  key :: PubKeyI -> KeyDescriptor key = KeyDescriptor Nothing . Pubkey@@ -63,6 +102,32 @@   where     Just k = importPubKey =<< decodeHex h +withAbsentChecksum ::+    Example OutputDescriptor -> Example ChecksumDescriptor+withAbsentChecksum example =+    example+        { script =+            ChecksumDescriptor+                { descriptor = script example+                , checksumStatus = Absent+                , expectedChecksum =+                    fromMaybe "" $ descriptorChecksum $ text example+                }+        }++withValidChecksum ::+    Example OutputDescriptor -> Text -> Example ChecksumDescriptor+withValidChecksum example checksum =+    example+        { script =+            ChecksumDescriptor+                { descriptor = script example+                , checksumStatus = Valid+                , expectedChecksum = checksum+                }+        , text = text example <> "#" <> checksum+        }+ example1 :: Example OutputDescriptor example1 =     Example@@ -221,7 +286,7 @@         }   where     Just xpub = xPubImport btc "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL"-    fp = 0xd34db33f+    fp = "d34db33f"  example15 :: Example OutputDescriptor example15 =

@@ -1,3 +1,4 @@+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -6,33 +7,73 @@ ) where  import qualified Data.ByteString as BS+import Data.Bytes.Put (runPutS)+import Data.Bytes.Serial (serialize)+import qualified Data.HashMap.Strict as HM import Data.List (sort) import Data.Maybe (mapMaybe) import Data.Serialize (encode) import Haskoin (+    DerivPath,+    DerivPathI (..),+    OutPoint (OutPoint),     PubKeyI (PubKeyI),     Script (Script),     ScriptOp (..),+    ScriptOutput (..),+    XPubKey,+    addressHash,+    btc,     btcRegTest,+    buildTx,     derivePubKey,+    derivePubPath,+    emptyInput,+    encodeOutput,+    inputHDKeypaths,+    inputRedeemScript,+    inputWitnessScript,+    nonWitnessUtxo,     opPushData,+    pathToList,     ripemd160,     secKey,     textToAddr,+    toP2SH,+    toP2WSH,+    toSoft,+    txOut,+    witnessUtxo,+    xPubFP,+    xPubImport,+    xPubKey,  ) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.HUnit (testCase, testCaseSteps, (@?=))  import Language.Bitcoin.Script.Descriptors (+    Key (XPub),+    KeyCollection (..),+    KeyDescriptor (KeyDescriptor),     OutputDescriptor (..),     ScriptDescriptor (..),     compile,     descriptorAddresses,+    keyDescriptorAtIndex,+    outputDescriptorAtIndex,     pubKey,+    toPsbtInput,  )  testDescriptorUtils :: TestTree-testDescriptorUtils = testGroup "descriptor utils" [testCompile, testAddresses]+testDescriptorUtils =+    testGroup+        "descriptor utils"+        [ testCompile+        , testAddresses+        , testKeyAtIndex+        , testToPsbtInput+        ]  -- Address tests generated using @bitcoin-cli deriveaddresses@ testAddresses :: TestTree@@ -48,6 +89,14 @@         , testCombo         ] +testKeyAtIndex :: TestTree+testKeyAtIndex =+    testGroup+        "keyAtIndex"+        [ testKeyDescriptorAtIndex+        , testOutputDescriptorAtIndex+        ]+ testP2PKH :: TestTree testP2PKH = testCase "P2PKH" $ descriptorAddresses example @?= [expected]   where@@ -129,8 +178,141 @@     ks = take 3 testPubKeys     [k0, k1, k2] = sort $ encode <$> ks +testKeyDescriptorAtIndex :: TestTree+testKeyDescriptorAtIndex = testCase "keyDescriptorAtIndex" $ do+    keyDescriptorAtIndex 5 keyFamA @?= keyA+    keyDescriptorAtIndex 5 keyFamB @?= keyB+    keyDescriptorAtIndex 5 keyC @?= keyC+  where+    keyFamA = KeyDescriptor Nothing $ XPub someXPubA basePath HardKeys+    keyA = KeyDescriptor Nothing $ XPub someXPubA (basePath :| 5) Single++    keyFamB = KeyDescriptor Nothing $ XPub someXPubA basePath SoftKeys+    keyB = KeyDescriptor Nothing $ XPub someXPubA (basePath :/ 5) Single++    keyC = KeyDescriptor Nothing $ XPub someXPubA basePath Single++testOutputDescriptorAtIndex :: TestTree+testOutputDescriptorAtIndex = testCase "outputDescriptorAtIndex" $ do+    outputDescriptorAtIndex 5 descFamA @?= descA+    outputDescriptorAtIndex 5 descFamB @?= descB+    outputDescriptorAtIndex 5 descFamC @?= descC+  where+    descFamA = P2SH $ SortedMulti 2 [keyFamA, keyFamB]+    descA = P2SH $ SortedMulti 2 [keyA, keyB]++    descFamB = P2WSH $ Pkh keyFamB+    descB = P2WSH $ Pkh keyB++    descFamC = P2WPKH keyFamA+    descC = P2WPKH keyA++    keyFamA = KeyDescriptor Nothing $ XPub someXPubA basePath HardKeys+    keyA = KeyDescriptor Nothing $ XPub someXPubA (basePath :| 5) Single++    keyFamB = KeyDescriptor Nothing $ XPub someXPubB basePath HardKeys+    keyB = KeyDescriptor Nothing $ XPub someXPubB (basePath :| 5) Single++testToPsbtInput :: TestTree+testToPsbtInput = testCaseSteps "toPsbtInput" $ \step -> do+    step "P2PKH"+    toPsbtInput p2pkhTx 0 p2pkhDescriptor @?= Right expectedP2pkhInput++    step "P2SH-MS"+    toPsbtInput p2shMsTx 0 p2shMsDescriptor @?= Right expectedP2shMsInput++    step "P2SH-WPKH"+    toPsbtInput p2shWpkhTx 0 p2shWpkhDescriptor @?= Right expectedP2shWpkhInput++    step "P2SH-WSH-MS"+    toPsbtInput p2shWshMsTx 0 p2shWshMsDescriptor @?= Right expectedP2shWshMsInput++    step "P2WPKH"+    toPsbtInput wpkhTx 0 wpkhDescriptor @?= Right expectedWpkhInput++    step "P2WSH-MS"+    toPsbtInput wshMsTx 0 wshMsDescriptor @?= Right expectedWshMsInput+  where+    p2pkhTx = buildTx [outPoint] [(PayPKHash hashA, 1_000_000)]+    p2pkhDescriptor = ScriptPubKey $ Pkh keyA+    expectedP2pkhInput =+        emptyInput+            { nonWitnessUtxo = Just p2pkhTx+            , inputHDKeypaths = hdKeypathA+            }++    p2shMsTx = buildTx [outPoint] [(msScriptOutput, 1_000_000)]+    p2shMsDescriptor = P2SH msDescriptor+    expectedP2shMsInput =+        emptyInput+            { nonWitnessUtxo = Just p2shMsTx+            , inputRedeemScript = Just $ encodeOutput msScriptOutput+            , inputHDKeypaths = hdKeypathA <> hdKeypathB+            }+    msScriptOutput = PayMulSig [pubKeyA, pubKeyB] 1+    msDescriptor = Multi 1 [keyA, keyB]++    keyA = KeyDescriptor Nothing $ XPub someXPubA path Single+    pubKeyA = (`PubKeyI` True) . xPubKey $ derivePubPath softPath someXPubA+    hashA = addressHash . runPutS $ serialize pubKeyA+    hdKeypathA = HM.singleton pubKeyA (xPubFP someXPubA, pathToList path)++    keyB = KeyDescriptor Nothing $ XPub someXPubB path Single+    pubKeyB = (`PubKeyI` True) . xPubKey $ derivePubPath softPath someXPubB+    hdKeypathB = HM.singleton pubKeyB (xPubFP someXPubB, pathToList path)++    p2shWpkhDescriptor = WrappedWPkh keyA+    p2shWpkhTx = buildTx [outPoint] [(p2shWpkhScriptOutput, 1_000_000)]+    expectedP2shWpkhInput =+        emptyInput+            { witnessUtxo = Just $ (head . txOut) p2shWpkhTx+            , inputRedeemScript = Just $ encodeOutput wpkhScriptOutputA+            , inputHDKeypaths = hdKeypathA+            }+    p2shWpkhScriptOutput = toP2SH $ encodeOutput wpkhScriptOutputA+    wpkhScriptOutputA = PayWitnessPKHash hashA++    p2shWshMsTx = buildTx [outPoint] [(p2shWshMsOutput, 1_000_000)]+    p2shWshMsDescriptor = WrappedWSh msDescriptor+    expectedP2shWshMsInput =+        emptyInput+            { witnessUtxo = Just $ (head . txOut) p2shWshMsTx+            , inputRedeemScript = Just $ encodeOutput wshMsOutput+            , inputWitnessScript = Just $ encodeOutput msScriptOutput+            , inputHDKeypaths = hdKeypathA <> hdKeypathB+            }+    p2shWshMsOutput = toP2SH $ encodeOutput wshMsOutput+    wshMsOutput = toP2WSH $ encodeOutput msScriptOutput++    wpkhTx = buildTx [outPoint] [(PayWitnessPKHash hashA, 1_000_000)]+    wpkhDescriptor = P2WPKH keyA+    expectedWpkhInput =+        emptyInput+            { witnessUtxo = Just . head $ txOut wpkhTx+            , inputHDKeypaths = hdKeypathA+            }+    wshMsTx = buildTx [outPoint] [(wshMsOutput, 1_000_000)]+    wshMsDescriptor = P2WSH msDescriptor+    expectedWshMsInput =+        emptyInput+            { witnessUtxo = Just $ (head . txOut) wshMsTx+            , inputWitnessScript = Just $ encodeOutput msScriptOutput+            , inputHDKeypaths = hdKeypathA <> hdKeypathB+            }++    outPoint = OutPoint "0000000000000000000000000000000000000000000000000000000000000000" 0+    path = Deriv :/ 1 :: DerivPath+    Just softPath = toSoft path+ key0 :: PubKeyI testPubKeys :: [PubKeyI] testPubKeys@(key0 : _) = (`PubKeyI` True) . derivePubKey <$> mapMaybe (secKey . mkSecKey) [1 .. 255]   where     mkSecKey i = BS.pack $ replicate 31 0 <> [i]++someXPubA, someXPubB :: XPubKey+Just someXPubA = xPubImport btc "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB"+Just someXPubB = xPubImport btc "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH"++basePath :: DerivPath+basePath = Deriv :| 1500