Sulkta-Coop/agora
2
0
Fork 0
Code Issues 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 6c62c007f1
commit fe5c18969e
No known key found for this signature in database
GPG key ID: 9B0E12D357369B66
3 changed files with 165 additions and 163 deletions
Download patch file Download diff file Expand all files Collapse all files

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

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

@ -22,8 +22,6 @@ import Plutarch (popaque)
import Plutarch.Api.V1 (
PCredential,
PTuple,
PTxInInfo (PTxInInfo),
PTxOut (PTxOut),
PValidator,
PValue,
ptuple,
@ -92,58 +90,55 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
let outputValues =
pmap
# plam
( \out' -> P.do
out <- pletFields @'["address", "value"] $ pfromData out'
( \(pfromData -> out') -> P.do
out <- pletFields @'["address", "value"] $ out'
cred <- pletFields @'["credential"] $ pfromData out.address
pdata $ ptuple # cred.credential # out.value
)
# 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 =
pall # plam (\out -> pelem # out # outputValues)
#$ 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 =
pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs
pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
shouldNotPayToEffect =
pnot #$ pany
# plam
@ -154,5 +149,5 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
passert "Transaction output does not match receivers" outputContentMatchesRecivers
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 ()