diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index 96dbc35..f3e9396 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -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" + } diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 1ebdc07..32fa1b1 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -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 diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 1156a3c..ddf3f32 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -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 ()