Merge pull request #24 from input-output-hk/MetaLamp/lending-pool/pla…

…tform-upgrade-new

Meta lamp/lending pool/platform upgrade

MetaLamp/lending-pool/cabal.project

@@ -22,11 +22,11 @@ source-repository-package
     plutus-tx
     plutus-tx-plugin
     plutus-pab
-    plutus-ledger-api
     plutus-use-cases
     prettyprinter-configurable
     quickcheck-dynamic
-  tag: 58bf9ed626d498c140c69a859a508da03843d097
+    word-array
+  tag: 5cdd2c3d708bf4c33514681dee096da6463273b7
 
 -- The following sections are copied from the 'plutus' repository cabal.project at the revision
 -- given above.
@@ -143,3 +143,8 @@ source-repository-package
   type: git
   location: https://github.com/input-output-hk/goblins
   tag: cde90a2b27f79187ca8310b6549331e59595e7ba
+
+source-repository-package
+  type: git
+  location: https://github.com/Quid2/flat.git
+  tag: 95e5d7488451e43062ca84d5376b3adcc465f1cd

MetaLamp/lending-pool/client/scripts/fetch-plutus-purs.sh

@@ -6,4 +6,4 @@ git remote add origin -f https://github.com/input-output-hk/plutus
 git config core.sparseCheckout true
 echo 'web-common-plutus/*' >> .git/info/sparse-checkout
 echo 'web-common/*' >> .git/info/sparse-checkout
-git pull origin 58bf9ed626d498c140c69a859a508da03843d097
+git pull origin 5cdd2c3d708bf4c33514681dee096da6463273b7

MetaLamp/lending-pool/client/src/AppAff.purs

@@ -86,5 +86,5 @@ instance contractAppM :: Contract AppM where
   callEndpoint (Endpoint endpoint) (ContractId cid) params = post ("/api/new/contract/instance/" <> cid <> "/endpoint/" <> endpoint) (string <<< encodeJSON $ params)
 
 instance pollContractAppM :: PollContract AppM where
-  pollDelay = liftAff <<< delay <<< Milliseconds $ 300.0
+  pollDelay = liftAff <<< delay <<< Milliseconds $ 1000.0
   tooManyRetries retryCount = pure $ retryCount > 10

MetaLamp/lending-pool/generate-purs/Main.hs

