Merge pull request #91 from Liqwid-Labs/emiflake/script-export

Export Scripts into JSON file for CTL consumption.

agora-scripts/Options.hs

@@ -0,0 +1,45 @@
+{- |
+Module     : Options
+Maintainer : emi@haskell.fyi
+Description: Command line options for 'agora-scripts'.
+
+Command line options for 'agora-scripts'.
+-}
+module Options (Options (..), parseOptions) where
+
+import Options.Applicative ((<**>))
+import Options.Applicative qualified as Opt
+
+data Options = Options
+  { config :: FilePath
+  , output :: FilePath
+  }
+  deriving stock (Show, Eq)
+
+opt :: Opt.Parser Options
+opt =
+  Options
+    <$> Opt.strOption
+      ( Opt.long "config"
+          <> Opt.short 'c'
+          <> Opt.metavar "CONFIG_PATH"
+          <> Opt.value "./agora-scripts/agora-params.json"
+          <> Opt.help "The path where the script configuration is."
+      )
+    <*> Opt.strOption
+      ( Opt.long "output"
+          <> Opt.short 'o'
+          <> Opt.metavar "OUTPUT_PATH"
+          <> Opt.value "./agora-scripts/agora-scripts.json"
+          <> Opt.help "Output where generated scripts will be."
+      )
+
+parseOptions :: IO Options
+parseOptions = Opt.execParser p
+  where
+    p =
+      Opt.info
+        (opt <**> Opt.helper)
+        ( Opt.fullDesc
+            <> Opt.progDesc "Generate Agora scripts for off-chain use."
+        )

agora-scripts/Scripts.hs

@@ -0,0 +1,113 @@
+{- |
+Module     : Scripts
+Maintainer : emi@haskell.fyi
+Description: Export scripts given configuration.
+
+Export scripts given configuration.
+-}
+module Main (main) where
+
+import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy)
+import Agora.Governor (Governor (Governor))
+import Agora.Governor qualified as Governor
+import Agora.Governor.Scripts (
+  authorityTokenFromGovernor,
+  authorityTokenSymbolFromGovernor,
+  governorPolicy,
+  governorValidator,
+  proposalFromGovernor,
+  stakeFromGovernor,
+ )
+import Agora.Proposal (Proposal)
+import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
+import Agora.SafeMoney (GTTag)
+import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo)
+import Agora.Stake (Stake)
+import Agora.Stake.Scripts (stakePolicy, stakeValidator)
+import Agora.Treasury (treasuryValidator)
+import Control.Monad ((>=>))
+import Data.Aeson qualified as Aeson
+import GHC.Generics qualified as GHC
+import Options (Options (..), parseOptions)
+import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
+import Plutarch.SafeMoney (Tagged)
+import Plutus.V1.Ledger.Api (TxOutRef)
+import Plutus.V1.Ledger.Value (AssetClass, CurrencySymbol)
+import Plutus.V1.Ledger.Value qualified as Value
+import System.Exit (exitFailure)
+import Text.Printf (printf)
+
+-- | Params required for creating script export.
+data ScriptParams = ScriptParams
+  { governorInitialSpend :: TxOutRef
+  , gtClassRef :: Tagged GTTag AssetClass
+  , maximumCosigners :: Integer
+  }
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+  deriving stock (Show, Eq, GHC.Generic)
+
+-- | Scripts that get exported.
+data AgoraScripts = AgoraScripts
+  { governorPolicyInfo :: PolicyInfo
+  , governorValidatorInfo :: ValidatorInfo
+  , stakePolicyInfo :: PolicyInfo
+  , stakeValidatorInfo :: ValidatorInfo
+  , proposalPolicyInfo :: PolicyInfo
+  , proposalValidatorInfo :: ValidatorInfo
+  , treasuryValidatorInfo :: ValidatorInfo
+  , authorityTokenPolicyInfo :: PolicyInfo
+  }
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+  deriving stock (Show, Eq, GHC.Generic)
+
+main :: IO ()
+main = do
+  options <- parseOptions
+
+  params <-
+    Aeson.eitherDecodeFileStrict @ScriptParams options.config
+      >>= either (putStrLn >=> const exitFailure) pure
+
+  let scripts = agoraScripts params
+
+  Aeson.encodeFile options.output scripts
+
+  printf "Done! Wrote to %s\n" options.output
+
+-- | Create scripts from params.
+agoraScripts :: ScriptParams -> AgoraScripts
+agoraScripts params =
+  AgoraScripts
+    { governorPolicyInfo = mkPolicyInfo (governorPolicy governor)
+    , governorValidatorInfo = mkValidatorInfo (governorValidator governor)
+    , stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef)
+    , stakeValidatorInfo = mkValidatorInfo (stakeValidator stake)
+    , proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass)
+    , proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal)
+    , treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol)
+    , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken)
+    }
+  where
+    governor :: Governor
+    governor =
+      Governor
+        { Governor.gstOutRef = params.governorInitialSpend
+        , Governor.gtClassRef = params.gtClassRef
+        , Governor.maximumCosigners = params.maximumCosigners
+        }
+
+    authorityToken :: AuthorityToken
+    authorityToken = authorityTokenFromGovernor governor
+
+    authorityTokenSymbol :: CurrencySymbol
+    authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
+
+    governorSTAssetClass :: AssetClass
+    governorSTAssetClass =
+      Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) ""
+
+    proposal :: Proposal
+    proposal = proposalFromGovernor governor
+
+    stake :: Stake
+    stake = stakeFromGovernor governor

