Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

withdrawal effect that actually passes tests

Browse source
This commit is contained in:
Seungheon Oh 2022-04-20 19:57:14 -05:00
parent 6c02b94e16
commit bed2f37c2f
3 changed files with 165 additions and 163 deletions
Download patch file Download diff file Expand all files Collapse all files

230
agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
View file

@ -7,17 +7,17 @@ This module tests the Treasury Withdrawal Effect.
-} -}
module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
import Plutarch.Evaluate
import Plutarch.Builtin
import Plutarch.Api.V1 import Plutarch.Api.V1
import Plutarch.Builtin
import Plutarch.Evaluate
import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Api
import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Value qualified as Value import Plutus.V1.Ledger.Value qualified as Value
import Data.ByteString.Hash import Data.ByteString.Hash
import Agora.Effect.TreasuryWithdrawal
import Agora.AuthorityToken import Agora.AuthorityToken
import Agora.Effect.TreasuryWithdrawal
import Spec.Util import Spec.Util
@ -65,9 +65,9 @@ _aa = treasuries
datum :: TreasuryWithdrawalDatum datum :: TreasuryWithdrawalDatum
datum = datum =
TreasuryWithdrawalDatum TreasuryWithdrawalDatum
[ (users !! 0, Value.singleton gtSymbol gtToken 1) [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
, (users !! 1, Value.singleton gtSymbol gtToken 1) , (users !! 1, Value.singleton "1234ab" "LQ" 1)
, (users !! 2, Value.singleton gtSymbol gtToken 1) , (users !! 2, Value.singleton "1234ab" "LQ" 1)
] ]
-- | Effect validator instance. -- | Effect validator instance.
@ -91,46 +91,46 @@ scriptContext1 =
, txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
, txOutDatumHash = Just (DatumHash "") , txOutDatumHash = Just (DatumHash "")
} }
-- , TxInInfo -- Treasury 1 , TxInInfo -- Treasury 1
-- (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-- TxOut TxOut
-- { txOutAddress = Address (treasuries !! 0) Nothing { txOutAddress = Address (treasuries !! 0) Nothing
-- , txOutValue = Value.singleton gtSymbol gtToken 10 , txOutValue = Value.singleton "1234ab" "LQ" 10
-- , txOutDatumHash = Just (DatumHash "") , txOutDatumHash = Just (DatumHash "")
-- } }
-- , TxInInfo -- Treasury 2 , TxInInfo -- Treasury 2
-- (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-- TxOut TxOut
-- { txOutAddress = Address (treasuries !! 1) Nothing { txOutAddress = Address (treasuries !! 1) Nothing
-- , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 , txOutValue = Value.singleton "1234ab" "LQ" 10
-- , txOutDatumHash = Just (DatumHash "") , txOutDatumHash = Just (DatumHash "")
-- } }
] ]
, txInfoOutputs = , txInfoOutputs =
[ TxOut [ TxOut
{ txOutAddress = Address (users !! 0) Nothing { txOutAddress = Address (users !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1 , txOutValue = Value.singleton "1234ab" "LQ" 1
, txOutDatumHash = Nothing , txOutDatumHash = Nothing
} }
, TxOut , TxOut
{ txOutAddress = Address (users !! 1) Nothing { txOutAddress = Address (users !! 1) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1 , txOutValue = Value.singleton "1234ab" "LQ" 1
, txOutDatumHash = Nothing , txOutDatumHash = Nothing
} }
, TxOut , TxOut
{ txOutAddress = Address (users !! 2) Nothing { txOutAddress = Address (users !! 2) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1 , txOutValue = Value.singleton "1234ab" "LQ" 1
, txOutDatumHash = Nothing , txOutDatumHash = Nothing
} }
-- Send left overs to treasuries , -- Send left overs to treasuries
, TxOut TxOut
{ txOutAddress = Address (treasuries !! 0) Nothing { txOutAddress = Address (treasuries !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 7 , txOutValue = Value.singleton "1234ab" "LQ" 7
, txOutDatumHash = Nothing , txOutDatumHash = Nothing
} }
, TxOut , TxOut
{ txOutAddress = Address (treasuries !! 1) Nothing { txOutAddress = Address (treasuries !! 1) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 10 , txOutValue = Value.singleton "1234ab" "LQ" 10
, txOutDatumHash = Nothing , txOutDatumHash = Nothing
} }
] ]
@ -147,103 +147,111 @@ scriptContext1 =
Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
} }
tests :: [TestTree] tests :: [TestTree]
tests = tests =
[ testGroup [ testGroup
"effect" "effect"
[ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
] ]
_asdfa :: IO () _asdfa :: IO ()
_asdfa = do _asdfa = do
let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
case res of case res of
Left e -> do Left e -> do
putStrLn $ show e <> " Traces: " <> show traces putStrLn $ show e <> " Traces: " <> show traces
Right _v -> Right _v ->
pure () pure ()
_test :: IO () _test :: IO ()
_test = do _test = do
let (res, _budget, traces) = evalScript $ compile (authorityTokensValidIn # pconstant currSymbol # (pconstant $ let (res, _budget, traces) =
TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , evalScript $
txOutValue = Value.singleton currSymbol validatorHashTN 1, compile
txOutDatumHash = Just (DatumHash "")})) ( authorityTokensValidIn # pconstant currSymbol
case res of # ( pconstant $
Left e -> do TxOut
putStrLn $ show e <> " Traces: " <> show traces { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
Right _v -> , txOutValue = Value.singleton currSymbol validatorHashTN 1
pure () , txOutDatumHash = Just (DatumHash "")
}
)
)
case res of
Left e -> do
putStrLn $ show e <> " Traces: " <> show traces
Right _v ->
pure ()
_test2 :: IO() _test2 :: IO ()
_test2 = do _test2 = do
let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv)) let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv))
case res of case res of
Left e -> do Left e -> do
putStrLn $ show e <> " Traces: " <> show traces putStrLn $ show e <> " Traces: " <> show traces
Right _v -> Right _v ->
putStrLn $ show res putStrLn $ show res
where where
mv = mempty -- Value.singleton currSymbol validatorHashTN (1) mv = mempty -- Value.singleton currSymbol validatorHashTN (1)
tinfo = TxInfo tinfo =
{ txInfoInputs = TxInfo
[ TxInInfo -- Initiator { txInfoInputs =
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) [ TxInInfo -- Initiator
TxOut (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing TxOut
, txOutValue = mempty { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutDatumHash = Just (DatumHash "") , txOutValue = mempty
} , txOutDatumHash = Just (DatumHash "")
, TxInInfo -- Treasury 1
(TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
TxOut
{ txOutAddress = Address (treasuries !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 10
, txOutDatumHash = Just (DatumHash "")
}
, TxInInfo -- Treasury 2
(TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
TxOut
{ txOutAddress = Address (treasuries !! 1) Nothing
, txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
, txOutDatumHash = Just (DatumHash "")
}
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (users !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1
, txOutDatumHash = Nothing
} }
, TxOut , TxInInfo -- Treasury 1
{ txOutAddress = Address (users !! 1) Nothing (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
, txOutValue = Value.singleton gtSymbol gtToken 1 TxOut
, txOutDatumHash = Nothing
}
, TxOut
{ txOutAddress = Address (users !! 2) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1
, txOutDatumHash = Nothing
}
-- Send left overs to treasuries
, TxOut
{ txOutAddress = Address (treasuries !! 0) Nothing { txOutAddress = Address (treasuries !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 7
, txOutDatumHash = Nothing
}
, TxOut
{ txOutAddress = Address (treasuries !! 1) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 10 , txOutValue = Value.singleton gtSymbol gtToken 10
, txOutDatumHash = Nothing , txOutDatumHash = Just (DatumHash "")
} }
] , TxInInfo -- Treasury 2
, txInfoFee = Value.singleton "" "" 2 (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
, txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1) TxOut
, txInfoDCert = [] { txOutAddress = Address (treasuries !! 1) Nothing
, txInfoWdrl = [] , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
, txInfoValidRange = Interval.always , txOutDatumHash = Just (DatumHash "")
, txInfoSignatories = [signer] }
, txInfoData = [] ]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" , txInfoOutputs =
} [ TxOut
{ txOutAddress = Address (users !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1
, txOutDatumHash = Nothing
}
, TxOut
{ txOutAddress = Address (users !! 1) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1
, txOutDatumHash = Nothing
}
, TxOut
{ txOutAddress = Address (users !! 2) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 1
, txOutDatumHash = Nothing
}
, -- Send left overs to treasuries
TxOut
{ txOutAddress = Address (treasuries !! 0) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 7
, txOutDatumHash = Nothing
}
, TxOut
{ txOutAddress = Address (treasuries !! 1) Nothing
, txOutValue = Value.singleton gtSymbol gtToken 10
, txOutDatumHash = Nothing
}
]
, txInfoFee = Value.singleton "" "" 2
, txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1)
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = [signer]
, txInfoData = []
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
}

1
agora-test/Spec/Util.hs
View file

@ -131,7 +131,6 @@ validatorFailsWith tag policy datum redeemer scriptContext =
# pconstant scriptContext # pconstant scriptContext
) )
-- | Check that a validator script succeeds, given a name and arguments. -- | Check that a validator script succeeds, given a name and arguments.
effectSucceedsWith :: effectSucceedsWith ::
( PLift datum ( PLift datum

89
agora/Agora/Effect/TreasuryWithdrawal.hs
View file

@ -22,8 +22,6 @@ import Plutarch (popaque)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PCredential, PCredential,
PTuple, PTuple,
PTxInInfo (PTxInInfo),
PTxOut (PTxOut),
PValidator, PValidator,
PValue, PValue,
ptuple, ptuple,
@ -92,58 +90,55 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
let outputValues = let outputValues =
pmap pmap
# plam # plam
( \out' -> P.do ( \(pfromData -> out') -> P.do
out <- pletFields @'["address", "value"] $ pfromData out' out <- pletFields @'["address", "value"] $ out'
cred <- pletFields @'["credential"] $ pfromData out.address cred <- pletFields @'["credential"] $ pfromData out.address
pdata $ ptuple # cred.credential # out.value pdata $ ptuple # cred.credential # out.value
) )
# txInfo.outputs # txInfo.outputs
inputValues =
pmap
# plam
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
txOut <- pletFields @'["address", "value"] $ txOut'
pdata $ ptuple # txOut.address # txOut.value
)
# txInfo.inputs
treasuryInputValues =
pfilter
# plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
# inputValues
treasuryCredentials =
pmap
# plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData)
# treasuryInputValues
treasuryOutputValues =
pfilter
# plam
( \((pfield @"_0" #) . pfromData -> addr) -> P.do
pelem # addr # treasuryCredentials
)
# outputValues
treasuryInputValuesSum =
pfoldr
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
# pconstant (mempty :: Value)
# treasuryInputValues
treasuryOutputValuesSum =
pfoldr
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
# pconstant (mempty :: Value)
# treasuryOutputValues
receiverValuesSum =
pfoldr
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
# pconstant (mempty :: Value)
# receivers
outputContentMatchesRecivers = outputContentMatchesRecivers =
pall # plam (\out -> pelem # out # outputValues) pall # plam (\out -> pelem # out # outputValues)
#$ receivers #$ receivers
sumValues =
pfoldr
# plam
( \((pfield @"_1" #) . pfromData -> x) y -> P.do
paddValue # pfromData x # y
)
# pconstant (mempty :: Value)
inputCred =
pmap
# plam
( \inInfo -> P.do
PTxInInfo inInfo' <- pmatch $ pfromData inInfo
PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo'
let addr = pfromData $ pfield @"address" # out
pfield @"credential" # addr
)
# pfromData txInfo.inputs
totalTreasuryInputs =
pfoldr
# plam
( \x' y -> P.do
PTxInInfo x <- pmatch $ pfromData x'
PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x
-- only take ones from treasury
pif
(effInput.address #== pfield @"address" # out)
(paddValue # pfromData (pfield @"value" # out) # y)
y
)
# pconstant (mempty :: Value)
# pfromData txInfo.inputs
sumOutputsToTreasury =
sumValues
#$ pfilter
# plam
( \((pfield @"_0" #) . pfromData -> addr) ->
pelem # addr # inputCred
#&& pnot # (addr #== pfield @"credential" # effInput.address)
)
# outputValues
-- TODO: Probably need to check/exclude the effect input...
excessShouldBePaidToInputs = excessShouldBePaidToInputs =
pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
shouldNotPayToEffect = shouldNotPayToEffect =
pnot #$ pany pnot #$ pany
# plam # plam
@ -154,5 +149,5 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Transaction output does not match receivers" outputContentMatchesRecivers
passert "Transaction should not pay to effects" shouldNotPayToEffect passert "Transaction should not pay to effects" shouldNotPayToEffect
passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs -- We might not need this. passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
popaque $ pconstant () popaque $ pconstant ()