{-# 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.Syntax (
    KeyDescriptor,
    keyDescPubKey,
 )

data Signature = Signature
    { Signature -> Sig
sig :: !Sig
    , Signature -> SigHash
sigHash :: !SigHash
    }
    deriving (Signature -> Signature -> Bool
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
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
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
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 = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PubKeyI -> ByteString
toOrdered forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdPubKeyI -> PubKeyI
unOrdPubKeyI
      where
        toOrdered :: PubKeyI -> ByteString
toOrdered (PubKeyI PubKey
pk 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
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
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
    SatisfactionContext
icA <> :: SatisfactionContext -> SatisfactionContext -> SatisfactionContext
<> SatisfactionContext
icB =
        SatisfactionContext
            { signatures :: Map OrdPubKeyI Signature
signatures = SatisfactionContext -> Map OrdPubKeyI Signature
signatures SatisfactionContext
icA 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 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 forall a. Monoid a => a
mempty 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 PubKeyI
pk = (Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
`SatisfactionContext` forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ByteString
h = Map OrdPubKeyI Signature
-> Map ByteString ByteString -> SatisfactionContext
SatisfactionContext forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [(ByteString, ByteString)]
preimages [(PubKeyI, Signature)]
sigs =
    SatisfactionContext
        { signatures :: Map OrdPubKeyI Signature
signatures = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PubKeyI -> OrdPubKeyI
OrdPubKeyI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PubKeyI, Signature)]
sigs
        , hashPreimages :: Map ByteString ByteString
hashPreimages = 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 PubKeyI
pk = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PubKeyI -> OrdPubKeyI
OrdPubKeyI PubKeyI
pk) 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 ByteString
h = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
h 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
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
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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing

data SatisfactionError
    = MissingSignature [KeyDescriptor]
    | MissingPreimage ByteString
    | FreeVariable Text
    | TypeError Text Miniscript
    | Impossible
    | AbstractKey KeyDescriptor
    deriving (SatisfactionError -> SatisfactionError -> Bool
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
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
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
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 Int
n0 [ScriptOp]
s0 <> :: SatScript -> SatScript -> SatScript
<> SatScript Int
n1 [ScriptOp]
s1 = Int -> [ScriptOp] -> SatScript
SatScript (Int
n0 forall a. Num a => a -> a -> a
+ Int
n1) ([ScriptOp]
s0 forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
s1)

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

fromScript :: [ScriptOp] -> SatScript
fromScript :: [ScriptOp] -> SatScript
fromScript [ScriptOp]
s = Int -> [ScriptOp] -> SatScript
SatScript (ByteString -> Int
BS.length forall a b. (a -> b) -> a -> b
$ 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
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
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 SatisfactionContext
sc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ScriptOp] -> Script
Script forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatScript -> [ScriptOp]
satScript) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatResult -> Either SatisfactionError SatScript
sat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r a. Reader r a -> r -> a
`runReader` forall a. Monoid a => a
mempty) 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 SatisfactionContext
sc = \case
    Boolean Bool
False ->
        forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = forall a b. a -> Either a b
Left SatisfactionError
Impossible
                , dsat :: Either SatisfactionError SatScript
dsat = forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty
                }
    Boolean Bool
True ->
        forall (m :: * -> *) a. Monad m => a -> m a
return
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty
                , dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    Key Value KeyDescriptor
vk -> 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 forall {m :: * -> *}. Monad m => KeyDescriptor -> m SatResult
satisfyKey Value KeyDescriptor
vk
      where
        satisfyKey :: KeyDescriptor -> m SatResult
satisfyKey KeyDescriptor
k
            | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [Signature -> ScriptOp
pushSig Signature
s]) (Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0])
            | Bool
otherwise =
                forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult
                        { sat :: Either SatisfactionError SatScript
sat = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]
                        }
    KeyH Value KeyDescriptor
