added 'Signed'

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

@@ -11,6 +11,7 @@ License-files:       LICENSE
 library
   hs-source-dirs:      src
   exposed-modules:     Week05.Free
+                     , Week05.Signed
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers

code/week05/src/Week05/Free.hs

@@ -32,12 +32,12 @@ import           Playground.Types           (KnownCurrency (..))
 import           Text.Printf                (printf)
 import           Wallet.Emulator.Wallet
 
-{-# INLINABLE mkValidator #-}
+{-# INLINABLE mkPolicy #-}
-mkValidator :: ScriptContext -> Bool
+mkPolicy :: ScriptContext -> Bool
-mkValidator _ = True
+mkPolicy _ = True
 
 policy :: Scripts.MonetaryPolicy
-policy = mkMonetaryPolicyScript $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy mkValidator ||])
+policy = mkMonetaryPolicyScript $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy mkPolicy ||])
 
 curSymbol :: CurrencySymbol
 curSymbol = scriptCurrencySymbol policy

code/week05/src/Week05/Signed.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week05.Signed where
+
+import           Control.Monad              hiding (fmap)
+import           Control.Monad.Freer.Extras as Extras
+import           Data.Aeson                 (ToJSON, FromJSON)
+import           Data.Text                  (Text)
+import           Data.Void                  (Void)
+import           GHC.Generics               (Generic)
+import           Plutus.Contract            as Contract hiding (when)
+import           Plutus.Trace.Emulator      as Emulator
+import qualified PlutusTx
+import           PlutusTx.Prelude           hiding (Semigroup(..), unless)
+import           Ledger                     hiding (singleton)
+import           Ledger.Constraints         as Constraints
+import qualified Ledger.Typed.Scripts       as Scripts
+import           Ledger.Value               as Value
+import           Playground.Contract        (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
+import           Playground.TH              (mkKnownCurrencies, mkSchemaDefinitions)
+import           Playground.Types           (KnownCurrency (..))
+import           Text.Printf                (printf)
+import           Wallet.Emulator.Wallet
+
+{-# INLINABLE mkPolicy #-}
+mkPolicy :: PubKeyHash -> ScriptContext -> Bool
+mkPolicy pkh ctx = txSignedBy (scriptContextTxInfo ctx) pkh
+
+policy :: PubKeyHash -> Scripts.MonetaryPolicy
+policy pkh = mkMonetaryPolicyScript $
+    $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . mkPolicy ||])
+        `PlutusTx.applyCode`
+            PlutusTx.liftCode pkh
+
+curSymbol :: PubKeyHash -> CurrencySymbol
+curSymbol = scriptCurrencySymbol . policy
+
+data MintParams = MintParams
+    { mpTokenName :: !TokenName
+    , mpAmount    :: !Integer
+    } deriving (Generic, ToJSON, FromJSON, ToSchema)
+
+type SignedSchema =
+    BlockchainActions
+        .\/ Endpoint "mint" MintParams
+
+mint :: (HasBlockchainActions s, AsContractError e) => MintParams -> Contract w s e ()
+mint mp = do
+    pkh <- pubKeyHash <$> Contract.ownPubKey
+    let val     = Value.singleton (curSymbol pkh) (mpTokenName mp) (mpAmount mp)
+        lookups = Constraints.monetaryPolicy $ policy pkh
+        tx      = Constraints.mustForgeValue val
+    ledgerTx <- submitTxConstraintsWith @Void lookups tx
+    void $ awaitTxConfirmed $ txId ledgerTx
+    Contract.logInfo @String $ printf "forged %s" (show val)
+
+endpoints :: Contract () SignedSchema Text ()
+endpoints = mint' >> endpoints
+  where
+    mint' = endpoint @"mint" >>= mint
+
+mkSchemaDefinitions ''SignedSchema
+
+mkKnownCurrencies []
+
+test :: IO ()
+test = runEmulatorTraceIO $ do
+    let tn = "ABC"
+    h1 <- activateContractWallet (Wallet 1) endpoints
+    h2 <- activateContractWallet (Wallet 2) endpoints
+    callEndpoint @"mint" h1 $ MintParams
+        { mpTokenName = tn
+        , mpAmount    = 555
+        }
+    callEndpoint @"mint" h2 $ MintParams
+        { mpTokenName = tn
+        , mpAmount    = 444
+        }
+    void $ Emulator.waitNSlots 1
+    callEndpoint @"mint" h1 $ MintParams
+        { mpTokenName = tn
+        , mpAmount    = -222
+        }
+    void $ Emulator.waitNSlots 1