Typed contract

code/week02/plutus-pioneer-program-week02.cabal

@@ -13,6 +13,7 @@ library
   exposed-modules:     Week02.Burn
                      , Week02.FortyTwo
                      , Week02.Gift
+                     , Week02.Typed
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers

code/week02/src/Week02/Burn.hs

@@ -39,18 +39,18 @@ import           Playground.Types    (KnownCurrency (..))
 import           Prelude             (Semigroup (..))
 import           Text.Printf         (printf)
 
-{-# INLINABLE mkGiftValidator #-}
-mkGiftValidator :: Data -> Data -> Data -> ()
-mkGiftValidator _ _ _ = traceError "NO WAY!"
+{-# INLINABLE mkBurnValidator #-}
+mkBurnValidator :: Data -> Data -> Data -> ()
+mkBurnValidator _ _ _ = traceError "NO WAY!"
 
-giftValidator :: Validator
-giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
+burnValidator :: Validator
+burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||])
 
-giftHash :: Ledger.ValidatorHash
-giftHash = Scripts.validatorHash giftValidator
+burnHash :: Ledger.ValidatorHash
+burnHash = Scripts.validatorHash burnValidator
 
-giftAddress :: Ledger.Address
-giftAddress = ScriptAddress giftHash
+burnAddress :: Ledger.Address
+burnAddress = ScriptAddress burnHash
 
 type BurnSchema =
     BlockchainActions
@@ -59,17 +59,17 @@ type BurnSchema =
 
 burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
 burn amount = do
-    let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
+    let tx = mustPayToOtherScript burnHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
     ledgerTx <- submitTx tx
     void $ awaitTxConfirmed $ txId ledgerTx
     logInfo @String $ printf "burnt %d lovelace" amount
 
 grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
 grab = do
-    utxos <- utxoAt $ ScriptAddress giftHash
+    utxos <- utxoAt $ ScriptAddress burnHash
     let orefs   = fst <$> Map.toList utxos
         lookups = Constraints.unspentOutputs utxos      <>
-                  Constraints.otherScript giftValidator
+                  Constraints.otherScript burnValidator
         tx :: TxConstraints Void Void
         tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs]
     ledgerTx <- submitTxConstraintsWith @Void lookups tx

code/week02/src/Week02/FortyTwo.hs

@@ -39,20 +39,20 @@ import           Playground.Types    (KnownCurrency (..))
 import           Prelude             (Semigroup (..))
 import           Text.Printf         (printf)
 
-{-# INLINABLE mkGiftValidator #-}
-mkGiftValidator :: Data -> Data -> Data -> ()
-mkGiftValidator _ (I n) _
-    | n == 42             = ()
-mkGiftValidator _ _     _ = traceError "UNEXPECTED REDEEMER!"
+{-# INLINABLE mkFortyTwoValidator #-}
+mkFortyTwoValidator :: Data -> Data -> Data -> ()
+mkFortyTwoValidator _ (I n) _
+    | n == 42                 = ()
+mkFortyTwoValidator _ _     _ = traceError "UNEXPECTED REDEEMER!"
 
-giftValidator :: Validator
-giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
+fortyTwoValidator :: Validator
+fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||])
 
-giftHash :: Ledger.ValidatorHash
-giftHash = Scripts.validatorHash giftValidator
+fortyTwoHash :: Ledger.ValidatorHash
+fortyTwoHash = Scripts.validatorHash fortyTwoValidator
 
-giftAddress :: Ledger.Address
-giftAddress = ScriptAddress giftHash
+fortyTwoAddress :: Ledger.Address
+fortyTwoAddress = ScriptAddress fortyTwoHash
 
 type FortyTwoSchema =
     BlockchainActions
@@ -61,17 +61,17 @@ type FortyTwoSchema =
 
 give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
 give amount = do