agora-scripts/agora-params.json

@@ -0,0 +1,11 @@
+{
+  "governorInitialSpend": {
+    "txOutRefId": "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be",
+    "txOutRefIdx": 0
+  },
+  "gtClassRef": [
+    "",
+    ""
+  ],
+  "maximumCosigners": 5
+}

agora.cabal

@@ -145,19 +145,21 @@ library
     Agora.Treasury
     Agora.Utils
     Agora.Utils.Value
+    Agora.ScriptInfo
 
   other-modules:
+    Agora.Aeson.Orphans
   hs-source-dirs:  agora
 
 library pprelude
+  default-language: Haskell2010
+  exposed-modules:  PPrelude
+  hs-source-dirs:   agora
+
   build-depends:
     , base
     , plutarch
 
-  exposed-modules:  PPrelude
-  hs-source-dirs:   agora
-  default-language: Haskell2010
-
 library agora-testlib
   import:          lang, deps, test-deps
   exposed-modules: Test.Util
@@ -165,7 +167,6 @@ library agora-testlib
 
 library agora-sample
   import:          lang, deps, test-deps
-  build-depends:   agora-testlib
   exposed-modules:
     Sample.Effect.TreasuryWithdrawal
     Sample.Governor
@@ -173,9 +174,10 @@ library agora-sample
     Sample.Shared
     Sample.Stake
     Sample.Treasury
-
   hs-source-dirs:  agora-sample
 
+  build-depends:   agora-testlib
+
 test-suite agora-test
   import:         lang, deps, test-deps
   type:           exitcode-stdio-1.0
@@ -205,16 +207,26 @@ benchmark agora-bench
     , agora
     , agora-sample
 
+executable agora-scripts
+  import:         lang, deps, exe-opts
+  main-is:        Scripts.hs
+  hs-source-dirs: agora-scripts
+  other-modules:
+    Options
+  build-depends:
+    , agora
+    , optparse-applicative
+
 executable agora-purescript-bridge
   import:         lang, deps, exe-opts
   main-is:        Bridge.hs
+  hs-source-dirs: agora-purescript-bridge
+  other-modules:
+    AgoraTypes
+    Options
+
   build-depends:
     , agora
     , optparse-applicative
     , path
     , purescript-bridge
-
-  hs-source-dirs: agora-purescript-bridge
-  other-modules:
-    AgoraTypes
-    Options

agora/Agora/Aeson/Orphans.hs