@@ -17,10 +17,7 @@ import           Cardano.Metadata.Types                     (AnnotatedSignature,
 import           Cardano.Wallet.Types                       (WalletInfo)
 import           Control.Applicative                        ((<|>))
 import           Control.Lens                               (set, view, (&))
-import           Control.Monad                              (void)
 import           Control.Monad.Freer.Extras.Log             (LogLevel, LogMessage)
-import qualified Data.Aeson.Encode.Pretty                   as JSON
-import qualified Data.ByteString.Lazy                       as BSL
 import           Data.Proxy                                 (Proxy (Proxy))
 import qualified Data.Text                                  as Text
 import           Language.PureScript.Bridge                 (BridgePart, Language (Haskell), SumType,
@@ -32,7 +29,7 @@ import           Language.PureScript.Bridge.CodeGenSwitches (ForeignOptions (For
 import           Language.PureScript.Bridge.TypeParameters  (A)
 import           Ledger.Constraints.OffChain                (UnbalancedTx)
 import qualified PSGenerator.Common
-import           Plutus.Contract.Checkpoint                 (CheckpointKey, CheckpointStore)
+import           Plutus.Contract.Checkpoint                 (CheckpointKey, CheckpointStore, CheckpointStoreItem)
 import           Plutus.Contract.Effects.AwaitSlot          (WaitingForSlot)
 import           Plutus.Contract.Effects.AwaitTxConfirmed   (TxConfirmed)
 import           Plutus.Contract.Effects.ExposeEndpoint     (ActiveEndpoint, EndpointValue)
@@ -41,17 +38,10 @@ import           Plutus.Contract.Effects.OwnPubKey          (OwnPubKeyRequest)
 import           Plutus.Contract.Effects.UtxoAt             (UtxoAtAddress)
 import           Plutus.Contract.Effects.WriteTx            (WriteTxResponse)
 import           Plutus.Contract.Resumable                  (Responses)
-import           Plutus.Contract.State                      (ContractRequest, State)
-import           Plutus.Contracts.Currency                  (SimpleMPS (..))
 import           Plutus.PAB.Effects.Contract.ContractExe    (ContractExe)
-import           Plutus.PAB.Effects.Contract.ContractTest   (TestContracts (Currency, GameStateMachine))
-import           Plutus.PAB.Events                          (PABEvent)
-import           Plutus.PAB.Events.Contract                 (ContractInstanceId (..), ContractPABRequest,
-                                                             ContractResponse)
+import           Plutus.PAB.Events.Contract                 (ContractPABRequest, ContractPABResponse)
 import           Plutus.PAB.Events.ContractInstanceState    (PartiallyDecodedResponse)
-import qualified Plutus.PAB.Simulator                       as Simulator
 import qualified Plutus.PAB.Webserver.API                   as API
-import qualified Plutus.PAB.Webserver.Handler               as Webserver
 import           Plutus.PAB.Webserver.Types                 (ChainReport, CombinedWSStreamToClient,
                                                              CombinedWSStreamToServer, ContractActivationArgs,
                                                              ContractInstanceClientState, ContractReport,
@@ -61,7 +51,6 @@ import           Servant                                    ((:<|>))
 import           Servant.PureScript                         (HasBridge, Settings, _generateSubscriberAPI, apiModuleName,
                                                              defaultBridge, defaultSettings, languageBridge,
                                                              writeAPIModuleWithSettings)
-import           System.FilePath                            ((</>))
 import           Wallet.Effects                             (AddressChangeRequest (..), AddressChangeResponse (..))
 import           Wallet.Emulator.Wallet                     (Wallet (..))
 import AaveTypes (aaveTypes, ratioBridge)
@@ -103,21 +92,19 @@ instance HasBridge MyBridge where
 
 myTypes :: [SumType 'Haskell]
 myTypes =
+    aaveTypes <>
     PSGenerator.Common.ledgerTypes <>
     PSGenerator.Common.playgroundTypes <>
     PSGenerator.Common.walletTypes <>
-    aaveTypes <>
     [ (equal <*> (genericShow <*> mkSumType)) (Proxy @ContractExe)
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @TestContracts)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(FullReport A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @ChainReport)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractReport A))
     , (equal <*> (genericShow <*> mkSumType))
           (Proxy @(ContractSignatureResponse A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(PartiallyDecodedResponse A))
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractRequest A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @ContractPABRequest)
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @ContractResponse)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @ContractPABResponse)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @UnbalancedTx)
 
     -- Contract request / response types
@@ -128,9 +115,9 @@ myTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @UtxoAtAddress)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @WriteTxResponse)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @WaitingForSlot)
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(State A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @CheckpointStore)
     , (order <*> (genericShow <*> mkSumType)) (Proxy @CheckpointKey)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(CheckpointStoreItem A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(Responses A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @AddressChangeRequest)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @AddressChangeResponse)
@@ -149,7 +136,6 @@ myTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(AnnotatedSignature A))
 
     -- * Web API types
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(PABEvent A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractActivationArgs A))
     , (genericShow <*> mkSumType) (Proxy @(ContractInstanceClientState A))
     , (genericShow <*> mkSumType) (Proxy @InstanceStatusToClient)
@@ -165,45 +151,17 @@ mySettings =
 
 defaultWallet :: Wallet
 defaultWallet = Wallet 1
