From c59a37ee6b3551e260e327d8d77c8f4c4a077521 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 4 Feb 2021 12:00:46 +0300 Subject: [PATCH] Unify Sigma & SigmaE `Sigma a` is isomorphic to `SigmaE () (Either Bool a)`. This change simplifies code quite a bit and allows to specify exactly where boolean literals could be present and where we want pure sigma expression --- .../src/Hschain/Utxo/API/Rest.hs | 8 +- .../src/Hschain/Utxo/Compiler/Commands.hs | 2 +- .../Hschain/Utxo/Lang/Compile/Hask/Utils.hs | 14 +- .../Hschain/Utxo/Lang/Core/Compile/Build.hs | 3 +- .../src/Hschain/Utxo/Lang/Core/Eval.hs | 35 ++-- .../src/Hschain/Utxo/Lang/Core/RefEval.hs | 25 +-- .../src/Hschain/Utxo/Lang/Core/ToHask.hs | 14 +- .../src/Hschain/Utxo/Lang/Expr.hs | 12 +- .../Hschain/Utxo/Lang/Parser/Hask/ToHask.hs | 12 +- .../src/Hschain/Utxo/Lang/Pretty.hs | 13 +- .../src/Hschain/Utxo/Lang/Sigma.hs | 157 ++++++------------ .../src/Hschain/Utxo/Lang/Sigma/Protocol.hs | 7 +- .../src/Hschain/Utxo/Lang/Types.hs | 19 +-- hschain-utxo-lang/test/TM/Core.hs | 3 +- hschain-utxo-lang/test/TM/Core/List.hs | 4 +- hschain-utxo-lang/test/TM/Tx/DTuple.hs | 6 +- hschain-utxo-lang/test/TM/Tx/Sigma.hs | 4 +- hschain-utxo-pow-node/app/CLI.hs | 3 +- .../hschain-utxo-pow-node.cabal | 1 - hschain-utxo-pow-node/test/TM/BCH/Util.hs | 10 +- .../test/TM/SmartCon/ErgoMix.hs | 19 +-- .../src/Hschain/Utxo/State/React.hs | 2 +- hschain-utxo-test/hschain-utxo-test.cabal | 1 - .../src/Hschain/Utxo/Test/Client/Monad.hs | 2 +- .../Utxo/Test/Client/Scripts/Channel.hs | 8 +- .../Utxo/Test/Client/Scripts/MultiSig.hs | 14 +- .../src/Hschain/Utxo/Test/Client/Wallet.hs | 15 +- 27 files changed, 176 insertions(+), 237 deletions(-) diff --git a/hschain-utxo-api/hschain-utxo-api-rest/src/Hschain/Utxo/API/Rest.hs b/hschain-utxo-api/hschain-utxo-api-rest/src/Hschain/Utxo/API/Rest.hs index cb3b40bc..60193592 100644 --- a/hschain-utxo-api/hschain-utxo-api-rest/src/Hschain/Utxo/API/Rest.hs +++ b/hschain-utxo-api/hschain-utxo-api-rest/src/Hschain/Utxo/API/Rest.hs @@ -82,9 +82,11 @@ data PostTxResponse = PostTxResponse -- | Result of execution of TX in the current state of blockchain. data SigmaTxResponse = SigmaTxResponse - { sigmaTxResponse'value :: !(Either Text (Vector BoolExprResult)) -- ^ result of execution - -- (sigma-expression or boolean) - , sigmaTxResponse'debug :: !Text } -- ^ Debug info on the process of execution + { sigmaTxResponse'value :: !(Either Text (Vector ScriptEvalResult)) + -- ^ result of execution (sigma-expression or boolean) + , sigmaTxResponse'debug :: !Text + -- ^ Debug info on the process of execution + } deriving (Show, Eq) -- | Useful stats about state of the blockchain diff --git a/hschain-utxo-compiler/src/Hschain/Utxo/Compiler/Commands.hs b/hschain-utxo-compiler/src/Hschain/Utxo/Compiler/Commands.hs index 90750e6c..a5c9131c 100644 --- a/hschain-utxo-compiler/src/Hschain/Utxo/Compiler/Commands.hs +++ b/hschain-utxo-compiler/src/Hschain/Utxo/Compiler/Commands.hs @@ -120,7 +120,7 @@ signSigma secretFile exprFile txFile output = do file <- LB.readFile secretFile return $ either (const failToReadSecret) id $ S.deserialiseOrFail file - readExpr :: IO BoolExprResult + readExpr :: IO ScriptEvalResult readExpr = do file <- LB.readFile exprFile return $ fromMaybe failToReadExpression $ decode' file diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Compile/Hask/Utils.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Compile/Hask/Utils.hs index 4bc4e14a..803c5474 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Compile/Hask/Utils.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Compile/Hask/Utils.hs @@ -12,7 +12,6 @@ module Hschain.Utxo.Lang.Compile.Hask.Utils( import Hex.Common.Text (showt) -import Data.Fix import Data.ByteString (ByteString) import Data.Text (Text) @@ -47,12 +46,15 @@ toTypedPat :: Loc -> Typed (HM.Type () Name) Name -> H.Pat Loc toTypedPat loc (Typed name ty) = H.PatTypeSig loc (H.PVar loc $ toName $ VarName loc name) (toType loc ty) toSigma :: Loc -> Sigma ProofInput -> H.Exp Loc -toSigma loc = foldFix $ \case - SigmaBool b -> H.App loc (H.Var loc $ toQName $ VarName loc "toSigma") (toBool loc b) - SigmaAnd as -> sigmaOp "&&" as - SigmaOr as -> sigmaOp "||" as - SigmaPk pk -> fromProofInput pk +toSigma loc = go where + go = \case + Leaf _ (Left b) -> H.App loc (H.Var loc $ toQName $ VarName loc "toSigma") (toBool loc b) + Leaf _ (Right pk) -> fromProofInput pk + AND _ as -> sigmaOp "&&" $ go <$> as + OR _ as -> sigmaOp "||" $ go <$> as + + sigmaOp op args = L.foldr1 (\a b -> H.InfixApp loc a (toQOp op) b) args toQOp op = H.QVarOp loc (toQName $ VarName loc op) diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Compile/Build.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Compile/Build.hs index 84c6d030..3ce2fbb0 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Compile/Build.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Compile/Build.hs @@ -30,7 +30,6 @@ module Hschain.Utxo.Lang.Core.Compile.Build( import Data.ByteString (ByteString) import Data.Int -import Data.Fix import Data.Text (Text) import Hschain.Utxo.Lang.Core.Compile.Expr @@ -63,7 +62,7 @@ bytes :: ByteString -> Core v bytes b = EPrim $ PrimBytes b sigmaBool :: Bool -> Core v -sigmaBool b = EPrim $ PrimSigma $ Fix $ SigmaBool b +sigmaBool b = EPrim $ PrimSigma $ Leaf () $ Left b equals :: TypeCore -> Core v -> Core v -> Core v equals t a b = ap (EPrimOp (OpEQ t)) [a, b] diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Eval.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Eval.hs index d82341f6..742c5177 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Eval.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Eval.hs @@ -5,7 +5,6 @@ module Hschain.Utxo.Lang.Core.Eval( , execScriptToSigma ) where -import Data.Fix import Data.Text import Data.Bifunctor import Data.Void @@ -15,7 +14,7 @@ import Hschain.Utxo.Lang.Core.Compile.Expr import Hschain.Utxo.Lang.Core.Compile.TypeCheck (typeCheck) import Hschain.Utxo.Lang.Core.RefEval (evalProg) import Hschain.Utxo.Lang.Core.Types (TypeCore(..),Prim(..)) -import Hschain.Utxo.Lang.Expr (BoolExprResult(..)) +import Hschain.Utxo.Lang.Expr (ScriptEvalResult(..)) import Hschain.Utxo.Lang.Error import Hschain.Utxo.Lang.Pretty import Hschain.Utxo.Lang.Sigma @@ -25,7 +24,7 @@ import qualified Data.Text as T -- | Executes spend-script in transaction. Spend script should be -- well-typed and evaluate to either sigma-expression or boolean. -execScriptToSigma :: InputEnv -> Core Void -> Either Error (Sigma ProofInput) +execScriptToSigma :: InputEnv -> Core Void -> Either Error ScriptEvalResult execScriptToSigma env prog = do -- Type check expression ty <- first (CoreScriptError . TypeCoreError) @@ -36,21 +35,21 @@ execScriptToSigma env prog = do _ -> Left $ CoreScriptError ResultIsNotSigma -- Evaluate script case evalProg env prog of - Right (PrimVal (PrimBool b)) -> Right $ Fix $ SigmaBool b + Right (PrimVal (PrimBool b)) -> pure $ ConstBool b Right (PrimVal (PrimSigma s)) -> case eliminateSigmaBool s of - Left b -> Right $ Fix $ SigmaBool b - Right s' -> Right s' - Left _ -> Right $ Fix $ SigmaBool False + Left b -> pure $ ConstBool b + Right s' -> pure $ SigmaResult s' + Left _ -> Right $ ConstBool False _ -> error "Internal error: Left $ E.CoreScriptError E.ResultIsNotSigma" -evalToSigma :: TxArg -> Either Error (Vector BoolExprResult) +evalToSigma :: TxArg -> Either Error (Vector ScriptEvalResult) evalToSigma tx = mapM (evalInput . getInputEnv tx) $ txArg'inputs tx -evalInput :: InputEnv -> Either Error BoolExprResult +evalInput :: InputEnv -> Either Error ScriptEvalResult evalInput env = case coreProgFromScript $ box'script $ postBox'content $ boxInput'box $ inputEnv'self env of - Just prog -> fmap (either ConstBool SigmaResult . eliminateSigmaBool) $ execScriptToSigma env prog + Just prog -> execScriptToSigma env prog Nothing -> Left $ ExecError FailedToDecodeScript verifyInput :: TxArg -> BoxInput -> Either Text () @@ -62,16 +61,12 @@ verifyInput txArg input@BoxInput{..} = do -- Script evaluated to literal Bool ConstBool True -> pure () ConstBool False -> false - SigmaResult sigma -> case sigma of - Fix (SigmaBool True) -> pure () - Fix (SigmaBool False) -> false - -- Attempt to prove sigma expression - _ | Just proof <- boxInput'proof - , equalSigmaProof sigma proof - , verifyProof proof boxInput'sigMsg - -> pure () - -- Otherwise failure - other -> Left $ T.unlines ["Sigma expression proof is not valid:", renderText other] + SigmaResult sigma + | Just proof <- boxInput'proof + , equalSigmaProof sigma proof + , verifyProof proof boxInput'sigMsg + -> pure () + | otherwise -> Left $ T.unlines ["Sigma expression proof is not valid"] where false = Left "Script evaluated to False" diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/RefEval.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/RefEval.hs index c2557c96..360bfc44 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/RefEval.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/RefEval.hs @@ -18,7 +18,6 @@ import Data.ByteString (ByteString) import Data.Bool import Data.Text (Text) import Data.Typeable -import Data.Fix import Data.Foldable (foldrM) import Data.Vector.Generic ((!?)) import qualified Data.Vector as V @@ -183,21 +182,23 @@ evalPrimOp env = \case False -> match y OpBoolNot -> pure $ lift1 not -- - OpSigBool -> pure $ lift1 $ Fix . SigmaBool - OpSigAnd -> pure $ lift2 $ \a b -> Fix $ SigmaAnd [a,b] - OpSigOr -> pure $ lift2 $ \a b -> Fix $ SigmaOr [a,b] - OpSigPK -> pure $ evalLift1 $ \t -> fmap (Fix . SigmaPk . dlogInput) $ parsePublicKey t - OpSigDTuple -> pure $ evalLift3 $ \genB keyA keyB -> liftA3 (\gB pkA pkB -> Fix $ SigmaPk $ dtupleInput gB pkA pkB) (parseGenerator genB) (parsePublicKey keyA) (parsePublicKey keyB) - OpSigListAnd -> pure $ lift1 $ Fix . SigmaAnd - OpSigListOr -> pure $ lift1 $ Fix . SigmaOr + OpSigBool -> pure $ lift1 $ Leaf () . Left + OpSigAnd -> pure $ lift2 $ \a b -> AND () [a,b] + OpSigOr -> pure $ lift2 $ \a b -> OR () [a,b] + OpSigPK -> pure $ evalLift1 $ \t -> fmap (sigmaPk . dlogInput) $ parsePublicKey t + OpSigDTuple -> pure $ evalLift3 $ \genB keyA keyB -> + liftA3 (\gB pkA pkB -> sigmaPk $ dtupleInput gB pkA pkB) + (parseGenerator genB) (parsePublicKey keyA) (parsePublicKey keyB) + OpSigListAnd -> pure $ lift1 $ AND () + OpSigListOr -> pure $ lift1 $ OR () OpSigListAll _ -> pure $ Val2F $ \valF valXS -> fmap inj $ do f <- match @(Val -> Eval Val) valF xs <- match @[Val] valXS - fmap (Fix . SigmaAnd) $ mapM (match <=< f) xs + AND () <$> mapM (match <=< f) xs OpSigListAny _ -> pure $ Val2F $ \valF valXS -> fmap inj $ do f <- match @(Val -> Eval Val) valF xs <- match @[Val] valXS - fmap (Fix . SigmaOr) $ mapM (match <=< f) xs + OR () <$> mapM (match <=< f) xs -- OpCheckSig -> pure $ evalLift2 $ \bs sigIndex -> do pk <- parsePublicKey bs @@ -382,7 +383,7 @@ instance MatchPrim LB.ByteString where match (ValP (PrimBytes a)) = pure $ LB.fromStrict a match _ = throwError "Expecting Bytes" -instance k ~ ProofInput => MatchPrim (Sigma k) where +instance (k ~ (), a ~ Either Bool ProofInput) => MatchPrim (SigmaE k a) where match (ValP (PrimSigma a)) = pure a match _ = throwError "Expecting Sigma" @@ -414,7 +415,7 @@ instance InjPrim ByteString where inj = ValP . PrimBytes instance InjPrim LB.ByteString where inj = inj . LB.toStrict instance InjPrim (Hash a) where inj (Hash h) = inj h -instance k ~ ProofInput => InjPrim (Sigma k) where +instance (k ~ (), a ~ Either Bool ProofInput) => InjPrim (SigmaE k a) where inj = ValP . PrimSigma instance InjPrim a => InjPrim [a] where diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/ToHask.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/ToHask.hs index 7424316d..3257a653 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/ToHask.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/ToHask.hs @@ -12,7 +12,6 @@ import Hex.Common.Text (showt) import qualified Codec.Serialise as CBOR import Control.Monad.State.Strict import Data.ByteString (ByteString) -import Data.Fix import Data.String import Data.Void import Data.Text (Text) @@ -98,14 +97,15 @@ toHaskExprCore = flip evalState (T.pack <$> stringPrettyLetters) . go [] fromBool b = H.Con () $ if b then toQName "True" else toQName "False" fromSigma :: Sigma ByteString -> H.Exp () - fromSigma = foldFix rec + fromSigma = rec where rec = \case - SigmaPk pkey -> let keyTxt = encodeBase58 pkey - in ap1 Const.pk $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt) - SigmaAnd as -> foldl1 (ap2 Const.sigmaAnd) as - SigmaOr as -> foldl1 (ap2 Const.sigmaOr) as - SigmaBool b -> fromBool b + Leaf _ (Right pkey) -> let keyTxt = encodeBase58 pkey + in ap1 Const.pk $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt) + Leaf _ (Left b) -> fromBool b + AND _ as -> foldl1 (ap2 Const.sigmaAnd) $ rec <$> as + OR _ as -> foldl1 (ap2 Const.sigmaOr) $ rec <$> as + ap1 f a = H.App () (toVar f) a ap2 f a b = H.App src (H.App () (toVar f) a) b diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Expr.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Expr.hs index bcddda39..37b09736 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Expr.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Expr.hs @@ -31,7 +31,7 @@ module Hschain.Utxo.Lang.Expr( , bindAlts , getBindsNames , secretVar - , BoolExprResult(..) + , ScriptEvalResult(..) , mapDeclsM , fromParserLoc , emptyTypeContext @@ -278,17 +278,17 @@ secretVar = flip mappend "___" -- | Result of the script can be boolean constant or sigma-expression -- that user have to prove. -data BoolExprResult - = ConstBool Bool - | SigmaResult (Sigma ProofInput) +data ScriptEvalResult + = ConstBool !Bool + | SigmaResult !(SigmaE () ProofInput) deriving (Show, Eq) -instance ToJSON BoolExprResult where +instance ToJSON ScriptEvalResult where toJSON = \case ConstBool b -> object ["bool" .= b] SigmaResult s -> object ["sigma" .= s] -instance FromJSON BoolExprResult where +instance FromJSON ScriptEvalResult where parseJSON = withObject "BoolExprResult" $ \obj -> (ConstBool <$> obj .: "bool") <|> (SigmaResult <$> obj .: "sigma") diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Parser/Hask/ToHask.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Parser/Hask/ToHask.hs index ee8ecb83..35153378 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Parser/Hask/ToHask.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Parser/Hask/ToHask.hs @@ -82,14 +82,14 @@ toLiteral loc = \case lit = H.Lit loc sigma :: Loc -> Sigma ProofInput -> H.Exp Loc - sigma src x = foldFix go x + sigma src x = go x where go = \case - SigmaPk pkey -> let keyTxt = encodeBase58 $ BL.toStrict $ CBOR.serialise pkey - in ap (VarName src "pk") $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt) - SigmaAnd as -> foldl1 (ap2 (VarName src Const.sigmaAnd)) as - SigmaOr as -> foldl1 (ap2 (VarName src Const.sigmaOr)) as - SigmaBool b -> H.Con src $ bool src b + Leaf _ (Right pkey) -> let keyTxt = encodeBase58 $ BL.toStrict $ CBOR.serialise pkey + in ap (VarName src "pk") $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt) + Leaf _ (Left b) -> H.Con src $ bool src b + AND _ as -> foldl1 (ap2 (VarName src Const.sigmaAnd)) $ go <$> as + OR _ as -> foldl1 (ap2 (VarName src Const.sigmaOr)) $ go <$> as ap f a = H.App (HM.getLoc f) (toVar (HM.getLoc f) f) a ap2 f a b = H.App src (H.App src (toVar src f) a) b diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Pretty.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Pretty.hs index c8f09a99..d3ba9ce9 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Pretty.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Pretty.hs @@ -11,7 +11,6 @@ import Codec.Serialise (deserialiseOrFail) import Hex.Common.Serialise import Data.Bool -import Data.Fix import Data.Void import Data.ByteString.Lazy (fromStrict) import Data.Text (Text) @@ -164,12 +163,12 @@ instance Pretty Env where instance Pretty Proof where pretty proof = pretty $ P.ppShow proof -instance Pretty a => Pretty (S.Sigma a) where - pretty = foldFix $ \case - S.SigmaPk k -> parens $ hsep ["pk", pretty k] - S.SigmaAnd as -> parens $ hsep $ Const.sigmaAnd : as - S.SigmaOr as -> parens $ hsep $ Const.sigmaOr : as - S.SigmaBool b -> "Sigma" <> pretty b +instance Pretty a => Pretty (S.SigmaE () (Either Bool a)) where + pretty = \case + S.Leaf () (Right k) -> parens $ hsep ["pk", pretty k] + S.Leaf () (Left b) -> "Sigma" <> pretty b + S.AND () as -> parens $ hsep $ Const.sigmaAnd : fmap pretty as + S.OR () as -> parens $ hsep $ Const.sigmaOr : fmap pretty as instance Pretty S.ProofInput where pretty = \case diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma.hs index 7e7c70c3..0d949b3e 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma.hs @@ -15,12 +15,12 @@ module Hschain.Utxo.Lang.Sigma( , AtomicProof , SigMessage(..) , Sigma + , Sigma.SigmaE(..) , sigmaPk , dlogSigma , dtupleSigma , mapPk , mapPkM - , SigmaF(..) , newProof , verifyProof , proofEnvFromKeys @@ -48,28 +48,20 @@ module Hschain.Utxo.Lang.Sigma( , getPublicKey ) where -import Hex.Common.Serialise - import Control.Monad.Except -import Control.DeepSeq (NFData,NFData1) +import Control.DeepSeq (NFData) import Codec.Serialise import Data.Aeson import Data.ByteString (ByteString) import Data.Boolean import Data.Bifunctor -import Data.Data import Data.Either -import Data.Fix import Data.Functor.Classes (Eq1(..)) import Data.Set (Set) import Data.Text (Text) -import Data.Eq.Deriving -import Data.Ord.Deriving - -import GHC.Generics (Generic, Generic1) -import Text.Show.Deriving +import GHC.Generics (Generic) import HSChain.Crypto.Classes (ViaBase58(..), ByteRepr(..)) import HSChain.Crypto.Classes.Hash @@ -140,22 +132,13 @@ getPublicKey = Sigma.getPublicKey toProofEnv :: [KeyPair] -> ProofEnv toProofEnv ks = Sigma.Env ks -instance Serialise a => ToJSON (Sigma a) where - toJSON = serialiseToJSON - -instance Serialise a => FromJSON (Sigma a) where - parseJSON = serialiseFromJSON - -- | Creates proof for sigma expression with given collection of key-pairs (@ProofEnv@). -- The last argument message is a serialised content of transaction. -- It's message to be signed. -- -- For the message use getTxBytes from TX that has no proof. -newProof :: ProofEnv -> Sigma ProofInput -> SigMessage -> IO (Either Text Proof) -newProof env expr message = - case toSigmaExprOrFail expr of - Right sigma -> Sigma.createProof env sigma $ encodeToBS message - Left err -> return $ Left err +newProof :: ProofEnv -> Sigma.SigmaE () ProofInput -> SigMessage -> IO (Either Text Proof) +newProof env expr message = Sigma.createProof env expr $ encodeToBS message -- | Verify the proof. -- @@ -165,116 +148,82 @@ newProof env expr message = verifyProof :: Proof -> SigMessage -> Bool verifyProof proof = Sigma.verifyProof proof . encodeToBS -type Sigma k = Fix (SigmaF k) +type Sigma k = Sigma.SigmaE () (Either Bool k) mapPk :: (a -> b) -> Sigma a -> Sigma b -mapPk f = foldFix $ \case - SigmaPk a -> Fix $ SigmaPk (f a) - SigmaAnd as -> Fix $ SigmaAnd as - SigmaOr as -> Fix $ SigmaOr as - SigmaBool b -> Fix $ SigmaBool b - -mapPkM :: Monad m => (a -> m b) -> Sigma a -> m (Sigma b) -mapPkM f = foldFixM $ \case - SigmaPk a -> fmap (Fix . SigmaPk) (f a) - SigmaAnd as -> pure $ Fix $ SigmaAnd as - SigmaOr as -> pure $ Fix $ SigmaOr as - SigmaBool b -> pure $ Fix $ SigmaBool b +mapPk = fmap . fmap + +mapPkM :: Applicative m => (a -> m b) -> Sigma a -> m (Sigma b) +mapPkM = traverse . traverse instance Boolean (Sigma k) where - true = Fix $ SigmaBool True - false = Fix $ SigmaBool False + true = Sigma.Leaf () $ Left True + false = Sigma.Leaf () $ Left False notB = error "Not is not defined for Sigma-expressions" - (&&*) a b = Fix $ SigmaAnd [a, b] - (||*) a b = Fix $ SigmaOr [a, b] + (&&*) a b = Sigma.AND () [a, b] + (||*) a b = Sigma.OR () [a, b] sigmaPk :: k -> Sigma k -sigmaPk k = Fix $ SigmaPk k - -dlogSigma :: PublicKey -> Sigma ProofInput -dlogSigma k = sigmaPk $ dlogInput k - -dtupleSigma :: ECPoint -> PublicKey -> PublicKey -> Sigma ProofInput -dtupleSigma genB keyA keyB = sigmaPk $ dtupleInput genB keyA keyB +sigmaPk k = Sigma.Leaf () (Right k) --- | Sigma-expression -data SigmaF k a = - SigmaPk k -- ownership of the key (contains public key) - | SigmaAnd [a] -- and-expression - | SigmaOr [a] -- or-expression - | SigmaBool Bool -- wraps boolean constants - deriving stock (Functor, Foldable, Traversable, Show, Read, Eq, Ord, Generic, Generic1, Data) - deriving anyclass (NFData, NFData1, Serialise) +dlogSigma :: PublicKey -> Sigma.SigmaE () ProofInput +dlogSigma k = Sigma.Leaf () $ dlogInput k -instance Serialise k => Serialise (Fix (SigmaF k)) - -instance (CryptoHashable k, CryptoHashable a) => CryptoHashable (SigmaF k a) where - hashStep = genericHashStep Sigma.hashDomain - -fromSigmaExpr :: Sigma.SigmaE () a -> Sigma a -fromSigmaExpr = \case - Sigma.Leaf _ k -> Fix $ SigmaPk k - Sigma.AND _ as -> Fix $ SigmaAnd $ fmap rec as - Sigma.OR _ as -> Fix $ SigmaOr $ fmap rec as - where - rec = fromSigmaExpr +dtupleSigma :: ECPoint -> PublicKey -> PublicKey -> Sigma.SigmaE () ProofInput +dtupleSigma genB keyA keyB = Sigma.Leaf () $ dtupleInput genB keyA keyB -- | Tries to remove all boolean constants. -- returns Left boolean if it's not possible -- to eliminate boolean constants. -eliminateSigmaBool :: Sigma a -> Either Bool (Sigma a) -eliminateSigmaBool = foldFix $ \case - SigmaBool b -> Left b - SigmaPk pk -> Right $ Fix $ SigmaPk pk - SigmaAnd as - | and bools -> case sigmas of - [] -> Left True - [sigma] -> Right sigma - _ -> Right $ Fix $ SigmaAnd sigmas - | otherwise -> Left False - where - (bools, sigmas) = partitionEithers as - SigmaOr as - | or bools -> Left True - | otherwise -> case sigmas of - [] -> Left False - [sigma] -> Right sigma - _ -> Right $ Fix $ SigmaOr sigmas - where - (bools, sigmas) = partitionEithers as +eliminateSigmaBool :: Sigma a -> Either Bool (Sigma.SigmaE () a) +eliminateSigmaBool = go + where + go = \case + Sigma.Leaf _ (Left b) -> Left b + Sigma.Leaf _ (Right a) -> Right $ Sigma.Leaf () a + Sigma.AND _ as + | and bools -> case sigmas of + [] -> Left True + [sigma] -> Right sigma + _ -> Right $ Sigma.AND () sigmas + | otherwise -> Left False + where + (bools, sigmas) = partitionEithers $ eliminateSigmaBool <$> as + Sigma.OR () as + | or bools -> Left True + | otherwise -> case sigmas of + [] -> Left False + [sigma] -> Right sigma + _ -> Right $ Sigma.OR () sigmas + where + (bools, sigmas) = partitionEithers $ eliminateSigmaBool <$> as toSigmaExpr :: Sigma a -> Either Bool (Sigma.SigmaE () a) -toSigmaExpr a = (maybe (Left False) Right . toPrimSigmaExpr) =<< eliminateSigmaBool a +toSigmaExpr = eliminateSigmaBool toSigmaExprOrFail :: Sigma a -> Either Text (Sigma.SigmaE () a) toSigmaExprOrFail = first (const "Expression is constant boolean. It is not a sigma-expression") . toSigmaExpr -toPrimSigmaExpr :: Sigma a -> Maybe (Sigma.SigmaE () a) -toPrimSigmaExpr = foldFix $ \case - SigmaPk k -> Just $ Sigma.Leaf () k - SigmaAnd as -> fmap (Sigma.AND ()) $ sequence as - SigmaOr as -> fmap (Sigma.OR ()) $ sequence as - SigmaBool _ -> Nothing - -- | Wrapper to contruct proof environment from list of key-pairs. proofEnvFromKeys :: [KeyPair] -> ProofEnv proofEnvFromKeys = Sigma.Env -- | Check if sigma expression is proven with given proof. -equalSigmaProof :: Sigma ProofInput -> Proof -> Bool +equalSigmaProof :: Sigma.SigmaE () ProofInput -> Proof -> Bool equalSigmaProof candidate proof = equalSigmaExpr candidate - (fromSigmaExpr $ Sigma.completeProvenTree proof) - -equalSigmaExpr :: Sigma ProofInput -> Sigma AtomicProof -> Bool -equalSigmaExpr (Fix x) (Fix y) = case (x, y) of - (SigmaPk inp, SigmaPk proof) -> inp == Sigma.getProofInput proof - (SigmaOr as, SigmaOr bs) -> equalList as bs - (SigmaAnd as, SigmaAnd bs) -> equalList as bs + (Sigma.completeProvenTree proof) + +equalSigmaExpr :: Sigma.SigmaE () ProofInput -> Sigma.SigmaE () AtomicProof -> Bool +equalSigmaExpr x y = case (x, y) of + (Sigma.Leaf _ inp, Sigma.Leaf _ proof) + -> inp == Sigma.getProofInput proof + (Sigma.OR _ as, Sigma.OR _ bs) -> equalList as bs + (Sigma.AND _ as, Sigma.AND _ bs) -> equalList as bs _ -> False where equalList = liftEq equalSigmaExpr @@ -414,7 +363,3 @@ dlogInput = Sigma.InputDLog dtupleInput :: ECPoint -> PublicKey -> PublicKey -> ProofInput dtupleInput genB keyA keyB = Sigma.InputDTuple $ Sigma.DTuple Sigma.groupGenerator genB keyA keyB - -$(deriveShow1 ''SigmaF) -$(deriveEq1 ''SigmaF) -$(deriveOrd1 ''SigmaF) diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma/Protocol.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma/Protocol.hs index 3e841d10..938de5b4 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma/Protocol.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Sigma/Protocol.hs @@ -46,8 +46,8 @@ data SigmaE k a -- ^ AND connective | OR k [SigmaE k a] -- ^ OR connective - deriving stock (Functor, Foldable, Traversable, Show, Eq, Generic) - deriving anyclass (Serialise) + deriving stock (Functor,Foldable,Traversable,Show,Eq,Ord,Generic,Data) + deriving anyclass (Serialise,NFData) sexprAnn :: SigmaE k a -> k sexprAnn = \case @@ -147,3 +147,6 @@ deriving instance (EC a) => Eq (AtomicProof a) instance (EC a) => CBOR.Serialise (AtomicProof a) instance (CryptoAsymmetric a) => CBOR.Serialise (FiatShamirLeaf a) + +instance (ToJSON k, ToJSON a) => ToJSON (SigmaE k a) where +instance (FromJSON k, FromJSON a) => FromJSON (SigmaE k a) where diff --git a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Types.hs b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Types.hs index 31ccb9bf..c29828e0 100644 --- a/hschain-utxo-lang/src/Hschain/Utxo/Lang/Types.hs +++ b/hschain-utxo-lang/src/Hschain/Utxo/Lang/Types.hs @@ -55,7 +55,6 @@ import Codec.Serialise import Data.ByteString (ByteString) import Data.Bifunctor import Data.Data -import Data.Fix import Data.Int import Data.Text (Text) import Data.Vector (Vector) @@ -410,9 +409,9 @@ isStartEpoch TxArg{..} = env'height txArg'env == 0 -- smartconstructors to create boxes and transactions makeInput - :: GTx (Sigma ProofInput) Box + :: GTx (SigmaE () ProofInput) Box -> ProofEnv - -> BoxInputRef (Sigma ProofInput) + -> BoxInputRef (SigmaE () ProofInput) -> IO (BoxInputRef Proof) makeInput tx proofEnv BoxInputRef{..} = do let message = getSigMessage boxInputRef'sigMask tx @@ -422,9 +421,9 @@ makeInput tx proofEnv BoxInputRef{..} = do } makeInputOrFail - :: GTx (Sigma ProofInput) Box + :: GTx (SigmaE () ProofInput) Box -> ProofEnv - -> BoxInputRef (Sigma ProofInput) + -> BoxInputRef (SigmaE () ProofInput) -> ExceptT Text IO (BoxInputRef Proof) makeInputOrFail tx proofEnv ref@BoxInputRef{..} = traverse toInput ref @@ -437,7 +436,7 @@ makeInputOrFail tx proofEnv ref@BoxInputRef{..} -- | Expectation of the result of the box. We use it when we know to -- what sigma expression input box script is going to be executed. -- Then we can generate proofs with function @newProofTx@. -type ExpectedBox = BoxInputRef (Sigma ProofInput) +type ExpectedBox = BoxInputRef (SigmaE () ProofInput) -- | If we know the expected sigma expressions for the inputs -- we can create transaction with all proofs supplied. @@ -447,7 +446,7 @@ type ExpectedBox = BoxInputRef (Sigma ProofInput) -- -- Note: If it can not produce the proof (user don't have corresponding private key) -- it produces @Nothing@ in the @boxInputRef'proof@. -newProofTx :: MonadIO io => ProofEnv -> GTx (Sigma ProofInput) Box -> io Tx +newProofTx :: MonadIO io => ProofEnv -> GTx (SigmaE () ProofInput) Box -> io Tx newProofTx proofEnv tx = liftIO $ traverseOf (tx'inputsL . each) (makeInput tx proofEnv) tx @@ -457,7 +456,7 @@ newProofTx proofEnv tx -- -- Otherwise we can create TX with empty proof and query the expected results of sigma-expressions -- over API. -newProofTxOrFail :: MonadIO io => ProofEnv -> GTx (Sigma ProofInput) Box -> io (Either Text Tx) +newProofTxOrFail :: MonadIO io => ProofEnv -> GTx (SigmaE () ProofInput) Box -> io (Either Text Tx) newProofTxOrFail proofEnv tx = liftIO $ runExceptT $ traverseOf (tx'inputsL . each) (makeInputOrFail tx proofEnv) tx @@ -472,8 +471,8 @@ hashScript = getSha256 . unScript -------------------------------------------- -- useful utils -singleOwnerSigma :: PublicKey -> Sigma ProofInput -singleOwnerSigma pubKey = Fix $ SigmaPk $ dlogInput pubKey +singleOwnerSigma :: PublicKey -> SigmaE () ProofInput +singleOwnerSigma pubKey = Leaf () $ dlogInput pubKey singleOwnerInput :: BoxId -> PublicKey -> ExpectedBox singleOwnerInput boxId pubKey = BoxInputRef diff --git a/hschain-utxo-lang/test/TM/Core.hs b/hschain-utxo-lang/test/TM/Core.hs index 86d0a76f..25f02e06 100644 --- a/hschain-utxo-lang/test/TM/Core.hs +++ b/hschain-utxo-lang/test/TM/Core.hs @@ -1,7 +1,6 @@ -- | module TM.Core ( tests )where -import Data.Fix import Test.Tasty import Test.Tasty.HUnit @@ -17,7 +16,7 @@ tests :: TestTree tests = testGroup "core" [ testGroup "Literal" [ testProgram nm (progLiteral p) p - | (nm,p) <- [ ("sigma", PrimSigma $ Fix $ SigmaBool True) + | (nm,p) <- [ ("sigma", PrimSigma $ Leaf () $ Left True) , ("bool" , PrimBool False) , ("int", PrimInt 123) , ("text", PrimText "XX") diff --git a/hschain-utxo-lang/test/TM/Core/List.hs b/hschain-utxo-lang/test/TM/Core/List.hs index 47493a6c..a771773b 100644 --- a/hschain-utxo-lang/test/TM/Core/List.hs +++ b/hschain-utxo-lang/test/TM/Core/List.hs @@ -9,7 +9,6 @@ module TM.Core.List( , withBigList ) where -import Data.Fix import Data.Int import Test.Tasty @@ -35,12 +34,13 @@ tests = testGroup "core-lists" , testProgram "Any list" (progAnyList 2) (PrimBool True) , testProgram "All list" (progAllList 2) (PrimBool False) , testProgram "All sigma list" progSigmaAllList - (PrimSigma (Fix (SigmaAnd [Fix (SigmaBool True), Fix (SigmaBool False), Fix (SigmaBool True)]))) + (PrimSigma $ AND () [sigmaB True, sigmaB False, sigmaB True]) , testProgramFail "Too many reductions" (progBigListReduce bigSize) , testProgram "Ok amount of reductions" (progBigListReduce okSize) (PrimInt (sum ([0 .. okSize] :: [Int64]))) ] ] where + sigmaB = Leaf () . Left bigSize = 1000000 okSize = 1000 diff --git a/hschain-utxo-lang/test/TM/Tx/DTuple.hs b/hschain-utxo-lang/test/TM/Tx/DTuple.hs index 81e241e8..79fe71b6 100644 --- a/hschain-utxo-lang/test/TM/Tx/DTuple.hs +++ b/hschain-utxo-lang/test/TM/Tx/DTuple.hs @@ -7,8 +7,6 @@ module TM.Tx.DTuple( import Test.Tasty import Test.Tasty.HUnit -import Data.Fix - import HSChain.Crypto (hashBlob) import Hschain.Utxo.Lang.Sigma import Hschain.Utxo.Lang.Parser.Quoter @@ -33,7 +31,7 @@ verifyDtupleProof = do gy = getPublicKey bob gxy = y .*^ gx inp = InputDTuple $ DTuple groupGenerator gx gy gxy - expr = Fix $ SigmaPk inp + expr = Leaf () inp eProof <- newProof (toProofEnv [bob]) expr msg return $ either (const False) (\proof -> verifyProof proof msg) eProof where @@ -61,7 +59,7 @@ dtupleTx gx keys = newProofTx (toProofEnv [keys]) $ Tx inBox = BoxInputRef { boxInputRef'id = BoxId $ hashBlob "box-1" , boxInputRef'args = mempty - , boxInputRef'proof = Just $ Fix $ SigmaPk $ dtupleInput gx gy gxy + , boxInputRef'proof = Just $ Leaf () $ dtupleInput gx gy gxy , boxInputRef'sigs = [] , boxInputRef'sigMask = SigAll } diff --git a/hschain-utxo-lang/test/TM/Tx/Sigma.hs b/hschain-utxo-lang/test/TM/Tx/Sigma.hs index f48b0858..9e2278e9 100644 --- a/hschain-utxo-lang/test/TM/Tx/Sigma.hs +++ b/hschain-utxo-lang/test/TM/Tx/Sigma.hs @@ -19,7 +19,7 @@ tests = testGroup "sigma-protocols" ] -- | Inits transaction that is owned by alice and has correct proof. -initTx :: IO (Tx, GTx (Sigma ProofInput) Box) +initTx :: IO (Tx, GTx (SigmaE () ProofInput) Box) initTx = do aliceSecret <- newSecret let alicePubKey = toPublicKey aliceSecret @@ -29,7 +29,7 @@ initTx = do where tx pubKey = Tx { tx'inputs = return $ singleOwnerInput (BoxId $ hashBlob "box-1") pubKey - , tx'outputs = return $ Box + , tx'outputs = return $ Box { box'value = 1 , box'script = [utxo| pk $(pubKey) |] , box'args = mempty diff --git a/hschain-utxo-pow-node/app/CLI.hs b/hschain-utxo-pow-node/app/CLI.hs index d854033d..1f2c0d74 100644 --- a/hschain-utxo-pow-node/app/CLI.hs +++ b/hschain-utxo-pow-node/app/CLI.hs @@ -10,7 +10,6 @@ import Control.Monad import Control.Exception import Data.Int -import Data.Fix import Data.Foldable import Data.Text (Text) import Data.Map.Strict (Map,(!)) @@ -103,7 +102,7 @@ parseSend = do ] , tx'outputs = V.fromList [ Box { box'value = amount - , box'script = coreProgToScript $ EPrim $ PrimSigma $ Fix $ SigmaPk $ dlogInput pk + , box'script = coreProgToScript $ EPrim $ PrimSigma $ sigmaPk $ dlogInput pk , box'args = mempty } ] diff --git a/hschain-utxo-pow-node/hschain-utxo-pow-node.cabal b/hschain-utxo-pow-node/hschain-utxo-pow-node.cabal index fb4c1e1d..35451106 100644 --- a/hschain-utxo-pow-node/hschain-utxo-pow-node.cabal +++ b/hschain-utxo-pow-node/hschain-utxo-pow-node.cabal @@ -126,7 +126,6 @@ executable hschain-utxo-pow-node-cli , text , yaml , vector - , data-fix >=0.3 , servant , servant-client , servant-client-core diff --git a/hschain-utxo-pow-node/test/TM/BCH/Util.hs b/hschain-utxo-pow-node/test/TM/BCH/Util.hs index d2d82a62..3c02f02f 100644 --- a/hschain-utxo-pow-node/test/TM/BCH/Util.hs +++ b/hschain-utxo-pow-node/test/TM/BCH/Util.hs @@ -130,7 +130,7 @@ badBlock txs = mineBlockE Nothing Nothing txs >>= \case Left _ -> return () Right _ -> error "Block should be rejected" -badTx :: Sigma.ProofEnv -> GTx (Sigma.Sigma Sigma.ProofInput) Box -> Mine () +badTx :: Sigma.ProofEnv -> GTx (Sigma.SigmaE () Sigma.ProofInput) Box -> Mine () badTx env tx = do tx' <- newProofTx env tx badBlock [tx'] @@ -154,7 +154,7 @@ mineBlockE mpk mFee txs = Mine $ do coinbaseBox = Box { box'value = miningRewardAmount + fee , box'script = coreProgToScript $ case mpk of Nothing -> EPrim $ PrimBool True - Just pk -> EPrim $ PrimSigma $ Sigma.dlogSigma pk + Just pk -> EPrim $ PrimSigma $ Sigma.Leaf () $ Right $ Sigma.dlogInput pk , box'args = mempty } coinbase = Tx { tx'inputs = V.singleton BoxInputRef @@ -205,17 +205,17 @@ mineBlockE mpk mFee txs = Mine $ do ---------------------------------------------------------------- -- | Create BoxInputRef which is protected by simple signature script -simpleInputRef :: BoxId -> Sigma.PublicKey -> BoxInputRef (Sigma.Sigma Sigma.ProofInput) +simpleInputRef :: BoxId -> Sigma.PublicKey -> BoxInputRef (Sigma.SigmaE () Sigma.ProofInput) simpleInputRef boxId pk = BoxInputRef { boxInputRef'id = boxId , boxInputRef'args = mempty - , boxInputRef'proof = Just $ Sigma.dlogSigma pk + , boxInputRef'proof = Just $ Sigma.Leaf () $ Sigma.dlogInput pk , boxInputRef'sigs = [] , boxInputRef'sigMask = SigAll } simpleScript :: Sigma.PublicKey -> Script -simpleScript pk = coreProgToScript $ EPrim $ PrimSigma $ Sigma.dlogSigma pk +simpleScript pk = coreProgToScript $ EPrim $ PrimSigma $ Sigma.Leaf () $ Right $ Sigma.dlogInput pk -- | Unspendable box burnBox :: Money -> Box diff --git a/hschain-utxo-pow-node/test/TM/SmartCon/ErgoMix.hs b/hschain-utxo-pow-node/test/TM/SmartCon/ErgoMix.hs index d2c2f3b2..c35cbcbd 100644 --- a/hschain-utxo-pow-node/test/TM/SmartCon/ErgoMix.hs +++ b/hschain-utxo-pow-node/test/TM/SmartCon/ErgoMix.hs @@ -6,7 +6,6 @@ module TM.SmartCon.ErgoMix where import Control.Monad.Reader import Data.ByteString (ByteString) -import Data.Fix import Test.Tasty import Test.Tasty.HUnit import Prelude hiding ((<*)) @@ -68,13 +67,13 @@ bobJoinMix bobGuess env bob pkAlice bidBob bidAlicePool = do , BoxInputRef { boxInputRef'id = bidAlicePool , boxInputRef'args = mempty - , boxInputRef'proof = Just $ Fix $ Sigma.SigmaOr - [ Fix $ Sigma.SigmaOr $ (if bobGuess then id else reverse) - [ Sigma.dtupleSigma gx gy gxy - , Sigma.dtupleSigma gx gxy gy - ] - , Sigma.dlogSigma gx - ] + , boxInputRef'proof = Just $ Sigma.OR () + [ Sigma.OR () $ (if bobGuess then id else reverse) + [ Sigma.dtupleSigma gx gy gxy + , Sigma.dtupleSigma gx gxy gy + ] + , Sigma.dlogSigma gx + ] , boxInputRef'sigs = [] , boxInputRef'sigMask = SigAll } @@ -113,7 +112,7 @@ aliceSpends bid alice pkBob = do spendInput = BoxInputRef { boxInputRef'id = bid , boxInputRef'args = mempty - , boxInputRef'proof = Just $ Fix $ Sigma.SigmaOr + , boxInputRef'proof = Just $ Sigma.OR () [ Sigma.dlogSigma g_xy , Sigma.dtupleSigma g_y g_x g_xy ] @@ -137,7 +136,7 @@ bobSpends bid bob pkAlice = do spendInput = BoxInputRef { boxInputRef'id = bid , boxInputRef'args = mempty - , boxInputRef'proof = Just $ Fix $ Sigma.SigmaOr + , boxInputRef'proof = Just $ Sigma.OR () [ Sigma.dlogSigma g_y , Sigma.dtupleSigma g_xy g_x g_y ] diff --git a/hschain-utxo-state/src/Hschain/Utxo/State/React.hs b/hschain-utxo-state/src/Hschain/Utxo/State/React.hs index 63059c54..c96dee62 100644 --- a/hschain-utxo-state/src/Hschain/Utxo/State/React.hs +++ b/hschain-utxo-state/src/Hschain/Utxo/State/React.hs @@ -56,7 +56,7 @@ updateBoxChain TxArg{..} bch@BoxChain{..} -- to get the sigma-expression of the evaluation of the transaction script. -- -- Also it returns debug-log for transaction execution. -execInBoxChain :: Tx -> BoxChain -> Either Text (Vector BoolExprResult) +execInBoxChain :: Tx -> BoxChain -> Either Text (Vector ScriptEvalResult) execInBoxChain tx bch = do txArg <- toTxArg bch tx either (Left . renderText) Right $ Core.evalToSigma txArg diff --git a/hschain-utxo-test/hschain-utxo-test.cabal b/hschain-utxo-test/hschain-utxo-test.cabal index 7ba07d3a..f25926b1 100644 --- a/hschain-utxo-test/hschain-utxo-test.cabal +++ b/hschain-utxo-test/hschain-utxo-test.cabal @@ -44,7 +44,6 @@ library , hschain-utxo-lang , hschain-utxo-service , hschain-utxo-state - , Boolean , containers , cryptonite , data-fix >=0.3 diff --git a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Monad.hs b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Monad.hs index 269c7e3c..1b2787c5 100644 --- a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Monad.hs +++ b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Monad.hs @@ -182,7 +182,7 @@ getState = call C.getState getBoxChainEnv :: App Env getBoxChainEnv = fmap unGetEnvResponse $ call C.getEnv -getTxSigma :: Tx -> App (Either Text (Vector (Sigma ProofInput))) +getTxSigma :: Tx -> App (Either Text (Vector (SigmaE () ProofInput))) getTxSigma tx = do resp <- call $ C.getTxSigma tx logTest $ T.unlines ["PRE TX SIGMA:", showt resp] diff --git a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/Channel.hs b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/Channel.hs index 92ebe0ff..db67642a 100644 --- a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/Channel.hs +++ b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/Channel.hs @@ -87,7 +87,7 @@ data PlayerEnv = PlayerEnv -- ^ partner's public key , playerEnv'commonBoxId :: !BoxId -- ^ shared boxId with initial balance - , playerEnv'commonScript :: !(Sigma ProofInput) + , playerEnv'commonScript :: !(SigmaE () ProofInput) -- ^ common sigma expression that guards shared balance box , playerEnv'revoceProc :: !RevoceProc } @@ -312,7 +312,7 @@ signOffChainTx (Player me) (Player other) preTx = liftIO $ do myProofEnv = getProofEnv $ playerEnv'wallet myEnv otherProofEnv = getProofEnv $ playerEnv'wallet otherEnv proof <- fmap eitherToMaybe $ runProve $ do - comQueryExpr <- initMultiSigProof knownKeys commonScript + comQueryExpr <- initMultiSigProof knownKeys $ Right <$> commonScript (myCommitments, mySecret) <- queryCommitments myKeys comQueryExpr (otherCommitments, otherSecret) <- queryCommitments otherKeys comQueryExpr commitments <- appendCommitments [(myKeys, myCommitments), (otherKeys, otherCommitments)] @@ -372,7 +372,7 @@ extractRevoceBox p secret = do -newGame :: BoxId -> Sigma ProofInput -> Balance -> Wallet -> Wallet -> App Game +newGame :: BoxId -> SigmaE () ProofInput -> Balance -> Wallet -> Wallet -> App Game newGame commonBoxId commonScript balance alice bob = do alicePlayer <- newPlayer commonBoxId commonScript balance alice (getWalletPublicKey bob) bobPlayer <- newPlayer commonBoxId commonScript balance bob (getWalletPublicKey alice) @@ -381,7 +381,7 @@ newGame commonBoxId commonScript balance alice bob = do , game'bob = bobPlayer } -newPlayer :: BoxId -> Sigma ProofInput -> Balance -> Wallet -> PublicKey -> App Player +newPlayer :: BoxId -> SigmaE () ProofInput -> Balance -> Wallet -> PublicKey -> App Player newPlayer commonBoxId commonScript balance wallet partnerPubKey = do proc <- newRevoceProc wallet player <- liftIO $ do diff --git a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/MultiSig.hs b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/MultiSig.hs index 4e11dc9c..7e0a4cba 100644 --- a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/MultiSig.hs +++ b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Scripts/MultiSig.hs @@ -11,7 +11,6 @@ module Hschain.Utxo.Test.Client.Scripts.MultiSig( , simpleSpendTo ) where -import Data.Boolean import Control.Monad import Control.Monad.IO.Class @@ -50,7 +49,7 @@ multiSigExchange = do bobShareValue = 6 -getSharedBoxTx :: Wallet -> Wallet -> (Int64, Int64) -> (Int64, Int64) -> BoxId -> BoxId -> App (Tx, BoxId, Sigma ProofInput) +getSharedBoxTx :: Wallet -> Wallet -> (Int64, Int64) -> (Int64, Int64) -> BoxId -> BoxId -> App (Tx, BoxId, SigmaE () ProofInput) getSharedBoxTx alice bob (aliceValue, aliceChange) (bobValue, bobChange) aliceBox bobBox = liftIO $ do aliceProof <- fmap eitherToMaybe $ newProof aliceEnv (singleOwnerSigmaExpr alice) message bobProof <- fmap eitherToMaybe $ newProof bobEnv (singleOwnerSigmaExpr bob) message @@ -82,7 +81,9 @@ getSharedBoxTx alice bob (aliceValue, aliceChange) (bobValue, bobChange) aliceBo , box'args = mempty } - commonScript = dlogSigma alicePk &&* dlogSigma bobPk + commonScript = AND () [ dlogSigma alicePk + , dlogSigma bobPk + ] alicePk = getWalletPublicKey alice bobPk = getWalletPublicKey bob @@ -94,7 +95,7 @@ getSharedBoxTx alice bob (aliceValue, aliceChange) (bobValue, bobChange) aliceBo spendCommonBoxTx :: Wallet -> Wallet -> BoxId -> (Int64, Int64) -> App (Tx, BoxId, BoxId) spendCommonBoxTx alice bob commonBoxId (aliceValue, bobValue) = liftIO $ do proof <- fmap eitherToMaybe $ runProve $ do - comQueryExpr <- initMultiSigProof knownKeys commonScript + comQueryExpr <- initMultiSigProof knownKeys $ Right <$> commonScript (aliceCommitments, aliceSecret) <- queryCommitments aliceKeys comQueryExpr (bobCommitments, bobSecret) <- queryCommitments bobKeys comQueryExpr commitments <- appendCommitments [(aliceKeys, aliceCommitments), (bobKeys, bobCommitments)] @@ -127,8 +128,9 @@ spendCommonBoxTx alice bob commonBoxId (aliceValue, bobValue) = liftIO $ do , boxInputRef'sigMask = SigAll } - commonScript = dlogSigma alicePk &&* dlogSigma bobPk - + commonScript = AND () [ dlogSigma alicePk + , dlogSigma bobPk + ] aliceBox = singleSpendBox aliceValue alicePk bobBox = singleSpendBox bobValue bobPk diff --git a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Wallet.hs b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Wallet.hs index 30291420..d6d5d45d 100644 --- a/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Wallet.hs +++ b/hschain-utxo-test/src/Hschain/Utxo/Test/Client/Wallet.hs @@ -27,7 +27,6 @@ import Control.Concurrent.STM import Control.Monad.IO.Class import Control.Monad.Except -import Data.Fix import Data.Int import Data.Maybe import Data.Text (Text) @@ -77,7 +76,7 @@ getBalance Wallet{..} = do -- | Create proof for a most simple expression of @pk user-key@ getOwnerProof :: MonadIO io => Wallet -> Tx -> io (Either Text Proof) getOwnerProof w@Wallet{..} tx = - liftIO $ newProof env (Fix $ SigmaPk $ dlogInput (getWalletPublicKey w)) (getSigMessage SigAll tx) + liftIO $ newProof env (Leaf () $ dlogInput (getWalletPublicKey w)) (getSigMessage SigAll tx) where env = toProofEnv [getKeyPair wallet'privateKey] @@ -109,21 +108,21 @@ newSendTx wallet send@Send{..} = do totalAmount <- fmap (fromMaybe 0) $ getBoxBalance send'from return $ SendBack totalAmount -newProofOrFail :: ProofEnv -> Sigma ProofInput -> SigMessage -> App Proof +newProofOrFail :: ProofEnv -> SigmaE () ProofInput -> SigMessage -> App Proof newProofOrFail env expr message = do eProof <- liftIO $ newProof env expr message case eProof of Right proof -> return proof Left err -> throwError err -getTxSigmaUnsafe :: Tx -> App (Vector (Sigma ProofInput)) +getTxSigmaUnsafe :: Tx -> App (Vector (SigmaE () ProofInput)) getTxSigmaUnsafe tx = either throwError pure =<< getTxSigma tx -getSigmaForProof :: Tx -> App (Vector (Sigma ProofInput)) +getSigmaForProof :: Tx -> App (Vector (SigmaE () ProofInput)) getSigmaForProof tx = getTxSigmaUnsafe tx -singleOwnerSigmaExpr :: Wallet -> Sigma ProofInput -singleOwnerSigmaExpr wallet = Fix $ SigmaPk $ dlogInput $ getWalletPublicKey wallet +singleOwnerSigmaExpr :: Wallet -> SigmaE () ProofInput +singleOwnerSigmaExpr wallet = Leaf () $ dlogInput $ getWalletPublicKey wallet -- | Sends money with exchange -- @@ -178,7 +177,7 @@ extractSenderReceiverIds tx = toBoxId = computeBoxId txId -- | BoxInputRef for single owner of the input. -singleOwnerBoxRef :: Wallet -> BoxId -> BoxInputRef (Sigma ProofInput) +singleOwnerBoxRef :: Wallet -> BoxId -> BoxInputRef (SigmaE () ProofInput) singleOwnerBoxRef wallet boxId = BoxInputRef { boxInputRef'id = boxId , boxInputRef'proof = Just $ singleOwnerSigmaExpr wallet