{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Bitcoin.Miniscript.Witness (
    satisfy,
    SatisfactionContext,
    satisfactionContext,
    signature,
    preimage,
    lookupSignature,
    lookupPreimage,
    ChainState (..),
    emptyChainState,
    Signature (..),
    SatisfactionError (..),
) where

import Control.Exception (Exception)
import Control.Monad.Trans.Reader (
    Reader,
    asks,
    local,
    runReader,
 )
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Either (rights)
import Data.Function (on)
import Data.List (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Serialize (encode)
import Data.Text (Text)
import Haskoin.Crypto (Sig)
import Haskoin.Keys (
    PubKeyI (..),
    exportPubKey,
 )
import Haskoin.Script (
    Script (..),
    ScriptOp (..),
    SigHash,
    TxSignature (..),
    encodeTxSig,
    opPushData,
 )

import Language.Bitcoin.Miniscript.Syntax (
    Miniscript (..),
    Value (..),
 )
import Language.Bitcoin.Script.Descriptors (
    KeyDescriptor,
    keyDescPubKey,
 )

data Signature = Signature
    { Signature -> Sig
sig :: !Sig
    , Signature -> SigHash
sigHash :: !SigHash
    }
    deriving (Signature -> Signature -> Bool
(Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool) -> Eq Signature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c== :: Signature -> Signature -> Bool
Eq, Int -> Signature -> ShowS
[Signature] -> ShowS
Signature -> String
(Int -> Signature -> ShowS)
-> (Signature -> String)
-> ([Signature] -> ShowS)
-> Show Signature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signature] -> ShowS
$cshowList :: [Signature] -> ShowS
show :: Signature -> String
$cshow :: Signature -> String
showsPrec :: Int -> Signature -> ShowS
$cshowsPrec :: Int -> Signature -> ShowS
Show)

newtype OrdPubKeyI = OrdPubKeyI {OrdPubKeyI -> PubKeyI
unOrdPubKeyI :: PubKeyI}
    deriving (OrdPubKeyI -> OrdPubKeyI -> Bool
(OrdPubKeyI -> OrdPubKeyI -> Bool)
-> (OrdPubKeyI -> OrdPubKeyI -> Bool) -> Eq OrdPubKeyI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdPubKeyI -> OrdPubKeyI -> Bool
$c/= :: OrdPubKeyI -> OrdPubKeyI -> Bool
== :: OrdPubKeyI -> OrdPubKeyI -> Bool
$c== :: OrdPubKeyI -> OrdPubKeyI -> Bool
Eq, Int -> OrdPubKeyI -> ShowS
[OrdPubKeyI] -> ShowS
OrdPubKeyI -> String
(Int -> OrdPubKeyI -> ShowS)
-> (OrdPubKeyI -> String)
-> ([OrdPubKeyI] -> ShowS)
-> Show OrdPubKeyI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OrdPubKeyI] -> ShowS
$cshowList :: [OrdPubKeyI] -> ShowS
show :: OrdPubKeyI -> String
$cshow :: OrdPubKeyI -> String
showsPrec :: Int -> OrdPubKeyI -> ShowS
$cshowsPrec :: Int -> OrdPubKeyI -> ShowS
Show)

instance Ord OrdPubKeyI where
    compare :: OrdPubKeyI -> OrdPubKeyI -> Ordering
compare = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> ByteString -> Ordering)
-> (OrdPubKeyI -> ByteString)
-> OrdPubKeyI
-> OrdPubKeyI
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PubKeyI -> ByteString
toOrdered (PubKeyI -> ByteString)
-> (OrdPubKeyI -> PubKeyI) -> OrdPubKeyI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdPubKeyI -> PubKeyI
unOrdPubKeyI
      where
        toOrdered :: PubKeyI -> ByteString
toOrdered (PubKeyI pk :: PubKey
pk c :: Bool
c) = Bool -> PubKey -> ByteString
exportPubKey Bool
c PubKey
pk

data SatisfactionContext = SatisfactionContext
    { SatisfactionContext -> Map OrdPubKeyI Signature
signatures :: Map OrdPubKeyI Signature
    , SatisfactionContext -> Map ByteString ByteString
hashPreimages :: Map ByteString ByteString
    }
    deriving (SatisfactionContext -> SatisfactionContext -> Bool
(SatisfactionContext -> SatisfactionContext -> Bool)
-> (SatisfactionContext -> SatisfactionContext -> Bool)
-> Eq SatisfactionContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatisfactionContext -> SatisfactionContext -> Bool
$c/= :: SatisfactionContext -> SatisfactionContext -> Bool
== :: SatisfactionContext -> SatisfactionContext -> Bool
$c== :: SatisfactionContext -> SatisfactionContext -> Bool
Eq, Int -> SatisfactionContext -> ShowS
[SatisfactionContext] -> ShowS
SatisfactionContext -> String
(Int -> SatisfactionContext -> ShowS)
-> (SatisfactionContext -> String)
-> ([SatisfactionContext] -> ShowS)
-> Show SatisfactionContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatisfactionContext] -> ShowS
$cshowList :: [SatisfactionContext] -> ShowS
show :: SatisfactionContext -> String
$cshow :: SatisfactionContext -> String
showsPrec :: Int -> SatisfactionContext -> ShowS
$cshowsPrec :: Int -> SatisfactionContext -> ShowS
Show)

instance Semigroup SatisfactionContext where
    icA :: SatisfactionContext