-
-------------------------------------------------------------
-writeTestData :: FilePath -> IO ()
-writeTestData outputDir = do
-    (fullReport, currencySchema) <-
-        fmap (either (error . show) id) $ Simulator.runSimulation $ do
-            currencyInstance1 <- Simulator.activateContract defaultWallet Currency
-            void $ Simulator.activateContract defaultWallet Currency
-            void $ Simulator.activateContract defaultWallet GameStateMachine
-            void $ Simulator.waitForEndpoint currencyInstance1 "Create native token"
-            void $ Simulator.callEndpointOnInstance currencyInstance1 "Create native token" SimpleMPS {tokenName = "TestCurrency", amount = 10000000000}
-            void $ Simulator.waitUntilFinished currencyInstance1
-            report :: FullReport TestContracts <- Webserver.getFullReport
-            schema :: ContractSignatureResponse TestContracts <- Webserver.contractSchema (Text.pack $ show $ unContractInstanceId currencyInstance1)
-            pure (report, schema)
-    BSL.writeFile
-        (outputDir </> "full_report_response.json")
-        (JSON.encodePretty fullReport)
-    BSL.writeFile
-        (outputDir </> "contract_schema_response.json")
-        (JSON.encodePretty currencySchema)
-
 ------------------------------------------------------------
 
 generateTo :: FilePath -> IO ()
 generateTo outputDir = do
     exists <- doesDirectoryExist outputDir
     when exists $ removeDirectoryRecursive outputDir
-    writeAPIModuleWithSettings
-        mySettings
-        outputDir
-        myBridgeProxy
-        (Proxy @(API.API ContractExe :<|> API.NewAPI ContractExe Text.Text :<|> (API.WalletProxy Text.Text)))
     writePSTypesWith
         (genForeign (ForeignOptions {unwrapSingleConstructors = True}))
         outputDir
         (buildBridge myBridge)
         myTypes
-    writeTestData outputDir
 
 main :: IO ()
 main = generateTo "client/generated"

MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs

@@ -14,7 +14,7 @@ import           Ledger                      (Address (Address),
 import           Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
 import qualified PlutusTx
 import           PlutusTx.Prelude            (Eq ((==)), Maybe (..),
-                                              Monad ((>>=)), find, fst,
+                                               find, fst, (>>=),
                                               mapMaybe, mconcat, snd, ($), (.),
                                               (<$>))
 

MetaLamp/lending-pool/src/Plutus/Contracts/Core.hs

@@ -30,7 +30,7 @@ import           Ledger                           hiding (singleton)
 import           Ledger.Constraints               as Constraints
 import           Ledger.Constraints.OnChain       as Constraints
 import           Ledger.Constraints.TxConstraints as Constraints
-import qualified Ledger.Scripts                   as Scripts
+import qualified Ledger.Scripts                   as UntypedScripts
 import qualified Ledger.Typed.Scripts             as Scripts
 import           Playground.Contract
 import           Plutus.Contract                  hiding (when)
@@ -42,8 +42,6 @@ import           PlutusTx.Prelude                 hiding (Semigroup (..),
 import           Prelude                          (Semigroup (..))
 import qualified Prelude
 
-deriving anyclass instance ToSchema AssetClass
-
 newtype Aave = Aave
     { aaveProtocolInst :: AssetClass
     } deriving stock    (Prelude.Eq, Show, Generic)
@@ -113,7 +111,7 @@ pickReserves (ReservesDatum stateToken configs) = Just (stateToken, configs)
 pickReserves _                                  = Nothing
 
 data AaveScript
-instance Scripts.ScriptType AaveScript where
+instance Scripts.ValidatorTypes AaveScript where
     type instance RedeemerType AaveScript = AaveRedeemer
     type instance DatumType AaveScript = AaveDatum
 
@@ -365,8 +363,8 @@ checkReservesConsistency oldState newState =
 aaveProtocolName :: TokenName
 aaveProtocolName = "Aave"
 
-aaveInstance :: Aave -> Scripts.ScriptInstance AaveScript
-aaveInstance aave = Scripts.validator @AaveScript
+aaveInstance :: Aave -> Scripts.TypedValidator AaveScript
+aaveInstance aave = Scripts.mkTypedValidator @AaveScript
     ($$(PlutusTx.compile [|| makeAaveValidator ||])
         `PlutusTx.applyCode` PlutusTx.liftCode aave)
      $$(PlutusTx.compile [|| wrap ||])
@@ -377,7 +375,7 @@ aaveValidator :: Aave -> Validator
 aaveValidator = Scripts.validatorScript . aaveInstance
 
 aaveHash :: Aave -> Ledger.ValidatorHash
-aaveHash = Scripts.validatorHash . aaveValidator
+aaveHash = UntypedScripts.validatorHash . aaveValidator
 
 aaveAddress :: Aave -> Ledger.Address
 aaveAddress = Ledger.scriptAddress . aaveValidator

MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs

@@ -53,7 +53,7 @@ import qualified PlutusTx.AssocMap                as AssocMap
 import           PlutusTx.Prelude                 hiding (Monoid (..),
                                                    Semigroup (..), mconcat,
                                                    unless)
-import           Prelude                          (Monoid (..), Semigroup (..))
+import           Prelude                          (Monoid (..), Semigroup (..), show, subtract)
 import qualified Prelude
 import           Text.Printf                      (printf)
 
@@ -96,7 +96,7 @@ start params = do
     ledgerTx <- TxUtils.submitTxPair userConfigsTx
     void $ awaitTxConfirmed $ txId ledgerTx
 
-    logInfo @String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave)
+    logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave)
     pure aave
 
 ownerEndpoint :: [CreateParams] -> Contract (Last (Either Text Aave)) BlockchainActions Void ()
