Sulkta-Coop/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #17 from Liqwid-Labs/jhodgdev/plutarch-bump

Browse source 
jhodgdev/plutarch bump
This commit is contained in:
Jack Hodgkinson 2022-02-02 15:38:00 +00:00 • committed by GitHub
commit f5fc5599b3
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
4 changed files with 63 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -11,7 +11,7 @@ usage:
HOOGLE_PORT=8081
hoogle:
hoogle server --local --port $(HOOGLE_PORT)
hoogle server --local --port $(HOOGLE_PORT) > /dev/null &
FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -fplugin=RecordDotPreprocessor
format:

31
flake.lock generated
View file

@ -710,6 +710,22 @@
}
},
"haskell-language-server": {
"flake": false,
"locked": {
"lastModified": 1643360816,
"narHash": "sha256-M4noTbTGa7oYfg2/8NqDugGX/qs8j//gJUiLwuPU9Co=",
"owner": "haskell",
"repo": "haskell-language-server",
"rev": "ce41b6459af131c845f942bd39e356f02b6306fa",
"type": "github"
},
"original": {
"owner": "haskell",
"repo": "haskell-language-server",
"type": "github"
}
},
"haskell-language-server_2": {
"flake": false,
"locked": {
"lastModified": 1638136578,
@ -726,7 +742,7 @@
"type": "github"
}
},
"haskell-language-server_2": {
"haskell-language-server_3": {
"flake": false,
"locked": {
"lastModified": 1638136578,
@ -1363,6 +1379,7 @@
"flake-compat-ci": "flake-compat-ci",
"flat": "flat_2",
"foundation": "foundation",
"haskell-language-server": "haskell-language-server",
"haskell-nix": "haskell-nix_2",
"hercules-ci-effects": "hercules-ci-effects",
"hs-memory": "hs-memory",
@ -1376,17 +1393,17 @@
"th-extras": "th-extras"
},
"locked": {
"lastModified": 1642778520,
"narHash": "sha256-wLWcjeuGUcH8rYz/LXIxUTO/Wnfvq/5GBS55cqof6nE=",
"lastModified": 1643303963,
"narHash": "sha256-Ta3PLyLX209Dj1LWljkp9ynlA+QPJyaI2g6oQgBeueM=",
"owner": "Plutonomicon",
"repo": "plutarch",
"rev": "d845c2ad3292d141b61024dc24c9ab305540dc98",
"rev": "d753dc34dfc30b144e94d6493c837ebd0c99b588",
"type": "github"
},
"original": {
"owner": "Plutonomicon",
"repo": "plutarch",
"rev": "d845c2ad3292d141b61024dc24c9ab305540dc98",
"rev": "d753dc34dfc30b144e94d6493c837ebd0c99b588",
"type": "github"
}
},
@ -1395,7 +1412,7 @@
"cardano-repo-tool": "cardano-repo-tool",
"gitignore-nix": "gitignore-nix",
"hackage-nix": "hackage-nix",
"haskell-language-server": "haskell-language-server",
"haskell-language-server": "haskell-language-server_2",
"haskell-nix": "haskell-nix_3",
"iohk-nix": "iohk-nix",
"nixpkgs": "nixpkgs_3",
@ -1440,7 +1457,7 @@
"cardano-repo-tool": "cardano-repo-tool_2",
"gitignore-nix": "gitignore-nix_2",
"hackage-nix": "hackage-nix_2",
"haskell-language-server": "haskell-language-server_2",
"haskell-language-server": "haskell-language-server_3",
"haskell-nix": "haskell-nix_4",
"iohk-nix": "iohk-nix_2",
"nixpkgs": "nixpkgs_4",

2
flake.nix
View file

@ -10,7 +10,7 @@
"github:input-output-hk/plutus?rev=65bad0fd53e432974c3c203b1b1999161b6c2dce";
inputs.plutarch.url =
"github:Plutonomicon/plutarch?rev=d845c2ad3292d141b61024dc24c9ab305540dc98";
"github:Plutonomicon/plutarch?rev=d753dc34dfc30b144e94d6493c837ebd0c99b588";
inputs.goblins.url =
"github:input-output-hk/goblins?rev=cde90a2b27f79187ca8310b6549331e59595e7ba";

67
src/Agora/AuthorityToken.hs
View file

@ -1,8 +1,11 @@
module Agora.AuthorityToken (authorityTokenPolicy, AuthorityToken (..), serialisedScriptSize) where
module Agora.AuthorityToken (
authorityTokenPolicy,
AuthorityToken (..),
serialisedScriptSize,
) where
--------------------------------------------------------------------------------
import Data.Proxy (Proxy (..))
import Prelude
--------------------------------------------------------------------------------
@ -24,23 +27,17 @@ import Plutus.V1.Ledger.Value (AssetClass (..))
--------------------------------------------------------------------------------
import Plutarch.Api.V1 hiding (PMaybe (..))
import Plutarch.Bool (PBool, PEq, pif, (#<), (#==))
import Plutarch.Builtin (PBuiltinPair, PData, pdata, pfromData, pfstBuiltin, psndBuiltin)
import Plutarch.DataRepr (pindexDataList)
import Plutarch.Integer (PInteger)
import Plutarch.Lift (pconstant)
import Plutarch.List (PIsListLike, pfoldr', precList)
import Plutarch.Maybe (PMaybe (PJust, PNothing))
import Plutarch.Api.V1
import Plutarch.List (pfoldr')
import Plutarch.Prelude
import Plutarch.Trace (ptraceError)
import Plutarch.Unit (PUnit)
--------------------------------------------------------------------------------
{- | An AuthorityToken represents a proof that a particular token moved while this token was minted.
In effect, this means that the validator that locked such a token must have approved said transaction.
Said validator should be made aware of _this_ token's existence in order to prevent incorrect minting.
{- | An AuthorityToken represents a proof that a particular token
moved while this token was minted. In effect, this means that
the validator that locked such a token must have approved
said transaction. Said validator should be made aware of
_this_ token's existence in order to prevent incorrect minting.
-}
data AuthorityToken = AuthorityToken
{ -- | Token that must move in order for minting this to be valid.
@ -50,14 +47,19 @@ data AuthorityToken = AuthorityToken
--------------------------------------------------------------------------------
-- TODO: upstream something like this
pfind' :: PIsListLike list a => (Term s a -> Term s PBool) -> Term s (list a :--> PMaybe a)
pfind' ::
PIsListLike list a =>
(Term s a -> Term s PBool) ->
Term s (list a :--> PMaybe a)
pfind' p =
precList
(\self x xs -> pif (p x) (pcon (PJust x)) (self # xs))
(const $ pcon PNothing)
-- TODO: upstream something like this
plookup :: (PEq a, PIsListLike list (PBuiltinPair a b)) => Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b)
plookup ::
(PEq a, PIsListLike list (PBuiltinPair a b)) =>
Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b)
plookup =
phoistAcyclic $
plam $ \k xs ->
@ -69,7 +71,8 @@ passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
passetClassValueOf' (AssetClass (sym, token)) =
passetClassValueOf # pconstant sym # pconstant token
passetClassValueOf :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger)
passetClassValueOf ::
Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger)
passetClassValueOf =
phoistAcyclic $
plam $ \sym token value'' ->
@ -83,7 +86,8 @@ passetClassValueOf =
PNothing -> 0
PJust v -> pfromData v
-- TODO: We should rely on plutus-extra instead of rolling our own, this is just quick & hacky.
-- TODO: We should rely on plutus-extra instead of rolling our own,
-- this is just quick and hacky.
serialisedScriptSize :: Script -> Int
serialisedScriptSize =
BSS.length
@ -93,26 +97,29 @@ serialisedScriptSize =
. BS.toStrict
. serialise
authorityTokenPolicy :: AuthorityToken -> Term s (PData :--> PData :--> PScriptContext :--> PUnit)
authorityTokenPolicy ::
AuthorityToken ->
Term s (PData :--> PData :--> PScriptContext :--> PUnit)
authorityTokenPolicy params =
plam $ \_datum _redeemer ctx' ->
pmatch ctx' $ \(PScriptContext ctx) ->
let txInfo' =
pfromData $ pindexDataList (Proxy @0) # ctx
purpose' =
pfromData $ pindexDataList (Proxy @1) # ctx
let txInfo' = pfromData $ pfield @"txInfo" # ctx
purpose' = pfromData $ pfield @"purpose" # ctx
inputs =
pmatch txInfo' $ \(PTxInfo txInfo) ->
pfromData $ pindexDataList (Proxy @0) # txInfo
pfromData $ pfield @"inputs" # txInfo
authorityTokenInputs =
pfoldr'
( \txInInfo' acc ->
pmatch (pfromData txInInfo') $ \(PTxInInfo txInInfo) ->
let txOut' = pfromData $ pindexDataList (Proxy @1) # txInInfo
txOutValue = pmatch txOut' $ \(PTxOut txOut) -> pfromData $ pindexDataList (Proxy @1) # txOut
let txOut' =
pfromData $ pfield @"resolved" # txInInfo
txOutValue =
pmatch txOut' $
\(PTxOut txOut) ->
pfromData $ pfield @"value" # txOut
in passetClassValueOf' params.authority # txOutValue + acc
)
# (0 :: Term s PInteger)
@ -121,12 +128,12 @@ authorityTokenPolicy params =
-- We incur the cost twice here. This will be fixed upstream in Plutarch.
mintedValue =
pmatch txInfo' $ \(PTxInfo txInfo) ->
pfromData $ pindexDataList (Proxy @3) # txInfo
pfromData $ pfield @"mint" # txInfo
tokenMoved = 0 #< authorityTokenInputs
in pmatch purpose' $ \case
PMinting sym' ->
let sym = pfromData $ pindexDataList (Proxy @0) # sym'
let sym = pfromData $ pfield @"_0" # sym'
mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
in pif
(0 #< mintedATs)