icA <> :: SatisfactionContext -> SatisfactionContext -> SatisfactionContext
<> icB :: SatisfactionContext
icB =
        SatisfactionContext :: Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext
            { signatures :: Map OrdPubKeyI Signature
signatures = SatisfactionContext -> Map OrdPubKeyI Signature
signatures SatisfactionContext
icA Map OrdPubKeyI Signature
-> Map OrdPubKeyI Signature -> Map OrdPubKeyI Signature
forall a. Semigroup a => a -> a -> a
<> SatisfactionContext -> Map OrdPubKeyI Signature
signatures SatisfactionContext
icB
            , hashPreimages :: Map ByteString ByteString
hashPreimages = SatisfactionContext -> Map ByteString ByteString
hashPreimages SatisfactionContext
icA Map ByteString ByteString
-> Map ByteString ByteString -> Map ByteString ByteString
forall a. Semigroup a => a -> a -> a
<> SatisfactionContext -> Map ByteString ByteString
hashPreimages SatisfactionContext
icB
            }

instance Monoid SatisfactionContext where
    mempty :: SatisfactionContext
mempty = Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext Map OrdPubKeyI Signature
forall a. Monoid a => a
mempty Map ByteString ByteString
forall a. Monoid a => a
mempty

-- | Use with the monoid instance to add a signature to the 'SatisfactionContext'
signature :: PubKeyI -> Signature -> SatisfactionContext
signature :: PubKeyI -> Signature -> SatisfactionContext
signature pk :: PubKeyI
pk = (Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
`SatisfactionContext` Map ByteString ByteString
forall a. Monoid a => a
mempty) (Map OrdPubKeyI Signature -> SatisfactionContext)
-> (Signature -> Map OrdPubKeyI Signature)
-> Signature
-> SatisfactionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdPubKeyI -> Signature -> Map OrdPubKeyI Signature
forall k a. k -> a -> Map k a
Map.singleton (PubKeyI -> OrdPubKeyI
OrdPubKeyI PubKeyI
pk)

-- | Use with the monoid instance to add preimage to the 'SatisfactionContext'
preimage ::
    -- | hash
    ByteString ->
    -- | preimage
    ByteString ->
    SatisfactionContext
preimage :: ByteString -> ByteString -> SatisfactionContext
preimage h :: ByteString
h = Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext Map OrdPubKeyI Signature
forall a. Monoid a => a
mempty (Map ByteString ByteString -> SatisfactionContext)
-> (ByteString -> Map ByteString ByteString)
-> ByteString
-> SatisfactionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Map ByteString ByteString
forall k a. k -> a -> Map k a
Map.singleton ByteString
h

satisfactionContext :: [(ByteString, ByteString)] -> [(PubKeyI, Signature)] -> SatisfactionContext
satisfactionContext :: [(ByteString, ByteString)]
-> [(PubKeyI, Signature)] -> SatisfactionContext
satisfactionContext preimages :: [(ByteString, ByteString)]
preimages sigs :: [(PubKeyI, Signature)]
sigs =
    SatisfactionContext :: Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext
        { signatures :: Map OrdPubKeyI Signature
signatures = [(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature)
-> [(OrdPubKeyI, Signature)] -> Map OrdPubKeyI Signature
forall a b. (a -> b) -> a -> b
$ (PubKeyI -> OrdPubKeyI)
-> (PubKeyI, Signature) -> (OrdPubKeyI, Signature)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PubKeyI -> OrdPubKeyI
OrdPubKeyI ((PubKeyI, Signature) -> (OrdPubKeyI, Signature))
-> [(PubKeyI, Signature)] -> [(OrdPubKeyI, Signature)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PubKeyI, Signature)]
sigs
        , hashPreimages :: Map ByteString ByteString
hashPreimages = [(ByteString, ByteString)] -> Map ByteString ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ByteString, ByteString)]
preimages
        }

lookupSignature :: PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature :: PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature pk :: PubKeyI
pk = OrdPubKeyI -> Map OrdPubKeyI Signature -> Maybe Signature
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PubKeyI -> OrdPubKeyI
OrdPubKeyI PubKeyI
pk) (Map OrdPubKeyI Signature -> Maybe Signature)
-> (SatisfactionContext -> Map OrdPubKeyI Signature)
-> SatisfactionContext
-> Maybe Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatisfactionContext -> Map OrdPubKeyI Signature
signatures

lookupPreimage :: ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage :: ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage h :: ByteString
h = ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
h (Map ByteString ByteString -> Maybe ByteString)
-> (SatisfactionContext -> Map ByteString ByteString)
-> SatisfactionContext
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatisfactionContext -> Map ByteString ByteString
hashPreimages

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

emptyChainState :: ChainState
emptyChainState :: ChainState
emptyChainState = Maybe Int -> Maybe Int -> ChainState
ChainState Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing

data SatisfactionError
    = MissingSignature [KeyDescriptor]
    | MissingPreimage ByteString
    | FreeVariable Text
    | TypeError Text Miniscript
    | Impossible
    | AbstractKey KeyDescriptor
    deriving (SatisfactionError -> SatisfactionError -> Bool
(SatisfactionError -> SatisfactionError -> Bool)
-> (SatisfactionError -> SatisfactionError -> Bool)
-> Eq SatisfactionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatisfactionError -> SatisfactionError -> Bool
$c/= :: SatisfactionError -> SatisfactionError -> Bool
== :: SatisfactionError -> SatisfactionError -> Bool
$c== :: SatisfactionError -> SatisfactionError -> Bool
Eq, Int -> SatisfactionError -> ShowS
[SatisfactionError] -> ShowS
SatisfactionError -> String
(Int -> SatisfactionError -> ShowS)
-> (SatisfactionError -> String)
-> ([SatisfactionError] -> ShowS)
-> Show SatisfactionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatisfactionError] -> ShowS
$cshowList :: [SatisfactionError] -> ShowS
show :: SatisfactionError -> String
$cshow :: SatisfactionError -> String
showsPrec :: Int -> SatisfactionError -> ShowS
$cshowsPrec :: Int -> SatisfactionError -> ShowS
Show)