@@ -0,0 +1,146 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Agora.Aeson.Orphans (AsBase16Bytes (..)) where
+
+--------------------------------------------------------------------------------
+
+import Data.Coerce (Coercible, coerce)
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Codec.Serialise qualified as Codec
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Types qualified as Aeson
+import Data.ByteString.Lazy qualified as Lazy
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api qualified as Plutus
+import Plutus.V1.Ledger.Bytes qualified as Plutus
+import Plutus.V1.Ledger.Value qualified as Plutus
+
+--------------------------------------------------------------------------------
+
+newtype AsBase16Bytes a = AsBase16Bytes {unAsBase16Bytes :: a}
+newtype AsBase16Codec a = AsBase16Codec {unAsBase16Codec :: a}
+
+deriving via
+  (Plutus.CurrencySymbol, Plutus.TokenName)
+  instance
+    Aeson.ToJSON Plutus.AssetClass
+
+deriving via
+  (Plutus.CurrencySymbol, Plutus.TokenName)
+  instance
+    Aeson.FromJSON Plutus.AssetClass
+
+deriving via
+  AsBase16Bytes Plutus.TxId
+  instance
+    Aeson.FromJSON Plutus.TxId
+
+deriving via
+  AsBase16Bytes Plutus.TxId
+  instance
+    Aeson.ToJSON Plutus.TxId
+
+deriving anyclass instance Aeson.FromJSON Plutus.TxOutRef
+deriving anyclass instance Aeson.ToJSON Plutus.TxOutRef
+
+instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) where
+  toJSON =
+    Aeson.String
+      . Plutus.encodeByteString
+      . Plutus.bytes
+      . coerce @(AsBase16Bytes a) @Plutus.LedgerBytes
+
+instance (Coercible Plutus.LedgerBytes a) => Aeson.FromJSON (AsBase16Bytes a) where
+  parseJSON v =
+    Aeson.parseJSON @T.Text v
+      >>= either (Aeson.parserThrowError []) (pure . coerce @_ @(AsBase16Bytes a))
+        . Plutus.fromHex
+        . T.encodeUtf8
+
+instance (Codec.Serialise a) => Aeson.ToJSON (AsBase16Codec a) where
+  toJSON =
+    Aeson.String
+      . Plutus.encodeByteString
+      . Lazy.toStrict
+      . Codec.serialise @a
+      . (.unAsBase16Codec)
+
+instance (Codec.Serialise a) => Aeson.FromJSON (AsBase16Codec a) where
+  parseJSON v =
+    Aeson.parseJSON @T.Text v
+      >>= either (Aeson.parserThrowError [] . show) (pure . AsBase16Codec)
+        . Codec.deserialiseOrFail
+        . Lazy.fromStrict
+        . T.encodeUtf8
+
+--------------------------------------------------------------------------------
+
+deriving via
+  (AsBase16Bytes Plutus.CurrencySymbol)
+  instance
+    (Aeson.ToJSON Plutus.CurrencySymbol)
+deriving via
+  (AsBase16Bytes Plutus.CurrencySymbol)
+  instance
+    (Aeson.FromJSON Plutus.CurrencySymbol)
+
+deriving via
+  (AsBase16Bytes Plutus.TokenName)
+  instance
+    (Aeson.ToJSON Plutus.TokenName)
+deriving via
+  (AsBase16Bytes Plutus.TokenName)
+  instance
+    (Aeson.FromJSON Plutus.TokenName)
+
+deriving via
+  (AsBase16Bytes Plutus.ValidatorHash)
+  instance
+    (Aeson.ToJSON Plutus.ValidatorHash)
+deriving via
+  (AsBase16Bytes Plutus.ValidatorHash)
+  instance
+    (Aeson.FromJSON Plutus.ValidatorHash)
+
+deriving via
+  (AsBase16Codec Plutus.Validator)
+  instance
+    (Aeson.ToJSON Plutus.Validator)
+deriving via
+  (AsBase16Codec Plutus.Validator)
+  instance
+    (Aeson.FromJSON Plutus.Validator)
+
+deriving via
+  (AsBase16Codec Plutus.MintingPolicy)
+  instance
+    (Aeson.ToJSON Plutus.MintingPolicy)
+deriving via
+  (AsBase16Codec Plutus.MintingPolicy)
+  instance
+    (Aeson.FromJSON Plutus.MintingPolicy)
+
+deriving via
+  (AsBase16Codec Plutus.Script)
+  instance
+    (Aeson.ToJSON Plutus.Script)
+deriving via
+  (AsBase16Codec Plutus.Script)
+  instance
+    (Aeson.FromJSON Plutus.Script)
+
+deriving via
+  Integer
+  instance
+    (Aeson.ToJSON Plutus.POSIXTime)
+deriving via
+  Integer
+  instance
+    (Aeson.FromJSON Plutus.POSIXTime)