vk -> 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 forall {m :: * -> *}. Monad m => KeyDescriptor -> m SatResult
satisfyKeyH Value KeyDescriptor
vk
      where
        satisfyKeyH :: KeyDescriptor -> m SatResult
satisfyKeyH KeyDescriptor
k
            | Just PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k
              , Just Signature
s <- PubKeyI -> SatisfactionContext -> Maybe Signature
lookupSignature PubKeyI
pk SatisfactionContext
sc =
                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 PubKeyI
pk <- KeyDescriptor -> Maybe PubKeyI
keyDescPubKey KeyDescriptor
k =
                forall (m :: * -> *) a. Monad m => a -> m a
return
                    SatResult
                        { sat :: Either SatisfactionError SatScript
sat = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [KeyDescriptor] -> SatisfactionError
MissingSignature [KeyDescriptor
k]
                        , dsat :: Either SatisfactionError SatScript
dsat = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> SatScript
fromScript [ScriptOp
OP_0, PubKeyI -> ScriptOp
pushKey PubKeyI
pk]
                        }
            | Bool
otherwise = forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> SatisfactionError
AbstractKey KeyDescriptor
k
    Sha256 Value ByteString
h -> 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 forall {m :: * -> *}. Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Ripemd160 Value ByteString
h -> 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 forall {m :: * -> *}. Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash256 Value ByteString
h -> 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 forall {m :: * -> *}. Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    Hash160 Value ByteString
h -> 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 forall {m :: * -> *}. Monad m => ByteString -> m SatResult
satisfyHash Value ByteString
h
    AndOr Miniscript
x Miniscript
y Miniscript
z -> SatResult -> SatResult -> SatResult -> SatResult
satAndOr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
y 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 SatResult
sx SatResult
sy SatResult
sz =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = 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 forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` 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 = 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 Miniscript
x Miniscript
y -> SatResult -> SatResult -> SatResult
satAndV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sy =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
                }
    AndB Miniscript
x Miniscript
y -> SatResult -> SatResult -> SatResult
satAndB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sy =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = 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 = 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 Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sz =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = 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 forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` 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 = 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 Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sz =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` 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 = forall a b. a -> Either a b
Left SatisfactionError
Impossible
                }
    OrD Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sz =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat = SatResult -> Either SatisfactionError SatScript
sat SatResult
sx forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` 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 = 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 Miniscript
x Miniscript
z -> SatResult -> SatResult -> SatResult
satOrI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x 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 SatResult
sx SatResult
sz =
            SatResult
                { sat :: Either SatisfactionError SatScript
sat =
                    let satA :: Either SatisfactionError SatScript
satA = (forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sx
                        satB :: Either SatisfactionError SatScript
satB = (forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
sz
                     in Either SatisfactionError SatScript
satA 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 = (forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sx
                        dsatB :: Either SatisfactionError SatScript
dsatB = (forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
dsat SatResult
sz
                     in Either SatisfactionError SatScript
dsatA forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
`satOr` Either SatisfactionError SatScript
dsatB
                }
    Thresh Value Int
vk Miniscript
x [Miniscript]
xs -> 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 Int
k = do
            [SatResult]
sxs <- 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 forall a. a -> [a] -> [a]
: [Miniscript]
xs)
            forall (m :: * -> *) a. Monad m => a -> m a
return
                SatResult
                    { sat :: Either SatisfactionError SatScript
sat = [SatScript] -> Either SatisfactionError SatScript
getSat 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 forall a b. (a -> b) -> a -> b
$ Int -> [SatResult] -> [SatScript]
dsatResults Int
k [SatResult]
sxs
                    }

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

        chooseComplement :: Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
chooseComplement Int
k a -> b
f a -> b
g [a]
zs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
k' -> forall a b. Int -> (a -> b) -> (a -> b) -> [a] -> [[b]]
choose Int
k' a -> b
f a -> b
g [a]
zs) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Int
k) [Int
0 .. 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 SatScript
s0) SatScript
s1
            | SatScript -> Int
satWeight SatScript
s1 forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s0 = forall a b. b -> Either a b
Right SatScript
s1
            | Bool
otherwise = Either a SatScript
z
        accumResult Left{} SatScript
s = forall a b. b -> Either a b
Right SatScript
s
    Multi Value Int
vk [Value KeyDescriptor]
vks -> 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 Int
k = ([KeyDescriptor] -> Reader (Map Text Miniscript) SatResult)
-> [Value KeyDescriptor]
-> [KeyDescriptor]
-> Reader (Map Text Miniscript) SatResult
withKeys (forall {m :: * -> *}.
Monad m =>
Int -> [KeyDescriptor] -> m SatResult
satisfyMulti Int
k) [Value KeyDescriptor]
vks forall a. Monoid a => a
mempty

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

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

        accumMS :: Maybe SatScript -> SatScript -> Maybe SatScript
accumMS Maybe SatScript
Nothing SatScript
s = forall a. a -> Maybe a
Just SatScript
s
        accumMS x :: Maybe SatScript
x@(Just SatScript
s1) SatScript
s2
            | SatScript -> Int
satWeight SatScript
s2 forall a. Ord a => a -> a -> Bool
< SatScript -> Int
satWeight SatScript
s1 = 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 [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f (Value KeyDescriptor
x : [Value KeyDescriptor]
xs) [KeyDescriptor]
ks = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [KeyDescriptor]
ks)) Value KeyDescriptor
x
        withKeys [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [] [KeyDescriptor]
ks = [KeyDescriptor] -> Reader (Map Text Miniscript) SatResult
f [KeyDescriptor]
ks

        dsatScript :: Int -> SatScript
dsatScript Int
k = Int -> [ScriptOp] -> SatScript
SatScript (Int
k forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Int
k forall a. Num a => a -> a -> a
+ Int
1) ScriptOp
OP_0
    AnnA Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnS Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnC Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    AnnD Miniscript
x -> SatResult -> SatResult
revise 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 SatResult
s =
            SatResult
s
                { sat :: Either SatisfactionError SatScript
sat = (forall a. Semigroup a => a -> a -> a
<> Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_1]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatResult -> Either SatisfactionError SatScript
sat SatResult
s
                , dsat :: Either SatisfactionError SatScript
dsat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]
                }
    AnnV Miniscript