instance Exception SatisfactionError

data SatScript = SatScript
    { SatScript -> Int
satWeight :: Int
    , SatScript -> [ScriptOp]
satScript :: [ScriptOp]
    }
    deriving (SatScript -> SatScript -> Bool
(SatScript -> SatScript -> Bool)
-> (SatScript -> SatScript -> Bool) -> Eq SatScript
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatScript -> SatScript -> Bool
$c/= :: SatScript -> SatScript -> Bool
== :: SatScript -> SatScript -> Bool
$c== :: SatScript -> SatScript -> Bool
Eq, Int -> SatScript -> ShowS
[SatScript] -> ShowS
SatScript -> String
(Int -> SatScript -> ShowS)
-> (SatScript -> String)
-> ([SatScript] -> ShowS)
-> Show SatScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatScript] -> ShowS
$cshowList :: [SatScript] -> ShowS
show :: SatScript -> String
$cshow :: SatScript -> String
showsPrec :: Int -> SatScript -> ShowS
$cshowsPrec :: Int -> SatScript -> ShowS
Show)

instance Semigroup SatScript where
    SatScript n0 :: Int
n0 s0 :: [ScriptOp]
s0 <> :: SatScript -> SatScript -> SatScript
<> SatScript n1 :: Int
n1 s1 :: [ScriptOp]
s1 = Int -> [ScriptOp] -> SatScript
SatScript (Int
n0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1) ([ScriptOp]
s0 [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
s1)

instance Monoid SatScript where
    mempty :: SatScript
mempty = Int -> [ScriptOp] -> SatScript
SatScript 0 [ScriptOp]
forall a. Monoid a => a
mempty

fromScript :: [ScriptOp] -> SatScript
fromScript :: [ScriptOp] -> SatScript
fromScript s :: [ScriptOp]
s = Int -> [ScriptOp] -> SatScript
SatScript (ByteString -> Int
BS.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> ByteString
forall a. Serialize a => a -> ByteString
encode [ScriptOp]
s) [ScriptOp]
s

data SatResult = SatResult
    { SatResult -> Either SatisfactionError SatScript
sat :: Either SatisfactionError SatScript
    , SatResult -> Either SatisfactionError SatScript
dsat :: Either SatisfactionError SatScript
    }
    deriving (SatResult -> SatResult -> Bool
(SatResult -> SatResult -> Bool)
-> (SatResult -> SatResult -> Bool) -> Eq SatResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SatResult -> SatResult -> Bool
$c/= :: SatResult -> SatResult -> Bool
== :: SatResult -> SatResult -> Bool
$c== :: SatResult -> SatResult -> Bool
Eq, Int -> SatResult -> ShowS
[SatResult] -> ShowS
SatResult -> String
(Int -> SatResult -> ShowS)
-> (SatResult -> String)
-> ([SatResult] -> ShowS)
-> Show SatResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SatResult] -> ShowS
$cshowList :: [SatResult] -> ShowS
show :: SatResult -> String
$cshow :: SatResult -> String
showsPrec :: Int -> SatResult -> ShowS
$cshowsPrec :: Int -> SatResult -> ShowS
Show)

-- | Compute a scriptinput which satisfies this miniscript
satisfy :: ChainState -> SatisfactionContext -> Miniscript -> Either SatisfactionError Script
satisfy :: ChainState
-> SatisfactionContext
-> Miniscript
-> Either SatisfactionError Script
satisfy chainState :: ChainState
chainState sc :: SatisfactionContext
sc = (SatScript -> Script)
-> Either SatisfactionError SatScript
-> Either SatisfactionError Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ScriptOp] -> Script
Script ([ScriptOp] -> Script)
-> (SatScript -> [ScriptOp]) -> SatScript -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatScript -> [ScriptOp]
satScript) (Either SatisfactionError SatScript
 -> Either SatisfactionError Script)
-> (Miniscript -> Either SatisfactionError SatScript)
-> Miniscript
-> Either SatisfactionError Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatResult -> Either SatisfactionError SatScript
sat (SatResult -> Either SatisfactionError SatScript)
-> (Miniscript -> SatResult)
-> Miniscript
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader (Map Text Miniscript) SatResult
-> Map Text Miniscript -> SatResult
forall r a. Reader r a -> r -> a
`runReader` Map Text Miniscript
forall a. Monoid a => a
mempty) (Reader (Map Text Miniscript) SatResult -> SatResult)
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Miniscript
-> SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' ChainState
chainState SatisfactionContext
sc

satisfy' :: ChainState -> SatisfactionContext -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfy' :: ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' chainState :: ChainState
chainState sc :: SatisfactionContext
sc = \case
    Boolean False ->
        SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
forall a. Monoid a => a
mempty
                }
    Boolean True ->
        SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
forall a. Monoid a => a
mempty
                , dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    Key vk :: Value KeyDescriptor
vk -> (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey KeyDescriptor -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => KeyDescriptor -> m SatResult
satisfyKey Value KeyDescriptor
vk
      where
        satisfyKey :: KeyDescriptor -> m SatResult
satisfyKey k :: KeyDescriptor
k
            | Just pk :: PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just s :: Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [Signature -> ScriptOp
pushSig Signature
s]) (Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0])
            | Bool