agora/Agora/SafeMoney.hs

@@ -8,6 +8,9 @@ Tags and extras for "Plutarch.SafeMoney".
 module Agora.SafeMoney (
   ADATag,
   GTTag,
+  GovernorSTTag,
+  StakeSTTag,
+  ProposalSTTag,
   adaRef,
 ) where
 
@@ -18,7 +21,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 import Plutarch.SafeMoney
 
 --------------------------------------------------------------------------------
--- Example tags
+-- Tags
 
 -- | Governance token.
 data GTTag
@@ -26,6 +29,15 @@ data GTTag
 -- | ADA.
 data ADATag
 
+-- | Governor ST token.
+data GovernorSTTag
+
+-- | Stake ST token.
+data StakeSTTag
+
+-- | Proposal ST token.
+data ProposalSTTag
+
 --------------------------------------------------------------------------------
 
 -- | Resolves ada tags.

agora/Agora/ScriptInfo.hs

@@ -0,0 +1,63 @@
+{- |
+Module     : Agora.ScriptInfo
+Maintainer : emi@haskell.fyi
+Description: Exportable script bundles for off-chain consumption.
+
+Exportable script bundles for off-chain consumption.
+-}
+module Agora.ScriptInfo (
+  -- * Types
+  PolicyInfo (..),
+  ValidatorInfo (..),
+
+  -- * Introduction functions
+  mkValidatorInfo,
+  mkPolicyInfo,
+) where
+
+import Agora.Aeson.Orphans ()
+import Data.Aeson qualified as Aeson
+import GHC.Generics qualified as GHC
+import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
+import Plutus.V1.Ledger.Api (MintingPolicy, Validator, ValidatorHash)
+import Plutus.V1.Ledger.Value (CurrencySymbol)
+
+-- | Bundle containing a 'Validator' and its hash.
+data ValidatorInfo = ValidatorInfo
+  { script :: Validator
+  -- ^ The validator script.
+  , hash :: ValidatorHash
+  -- ^ Hash of the validator.
+  }
+  deriving stock (Show, Eq, GHC.Generic)
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+
+-- | Create a 'ValidatorInfo' given a Plutarch term.
+mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
+mkValidatorInfo term =
+  ValidatorInfo
+    { script = validator
+    , hash = validatorHash validator
+    }
+  where
+    validator = mkValidator term
+
+-- | Bundle containing a 'MintingPolicy' and its symbol.
+data PolicyInfo = PolicyInfo
+  { policy :: MintingPolicy
+  -- ^ The minting policy.
+  , currencySymbol :: CurrencySymbol
+  -- ^ The symbol given by the minting policy.
+  }
+  deriving stock (Show, Eq, GHC.Generic)
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+
+-- | Create a 'PolicyInfo' given a Plutarch term.
+mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
+mkPolicyInfo term =
+  PolicyInfo
+    { policy = policy
+    , currencySymbol = mintingPolicySymbol policy
+    }
+  where
+    policy = mkMintingPolicy term

agora/Agora/Treasury.hs

@@ -72,6 +72,7 @@ deriving via
      do so in a valid manner.
 -}
 treasuryValidator ::
+  -- | Governance Authority Token that can unlock this validator.
   CurrencySymbol ->
   ClosedTerm PValidator
 treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do