Plutus Playground Smart Contract

Playground.hs

import           Wallet.Emulator.Types             (walletPubKey)               
import           Control.Monad             (void)
import qualified Ledger                               as Ledger   
import           Language.Plutus.Contract
import           Language.Plutus.Contract  hiding (when)
import qualified Language.PlutusTx         as PlutusTx
import           Language.PlutusTx.Prelude
import qualified Ledger.Scripts                       as Scripts

import           Language.PlutusTx.Prelude hiding (pure, (<$>))
import           Ledger                    (PubKeyHash, Ada, Address, Validator, ValidatorCtx, Value, scriptAddress)
import           Playground.Contract
import           Playground.Contract
import qualified Data.ByteString.Char8     as C
import qualified Data.Text                 as T
import qualified Language.PlutusTx         as PlutusTx
import qualified Ledger.Constraints        as Constraints
import qualified Ledger.Typed.Scripts      as Scripts
import qualified Prelude

-- Taxman
-- ======

-- You live in a jurisdiction where you must keep your money in taxable scripts
-- The taxman must give you a warning by taking 1 ADA, then 2 slots later he can take the lot
-- You must notice the warning and get your money into another script. 
-- He'll then find out where you put it and issue the warning 2 slots later.
-- Can you move the money about fast enough?

newtype Name = Name ByteString -- deriving (Prelude.Eq, Prelude.Show, Generic, ToJSON, FromJSON, ToSchema, PlutusTx.IsData)
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument, PlutusTx.IsData)
PlutusTx.makeLift ''Name

data TaxableParams = TaxableParams
  { taxman      :: PubKeyHash -- could be global
  , name        :: Name -- so you can have different ones
  , owner       :: PubKeyHash -- you
  } deriving (Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeLift ''TaxableParams

-- The script always allows the taxman to take exactly 1 ADA, but interprets that as a warning if it's the first time
-- The datum will remember whether we've been warned or not
-- I suppose we need a button to forge a new script full of money
-- You need a button to move the money to a script with another name
-- The taxman needs a button to warn a script, wait, either take the lot or find a script it paid, and repeat
-- I'm not sure if it's possible to "find a script it paid" so maybe I bung that in the datum for now
-- Nor am I sure if scripts with no money can hang about. If not I'll forbid taking the last ADA


type TaxableSchema =
    BlockchainActions
        .\/ Endpoint "mint" MintParams
--        .\/ Endpoint "hide" HideParams -- run to new script called the Name
--        .\/ Endpoint "grab" GrabParams
        
data MintParams = MintParams Name Value
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument)
    
data HideParams = HideParams Name 
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument)
    
newtype GrabParams = GrabParams ()
    deriving stock (Prelude.Eq, Prelude.Show, Generic)
    deriving anyclass (FromJSON, ToJSON, ToSchema, ToArgument)

data TaxableRedeemer = Hide | Grab

data TaxableDatum = TaxableDatum { warned :: Bool, ranto :: Maybe ValidatorHash }

data Taxable
instance Scripts.ScriptType Taxable where
    type instance RedeemerType Taxable = TaxableRedeemer
    type instance DatumType Taxable = TaxableDatum
        

taxableInstance :: TaxableParams -> Scripts.ScriptInstance Taxable
taxableInstance params = Scripts.validator @Taxable
    ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode params)
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap = Scripts.wrapValidator @TaxableDatum @TaxableRedeemer

mkValidator :: TaxableParams -> TaxableDatum -> TaxableRedeemer -> ValidatorCtx -> Bool
mkValidator par dat red ctx = True -- case red of
--    Mint -> validMint par dat (valCtxTxInfo ctx)
--     Hide -> validHide par dat (valCtxTxInfo ctx)
--     Grab -> validGrab par dat (valCtxTxInfo ctx)
    
-- validMint :: TaxableParams -> TaxableDatum -> TxInfo -> Bool

-- validHide :: TaxableParams -> TaxableDatum -> TxInfo -> Bool

-- validGrab :: TaxableParams -> TaxableDatum -> TxInfo -> Bool

taxableScript :: TaxableParams -> Validator
taxableScript = Scripts.validatorScript . taxableInstance

taxableAddress :: TaxableParams -> Ledger.ValidatorHash
taxableAddress = Scripts.validatorHash . taxableScript

taxable :: AsContractError e => TaxableParams -> Contract () TaxableSchema e ()
taxable par = mint par -- `select` hide par `select` grab par

mint :: AsContractError e => TaxableParams -> Contract () TaxableSchema e ()
mint par = do
  MintParams name amt <- endpoint @"mint" @MintParams
  let tx = Constraints.mustPayToTheScript (TaxableDatum False Nothing) amt
  void (submitTxConstraints (taxableInstance par) tx)
  
-- hide :: AsContractError e => TaxableParams -> Contract () TaxableSchema e ()
-- hide = do
--   HideParams name <- endpoint @"mint" @HideParams
--   
-- grab :: AsContractError e => TaxableParams -> Contract () TaxableSchema e ()
-- grab = do
--   GrabParams () <- endpoint @"mint" @GrabParams

endpoints :: AsContractError e => Contract () TaxableSchema e ()
endpoints = Ledger.pubKeyHash <$> ownPubKey >>= \me -> taxable $ TaxableParams 
  (Ledger.pubKeyHash $ walletPubKey $ Wallet 1)
  "hideyhole"
  me

mkSchemaDefinitions ''TaxableSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[]]