Now it checks specific treasury
Emily's suggestion on the review
This commit is contained in:
parent
17817ba68b
commit
ec46273b5b
4 changed files with 64 additions and 34 deletions
|
|
@ -7,16 +7,16 @@ This module tests the Treasury Withdrawal Effect.
|
||||||
-}
|
-}
|
||||||
module Spec.Effect.TreasuryWithdrawal (tests) where
|
module Spec.Effect.TreasuryWithdrawal (tests) where
|
||||||
|
|
||||||
import Spec.Sample.Effect.TreasuryWithdrawal (
|
import Spec.Sample.Effect.TreasuryWithdrawal
|
||||||
buildReceiversOutputFromDatum,
|
( currSymbol,
|
||||||
buildScriptContext,
|
users,
|
||||||
currSymbol,
|
treasuries,
|
||||||
inputGAT,
|
inputGAT,
|
||||||
inputTreasury,
|
inputTreasury,
|
||||||
outputTreasury,
|
outputTreasury,
|
||||||
outputUser,
|
outputUser,
|
||||||
users,
|
buildReceiversOutputFromDatum,
|
||||||
)
|
buildScriptContext )
|
||||||
|
|
||||||
import Agora.Effect.TreasuryWithdrawal (
|
import Agora.Effect.TreasuryWithdrawal (
|
||||||
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
||||||
|
|
@ -102,6 +102,18 @@ tests =
|
||||||
]
|
]
|
||||||
++ drop 1 (buildReceiversOutputFromDatum datum2)
|
++ drop 1 (buildReceiversOutputFromDatum datum2)
|
||||||
)
|
)
|
||||||
|
, effectFailsWith
|
||||||
|
"Unauthorized treasury"
|
||||||
|
(treasuryWithdrawalValidator currSymbol)
|
||||||
|
datum3
|
||||||
|
( buildScriptContext
|
||||||
|
[ inputGAT
|
||||||
|
, inputTreasury 999 (asset1 20)
|
||||||
|
]
|
||||||
|
$ [ outputTreasury 999 (asset1 17)
|
||||||
|
]
|
||||||
|
++ buildReceiversOutputFromDatum datum3
|
||||||
|
)
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
|
|
@ -112,10 +124,26 @@ tests =
|
||||||
[ (head users, asset1 1)
|
[ (head users, asset1 1)
|
||||||
, (users !! 1, asset1 1)
|
, (users !! 1, asset1 1)
|
||||||
, (users !! 2, asset1 1)
|
, (users !! 2, asset1 1)
|
||||||
|
] $
|
||||||
|
[ head treasuries
|
||||||
|
, treasuries !! 1
|
||||||
|
, treasuries !! 2
|
||||||
]
|
]
|
||||||
datum2 =
|
datum2 =
|
||||||
TreasuryWithdrawalDatum
|
TreasuryWithdrawalDatum
|
||||||
[ (head users, asset1 4 <> asset2 5)
|
[ (head users, asset1 4 <> asset2 5)
|
||||||
, (users !! 1, asset1 2 <> asset2 1)
|
, (users !! 1, asset1 2 <> asset2 1)
|
||||||
, (users !! 2, asset1 1)
|
, (users !! 2, asset1 1)
|
||||||
|
] $
|
||||||
|
[ head treasuries
|
||||||
|
, treasuries !! 1
|
||||||
|
, treasuries !! 2
|
||||||
|
]
|
||||||
|
datum3 =
|
||||||
|
TreasuryWithdrawalDatum
|
||||||
|
[ (head users, asset1 1)
|
||||||
|
, (users !! 1, asset1 1)
|
||||||
|
, (users !! 2, asset1 1)
|
||||||
|
] $
|
||||||
|
[ treasuries !! 1
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -112,7 +112,7 @@ outputUser indx val =
|
||||||
}
|
}
|
||||||
|
|
||||||
buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
|
buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
|
||||||
buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs
|
buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
|
||||||
where
|
where
|
||||||
f x =
|
f x =
|
||||||
TxOut
|
TxOut
|
||||||
|
|
|
||||||
|
|
@ -38,7 +38,11 @@ import Plutus.V1.Ledger.Credential (Credential)
|
||||||
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
|
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
|
||||||
import PlutusTx qualified
|
import PlutusTx qualified
|
||||||
|
|
||||||
newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
|
data TreasuryWithdrawalDatum =
|
||||||
|
TreasuryWithdrawalDatum
|
||||||
|
{ receivers :: [(Credential, Value)]
|
||||||
|
, treasuries :: [Credential]
|
||||||
|
}
|
||||||
deriving stock (Show, GHC.Generic)
|
deriving stock (Show, GHC.Generic)
|
||||||
deriving anyclass (Generic)
|
deriving anyclass (Generic)
|
||||||
|
|
||||||
|
|
@ -50,7 +54,9 @@ newtype PTreasuryWithdrawalDatum (s :: S)
|
||||||
( Term
|
( Term
|
||||||
s
|
s
|
||||||
( PDataRecord
|
( PDataRecord
|
||||||
'["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))]
|
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
|
||||||
|
, "treasuries" ':= PBuiltinList (PAsData PCredential)
|
||||||
|
]
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
deriving stock (GHC.Generic)
|
deriving stock (GHC.Generic)
|
||||||
|
|
@ -83,17 +89,17 @@ deriving via
|
||||||
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
|
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
|
||||||
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
||||||
\_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
|
\_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
|
||||||
receivers <- plet $ pfromData $ pfield @"receivers" # datum'
|
datum <- pletFields @'["receivers", "treasuries"] datum'
|
||||||
txInfo <- pletFields @'["outputs", "inputs"] txInfo'
|
txInfo <- pletFields @'["outputs", "inputs"] txInfo'
|
||||||
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
|
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
|
||||||
effInput <- pletFields @'["address", "value"] $ txOut
|
effInput <- pletFields @'["address", "value"] $ txOut
|
||||||
let outputValues =
|
let outputValues =
|
||||||
pmap
|
pmap
|
||||||
# plam
|
# plam
|
||||||
( \(pfromData -> out') -> P.do
|
( \(pfromData -> txOut') -> P.do
|
||||||
out <- pletFields @'["address", "value"] $ out'
|
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||||
cred <- pletFields @'["credential"] $ pfromData out.address
|
let cred = pfield @"credential" # pfromData txOut.address
|
||||||
pdata $ ptuple # cred.credential # out.value
|
pdata $ ptuple # cred # txOut.value
|
||||||
)
|
)
|
||||||
# txInfo.outputs
|
# txInfo.outputs
|
||||||
inputValues =
|
inputValues =
|
||||||
|
|
@ -101,23 +107,19 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
||||||
# plam
|
# plam
|
||||||
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
|
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
|
||||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||||
pdata $ ptuple # txOut.address # txOut.value
|
let cred = pfield @"credential" # pfromData txOut.address
|
||||||
|
pdata $ ptuple # cred # txOut.value
|
||||||
)
|
)
|
||||||
# txInfo.inputs
|
# txInfo.inputs
|
||||||
treasuryInputValues <- plet $
|
treasuryInputValues <-
|
||||||
pfilter
|
plet $
|
||||||
# plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
|
pfilter
|
||||||
# inputValues
|
# plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
|
||||||
let treasuryCredentials =
|
# inputValues
|
||||||
pmap
|
let treasuryOutputValues =
|
||||||
# plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData)
|
|
||||||
# treasuryInputValues
|
|
||||||
treasuryOutputValues =
|
|
||||||
pfilter
|
pfilter
|
||||||
# plam
|
# plam
|
||||||
( \((pfield @"_0" #) . pfromData -> addr) -> P.do
|
( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
|
||||||
pelem # addr # treasuryCredentials
|
|
||||||
)
|
|
||||||
# outputValues
|
# outputValues
|
||||||
treasuryInputValuesSum =
|
treasuryInputValuesSum =
|
||||||
pfoldr
|
pfoldr
|
||||||
|
|
@ -133,10 +135,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
||||||
pfoldr
|
pfoldr
|
||||||
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
|
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
|
||||||
# pconstant (mempty :: Value)
|
# pconstant (mempty :: Value)
|
||||||
# receivers
|
# datum.receivers
|
||||||
outputContentMatchesRecivers =
|
outputContentMatchesRecivers =
|
||||||
pall # plam (\out -> pelem # out # outputValues)
|
pall # plam (\out -> pelem # out # outputValues)
|
||||||
#$ receivers
|
#$ datum.receivers
|
||||||
excessShouldBePaidToInputs =
|
excessShouldBePaidToInputs =
|
||||||
pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
|
pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
|
||||||
shouldNotPayToEffect =
|
shouldNotPayToEffect =
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue