{-# 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 (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,
    pubKeyAddr,
    pubKeyCompatWitnessAddr,
    pubKeyCompressed,
    pubKeyWitnessAddr,
    sortMulSig,
    toP2SH,
    toP2WSH,
    txOut,
    witnessUtxo,
    xPubFP,
    (++/),
 )

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,
 )

{- | Get the set of addresses associated with an output descriptor.  The list will be empty if:

     * any keys are indefinite
     * the output is p2pk
     * the output has a non-standard script

     The list can contain more than one address in the case of the "combo" construct.
-}
descriptorAddresses :: OutputDescriptor -> [Address]
descriptorAddresses :: OutputDescriptor -> [Address]
descriptorAddresses = \case
    ScriptPubKey Pk{} -> forall a. Monoid a => a
mempty
    ScriptPubKey (Pkh KeyDescriptor
key) -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Address
pubKeyAddr) forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key
    P2SH ScriptDescriptor
descriptor -> forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ ScriptOutput -> Address
payToScriptAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptDescriptor -> Maybe ScriptOutput
scriptDescriptorOutput ScriptDescriptor
descriptor
    P2WPKH KeyDescriptor
key -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Address
pubKeyWitnessAddr) forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key
    P2WSH ScriptDescriptor
descriptor -> forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ ScriptOutput -> Address
payToWitnessScriptAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptDescriptor -> Maybe ScriptOutput
scriptDescriptorOutput ScriptDescriptor
descriptor
    WrappedWPkh KeyDescriptor
key -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Address
pubKeyCompatWitnessAddr) forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key
    WrappedWSh ScriptDescriptor
descriptor -> forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ ScriptOutput -> Address
payToNestedScriptAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptDescriptor -> Maybe ScriptOutput
scriptDescriptorOutput ScriptDescriptor
descriptor
    Combo KeyDescriptor
key
        | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key ->
            [PubKeyI -> Address
pubKeyAddr PubKeyI
pk]
                forall a. Semigroup a => a -> a -> a
<> if PubKeyI -> Bool
pubKeyCompressed PubKeyI
pk
                    then [PubKeyI -> Address
pubKeyWitnessAddr PubKeyI
pk, PubKeyI -> Address
pubKeyCompatWitnessAddr PubKeyI
pk]
                    else forall a. Monoid a => a
mempty
    Addr Address
addr -> [Address
addr]
    OutputDescriptor
_ -> forall a. Monoid a => a
mempty

scriptDescriptorOutput :: ScriptDescriptor -> Maybe ScriptOutput
scriptDescriptorOutput :: ScriptDescriptor -> Maybe ScriptOutput
scriptDescriptorOutput = \case
    Pk KeyDescriptor
key -> PubKeyI -> ScriptOutput
PayPK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key
    Pkh KeyDescriptor
key -> Hash160 -> ScriptOutput
PayPKHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ByteArrayAccess b => b -> Hash160
addressHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
key
    Multi Int
k [KeyDescriptor]
ks -> [PubKeyI] -> Int -> ScriptOutput
PayMulSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KeyDescriptor -> Maybe PubKeyI
keyDescPubKey [KeyDescriptor]
ks forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
k
    SortedMulti Int
k [KeyDescriptor]
ks -> ScriptOutput -> ScriptOutput
sortMulSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([PubKeyI] -> Int -> ScriptOutput
PayMulSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KeyDescriptor -> Maybe PubKeyI
keyDescPubKey [KeyDescriptor]
ks forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
k)
    ScriptDescriptor
_ -> forall a. Maybe a
Nothing

-- | Produce the script described by the descriptor.  Fails when any keys in the descriptor are indeterminate.
compile :: ScriptDescriptor -> Maybe Script
compile :: ScriptDescriptor -> Maybe Script
compile = \case
    Pk KeyDescriptor
key -> Miniscript -> Maybe Script
compileMaybe forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Miniscript
M.key KeyDescriptor
key
    Pkh KeyDescriptor
key -> Miniscript -> Maybe Script
compileMaybe forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Miniscript
M.keyH KeyDescriptor
key
    Multi Int
k [KeyDescriptor]
ks -> Miniscript -> Maybe Script
compileMaybe forall a b. (a -> b) -> a -> b
$ Int -> [KeyDescriptor] -> Miniscript
M.multi Int
k [KeyDescriptor]
ks
    SortedMulti Int
k [KeyDescriptor]
ks -> Miniscript -> Maybe Script
compileMaybe forall a b. (a -> b) -> a -> b
$ Int -> [KeyDescriptor] -> Miniscript
M.multi Int
k (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn KeyDescriptor -> Maybe ByteString
keyBytes [KeyDescriptor]
ks)
    Raw ByteString
bs -> forall a b. Either a b -> Maybe b
eitherToMaybe (forall a. Serialize a => ByteString -> Either String a
decode ByteString
bs)
  where
    compileMaybe :: Miniscript -> Maybe Script
compileMaybe = forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Miniscript -> Either CompilerError Script
M.compile

data TransactionScripts = TransactionScripts
    { TransactionScripts -> Script
txScriptPubKey :: Script
    , TransactionScripts -> Maybe Script
txRedeemScript :: Maybe Script
    , TransactionScripts -> Maybe Script
txWitnessScript :: Maybe Script
    }
    deriving (TransactionScripts -> TransactionScripts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionScripts -> TransactionScripts -> Bool
$c/= :: TransactionScripts -> TransactionScripts -> Bool
== :: TransactionScripts -> TransactionScripts -> Bool
$c== :: TransactionScripts -> TransactionScripts -> Bool
Eq, Int -> TransactionScripts -> ShowS
[TransactionScripts] -> ShowS
TransactionScripts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionScripts] -> ShowS
$cshowList :: [TransactionScripts] -> ShowS
show :: TransactionScripts -> String
$cshow :: TransactionScripts -> String
showsPrec :: Int -> TransactionScripts -> ShowS
$cshowsPrec :: Int -> TransactionScripts -> ShowS
Show)

outputDescriptorScripts :: OutputDescriptor -> Maybe TransactionScripts
outputDescriptorScripts :: OutputDescriptor -> Maybe TransactionScripts
outputDescriptorScripts =
    \case
        ScriptPubKey ScriptDescriptor
sd ->
            ScriptDescriptor -> Maybe Script
compile ScriptDescriptor
sd forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Script
theScriptPubKey ->
                TransactionScripts
                    { txScriptPubKey :: Script
txScriptPubKey = Script
theScriptPubKey
                    , txRedeemScript :: Maybe Script
txRedeemScript = forall a. Maybe a
Nothing
                    , txWitnessScript :: Maybe Script
txWitnessScript = forall a. Maybe a
Nothing
                    }
        P2SH ScriptDescriptor
sd ->
            ScriptDescriptor -> Maybe Script
compile ScriptDescriptor
sd forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Script
theScript ->
                TransactionScripts
                    { txScriptPubKey :: Script
txScriptPubKey = ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2SH Script
theScript
                    , txRedeemScript :: Maybe Script
txRedeemScript = forall a. a -> Maybe a
Just Script
theScript
                    , txWitnessScript :: Maybe Script
txWitnessScript = forall a. Maybe a
Nothing
                    }
        P2WPKH KeyDescriptor
kd -> do
            Script
theScriptPubKey <- ScriptOutput -> Script
encodeOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash160 -> ScriptOutput
PayWitnessPKHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ByteArrayAccess b => b -> Hash160
addressHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
S.encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                TransactionScripts
                    { txScriptPubKey :: Script
txScriptPubKey = Script
theScriptPubKey
                    , txRedeemScript :: Maybe Script
txRedeemScript = forall a. Maybe a
Nothing
                    , txWitnessScript :: Maybe Script
txWitnessScript = forall a. Maybe a
Nothing
                    }
        P2WSH ScriptDescriptor
sd ->
            ScriptDescriptor -> Maybe Script
compile ScriptDescriptor
sd forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Script
theScript ->
                TransactionScripts
                    { txScriptPubKey :: Script
txScriptPubKey = ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2WSH Script
theScript
                    , txRedeemScript :: Maybe Script
txRedeemScript = forall a. Maybe a
Nothing
                    , txWitnessScript :: Maybe Script
txWitnessScript = forall a. a -> Maybe a
Just Script
theScript
                    }
        WrappedWPkh KeyDescriptor
kd -> do
            Script
theRedeemScript <- ScriptOutput -> Script
encodeOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash160 -> ScriptOutput
PayWitnessPKHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ByteArrayAccess b => b -> Hash160
addressHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
S.encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                TransactionScripts
                    { txScriptPubKey :: Script
txScriptPubKey = ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2SH Script
theRedeemScript
                    , txRedeemScript :: Maybe Script
txRedeemScript = forall a. a -> Maybe a
Just Script
theRedeemScript
                    , txWitnessScript :: Maybe Script
txWitnessScript = forall a. Maybe a
Nothing
                    }
        WrappedWSh ScriptDescriptor
sd ->
            ScriptDescriptor -> Maybe Script
compile ScriptDescriptor
sd forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Script
theScript ->
                let theRedeemScript :: Script
theRedeemScript = ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2WSH Script
theScript
                 in TransactionScripts
                        { txScriptPubKey :: Script
txScriptPubKey = ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2SH Script
theRedeemScript
                        , txRedeemScript :: Maybe Script
txRedeemScript = forall a. a -> Maybe a
Just Script
theRedeemScript
                        , txWitnessScript :: Maybe Script
txWitnessScript = forall a. a -> Maybe a
Just Script
theScript
                        }
        Combo KeyDescriptor
_kd -> forall a. Maybe a
Nothing
        Addr Address
_ad -> forall a. Maybe a
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 :: KeyIndex -> Key -> Key
keyAtIndex KeyIndex
ix = \case
    XPub XPubKey
xpub DerivPath
path KeyCollection
HardKeys -> XPubKey -> DerivPath -> KeyCollection -> Key
XPub XPubKey
xpub (DerivPath
path forall t. HardOrAny t => DerivPathI t -> KeyIndex -> DerivPathI t
:| KeyIndex
ix) KeyCollection
Single
    XPub XPubKey
xpub DerivPath
path KeyCollection
SoftKeys -> XPubKey -> DerivPath -> KeyCollection -> Key
XPub XPubKey
xpub (DerivPath
path forall t. AnyOrSoft t => DerivPathI t -> KeyIndex -> DerivPathI t
:/ KeyIndex
ix) KeyCollection
Single
    Key
key -> Key
key

{- | Specialize key families occurring in the descriptor to the given index

 @since 0.2.1
-}
outputDescriptorAtIndex :: KeyIndex -> OutputDescriptor -> OutputDescriptor
outputDescriptorAtIndex :: KeyIndex -> OutputDescriptor -> OutputDescriptor
outputDescriptorAtIndex KeyIndex
ix = \case
    o :: OutputDescriptor
o@ScriptPubKey{} -> OutputDescriptor
o
    P2SH ScriptDescriptor
sd -> ScriptDescriptor -> OutputDescriptor
P2SH forall a b. (a -> b) -> a -> b
$ KeyIndex -> ScriptDescriptor -> ScriptDescriptor
scriptDescriptorAtIndex KeyIndex
ix ScriptDescriptor
sd
    P2WPKH KeyDescriptor
kd -> KeyDescriptor -> OutputDescriptor
P2WPKH forall a b. (a -> b) -> a -> b
$ KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex KeyIndex
ix KeyDescriptor
kd
    P2WSH ScriptDescriptor
sd -> ScriptDescriptor -> OutputDescriptor
P2WSH forall a b. (a -> b) -> a -> b
$ KeyIndex -> ScriptDescriptor -> ScriptDescriptor
scriptDescriptorAtIndex KeyIndex
ix ScriptDescriptor
sd
    WrappedWPkh KeyDescriptor
kd -> KeyDescriptor -> OutputDescriptor
WrappedWPkh forall a b. (a -> b) -> a -> b
$ KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex KeyIndex
ix KeyDescriptor
kd
    WrappedWSh ScriptDescriptor
sd -> ScriptDescriptor -> OutputDescriptor
WrappedWSh forall a b. (a -> b) -> a -> b
$ KeyIndex -> ScriptDescriptor -> ScriptDescriptor
scriptDescriptorAtIndex KeyIndex
ix ScriptDescriptor
sd
    Combo KeyDescriptor
kd -> KeyDescriptor -> OutputDescriptor
Combo forall a b. (a -> b) -> a -> b
$ KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex KeyIndex
ix KeyDescriptor
kd
    a :: OutputDescriptor
a@Addr{} -> OutputDescriptor
a

{- | Specialize key families occurring in the descriptor to the given index

 @since 0.2.1
-}
scriptDescriptorAtIndex :: KeyIndex -> ScriptDescriptor -> ScriptDescriptor
scriptDescriptorAtIndex :: KeyIndex -> ScriptDescriptor -> ScriptDescriptor
scriptDescriptorAtIndex KeyIndex
ix = \case
    Pk KeyDescriptor
kd -> KeyDescriptor -> ScriptDescriptor
Pk forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> KeyDescriptor
specialize KeyDescriptor
kd
    Pkh KeyDescriptor
kd -> KeyDescriptor -> ScriptDescriptor
Pkh forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> KeyDescriptor
specialize KeyDescriptor
kd
    Multi Int
k [KeyDescriptor]
ks -> Int -> [KeyDescriptor] -> ScriptDescriptor
Multi Int
k forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> KeyDescriptor
specialize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyDescriptor]
ks
    SortedMulti Int
k [KeyDescriptor]
ks -> Int -> [KeyDescriptor] -> ScriptDescriptor
SortedMulti Int
k forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> KeyDescriptor
specialize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyDescriptor]
ks
    r :: ScriptDescriptor
r@Raw{} -> ScriptDescriptor
r
  where
    specialize :: KeyDescriptor -> KeyDescriptor
specialize = KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex KeyIndex
ix

{- | Specialize key families occurring in the descriptor to the given index

 @since 0.2.1
-}
keyDescriptorAtIndex :: KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex :: KeyIndex -> KeyDescriptor -> KeyDescriptor
keyDescriptorAtIndex KeyIndex
ix KeyDescriptor
keyDescriptor = KeyDescriptor
keyDescriptor{keyDef :: Key
keyDef = KeyIndex -> Key -> Key
keyAtIndex KeyIndex
ix forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Key
keyDef KeyDescriptor
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 -> Int -> OutputDescriptor -> Either PsbtInputError Input
toPsbtInput Tx
tx Int
ix OutputDescriptor
descriptor = case OutputDescriptor
descriptor of
    ScriptPubKey ScriptDescriptor
sd ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { nonWitnessUtxo :: Maybe Tx
nonWitnessUtxo = forall a. a -> Maybe a
Just Tx
tx
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = ScriptDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPaths ScriptDescriptor
sd
                }
    P2SH ScriptDescriptor
sd -> do
        Script
script <- ScriptDescriptor -> Either PsbtInputError Script
compileForInput ScriptDescriptor
sd
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { nonWitnessUtxo :: Maybe Tx
nonWitnessUtxo = forall a. a -> Maybe a
Just Tx
tx
                , inputRedeemScript :: Maybe Script
inputRedeemScript = forall a. a -> Maybe a
Just Script
script
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = ScriptDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPaths ScriptDescriptor
sd
                }
    P2WPKH KeyDescriptor
kd -> do
        TxOut
output <- Tx -> [TxOut]
txOut Tx
tx forall {t} {a}.
(Num t, Ord t) =>
[a] -> t -> Either PsbtInputError a
`safeIndex` Int
ix
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { witnessUtxo :: Maybe TxOut
witnessUtxo = forall a. a -> Maybe a
Just TxOut
output
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPath KeyDescriptor
kd
                }
    P2WSH ScriptDescriptor
sd -> do
        TxOut
output <- Tx -> [TxOut]
txOut Tx
tx forall {t} {a}.
(Num t, Ord t) =>
[a] -> t -> Either PsbtInputError a
`safeIndex` Int
ix
        Script
script <- ScriptDescriptor -> Either PsbtInputError Script
compileForInput ScriptDescriptor
sd
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { witnessUtxo :: Maybe TxOut
witnessUtxo = forall a. a -> Maybe a
Just TxOut
output
                , inputWitnessScript :: Maybe Script
inputWitnessScript = forall a. a -> Maybe a
Just Script
script
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = ScriptDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPaths ScriptDescriptor
sd
                }
    WrappedWPkh KeyDescriptor
kd -> do
        TxOut
output <- Tx -> [TxOut]
txOut Tx
tx forall {t} {a}.
(Num t, Ord t) =>
[a] -> t -> Either PsbtInputError a
`safeIndex` Int
ix
        PubKeyI
k <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> PsbtInputError
KeyNotAvailable KeyDescriptor
kd) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { witnessUtxo :: Maybe TxOut
witnessUtxo = forall a. a -> Maybe a
Just TxOut
output
                , inputRedeemScript :: Maybe Script
inputRedeemScript =
                    forall a. a -> Maybe a
Just
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptOutput -> Script
encodeOutput
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash160 -> ScriptOutput
PayWitnessPKHash
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ByteArrayAccess b => b -> Hash160
addressHash
                        forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
encode PubKeyI
k
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPath KeyDescriptor
kd
                }
    WrappedWSh ScriptDescriptor
sd -> do
        TxOut
output <- Tx -> [TxOut]
txOut Tx
tx forall {t} {a}.
(Num t, Ord t) =>
[a] -> t -> Either PsbtInputError a
`safeIndex` Int
ix
        Script
script <- ScriptDescriptor -> Either PsbtInputError Script
compileForInput ScriptDescriptor
sd
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Input
emptyInput
                { witnessUtxo :: Maybe TxOut
witnessUtxo = forall a. a -> Maybe a
Just TxOut
output
                , inputRedeemScript :: Maybe Script
inputRedeemScript = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptOutput -> Script
encodeOutput forall a b. (a -> b) -> a -> b
$ Script -> ScriptOutput
toP2WSH Script
script
                , inputWitnessScript :: Maybe Script
inputWitnessScript = forall a. a -> Maybe a
Just Script
script
                , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex])
inputHDKeypaths = ScriptDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPaths ScriptDescriptor
sd
                }
    o :: OutputDescriptor
o@Combo{} -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ OutputDescriptor -> PsbtInputError
InvalidOutput OutputDescriptor
o
    o :: OutputDescriptor
o@Addr{} -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ OutputDescriptor -> PsbtInputError
InvalidOutput OutputDescriptor
o
  where
    hdPaths :: ScriptDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPaths = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptDescriptor -> [KeyDescriptor]
scriptKeys
    compileForInput :: ScriptDescriptor -> Either PsbtInputError Script
compileForInput ScriptDescriptor
sd = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ScriptDescriptor -> PsbtInputError
CompileError ScriptDescriptor
sd) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ScriptDescriptor -> Maybe Script
compile ScriptDescriptor
sd

    safeIndex :: [a] -> t -> Either PsbtInputError a
safeIndex (a
x : [a]
xs) t
n
        | t
n forall a. Eq a => a -> a -> Bool
== t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        | t
n forall a. Ord a => a -> a -> Bool
> t
0 = [a] -> t -> Either PsbtInputError a
safeIndex [a]
xs (t
n forall a. Num a => a -> a -> a
- t
1)
    safeIndex [a]
_ t
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Tx -> Int -> PsbtInputError
OutputIndexOOB Tx
tx Int
ix

data PsbtInputError
    = OutputIndexOOB Tx Int
    | CompileError ScriptDescriptor
    | KeyNotAvailable KeyDescriptor
    | InvalidOutput OutputDescriptor
    deriving (PsbtInputError -> PsbtInputError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PsbtInputError -> PsbtInputError -> Bool
$c/= :: PsbtInputError -> PsbtInputError -> Bool
== :: PsbtInputError -> PsbtInputError -> Bool
$c== :: PsbtInputError -> PsbtInputError -> Bool
Eq, Int -> PsbtInputError -> ShowS
[PsbtInputError] -> ShowS
PsbtInputError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PsbtInputError] -> ShowS
$cshowList :: [PsbtInputError] -> ShowS
show :: PsbtInputError -> String
$cshow :: PsbtInputError -> String
showsPrec :: Int -> PsbtInputError -> ShowS
$cshowsPrec :: Int -> PsbtInputError -> ShowS
Show)

instance Exception PsbtInputError

hdPath :: KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPath :: KeyDescriptor -> HashMap PubKeyI (Fingerprint, [KeyIndex])
hdPath k :: KeyDescriptor
k@(KeyDescriptor Maybe Origin
origin Key
theKeyDef) = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ do
    PubKeyI
pubKey <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
    forall {k}.
Hashable k =>
k -> Maybe (HashMap k (Fingerprint, [KeyIndex]))
fromOrigin PubKeyI
pubKey forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {k}.
Hashable k =>
k -> Maybe (HashMap k (Fingerprint, [KeyIndex]))
fromKey PubKeyI
pubKey
  where
    fromOrigin :: k -> Maybe (HashMap k (Fingerprint, [KeyIndex]))
fromOrigin k
pubKey = do
        Origin
theOrigin <- Maybe Origin
origin
        DerivPath
theKeyPath <- Key -> Maybe DerivPath
keyPath Key
theKeyDef
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton
                k
pubKey
                ( Origin -> Fingerprint
fingerprint Origin
theOrigin
                , forall t. DerivPathI t -> [KeyIndex]
pathToList forall a b. (a -> b) -> a -> b
$ Origin -> DerivPath
derivation Origin
theOrigin forall t1 t2. DerivPathI t1 -> DerivPathI t2 -> DerivPath
++/ DerivPath
theKeyPath
                )
    fromKey :: k -> Maybe (HashMap k (Fingerprint, [KeyIndex]))
fromKey k
pubKey =
        case Key
theKeyDef of
            XPub XPubKey
xpub DerivPath
path KeyCollection
Single ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                    forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton
                        k
pubKey
                        ( XPubKey -> Fingerprint
xPubFP XPubKey
xpub
                        , forall t. DerivPathI t -> [KeyIndex]
pathToList DerivPath
path
                        )
            Key
_ -> forall a. Maybe a
Nothing

keyPath :: Key -> Maybe DerivPath
keyPath :: Key -> Maybe DerivPath
keyPath = \case
    XPub XPubKey
_ DerivPath
path KeyCollection
Single -> forall a. a -> Maybe a
Just DerivPath
path
    Key
_ -> forall a. Maybe a
Nothing

scriptKeys :: ScriptDescriptor -> [KeyDescriptor]
scriptKeys :: ScriptDescriptor -> [KeyDescriptor]
scriptKeys = \case
    Pk KeyDescriptor
k -> [KeyDescriptor
k]
    Pkh KeyDescriptor
k -> [KeyDescriptor
k]
    Multi Int
_ [KeyDescriptor]
ks -> [KeyDescriptor]
ks
    SortedMulti Int
_ [KeyDescriptor]
ks -> [KeyDescriptor]
ks
    Raw{} -> forall a. Monoid a => a
mempty

-- | Extract pubkeys from an 'OutputDescriptor' where possible
outputDescriptorPubKeys :: OutputDescriptor -> [PubKeyI]
outputDescriptorPubKeys :: OutputDescriptor -> [PubKeyI]
outputDescriptorPubKeys = \case
    ScriptPubKey ScriptDescriptor
sd -> ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys ScriptDescriptor
sd
    P2SH ScriptDescriptor
sd -> ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys ScriptDescriptor
sd
    P2WPKH KeyDescriptor
kd -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
    P2WSH ScriptDescriptor
sd -> ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys ScriptDescriptor
sd
    WrappedWPkh KeyDescriptor
kd -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
    WrappedWSh ScriptDescriptor
sd -> ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys ScriptDescriptor
sd
    Combo KeyDescriptor
kd -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
kd
    Addr Address
_ad -> forall a. Monoid a => a
mempty

-- | Extract pubkeys from a 'ScriptDescriptor' where possible
scriptDescriptorPubKeys :: ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys :: ScriptDescriptor -> [PubKeyI]
scriptDescriptorPubKeys = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe KeyDescriptor -> Maybe PubKeyI
keyDescPubKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptDescriptor -> [KeyDescriptor]
scriptKeys