diff --git a/language-plutus-core/language-plutus-core.cabal b/language-plutus-core/language-plutus-core.cabal index cc49de0509d..c031ca39cc4 100644 --- a/language-plutus-core/language-plutus-core.cabal +++ b/language-plutus-core/language-plutus-core.cabal @@ -63,6 +63,7 @@ library Language.PlutusCore.Generators.Test PlutusPrelude Common + Data.ByteString.Lazy.Hash PlcTestUtils build-tool-depends: alex:alex, happy:happy >= 1.17.1 hs-source-dirs: src prelude stdlib generators common @@ -115,6 +116,7 @@ library build-depends: base >=4.9 && <5, bytestring -any, + cryptonite -any, containers -any, array -any, mtl -any, @@ -127,6 +129,7 @@ library composition-prelude >=1.1.0.1, template-haskell -any, th-lift-instances -any, + memory -any, mmorph -any, cborg -any, serialise -any, diff --git a/language-plutus-core/src/Data/ByteString/Lazy/Hash.hs b/language-plutus-core/src/Data/ByteString/Lazy/Hash.hs new file mode 100644 index 00000000000..30cce1d2d21 --- /dev/null +++ b/language-plutus-core/src/Data/ByteString/Lazy/Hash.hs @@ -0,0 +1,18 @@ +-- | Hash functions for lazy [[Data.ByteString.Lazy.ByteString]]s +{-# LANGUAGE TypeApplications #-} +module Data.ByteString.Lazy.Hash + ( sha2 + , sha3 + ) where + +import Crypto.Hash (SHA256, SHA3_256, hashlazy) +import qualified Data.ByteArray as B +import qualified Data.ByteString.Lazy as BSL + +-- | Hash a [[BSL.ByteString]] using the SHA-256 hash function. +sha2 :: BSL.ByteString -> BSL.ByteString +sha2 = BSL.fromStrict . B.convert . hashlazy @SHA256 + +-- | Hash a [[BSL.ByteString]] using the SHA3-256 hash function. +sha3 :: BSL.ByteString -> BSL.ByteString +sha3 = BSL.fromStrict . B.convert . hashlazy @SHA3_256 diff --git a/language-plutus-core/src/Language/PlutusCore/Constant/Apply.hs b/language-plutus-core/src/Language/PlutusCore/Constant/Apply.hs index aeaf0048214..54281555402 100644 --- a/language-plutus-core/src/Language/PlutusCore/Constant/Apply.hs +++ b/language-plutus-core/src/Language/PlutusCore/Constant/Apply.hs @@ -28,6 +28,7 @@ import PlutusPrelude import Control.Monad.Trans.Class (lift) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Hash as Hash import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap @@ -240,8 +241,8 @@ applyBuiltinName Concatenate = applyTypedBuiltinName typedConcatenate applyBuiltinName TakeByteString = applyTypedBuiltinName typedTakeByteString (BSL.take . fromIntegral) applyBuiltinName DropByteString = applyTypedBuiltinName typedDropByteString (BSL.drop . fromIntegral) applyBuiltinName ResizeByteString = applyTypedBuiltinName typedResizeByteString (const id) -applyBuiltinName SHA2 = applyTypedBuiltinName typedSHA2 undefined -applyBuiltinName SHA3 = applyTypedBuiltinName typedSHA3 undefined +applyBuiltinName SHA2 = applyTypedBuiltinName typedSHA2 Hash.sha2 +applyBuiltinName SHA3 = applyTypedBuiltinName typedSHA3 Hash.sha3 applyBuiltinName VerifySignature = applyTypedBuiltinName typedVerifySignature undefined applyBuiltinName EqByteString = applyTypedBuiltinName typedEqByteString (==) applyBuiltinName TxHash = applyTypedBuiltinName typedTxHash undefined diff --git a/language-plutus-core/test/Evaluation/Constant/Success.hs b/language-plutus-core/test/Evaluation/Constant/Success.hs index 509a50cdabd..91b1ea0af9b 100644 --- a/language-plutus-core/test/Evaluation/Constant/Success.hs +++ b/language-plutus-core/test/Evaluation/Constant/Success.hs @@ -10,6 +10,7 @@ import Evaluation.Constant.Apply import Control.Monad.Morph import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Hash as Hash import Data.Maybe import Hedgehog import Test.Tasty @@ -99,6 +100,18 @@ test_typedTakeByteStringSuccess $ prop_applyBuiltinNameSuccess typedTakeByteString (BSL.take . fromIntegral) $ genTypedBuiltinDef +test_typedSHA2Success :: TestTree +test_typedSHA2Success + = testProperty "typedSHA2" + $ prop_applyBuiltinNameSuccess typedSHA2 Hash.sha2 + $ genTypedBuiltinDef + +test_typedSHA3Success :: TestTree +test_typedSHA3Success + = testProperty "typedSHA3" + $ prop_applyBuiltinNameSuccess typedSHA3 Hash.sha3 + $ genTypedBuiltinDef + test_typedDropByteStringSuccess :: TestTree test_typedDropByteStringSuccess = testProperty "typedDropByteString" @@ -130,6 +143,8 @@ test_applyBuiltinNameSuccess = , test_typedTakeByteStringSuccess , test_typedDropByteStringSuccess , test_typedEqByteStringSuccess + , test_typedSHA2Success + , test_typedSHA3Success ] -- | Generates in-bounds constants and checks that their evaluation results in an 'EvaluationSuccess'. diff --git a/pkgs/default.nix b/pkgs/default.nix index 49b2df85a5d..fa7a7bf272a 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -43094,6 +43094,7 @@ license = stdenv.lib.licenses.bsd3; , composition-prelude , containers , criterion +, cryptonite , deepseq , dependent-map , dependent-sum @@ -43101,6 +43102,7 @@ license = stdenv.lib.licenses.bsd3; , happy , hedgehog , lens +, memory , mmorph , mtl , prettyprinter @@ -43131,12 +43133,14 @@ bytestring cborg composition-prelude containers +cryptonite deepseq dependent-map dependent-sum filepath hedgehog lens +memory mmorph mtl prettyprinter @@ -55701,6 +55705,7 @@ license = stdenv.lib.licenses.bsd3; , http-media , insert-ordered-containers , lens +, memory , mtl , network , newtype-generics @@ -55732,6 +55737,7 @@ hint http-media insert-ordered-containers lens +memory mtl network newtype-generics @@ -55775,9 +55781,11 @@ license = stdenv.lib.licenses.bsd3; , directory , exceptions , file-embed +, filepath , gitrev , hint , hspec +, hspec-discover , http-media , http-types , insert-ordered-containers @@ -55802,6 +55810,7 @@ license = stdenv.lib.licenses.bsd3; , temporary , text , transformers +, unordered-containers , wai , wai-cors , wai-extra @@ -55815,6 +55824,7 @@ version = "0.1.0.0"; src = .././plutus-playground/plutus-playground-server; isLibrary = true; isExecutable = true; +enableSeparateDataOutput = true; libraryHaskellDepends = [ aeson base @@ -55860,6 +55870,7 @@ containers cryptonite data-default-class file-embed +filepath gitrev hspec http-media @@ -55890,8 +55901,10 @@ warp testHaskellDepends = [ aeson base +bytestring containers data-default-class +file-embed gitrev hspec http-media @@ -55910,11 +55923,16 @@ servant-server swagger2 text transformers +unordered-containers wai wai-cors wai-extra +wallet-api warp ]; +testToolDepends = [ +hspec-discover +]; doHaddock = false; homepage = "https://github.com/iohk/plutus#readme"; license = stdenv.lib.licenses.bsd3; @@ -55924,6 +55942,7 @@ license = stdenv.lib.licenses.bsd3; ({ mkDerivation , base +, bytestring , doctest , language-plutus-core , markdown-unlit @@ -55942,6 +55961,7 @@ version = "0.1.0.0"; src = .././plutus-tx; libraryHaskellDepends = [ base +bytestring language-plutus-core plutus-core-interpreter plutus-tx-plugin @@ -56024,6 +56044,7 @@ license = stdenv.lib.licenses.bsd3; ({ mkDerivation , base +, bytestring , containers , hedgehog , lens @@ -56044,6 +56065,7 @@ version = "0.1.0.0"; src = .././plutus-use-cases; libraryHaskellDepends = [ base +bytestring containers lens mtl diff --git a/plutus-playground/plutus-playground-server/test/Playground/UsecasesSpec.hs b/plutus-playground/plutus-playground-server/test/Playground/UsecasesSpec.hs index 7ad14d3e9b7..b5a253c9681 100644 --- a/plutus-playground/plutus-playground-server/test/Playground/UsecasesSpec.hs +++ b/plutus-playground/plutus-playground-server/test/Playground/UsecasesSpec.hs @@ -6,10 +6,13 @@ module Playground.UsecasesSpec import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Text as JSON +import Data.Aeson.Types (object, (.=)) import qualified Data.ByteString.Char8 as BSC import Data.Either (isRight) import Data.Swagger.Internal (Schema) import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL import Ledger.Types (Blockchain, Value) import Playground.API (Evaluation (Evaluation), Expression (Action, Wait), Fn (Fn), FunctionSchema, PlaygroundError, SourceCode (SourceCode)) @@ -58,6 +61,18 @@ gameSpec :: Spec gameSpec = describe "game" $ do it "should compile" $ compile game >>= (`shouldSatisfy` isRight) + it "should unlock the funds" $ + evaluate gameEvalSuccess >>= + (`shouldSatisfy` hasFundsDistribution + [ (Wallet 1, 12) + , (Wallet 2, 8) + ]) + it "should keep the funds" $ + evaluate gameEvalFailure >>= + (`shouldSatisfy` hasFundsDistribution + [ (Wallet 1, 10) + , (Wallet 2, 8) + ]) it "Sequential fund transfer fails - 'Game' script - 'payToPublicKey_' action" $ evaluate payAll >>= @@ -67,27 +82,49 @@ gameSpec = , (Wallet 3, 10) ]) where + gameEvalFailure = + Evaluation + [(Wallet 1, 10), (Wallet 2, 10)] + [ Action (Fn "startGame") (Wallet 1) [] + , Action (Fn "lock") (Wallet 2) + [ JSON.String "\"abcde\"" + , JSON.String "{\"getValue\": 2}"] + , Action (Fn "guess") (Wallet 1) [JSON.String "\"ade\""] + ] + (sourceCode game) + [] + gameEvalSuccess = + Evaluation + [(Wallet 1, 10), (Wallet 2, 10)] + [ Action (Fn "startGame") (Wallet 1) [] + , Action (Fn "lock") (Wallet 2) + [ JSON.String "\"abcde\"" + , JSON.String "{\"getValue\": 2}"] + , Action (Fn "guess") (Wallet 1) [JSON.String "\"abcde\""] + ] + (sourceCode game) + [] payAll = Evaluation [(Wallet 1, 10), (Wallet 2, 10), (Wallet 3, 10)] [ Action - (Fn "payToPublicKey_") - (Wallet 1) - [ JSON.String "{\"getValue\":9}" - , JSON.String "{\"getPubKey\":2}" - ] + (Fn "payToPublicKey_") + (Wallet 1) + [ JSON.String "{\"getValue\":9}" + , JSON.String "{\"getPubKey\":2}" + ] , Action - (Fn "payToPublicKey_") - (Wallet 2) - [ JSON.String "{\"getValue\":9}" - , JSON.String "{\"getPubKey\":3}" - ] + (Fn "payToPublicKey_") + (Wallet 2) + [ JSON.String "{\"getValue\":9}" + , JSON.String "{\"getPubKey\":3}" + ] , Action - (Fn "payToPublicKey_") - (Wallet 3) - [ JSON.String "{\"getValue\":9}" - , JSON.String "{\"getPubKey\":1}" - ] + (Fn "payToPublicKey_") + (Wallet 3) + [ JSON.String "{\"getValue\":9}" + , JSON.String "{\"getPubKey\":1}" + ] ] (sourceCode game) [] @@ -107,8 +144,77 @@ messagesSpec = crowdfundingSpec :: Spec crowdfundingSpec = - describe "crowdfunding" $ - it "should compile" $ compile crowdfunding >>= (`shouldSatisfy` isRight) + describe "crowdfunding" $ do + it "should compile" $ compile crowdfunding >>= (`shouldSatisfy` isRight) + it "should run successful campaign" + $ evaluate successfulCampaign >>= + (`shouldSatisfy` hasFundsDistribution + [ (Wallet 1, 26) + , (Wallet 2, 2) + , (Wallet 3, 2) + ]) + it "should run failed campaign" + $ evaluate failedCampaign >>= + (`shouldSatisfy` hasFundsDistribution + [ (Wallet 1, 10) + , (Wallet 2, 10) + , (Wallet 3, 10) + ]) + where + failedCampaign = + Evaluation + [(Wallet 1, 10), (Wallet 2, 10), (Wallet 3, 10)] + [ Action + (Fn "scheduleCollection") + (Wallet 1) + [ theCampaign + ] + , Action + (Fn "contribute") + (Wallet 2) + [ theCampaign + , theContribution + ] + , Wait 20 + ] + (sourceCode crowdfunding) + [] + successfulCampaign = + Evaluation + [(Wallet 1, 10), (Wallet 2, 10), (Wallet 3, 10)] + [ Action + (Fn "scheduleCollection") + (Wallet 1) + [ theCampaign + ] + , Action + (Fn "contribute") + (Wallet 2) + [ theCampaign + , theContribution + ] + , Action + (Fn "contribute") + (Wallet 3) + [ theCampaign + , theContribution + ] + , Wait 10 + ] + (sourceCode crowdfunding) + [] + mkI :: Int -> JSON.Value + mkI = JSON.toJSON + theCampaign = JSON.String $ TL.toStrict $ JSON.encodeToLazyText $ + object + [ "campaignDeadline" .= object ["getHeight" .= mkI 10] + , "campaignTarget" .= object ["getValue" .= mkI 15] + , "campaignCollectionDeadline" .= object ["getHeight" .= mkI 20] + , "campaignOwner" .= object ["getPubKey" .= mkI 1] + ] + theContribution = JSON.String $ TL.toStrict $ JSON.encodeToLazyText $ + object + [ "getValue" .= mkI 8] sourceCode :: BSC.ByteString -> SourceCode sourceCode = SourceCode . Text.pack . BSC.unpack diff --git a/plutus-playground/plutus-playground-server/usecases/CrowdFunding.hs b/plutus-playground/plutus-playground-server/usecases/CrowdFunding.hs index 044e4bb68d1..b53b582bcfb 100644 --- a/plutus-playground/plutus-playground-server/usecases/CrowdFunding.hs +++ b/plutus-playground/plutus-playground-server/usecases/CrowdFunding.hs @@ -28,31 +28,6 @@ data CampaignAction = Collect | Refund PlutusTx.makeLift ''CampaignAction --- | Contribute funds to the campaign (contributor) --- -contribute :: Campaign -> Value -> MockWallet () -contribute cmp value = do - _ <- if value <= 0 then throwOtherError "Must contribute a positive value" else pure () - ownPK <- ownPubKey - let ds = DataScript (Ledger.lifted ownPK) - tx <- payToScript (campaignAddress cmp) value ds - logMsg "Submitted contribution" - - register (refundTrigger cmp) (refundHandler (Ledger.hashTx tx) cmp) - logMsg "Registered refund trigger" - --- | Register a [[EventHandler]] to collect all the funds of a campaign --- -scheduleCollection :: Campaign -> MockWallet () -scheduleCollection cmp = register (collectFundsTrigger cmp) (EventHandler (\_ -> do - logMsg "Collecting funds" - let redeemerScript = Ledger.RedeemerScript (Ledger.lifted Collect) - collectFromScript (contributionScript cmp) redeemerScript)) - --- | The address of a [[Campaign]] -campaignAddress :: Campaign -> Ledger.Address' -campaignAddress = Ledger.scriptAddress . contributionScript - -- | The validator script that determines whether the campaign owner can -- retrieve the funds or the contributors can claim a refund. -- @@ -73,52 +48,91 @@ campaignAddress = Ledger.scriptAddress . contributionScript contributionScript :: Campaign -> ValidatorScript contributionScript cmp = ValidatorScript val where val = Ledger.applyScript mkValidator (Ledger.lifted cmp) - mkValidator = Ledger.fromCompiledCode $$(PlutusTx.compile [|| (\Campaign{..} (act :: CampaignAction) (con :: CampaignActor) (p :: PendingTx ValidatorHash) -> - let - - infixr 3 && - (&&) :: Bool -> Bool -> Bool - (&&) = $$(PlutusTx.and) - - PendingTx ps outs _ _ (Height h) _ _ = p - - deadline :: Int - deadline = let Height h' = campaignDeadline in h' - - collectionDeadline :: Int - collectionDeadline = let Height h' = campaignCollectionDeadline in h' - - target :: Int - target = let Value v = campaignTarget in v - - -- | The total value of all contributions - totalInputs :: Int - totalInputs = - let v (PendingTxIn _ _ (Value vl)) = vl in - $$(P.foldr) (\i total -> total + v i) 0 ps + mkValidator = Ledger.fromCompiledCode $$(PlutusTx.compile [|| + + -- The validator script is a function of for arguments: + -- 1. The 'Campaign' definition. This argument is provided by the Plutus client, using 'Ledger.applyScript'. + -- As a result, the 'Campaign' definition is part of the script address, and different campaigns have different addresses. + -- The Campaign{..} syntax means that all fields of the 'Campaign' value are in scope (for example 'campaignDeadline' in l. 70). + -- See note [RecordWildCards]. + -- + -- 2. A 'CampaignAction'. This is the redeemer script. It is provided by the redeeming transaction. + -- + -- 3. A 'CampaignActor'. This is the data script. It is provided by the producing transaction (the contribution) + -- + -- 4. A 'PendingTx' value. It contains information about the current transaction and is provided by the slot leader. + -- See note [PendingTx] + \Campaign{..} (act :: CampaignAction) (con :: CampaignActor) (p :: PendingTx') -> + let + + infixr 3 && + (&&) :: Bool -> Bool -> Bool + (&&) = $$(PlutusTx.and) + + PendingTx ps outs _ _ (Height h) _ _ = p + + deadline :: Int + deadline = let Height h' = campaignDeadline in h' + + collectionDeadline :: Int + collectionDeadline = let Height h' = campaignCollectionDeadline in h' + + target :: Int + target = let Value v = campaignTarget in v + + -- | The total value of all contributions + totalInputs :: Int + totalInputs = + let v (PendingTxIn _ _ (Value vl)) = vl in + $$(P.foldr) (\i total -> total + v i) 0 ps + + isValid = case act of + Refund -> -- the "refund" branch + let + + contributorTxOut :: PendingTxOut -> Bool + contributorTxOut o = case $$(pubKeyOutput) o of + Nothing -> False + Just pk -> $$(eqPubKey) pk con + + -- Check that all outputs are paid to the public key + -- of the contributor (this key is provided as the data script `con`) + contributorOnly = $$(P.all) contributorTxOut outs + + refundable = h > collectionDeadline && contributorOnly && $$(txSignedBy) p con + + in refundable + Collect -> -- the "successful campaign" branch + let + payToOwner = h > deadline && h <= collectionDeadline && totalInputs >= target && $$(txSignedBy) p campaignOwner + in payToOwner + in + if isValid then () else $$(P.error) () ||]) - isValid = case act of - Refund -> -- the "refund" branch - let - - contributorTxOut :: PendingTxOut -> Bool - contributorTxOut o = case $$(pubKeyOutput) o of - Nothing -> False - Just pk -> $$(eqPubKey) pk con +-- | The address of a [[Campaign]] +campaignAddress :: Campaign -> Ledger.Address' +campaignAddress = Ledger.scriptAddress . contributionScript - -- Check that all outputs are paid to the public key - -- of the contributor (this key is provided as the data script `con`) - contributorOnly = $$(P.all) contributorTxOut outs +-- | Contribute funds to the campaign (contributor) +-- +contribute :: Campaign -> Value -> MockWallet () +contribute cmp value = do + _ <- if value <= 0 then throwOtherError "Must contribute a positive value" else pure () + ownPK <- ownPubKey + let ds = DataScript (Ledger.lifted ownPK) + tx <- payToScript (campaignAddress cmp) value ds + logMsg "Submitted contribution" - refundable = h > collectionDeadline && contributorOnly && $$(txSignedBy) p con + register (refundTrigger cmp) (refundHandler (Ledger.hashTx tx) cmp) + logMsg "Registered refund trigger" - in refundable - Collect -> -- the "successful campaign" branch - let - payToOwner = h > deadline && h <= collectionDeadline && totalInputs >= target && $$(txSignedBy) p campaignOwner - in payToOwner - in - if isValid then () else $$(P.error) ()) ||]) +-- | Register a [[EventHandler]] to collect all the funds of a campaign +-- +scheduleCollection :: Campaign -> MockWallet () +scheduleCollection cmp = register (collectFundsTrigger cmp) (EventHandler (\_ -> do + logMsg "Collecting funds" + let redeemerScript = Ledger.RedeemerScript (Ledger.lifted Collect) + collectFromScript (contributionScript cmp) redeemerScript)) -- | An event trigger that fires when a refund of campaign contributions can be claimed refundTrigger :: Campaign -> EventTrigger @@ -142,3 +156,22 @@ refundHandler txid cmp = EventHandler (\_ -> do $(mkFunction 'scheduleCollection) $(mkFunction 'contribute) + +{- note [RecordWildCards] + +We can use the syntax "Campaign{..}" here because the 'RecordWildCards' +extension is enabled automatically by the Playground backend. + +The extension is documented here: +* https://downloads.haskell.org/~ghc/7.2.1/docs/html/users_guide/syntax-extns.html + +A list of extensions that are enabled by default for the Playground can be found here: +* https://github.com/input-output-hk/plutus/blob/b0f49a0cc657cd1a4eaa4af72a6d69996b16d07a/plutus-playground/plutus-playground-server/src/Playground/Interpreter.hs#L44 + +-} + +{- note [PendingTx] + +This part of the API (the PendingTx argument) is experimental and subject to change. + +-} \ No newline at end of file diff --git a/plutus-playground/plutus-playground-server/usecases/Game.hs b/plutus-playground/plutus-playground-server/usecases/Game.hs index 78be4cfb98c..81a7c585491 100644 --- a/plutus-playground/plutus-playground-server/usecases/Game.hs +++ b/plutus-playground/plutus-playground-server/usecases/Game.hs @@ -33,7 +33,7 @@ mkRedeemerScript word = gameValidator :: ValidatorScript gameValidator = ValidatorScript (Ledger.fromCompiledCode $$(PlutusTx.compile [|| - \(ClearString guess) (HashedString actual) (p :: PendingTx ValidatorHash) -> + \(ClearString guess) (HashedString actual) (p :: PendingTx') -> if $$(P.equalsByteString) actual ($$(P.sha2_256) guess) then () diff --git a/plutus-playground/plutus-playground-server/usecases/Vesting.hs b/plutus-playground/plutus-playground-server/usecases/Vesting.hs index dcaf8af870c..76532c96752 100644 --- a/plutus-playground/plutus-playground-server/usecases/Vesting.hs +++ b/plutus-playground/plutus-playground-server/usecases/Vesting.hs @@ -85,7 +85,7 @@ validatorScriptHash = validatorScript :: Vesting -> ValidatorScript validatorScript v = ValidatorScript val where val = Ledger.applyScript inner (Ledger.lifted v) - inner = Ledger.fromCompiledCode $$(PlutusTx.compile [|| \Vesting{..} () VestingData{..} (p :: PendingTx ValidatorHash) -> + inner = Ledger.fromCompiledCode $$(PlutusTx.compile [|| \Vesting{..} () VestingData{..} (p :: PendingTx') -> let eqPk :: PubKey -> PubKey -> Bool diff --git a/plutus-tx-plugin/test/Plugin/Spec.hs b/plutus-tx-plugin/test/Plugin/Spec.hs index 31c21d6e910..7e15674dc10 100644 --- a/plutus-tx-plugin/test/Plugin/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Spec.hs @@ -82,6 +82,8 @@ primitives = testNested "primitives" [ --, goldenPlc "blocknum" blocknumPlc , goldenPir "bytestring" bytestring , goldenEval "bytestringApply" [ getPlc bytestring, unsafeLiftProgram ("hello"::ByteString) ] + , goldenEval "sha2_256" [ getPlc sha2, unsafeLiftProgram ("hello" :: ByteString)] + , goldenEval "equalsByteString" [ getPlc bsEquals, unsafeLiftProgram ("hello" :: ByteString), unsafeLiftProgram ("hello" :: ByteString)] , goldenPir "verify" verify ] @@ -131,6 +133,12 @@ ifThenElse = plc @"ifThenElse" (\(x::Int) (y::Int) -> if x == y then x else y) bytestring :: CompiledCode bytestring = plc @"bytestring" (\(x::ByteString) -> x) +sha2 :: CompiledCode +sha2 = plc @"sha2" (\(x :: ByteString) -> Builtins.sha2_256 x) + +bsEquals :: CompiledCode +bsEquals = plc @"bsEquals" (\(x :: ByteString) (y :: ByteString) -> Builtins.equalsByteString x y) + verify :: CompiledCode verify = plc @"verify" (\(x::ByteString) (y::ByteString) (z::ByteString) -> Builtins.verifySignature x y z) diff --git a/plutus-tx-plugin/test/Plugin/primitives/equalsByteString.plc.golden b/plutus-tx-plugin/test/Plugin/primitives/equalsByteString.plc.golden new file mode 100644 index 00000000000..38c8662edba --- /dev/null +++ b/plutus-tx-plugin/test/Plugin/primitives/equalsByteString.plc.golden @@ -0,0 +1,5 @@ +(abs + out_Bool_96 + (type) + (lam case_True_97 out_Bool_96 (lam case_False_98 out_Bool_96 case_True_97)) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/primitives/sha2_256.plc.golden b/plutus-tx-plugin/test/Plugin/primitives/sha2_256.plc.golden new file mode 100644 index 00000000000..a1427988720 --- /dev/null +++ b/plutus-tx-plugin/test/Plugin/primitives/sha2_256.plc.golden @@ -0,0 +1 @@ +(con 32 ! #2cf24dba5fb0a3e26e83b2ac5b9e29e1b161e5c1fa7425e7343362938b9824) \ No newline at end of file diff --git a/plutus-use-cases/plutus-use-cases.cabal b/plutus-use-cases/plutus-use-cases.cabal index ad0b715b988..0da73a7d012 100644 --- a/plutus-use-cases/plutus-use-cases.cabal +++ b/plutus-use-cases/plutus-use-cases.cabal @@ -23,6 +23,7 @@ library hs-source-dirs: src build-depends: base -any, + bytestring -any, containers -any, mtl -any, template-haskell -any, @@ -39,6 +40,7 @@ library Language.PlutusTx.Coordination.Contracts Language.PlutusTx.Coordination.Contracts.CrowdFunding Language.PlutusTx.Coordination.Contracts.Future + Language.PlutusTx.Coordination.Contracts.Game Language.PlutusTx.Coordination.Contracts.Vesting Language.PlutusTx.Coordination.Contracts.Swap ghc-options: @@ -54,6 +56,7 @@ test-suite plutus-use-cases-test other-modules: Spec.Crowdfunding Spec.Future + Spec.Game Spec.Vesting build-depends: base >=4.9 && <5, diff --git a/plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Game.hs b/plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Game.hs new file mode 100644 index 00000000000..7a79958a85a --- /dev/null +++ b/plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Game.hs @@ -0,0 +1,55 @@ +-- | A guessing game +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS -fplugin=Language.PlutusTx.Plugin -fplugin-opt Language.PlutusTx.Plugin:dont-typecheck #-} +module Language.PlutusTx.Coordination.Contracts.Game( + lock, + guess, + startGame + ) where + +import qualified Language.PlutusTx as PlutusTx +import qualified Language.PlutusTx.Prelude as P +import Ledger +import Ledger.Validation +import Wallet + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as C + +data HashedString = HashedString ByteString + +PlutusTx.makeLift ''HashedString + +data ClearString = ClearString ByteString + +PlutusTx.makeLift ''ClearString + +gameValidator :: ValidatorScript +gameValidator = ValidatorScript (Ledger.fromCompiledCode $$(PlutusTx.compile [|| + \(ClearString guess') (HashedString actual) (_ :: PendingTx ValidatorHash) -> + + if $$(P.equalsByteString) actual ($$(P.sha2_256) guess') + then () + else $$(P.traceH) "WRONG!" ($$(P.error) ()) + + ||])) + +gameAddress :: Address' +gameAddress = Ledger.scriptAddress gameValidator + +lock :: (WalletAPI m, WalletDiagnostics m) => String -> Value -> m () +lock word vl = do + let hashedWord = plcSHA2_256 (C.pack word) + ds = DataScript (Ledger.lifted (HashedString hashedWord)) + payToScript_ gameAddress vl ds + +guess :: (WalletAPI m, WalletDiagnostics m) => String -> m () +guess word = do + let clearWord = C.pack word + redeemer = RedeemerScript (Ledger.lifted (ClearString clearWord)) + collectFromScript gameValidator redeemer + +-- | Tell the wallet to start watching the address of the game script +startGame :: WalletAPI m => m () +startGame = startWatching gameAddress \ No newline at end of file diff --git a/plutus-use-cases/test/Spec.hs b/plutus-use-cases/test/Spec.hs index b9896554a72..4c131899201 100644 --- a/plutus-use-cases/test/Spec.hs +++ b/plutus-use-cases/test/Spec.hs @@ -3,6 +3,7 @@ module Main(main) where import qualified Spec.Crowdfunding import qualified Spec.Future +import qualified Spec.Game import qualified Spec.Vesting import Test.Tasty import Test.Tasty.Hedgehog (HedgehogTestLimit (..)) @@ -21,5 +22,6 @@ tests :: TestTree tests = localOption limit $ testGroup "use cases" [ Spec.Crowdfunding.tests, Spec.Vesting.tests, - Spec.Future.tests + Spec.Future.tests, + Spec.Game.tests ] diff --git a/plutus-use-cases/test/Spec/Game.hs b/plutus-use-cases/test/Spec/Game.hs new file mode 100644 index 00000000000..a2d93f6b8a7 --- /dev/null +++ b/plutus-use-cases/test/Spec/Game.hs @@ -0,0 +1,83 @@ +module Spec.Game(tests) where + +import Control.Monad (void) +import Data.Either (isRight) +import Data.Foldable (traverse_) +import qualified Data.Map as Map + +import Hedgehog (Property, forAll, property) +import qualified Hedgehog +import Test.Tasty +import Test.Tasty.Hedgehog (testProperty) + +import qualified Ledger +import Wallet.API (PubKey (..)) +import Wallet.Emulator +import qualified Wallet.Generators as Gen + +import Language.PlutusTx.Coordination.Contracts.Game (guess, lock, startGame) + +tests :: TestTree +tests = testGroup "game" [ + testProperty "lock" lockProp, + testProperty "guess right" guessRightProp, + testProperty "guess wrong" guessWrongProp + ] + +lockProp :: Property +lockProp = checkTrace $ do + lockFunds + traverse_ (uncurry assertOwnFundsEq) [ + (w1, startingBalance - 10), + (w2, startingBalance)] + +guessRightProp :: Property +guessRightProp = checkTrace $ do + void $ walletAction w2 startGame + lockFunds + void $ walletAction w2 (guess "abcde") + updateAll + traverse_ (uncurry assertOwnFundsEq) [ + (w1, startingBalance - 10), + (w2, startingBalance + 10)] + +guessWrongProp :: Property +guessWrongProp = checkTrace $ do + void $ walletAction w2 startGame + lockFunds + void $ walletAction w2 (guess "a") + updateAll + traverse_ (uncurry assertOwnFundsEq) [ + (w1, startingBalance - 10), + (w2, startingBalance)] + +-- | Funds available to wallets at the beginning. +startingBalance :: Ledger.Value +startingBalance = 1000000 + +-- | Wallet 1 +w1 :: Wallet +w1 = Wallet 1 + +-- | Wallet 2 +w2 :: Wallet +w2 = Wallet 2 + +lockFunds :: Trace MockWallet () +lockFunds = void $ walletAction w1 (lock "abcde" 10) >> updateAll + +checkTrace :: Trace MockWallet () -> Property +checkTrace t = property $ do + let + ib = Map.fromList [ + (PubKey 1, startingBalance), + (PubKey 2, startingBalance)] + model = Gen.generatorModel { Gen.gmInitialBalance = ib } + (result, st) <- forAll $ Gen.runTraceOn model (updateAll >> t) + Hedgehog.assert (isRight result) + Hedgehog.assert ([] == _txPool st) + +-- | Validate all pending transactions and notify all wallets +updateAll :: Trace MockWallet () +updateAll = + processPending >>= void . walletsNotifyBlock [w1, w2] diff --git a/wallet-api/src/Ledger/Validation.hs b/wallet-api/src/Ledger/Validation.hs index 7fef6e7832f..0c7f16a8b90 100644 --- a/wallet-api/src/Ledger/Validation.hs +++ b/wallet-api/src/Ledger/Validation.hs @@ -46,11 +46,11 @@ module Ledger.Validation ) where import Codec.Serialise (Serialise, deserialiseOrFail, serialise) -import Crypto.Hash (Digest, SHA256, hash) +import Crypto.Hash (Digest, SHA256) import Data.Aeson (FromJSON, ToJSON (toJSON), withText) import qualified Data.Aeson as JSON import Data.Bifunctor (first) -import qualified Data.ByteArray as BA +import qualified Data.ByteString.Lazy.Hash as Hash import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy (Proxy)) @@ -205,28 +205,24 @@ newtype TxHash = deriving (Eq, Generic) plcDataScriptHash :: Ledger.DataScript -> DataScriptHash -plcDataScriptHash = DataScriptHash . plcHash +plcDataScriptHash = DataScriptHash . plcSHA2_256 . serialise plcValidatorDigest :: Digest SHA256 -> ValidatorHash plcValidatorDigest = ValidatorHash . plcDigest plcRedeemerHash :: Ledger.RedeemerScript -> RedeemerHash -plcRedeemerHash = RedeemerHash . plcHash +plcRedeemerHash = RedeemerHash . plcSHA2_256 . serialise plcTxHash :: Ledger.TxId' -> TxHash plcTxHash = TxHash . plcDigest . Ledger.getTxId --- | PLC-compatible hash of a hashable value -plcHash :: BA.ByteArrayAccess a => a -> BSL.ByteString -plcHash = plcDigest . hash +-- | PLC-compatible SHA-256 hash of a hashable value +plcSHA2_256 :: BSL.ByteString -> BSL.ByteString +plcSHA2_256 = Hash.sha2 --- | PLC-compatible double SHA256 hash of a hashable value -plcSHA2_256 :: BA.ByteArrayAccess a => a -> BSL.ByteString -plcSHA2_256 = plcDigest . hash @(Digest SHA256) . hash - --- | PLC-compatible triple SHA256 hash of a hashable value -plcSHA3_256 :: BA.ByteArrayAccess a => a -> BSL.ByteString -plcSHA3_256 = plcDigest . hash @(Digest SHA256) . hash @(Digest SHA256) . hash +-- | PLC-compatible SHA3-256 hash of a hashable value +plcSHA3_256 :: BSL.ByteString -> BSL.ByteString +plcSHA3_256 = Hash.sha3 -- | Convert a `Digest SHA256` to a PLC `Hash` plcDigest :: Digest SHA256 -> BSL.ByteString