x -> SatResult -> SatResult
revise 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 SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    AnnJ Miniscript
x -> SatResult -> SatResult
revise 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 SatResult
s = SatResult
s{dsat :: Either SatisfactionError SatScript
dsat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> [ScriptOp] -> SatScript
SatScript Int
1 [ScriptOp
OP_0]}
    AnnN Miniscript
x -> Miniscript -> Reader (Map Text Miniscript) SatResult
satisfyInContext Miniscript
x
    Number{} -> forall (m :: * -> *) a. Monad m => a -> m a
return SatResult{sat :: Either SatisfactionError SatScript
sat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Bytes{} -> forall (m :: * -> *) a. Monad m => a -> m a
return SatResult{sat :: Either SatisfactionError SatScript
sat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    KeyDesc{} -> forall (m :: * -> *) a. Monad m => a -> m a
return SatResult{sat :: Either SatisfactionError SatScript
sat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
    Older Value Int
va -> 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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onAge :: Int -> Reader (Map Text Miniscript) SatResult
onAge Int
age = 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 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Ord a => a -> a -> SatResult
satisfyOlder Int
age) Value Int
va
        satisfyOlder :: a -> a -> SatResult
satisfyOlder a
age a
reqAge
            | a
age forall a. Ord a => a -> a -> Bool
>= a
reqAge = SatResult{sat :: Either SatisfactionError SatScript
sat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult{sat :: Either SatisfactionError SatScript
sat = forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty}
    After Value Int
vh -> 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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr SatisfactionError
Impossible) forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        onHeight :: Int -> Reader (Map Text Miniscript) SatResult
onHeight Int
h = 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 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Ord a => a -> a -> SatResult
satisfyAfter Int
h) Value Int
vh
        satisfyAfter :: a -> a -> SatResult
satisfyAfter a
height a
reqHeight
            | a
height forall a. Ord a => a -> a -> Bool
>= a
reqHeight = SatResult{sat :: Either SatisfactionError SatScript
sat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty, dsat :: Either SatisfactionError SatScript
dsat = forall a b. a -> Either a b
Left SatisfactionError
Impossible}
            | Bool
otherwise = SatResult{sat :: Either SatisfactionError SatScript
sat = forall a b. a -> Either a b
Left SatisfactionError
Impossible, dsat :: Either SatisfactionError SatScript
dsat = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty}
    Var 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 Text
name Miniscript
x Miniscript
b -> forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Miniscript
x) 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 ByteString
h
        | Just ByteString