-    let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
+    let tx = mustPayToOtherScript fortyTwoHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
     ledgerTx <- submitTx tx
     void $ awaitTxConfirmed $ txId ledgerTx
     logInfo @String $ printf "made a gift of %d lovelace" amount
 
 grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
 grab r = do
-    utxos <- utxoAt $ ScriptAddress giftHash
+    utxos <- utxoAt $ ScriptAddress fortyTwoHash
     let orefs   = fst <$> Map.toList utxos
         lookups = Constraints.unspentOutputs utxos      <>
-                  Constraints.otherScript giftValidator
+                  Constraints.otherScript fortyTwoValidator
         tx :: TxConstraints Void Void
         tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs]
     ledgerTx <- submitTxConstraintsWith @Void lookups tx

code/week02/src/Week02/Typed.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week02.Typed
+    ( give
+    , grab
+    , TypedSchema
+    , endpoints
+    , schemas
+    , registeredKnownCurrencies
+    , printJson
+    , printSchemas
+    , ensureKnownCurrencies
+    , stage
+    ) where
+
+import           Control.Monad        hiding (fmap)
+import           Data.Map             as Map
+import           Data.Text            (Text)
+import           Data.Void            (Void)
+import           Plutus.Contract      hiding (when)
+import           PlutusTx             (Data (..))
+import qualified PlutusTx
+import           PlutusTx.Prelude     hiding (Semigroup(..), unless)
+import           Ledger               hiding (singleton)
+import           Ledger.Constraints   as Constraints
+import qualified Ledger.Scripts       as Scripts
+import qualified Ledger.Typed.Scripts as Scripts
+import           Ledger.Ada           as Ada
+import           Playground.Contract  (printJson, printSchemas, ensureKnownCurrencies, stage)
+import           Playground.TH        (mkKnownCurrencies, mkSchemaDefinitions)
+import           Playground.Types     (KnownCurrency (..))
+import           Prelude              (Semigroup (..))
+import           Text.Printf          (printf)
+
+{-# INLINABLE mkTypedValidator #-}
+mkTypedValidator :: () -> Integer -> ValidatorCtx -> Bool
+mkTypedValidator () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == 42)
+
+data Typing
+instance Scripts.ScriptType Typing where
+    type instance RedeemerType Typing = Integer
+    type instance DatumType Typing = ()
+
+typedInstance :: Scripts.ScriptInstance Typing
+typedInstance = Scripts.validator @Typing
+    $$(PlutusTx.compile [|| mkTypedValidator ||])
+    $$(PlutusTx.compile [|| wrap ||])
+  where
+    wrap = Scripts.wrapValidator @() @Integer
+
+typedValidator :: Validator
+typedValidator = Scripts.validatorScript typedInstance
+
+typedHash :: Ledger.ValidatorHash
+typedHash = Scripts.validatorHash typedValidator
+
+typedAddress :: Ledger.Address
+typedAddress = ScriptAddress typedHash
+
+type TypedSchema =
+    BlockchainActions
+        .\/ Endpoint "give" Integer
+        .\/ Endpoint "grab" Integer
+
+give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
+give amount = do
+    let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
+    ledgerTx <- submitTxConstraints typedInstance tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ printf "made a gift of %d lovelace" amount
+
+grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
+grab r = do
+    utxos <- utxoAt $ ScriptAddress typedHash
+    let orefs   = fst <$> Map.toList utxos
+        lookups = Constraints.unspentOutputs utxos      <>
+                  Constraints.otherScript typedValidator
+        tx :: TxConstraints Void Void
+        tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs]
+    ledgerTx <- submitTxConstraintsWith @Void lookups tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ "collected gifts"
+
+endpoints :: Contract () TypedSchema Text ()
+endpoints = (give' `select` grab') >> endpoints
+  where
+    give' = endpoint @"give" >>= give
+    grab' = endpoint @"grab" >>= grab
+
+mkSchemaDefinitions ''TypedSchema
+
+mkKnownCurrencies []