@@ -291,9 +291,6 @@ type AaveUserSchema =
         .\/ Endpoint "users" ()
         .\/ Endpoint "ownPubKey" ()
 
-instance (Prelude.Eq k, Prelude.Eq v) => Prelude.Eq (AssocMap.Map k v) where
-    a == b = (AssocMap.toList a) Prelude.== (AssocMap.toList b)
-
 data UserContractState =
     Pending
     | Created

MetaLamp/lending-pool/src/Plutus/Contracts/TxUtils.hs

@@ -19,8 +19,7 @@ import qualified Ledger.Constraints               as Constraints
 import qualified Ledger.Constraints.OnChain       as Constraints
 import qualified Ledger.Constraints.TxConstraints as Constraints
 import           Ledger.Typed.Scripts             (MonetaryPolicy,
-                                                   ScriptInstance,
-                                                   ScriptType (..))
+                                                   TypedValidator, RedeemerType, DatumType)
 import qualified Ledger.Typed.Scripts             as Scripts
 import           Plutus.Contract
 import           Plutus.Contracts.Core            (Aave, Reserve (..))
@@ -44,7 +43,7 @@ type TxPair a = (Constraints.ScriptLookups a, Constraints.TxConstraints (Redeeme
 submitTxPair :: (AsContractError e, HasWriteTx s, PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
     TxPair a
     -> Contract w s e Tx
-submitTxPair = uncurry submitTxConstraintsWith
+submitTxPair = Prelude.uncurry submitTxConstraintsWith
 
 mustForgeValue :: (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
     MonetaryPolicy
@@ -56,18 +55,18 @@ mustForgeValue policy value = (lookups, tx)
         tx = Constraints.mustForgeValue value
 
 mustPayToScript :: (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
-  ScriptInstance a
+  TypedValidator a
   -> PubKeyHash
   -> DatumType a
   -> Value
   -> TxPair a
 mustPayToScript script pkh datum value = (lookups, tx)
     where
-        lookups = Constraints.ownPubKeyHash pkh <> Constraints.scriptInstanceLookups script
+        lookups = Constraints.ownPubKeyHash pkh <> Constraints.typedValidatorLookups script
         tx = Constraints.mustPayToTheScript datum value
 
 mustSpendScriptOutputs :: (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
-    ScriptInstance a
+    TypedValidator a
     -> [OutputValue (RedeemerType a)]
     -> TxPair a
 mustSpendScriptOutputs script inputs = (lookups, tx)
@@ -78,7 +77,7 @@ mustSpendScriptOutputs script inputs = (lookups, tx)
             fmap (\(OutputValue ref _ redeemer) -> Constraints.mustSpendScriptOutput ref (Redeemer $ PlutusTx.toData redeemer)) inputs
 
 mustSpendFromScript :: (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
-  ScriptInstance a
+  TypedValidator a
   -> [OutputValue (RedeemerType a)]
   -> PubKeyHash
   -> Value
@@ -89,7 +88,7 @@ mustSpendFromScript script inputs pkh value = (lookups, tx) <> mustSpendScriptOu
         tx = Constraints.mustPayToPubKey pkh value
 
 mustRoundTripToScript :: (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) =>
-  ScriptInstance a
+  TypedValidator a
   -> [OutputValue (RedeemerType a)]
   -> DatumType a
   -> PubKeyHash

MetaLamp/lending-pool/src/Plutus/State/Update.hs

@@ -26,10 +26,9 @@ import           Ledger                           hiding (getDatum, singleton)
 import           Ledger.Constraints               as Constraints
 import           Ledger.Constraints.OnChain       as Constraints
 import           Ledger.Constraints.TxConstraints as Constraints
-import qualified Ledger.Scripts                   as Scripts
-import           Ledger.Typed.Scripts             (ScriptType (..))
+import qualified Ledger.Scripts                   as UntypedScripts
 import qualified Ledger.Typed.Scripts             as Scripts
-
+import Ledger.Typed.Scripts (RedeemerType, DatumType)
 import           Ext.Plutus.Ledger.Contexts       (scriptInputsAt)
 import           Playground.Contract
 import           Plutus.Contract                  hiding (when)
@@ -75,7 +74,7 @@ makeStateToken :: ValidatorHash -> OwnerToken -> TokenName -> AssetClass
 makeStateToken ownerScript ownerToken tokenName = assetClass (makeStateCurrency ownerScript ownerToken tokenName) tokenName
 
 data PutStateHandle scriptType = PutStateHandle {
-    script           :: Scripts.ScriptInstance scriptType,
+    script           :: Scripts.TypedValidator scriptType,
     ownerToken       :: AssetClass,
     ownerTokenOutput :: OutputValue (DatumType scriptType)
 }
@@ -96,7 +95,7 @@ putState PutStateHandle {..} StateHandle{..} newState = do
     pkh <- pubKeyHash <$> ownPubKey
     let (_, stateTokenName) = unAssetClass stateToken
     pure $
-        TxUtils.mustForgeValue (makeStatePolicy (Scripts.scriptHash script) ownerToken stateTokenName) (assetClassValue stateToken 1)
+        TxUtils.mustForgeValue (makeStatePolicy (Scripts.validatorHash script) ownerToken stateTokenName) (assetClassValue stateToken 1)
         <> TxUtils.mustPayToScript script pkh (toDatum newState) (assetClassValue stateToken 1)
         <> TxUtils.mustRoundTripToScript
             script
@@ -107,7 +106,7 @@ putState PutStateHandle {..} StateHandle{..} newState = do
 
 updateState ::
     (HasBlockchainActions s, IsData (DatumType scriptType), IsData (RedeemerType scriptType)) =>
-    Scripts.ScriptInstance scriptType ->
+    Scripts.TypedValidator scriptType ->
     StateHandle scriptType a ->
     OutputValue a ->
     Contract w s Text (TxUtils.TxPair scriptType)