p <- ByteString -> SatisfactionContext -> Maybe ByteString
lookupPreimage ByteString
h SatisfactionContext
sc =
            forall (m :: * -> *).
Monad m =>
SatScript -> SatScript -> m SatResult
satVals ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData ByteString
p]) ([ScriptOp] -> SatScript
fromScript [ByteString -> ScriptOp
opPushData forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
otherValue ByteString
p])
        | Bool
otherwise = forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr forall a b. (a -> b) -> a -> b
$ ByteString -> SatisfactionError
MissingPreimage ByteString
h

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

pushKey :: PubKeyI -> ScriptOp
pushKey :: PubKeyI -> ScriptOp
pushKey (PubKeyI PubKey
k Bool
c) = ByteString -> ScriptOp
opPushData 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 ByteString
bs
    | ByteString
bs forall a. Eq a => a -> a -> Bool
== ByteString
zero32 = [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
32 Word8
0x1
    | Bool
otherwise = ByteString
zero32

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

withLiteral ::
    (Miniscript -> Either SatisfactionError a) ->
    (a -> Reader (Map Text Miniscript) SatResult) ->
    Value a ->
    Reader (Map Text Miniscript) SatResult
withLiteral :: forall a.
(Miniscript -> Either SatisfactionError a)
-> (a -> Reader (Map Text Miniscript) SatResult)
-> Value a
-> Reader (Map Text Miniscript) SatResult
withLiteral Miniscript -> Either SatisfactionError a
g a -> Reader (Map Text Miniscript) SatResult
f = \case
    Lit a
n -> a -> Reader (Map Text Miniscript) SatResult
f a
n
    Variable Text
n -> Text
-> (Miniscript -> Reader (Map Text Miniscript) SatResult)
-> Reader (Map Text Miniscript) SatResult
requiredValue Text
n forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr a -> Reader (Map Text Miniscript) SatResult
f 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 Text
name Miniscript -> Reader (Map Text Miniscript) SatResult
f = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => SatisfactionError -> m SatResult
satErr 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 Int
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
guardNumber Miniscript
e = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Miniscript -> SatisfactionError
TypeError Text
"number" Miniscript
e

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

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

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

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

satConcat :: (Applicative f, Monoid m) => (a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat :: forall (f :: * -> *) m a b.
(Applicative f, Monoid m) =>
(a -> f m) -> a -> (b -> f m) -> b -> f m
satConcat a -> f m
f a
x b -> f m
g b
y = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f m
f a
x 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 :: forall e.
Either e SatScript -> Either e SatScript -> Either e SatScript
satOr xA :: Either e SatScript
xA@(Right SatScript
sA) xB :: Either e SatScript
xB@(Right SatScript
sB)
    | SatScript -> Int
satWeight SatScript
sA forall a. Ord a => a -> a -> Bool
<= SatScript -> Int
satWeight SatScript
sB = Either e SatScript
xA
    | Bool
otherwise = Either e SatScript
xB
satOr Either e SatScript
sA Either e SatScript
sB = Either e SatScript
sA forall a. Semigroup a => a -> a -> a
<> Either e SatScript
sB

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