otherwise =
                SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                        { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0]
                        }
    KeyH vk :: Value KeyDescriptor
vk -> (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey KeyDescriptor -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => KeyDescriptor -> m SatResult
satisfyKeyH Value KeyDescriptor
vk
      where
        satisfyKeyH :: KeyDescriptor -> m SatResult
satisfyKeyH k :: KeyDescriptor
k
            | Just pk :: PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just s :: Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals
                    ([ScriptOp] -> SatScript
fromScript [Signature -> ScriptOp
pushSig Signature
s, PubKeyI -> ScriptOp
pushKey PubKeyI
pk])
                    ([ScriptOp] -> SatScript
fromScript [ScriptOp
OP_0, PubKeyI -> ScriptOp
pushKey PubKeyI
pk])
            | Just pk :: PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k =
                SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                        { sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> SatScript
fromScript [ScriptOp
OP_0, PubKeyI -> ScriptOp
pushKey PubKeyI
pk]
                        }
            | Bool
otherwise = SatisfactionError -> m SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> m SatResult)
-> SatisfactionError -> m SatResult
forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> SatisfactionError
AbstractKey KeyDescriptor
k
    Sha256 h :: Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Ripemd160 h :: Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash256 h :: Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash160 h :: Value ByteString
h -> (Miniscript -> Either SatisfactionError ByteString)
-> (ByteString -> Reader (Map Text Miniscript) SatResult)
-> Value ByteString
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError ByteString
guardBytes ByteString -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    AndOr x :: Miniscript
x y :: Miniscript
y z :: Miniscript
z -> SatResult -> SatResult -> SatResult -> SatResult
satAndOr (SatResult -> SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT
     (Map Text Miniscript)
     Identity
     (SatResult -> SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT
  (Map Text Miniscript)
  Identity
  (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satAndOr :: SatResult -> SatResult -> SatResult -> SatResult
satAndOr sx :: SatResult
sx sy :: SatResult
sy sz :: SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    AndV x :: Miniscript
x y :: Miniscript
y -> SatResult -> SatResult -> SatResult
satAndV (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y
      where
        satAndV :: SatResult -> SatResult -> SatResult
satAndV sx :: SatResult
sx sy :: SatResult
sy =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty
                }
    AndB x :: Miniscript
x y :: Miniscript
y -> SatResult -> SatResult -> SatResult
satAndB (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y
      where
        satAndB :: SatResult -> SatResult -> SatResult
satAndB sx :: SatResult
sx sy :: SatResult
sy =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sy SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sy SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrB x :: Miniscript
x z :: Miniscript
z -> SatResult -> SatResult -> SatResult
satOrB (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrB :: SatResult -> SatResult -> SatResult
satOrB sx :: SatResult
sx sz :: SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrC x :: Miniscript
x z :: Miniscript
z -> SatResult -> SatResult -> SatResult
satOrC (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrC :: SatResult -> SatResult -> SatResult
satOrC sx :: SatResult
sx sz :: SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    OrD x :: Miniscript
x z :: Miniscript
z -> SatResult -> SatResult -> SatResult
satOrD (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrD :: SatResult -> SatResult -> SatResult
satOrD sx :: SatResult
sx sz :: SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
sat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                , dsat :: Either SatisfactionError SatScript
dsat = (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> (SatResult -> Either SatisfactionError SatScript)
-> SatResult
-> Either SatisfactionError SatScript
forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                }
    OrI x :: Miniscript
x z :: Miniscript
z -> SatResult -> SatResult -> SatResult
satOrI (SatResult -> SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x ReaderT (Map Text Miniscript) Identity (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
z
      where
        satOrI :: SatResult -> SatResult -> SatResult
satOrI sx :: SatResult
sx sz :: SatResult
sz =
            SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                { sat :: Either SatisfactionError SatScript
sat =
                    let satA :: Either SatisfactionError SatScript
satA = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                        satB :: Either SatisfactionError SatScript
satB = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sz
                     in Either SatisfactionError SatScript
satA Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` Either SatisfactionError SatScript
satB
                , dsat :: Either SatisfactionError SatScript
dsat =
                    let dsatA :: Either SatisfactionError SatScript
dsatA = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                        dsatB :: Either SatisfactionError SatScript
dsatB = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz
                     in Either SatisfactionError SatScript
dsatA Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` Either SatisfactionError SatScript
dsatB
                }
    Thresh vk :: Value Int
vk x :: Miniscript
x xs :: [Miniscript]
xs -> (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber Int -> Reader (Map Text Miniscript) SatResult
satisfyThresh Value Int
vk
      where
        satisfyThresh :: Int -> Reader (Map Text Miniscript) SatResult
satisfyThresh k :: Int
k = do
            [SatResult]
sxs <- (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> [Miniscript]
-> ReaderT (Map Text Miniscript) Identity [SatResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext (Miniscript
x Miniscript -> [Miniscript] -> [Miniscript]
forall a. a -> [a] -> [a]
: [Miniscript]
xs)
            SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult
                    { sat :: Either SatisfactionError SatScript
sat = [SatScript] -> Either SatisfactionError SatScript
getSat ([SatScript] -> Either SatisfactionError SatScript)
-> [SatScript] -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [SatResult] -> [SatScript]
satResults Int
k [SatResult]
sxs
                    , dsat :: Either SatisfactionError SatScript
dsat = [SatScript] -> Either SatisfactionError SatScript
getSat ([SatScript] -> Either SatisfactionError SatScript)
-> [SatScript] -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [SatResult] -> [SatScript]
dsatResults Int
k [SatResult]
sxs
                    }

        getSat :: [SatScript] -> Either SatisfactionError SatScript
getSat = (Either SatisfactionError SatScript
 -> SatScript -> Either SatisfactionError SatScript)
-> Either SatisfactionError SatScript
-> [SatScript]
-> Either SatisfactionError SatScript
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either SatisfactionError SatScript
-> SatScript -> Either SatisfactionError SatScript
forall a. Either a SatScript -> SatScript -> Either a SatScript
accumResult (SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible)
        satResults :: Int -> [SatResult] -> [SatScript]
satResults k :: Int
k sxs :: [SatResult]
sxs = [Either SatisfactionError SatScript] -> [SatScript]
forall a b. [Either a b] -> [b]
rights ([Either SatisfactionError SatScript] -> [SatScript])
-> [Either SatisfactionError SatScript] -> [SatScript]
forall a b. (a -> b) -> a -> b
$ ([SatScript] -> SatScript)
-> Either SatisfactionError [SatScript]
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SatScript] -> SatScript
forall a. Monoid a => [a] -> a
mconcat (Either SatisfactionError [SatScript]
 -> Either SatisfactionError SatScript)
-> ([Either SatisfactionError SatScript]
    -> Either SatisfactionError [SatScript])
-> [Either SatisfactionError SatScript]
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either SatisfactionError SatScript]
-> Either SatisfactionError [SatScript]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either SatisfactionError SatScript]
 -> Either SatisfactionError SatScript)
-> [[Either SatisfactionError SatScript]]
-> [Either SatisfactionError SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (SatResult -> Either SatisfactionError SatScript)
-> (SatResult -> Either SatisfactionError SatScript)
-> [SatResult]
-> [[Either SatisfactionError SatScript]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k SatResult -> Either SatisfactionError SatScript
sat SatResult -> Either SatisfactionError SatScript
dsat ([SatResult] -> [SatResult]
forall a. [a] -> [a]
reverse [SatResult]
sxs)
        dsatResults :: Int -> [SatResult] -> [SatScript]
dsatResults k :: Int
k sxs :: [SatResult]
sxs = [Either SatisfactionError SatScript] -> [SatScript]
forall a b. [Either a b] -> [b]
rights ([Either SatisfactionError SatScript] -> [SatScript])
-> [Either SatisfactionError SatScript] -> [SatScript]
forall a b. (a -> b) -> a -> b
$ ([SatScript] -> SatScript)
-> Either SatisfactionError [SatScript]
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SatScript] -> SatScript
forall a. Monoid a => [a] -> a
mconcat (Either SatisfactionError [SatScript]
 -> Either SatisfactionError SatScript)
-> ([Either SatisfactionError SatScript]
    -> Either SatisfactionError [SatScript])
-> [Either SatisfactionError SatScript]
-> Either SatisfactionError SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either SatisfactionError SatScript]
-> Either SatisfactionError [SatScript]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either SatisfactionError SatScript]
 -> Either SatisfactionError SatScript)
-> [[Either SatisfactionError SatScript]]
-> [Either SatisfactionError SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (SatResult -> Either SatisfactionError SatScript)
-> (SatResult -> Either SatisfactionError SatScript)
-> [SatResult]
-> [[Either SatisfactionError SatScript]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
chooseComplement Int
k SatResult -> Either SatisfactionError SatScript
sat SatResult -> Either SatisfactionError SatScript
dsat ([SatResult] -> [SatResult]
forall a. [a] -> [a]
reverse [SatResult]
sxs)

        chooseComplement :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
chooseComplement k :: Int
k f :: a -> b
f g :: a -> b
g zs :: [a]
zs = (Int -> [[b]]) -> [Int] -> [[b]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\k' :: Int
k' -> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k' a -> b
f a -> b
g [a]
zs) ([Int] -> [[b]]) -> [Int] -> [[b]]
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
k) [0 .. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
zs]

        accumResult :: Either a SatScript -> SatScript -> Either a SatScript
accumResult z :: Either a SatScript
z@(Right s0 :: SatScript
s0) s1 :: SatScript
s1
            | SatScript -> Int
satWeight SatScript
s1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s0 = SatScript -> Either a SatScript
forall a b. b -> Either a b
Right SatScript
s1
            | Bool
otherwise = Either a SatScript
z
        accumResult Left{} s :: SatScript
s = SatScript -> Either a SatScript
forall a b. b -> Either a b
Right SatScript
s
    Multi vk :: Value Int
vk vks :: [Value KeyDescriptor]
vks -> (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber Int -> Reader (Map Text Miniscript) SatResult
stageSatisfyMulti Value Int
vk
      where
        stageSatisfyMulti :: Int -> Reader (Map Text Miniscript) SatResult
stageSatisfyMulti k :: Int
k = ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys (Int -> [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *).
Monad m =>
Int -> [KeyDescriptor] -> m SatResult
satisfyMulti Int
k) [Value KeyDescriptor]
vks [KeyDescriptor]
forall a. Monoid a => a
mempty

        satisfyMulti :: Int -> [KeyDescriptor] -> m SatResult
satisfyMulti k :: Int
k ks :: [KeyDescriptor]
ks
            | Just pks :: [PubKeyI]
pks <- (KeyDescriptor -> Maybe PubKeyI)
-> [KeyDescriptor] -> Maybe [PubKeyI]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KeyDescriptor -> Maybe PubKeyI
keyDescPubKey [KeyDescriptor]
ks
              , [Signature]
ss <- (PubKeyI -> Maybe Signature) -> [PubKeyI] -> [Signature]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PubKeyI -> SatisfactionContext -> Maybe Signature
`lookupSignature` SatisfactionContext
sc) [PubKeyI]
pks
              , Just result :: SatScript
result <- (Maybe SatScript -> SatScript -> Maybe SatScript)
-> Maybe SatScript -> [SatScript] -> Maybe SatScript
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe SatScript -> SatScript -> Maybe SatScript
accumMS Maybe SatScript
forall a. Maybe a
Nothing ([SatScript] -> Maybe SatScript) -> [SatScript] -> Maybe SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [Signature] -> [SatScript]
bestSigs Int
k [Signature]
ss =
                SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals SatScript
result (Int -> SatScript
dsatScript Int
k)
            | Bool
otherwise = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor]
ks, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> SatScript
dsatScript Int
k}

        bestSigs :: Int -> [Signature] -> [SatScript]
bestSigs k :: Int
k ss :: [Signature]
ss = [ScriptOp] -> SatScript
fromScript ([ScriptOp] -> SatScript)
-> ([Maybe ScriptOp] -> [ScriptOp])
-> [Maybe ScriptOp]
-> SatScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptOp
OP_0 ScriptOp -> [ScriptOp] -> [ScriptOp]
forall a. a -> [a] -> [a]
:) ([ScriptOp] -> [ScriptOp])
-> ([Maybe ScriptOp] -> [ScriptOp])
-> [Maybe ScriptOp]
-> [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ScriptOp] -> [ScriptOp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ScriptOp] -> SatScript)
-> [[Maybe ScriptOp]] -> [SatScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (Signature -> Maybe ScriptOp)
-> (Signature -> Maybe ScriptOp)
-> [Signature]
-> [[Maybe ScriptOp]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k (ScriptOp -> Maybe ScriptOp
forall a. a -> Maybe a
Just (ScriptOp -> Maybe ScriptOp)
-> (Signature -> ScriptOp) -> Signature -> Maybe ScriptOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> ScriptOp
pushSig) (Maybe ScriptOp -> Signature -> Maybe ScriptOp
forall a b. a -> b -> a
const Maybe ScriptOp
forall a. Maybe a
Nothing) [Signature]
ss

        accumMS :: Maybe SatScript -> SatScript -> Maybe SatScript
accumMS Nothing s :: SatScript
s = SatScript -> Maybe SatScript
forall a. a -> Maybe a
Just SatScript
s
        accumMS x :: Maybe SatScript
x@(Just s1 :: SatScript
s1) s2 :: SatScript
s2
            | SatScript -> Int
satWeight SatScript
s2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s1 = SatScript -> Maybe SatScript
forall a. a -> Maybe a
Just SatScript
s2
            | Bool
otherwise = Maybe SatScript
x

        withKeys :: ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys f :: [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f (x :: Value KeyDescriptor
x : xs :: [Value KeyDescriptor]
xs) ks :: [KeyDescriptor]
ks = (Miniscript -> Either SatisfactionError KeyDescriptor)
-> (KeyDescriptor -> Reader (Map Text Miniscript) SatResult)
-> Value KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError KeyDescriptor
guardKey (([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [Value KeyDescriptor]
xs ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> (KeyDescriptor -> [KeyDescriptor])
-> KeyDescriptor
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyDescriptor -> [KeyDescriptor] -> [KeyDescriptor]
forall a. a -> [a] -> [a]
: [KeyDescriptor]
ks)) Value KeyDescriptor
x
        withKeys f :: [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [] ks :: [KeyDescriptor]
ks = [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [KeyDescriptor]
ks

        dsatScript :: Int -> SatScript
dsatScript k :: Int
k = Int -> [ScriptOp] -> SatScript
SatScript (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ([ScriptOp] -> SatScript) -> [ScriptOp] -> SatScript
forall a b. (a -> b) -> a -> b
$ Int -> ScriptOp -> [ScriptOp]
forall a. Int -> a -> [a]
replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ScriptOp
OP_0
    AnnA x :: Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnS x :: Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnC x :: Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnD x :: Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise s :: SatResult
s =
            SatResult
s
                { sat :: Either SatisfactionError SatScript
sat = (SatScript -> SatScript -> SatScript
forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_1]) (SatScript -> SatScript)
-> Either SatisfactionError SatScript
-> Either SatisfactionError SatScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
s
                , dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0]
                }
    AnnV x :: Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise s :: SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    AnnJ x :: Miniscript
x -> SatResult -> SatResult
revise (SatResult -> SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
      where
        revise :: SatResult -> SatResult
revise s :: SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return (SatScript -> Either SatisfactionError SatScript)
-> SatScript -> Either SatisfactionError SatScript
forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript 1 [ScriptOp
OP_0]}
    AnnN x :: Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    Number{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Bytes{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    KeyDesc{} -> SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Older va :: Value Int
va -> (Int -> Reader (Map Text Miniscript) SatResult)
-> Maybe Int
-> ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Reader (Map Text Miniscript) SatResult
onAge (ChainState -> Maybe Int
utxoAge ChainState
chainState) ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
-> (Maybe SatResult -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (SatResult -> Reader (Map Text Miniscript) SatResult)
-> Maybe SatResult
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onAge :: Int -> Reader (Map Text Miniscript) SatResult
onAge age :: Int
age = (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber (SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> Reader (Map Text Miniscript) SatResult)
-> (Int -> SatResult)
-> Int
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> SatResult
forall a. Ord a => a -> a -> SatResult
satisfyOlder Int
age) Value Int
va
        satisfyOlder :: a -> a -> SatResult
satisfyOlder age :: a
age reqAge :: a
reqAge
            | a
age a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
reqAge = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty}
    After vh :: Value Int
vh -> (Int -> Reader (Map Text Miniscript) SatResult)
-> Maybe Int
-> ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Reader (Map Text Miniscript) SatResult
onHeight (ChainState -> Maybe Int
blockHeight ChainState
chainState) ReaderT (Map Text Miniscript) Identity (Maybe SatResult)
-> (Maybe SatResult -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (SatResult -> Reader (Map Text Miniscript) SatResult)
-> Maybe SatResult
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onHeight :: Int -> Reader (Map Text Miniscript) SatResult
onHeight h :: Int
h = (Miniscript -> Either SatisfactionError Int)
-> (Int -> Reader (Map Text Miniscript) SatResult)
-> Value Int
-> Reader (Map Text Miniscript) SatResult
forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError Int
guardNumber (SatResult -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> Reader (Map Text Miniscript) SatResult)
-> (Int -> SatResult)
-> Int
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> SatResult
forall a. Ord a => a -> a -> SatResult
satisfyAfter Int
h) Value Int
vh
        satisfyAfter :: a -> a -> SatResult
satisfyAfter height :: a
height reqHeight :: a
reqHeight
            | a
height a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
reqHeight = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult :: Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult{sat :: Either SatisfactionError SatScript
sat = SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = SatScript -> Either SatisfactionError SatScript
forall (m :: * -> *) a. Monad m => a -> m a
return SatScript
forall a. Monoid a => a
mempty}
    Var name :: Text
name -> Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
name Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext
    Let name :: Text
name x :: Miniscript
x b :: Miniscript
b -> (Map Text Miniscript -> Map Text Miniscript)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Text -> Miniscript -> Map Text Miniscript -> Map Text Miniscript
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Miniscript
x) (Reader (Map Text Miniscript) SatResult
 -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
-> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
b
  where
    satisfyInContext :: Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext = ChainState
-> SatisfactionContext
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
satisfy' ChainState
chainState SatisfactionContext
sc

    -- it is still possible to dissatisfy when we do not know the preimage since
    -- we can easily detect that some value is _not_ it
    satisfyHash :: ByteString -> m SatResult
satisfyHash h :: ByteString
h
        | Just p :: ByteString
p <- ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage ByteString
h SatisfactionContext
sc =
            SatScript -> SatScript -> m SatResult
forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData ByteString
p]) ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp) -> ByteString -> ScriptOp
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
otherValue ByteString
p])
        | Bool
otherwise = SatisfactionError -> m SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> m SatResult)
-> SatisfactionError -> m SatResult
forall a b. (a -> b) -> a -> b
$ ByteString -> SatisfactionError
MissingPreimage ByteString
h

pushSig :: Signature -> ScriptOp
pushSig :: Signature -> ScriptOp
pushSig (Signature s :: Sig
s sh :: SigHash
sh) = ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp)
-> (TxSignature -> ByteString) -> TxSignature -> ScriptOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSignature -> ByteString
encodeTxSig (TxSignature -> ScriptOp) -> TxSignature -> ScriptOp
forall a b. (a -> b) -> a -> b
$ Sig -> SigHash -> TxSignature
TxSignature Sig
s SigHash
sh

pushKey :: PubKeyI -> ScriptOp
pushKey :: PubKeyI -> ScriptOp
pushKey (PubKeyI k :: PubKey
k c :: Bool
c) = ByteString -> ScriptOp
opPushData (ByteString -> ScriptOp) -> ByteString -> ScriptOp
forall a b. (a -> b) -> a -> b
$ Bool -> PubKey -> ByteString
exportPubKey Bool
c PubKey
k

-- TODO fingerprinting implications
otherValue :: ByteString -> ByteString
otherValue :: ByteString -> ByteString
otherValue bs :: ByteString
bs
    | ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
zero32 = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate 32 0x1
    | Bool
otherwise = ByteString
zero32

zero32 :: ByteString
zero32 :: ByteString
zero32 = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate 32 0x0

withLiteral ::
    (Miniscript -> Either SatisfactionError a) ->
    (a -> Reader (Map Text Miniscript) SatResult) ->
    Value a ->
    Reader (Map Text Miniscript) SatResult
withLiteral :: (Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral g :: Miniscript -> Either SatisfactionError a
g f :: a -> Reader (Map Text Miniscript) SatResult
f = \case
    Lit n :: a
n -> a -> Reader (Map Text Miniscript) SatResult
f a
n
    Variable n :: Text
n -> Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
n ((Miniscript -> Reader (Map Text Miniscript) SatResult)
 -> Reader (Map Text Miniscript) SatResult)
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ (SatisfactionError -> Reader (Map Text Miniscript) SatResult)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Either SatisfactionError a
-> Reader (Map Text Miniscript) SatResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr a -> Reader (Map Text Miniscript) SatResult
f (Either SatisfactionError a
 -> Reader (Map Text Miniscript) SatResult)
-> (Miniscript -> Either SatisfactionError a)
-> Miniscript
-> Reader (Map Text Miniscript) SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Miniscript -> Either SatisfactionError a
g

requiredValue ::
    Text ->
    (Miniscript -> Reader (Map Text Miniscript) SatResult) ->
    Reader (Map Text Miniscript) SatResult
requiredValue :: Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue name :: Text
name f :: Miniscript -> Reader (Map Text Miniscript) SatResult
f = (Map Text Miniscript -> Maybe Miniscript)
-> ReaderT (Map Text Miniscript) Identity (Maybe Miniscript)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (Text -> Map Text Miniscript -> Maybe Miniscript
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name) ReaderT (Map Text Miniscript) Identity (Maybe Miniscript)
-> (Maybe Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reader (Map Text Miniscript) SatResult
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Maybe Miniscript
-> Reader (Map Text Miniscript) SatResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr (SatisfactionError -> Reader (Map Text Miniscript) SatResult)
-> SatisfactionError -> Reader (Map Text Miniscript) SatResult
forall a b. (a -> b) -> a -> b
$ Text -> SatisfactionError
FreeVariable Text
name) Miniscript -> Reader (Map Text Miniscript) SatResult
f

guardNumber :: Miniscript -> Either SatisfactionError Int
guardNumber :: Miniscript -> Either SatisfactionError Int
guardNumber (Number n :: Int
n) = Int -> Either SatisfactionError Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
guardNumber e :: Miniscript
e = SatisfactionError -> Either SatisfactionError Int
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError Int)
-> SatisfactionError -> Either SatisfactionError Int
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError "number" Miniscript
e

guardKey :: Miniscript -> Either SatisfactionError KeyDescriptor
guardKey :: Miniscript -> Either SatisfactionError KeyDescriptor
guardKey (KeyDesc k :: KeyDescriptor
k) = KeyDescriptor -> Either SatisfactionError KeyDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return KeyDescriptor
k
guardKey e :: Miniscript
e = SatisfactionError -> Either SatisfactionError KeyDescriptor
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError KeyDescriptor)
-> SatisfactionError -> Either SatisfactionError KeyDescriptor
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError "key" Miniscript
e

guardBytes :: Miniscript -> Either SatisfactionError ByteString
guardBytes :: Miniscript -> Either SatisfactionError ByteString
guardBytes (Bytes b :: ByteString
b) = ByteString -> Either SatisfactionError ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b
guardBytes e :: Miniscript
e = SatisfactionError -> Either SatisfactionError ByteString
forall a b. a -> Either a b
Left (SatisfactionError -> Either SatisfactionError ByteString)
-> SatisfactionError -> Either SatisfactionError ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError "bytes" Miniscript
e

satVals :: Monad m => SatScript -> SatScript -> m SatResult
satVals :: SatScript -> SatScript -> m SatResult
satVals x :: SatScript
x y :: SatScript
y = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> m SatResult) -> SatResult -> m SatResult
forall a b. (a -> b) -> a -> b
$ Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult (SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
x) (SatScript -> Either SatisfactionError SatScript
forall a b. b -> Either a b
Right SatScript
y)

satErr :: Monad m => SatisfactionError -> m SatResult
satErr :: SatisfactionError -> m SatResult
satErr = SatResult -> m SatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (SatResult -> m SatResult)
-> (SatisfactionError -> SatResult)
-> SatisfactionError
-> m SatResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either SatisfactionError SatScript
-> Either SatisfactionError SatScript -> SatResult
SatResult (Either SatisfactionError SatScript
 -> Either SatisfactionError SatScript -> SatResult)
-> (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError
-> Either SatisfactionError SatScript
-> SatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left (SatisfactionError
 -> Either SatisfactionError SatScript -> SatResult)
-> (SatisfactionError -> Either SatisfactionError SatScript)
-> SatisfactionError
-> SatResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SatisfactionError -> Either SatisfactionError SatScript
forall a b. a -> Either a b
Left)

satConcat :: (Applicative f, Monoid m) => (a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat :: (a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat f :: a -> f m
f x :: a
x g :: b -> f m
g y :: b
y = m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) (m -> m -> m) -> f m -> f (m -> m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f m
f a
x f (m -> m) -> f m -> f m
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f m
g b
y

satOr :: Either e SatScript -> Either e SatScript -> Either e SatScript
satOr :: Either e SatScript -> Either e SatScript -> Either e SatScript
satOr xA :: Either e SatScript
xA@(Right sA :: SatScript
sA) xB :: Either e SatScript
xB@(Right sB :: SatScript
sB)
    | SatScript -> Int
satWeight SatScript
sA Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= SatScript -> Int
satWeight SatScript
sB = Either e SatScript
xA
    | Bool
otherwise = Either e SatScript
xB
satOr sA :: Either e SatScript
sA sB :: Either e SatScript
sB = Either e SatScript
sA Either e SatScript -> Either e SatScript -> Either e SatScript
forall a. Semigroup a => a -> a -> a
<> Either e SatScript
sB

choose :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose 0 _ onExclude :: a -> b
onExclude xs :: [a]
xs = [a -> b
onExclude (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs]
choose k :: Int
k onInclude :: a -> b
onInclude _ xs :: [a]
xs
    | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = [a -> b
onInclude (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs]
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = []
choose k :: Int
k onInclude :: a -> b
onInclude onExclude :: a -> b
onExclude (x :: a
x : xs :: [a]
xs) =
    ((a -> b) -> [b] -> [b]
forall a. (a -> a) -> [a] -> [a]
handleX a -> b
onInclude ([b] -> [b]) -> [[b]] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
-1) a -> b
onInclude a -> b
onExclude [a]
xs)
        [[b]] -> [[b]] -> [[b]]
forall a. Semigroup a => a -> a -> a
<> ((a -> b) -> [b] -> [b]
forall a. (a -> a) -> [a] -> [a]
handleX a -> b
onExclude ([b] -> [b]) -> [[b]] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k a -> b
onInclude a -> b
onExclude [a]
xs)
  where
    handleX :: (a -> a) -> [a] -> [a]
handleX f :: a -> a
f zs :: [a]
zs = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs
choose _ _ _ [] = []