From eb4c50e73b3263225bbe2eb5b5c1f15ec0f2c652 Mon Sep 17 00:00:00 2001 From: SIDANWhatever Date: Tue, 22 Nov 2022 18:11:06 +0800 Subject: [PATCH] feature: modulized selected orphans --- example/gimbalabs-example.cabal | 5 +- example/src/ContributorToken/Types.hs | 2 +- example/src/Dev/DevDefaultOrphans.hs | 5 + .../Dev/DevInstances.hs} | 78 +--------- example/src/Dev/DevPlutusServer.hs | 75 ++++++++++ example/src/ParamScriptAPI.hs | 5 +- example/src/TestingValidator.hs | 22 ++- sidan-plutus-server.cabal | 2 + src/SIDANDefaultOrphans.hs | 5 + src/SIDANInstances.hs | 141 ++++++++++++++++++ 10 files changed, 253 insertions(+), 87 deletions(-) create mode 100644 example/src/Dev/DevDefaultOrphans.hs rename example/{dev/DevelopmentSourceCode.hs => src/Dev/DevInstances.hs} (60%) create mode 100644 example/src/Dev/DevPlutusServer.hs create mode 100644 src/SIDANDefaultOrphans.hs create mode 100644 src/SIDANInstances.hs diff --git a/example/gimbalabs-example.cabal b/example/gimbalabs-example.cabal index a9df990..07c723b 100644 --- a/example/gimbalabs-example.cabal +++ b/example/gimbalabs-example.cabal @@ -20,7 +20,10 @@ library , ContributorToken.ReferenceValidator , ContributorToken.Compiler , ContributorToken.Types - -- , DevelopmentSourceCode + + , Dev.DevPlutusServer + , Dev.DevInstances + , Dev.DevDefaultOrphans build-depends: aeson , base ^>=4.14.1.0 diff --git a/example/src/ContributorToken/Types.hs b/example/src/ContributorToken/Types.hs index 84caec5..a455d3f 100644 --- a/example/src/ContributorToken/Types.hs +++ b/example/src/ContributorToken/Types.hs @@ -21,7 +21,7 @@ import PlutusTx.Prelude hiding (Semigroup (..), unless) import Prelude (Show (..)) import qualified Prelude as Pr import Data.Aeson (FromJSON, ToJSON) -import SIDANPlutusServer +import Dev.DevDefaultOrphans() -- ReferenceParams data ReferenceParams = ReferenceParams diff --git a/example/src/Dev/DevDefaultOrphans.hs b/example/src/Dev/DevDefaultOrphans.hs new file mode 100644 index 0000000..b9ceb9f --- /dev/null +++ b/example/src/Dev/DevDefaultOrphans.hs @@ -0,0 +1,5 @@ +module Dev.DevDefaultOrphans where + +import Ledger.Builtins.Orphans +import Ledger.Credential.Orphans +import Ledger.Value.Orphans \ No newline at end of file diff --git a/example/dev/DevelopmentSourceCode.hs b/example/src/Dev/DevInstances.hs similarity index 60% rename from example/dev/DevelopmentSourceCode.hs rename to example/src/Dev/DevInstances.hs index 15e9dd2..bb313cb 100644 --- a/example/dev/DevelopmentSourceCode.hs +++ b/example/src/Dev/DevInstances.hs @@ -1,85 +1,14 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -module DevelopmentSourceCode ( - Api, - createServer, - createEndpoint, - mkV1Validator, - mkV2Validator, - mkV1MintingPolicy, - mkV2MintingPolicy -) where - -import Cardano.Api as API -import qualified Cardano.Api.SerialiseTextEnvelope as SAPI -import Cardano.Api.Shelley (PlutusScript (..)) -import Codec.Serialise (serialise) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Short as SBS -import Data.HVect hiding (pack) -import Data.Text (pack) -import qualified Plutus.V1.Ledger.Scripts as PlutusV1 -import qualified Plutus.V2.Ledger.Api as PlutusV2 -import Web.Spock -import Web.Spock.Config +module Dev.DevInstances where -- Below import for JSON instances implementations import qualified Plutus.V1.Ledger.Value as PlutusV1 +import qualified Plutus.V2.Ledger.Api as PlutusV2 import Data.Aeson ((.:), (.:?), (.=), parseJSON, withObject, toJSON, toEncoding, object, pairs, ToJSON, FromJSON) import Ledger.Builtins.Orphans import Cardano.Ledger.Crypto -type Api = SpockM () () () () - -createServer :: Web.Spock.SpockM () () () () -> IO () -createServer app = do - spockCfg <- defaultSpockCfg () PCNoDatabase () - runSpock 8080 (spock spockCfg app) - -createEndpoint :: Data.HVect.HasRep xs => - Path xs ps - -> Data.HVect.HVectElim xs (SpockActionCtx ctx conn sess st ()) - -> SpockCtxM ctx conn sess st () -createEndpoint path = do post path - --- Validator - -writeV1Validator :: PlutusV1.Validator -> LBS.ByteString -writeV1Validator = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV1) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV1.unValidatorScript - -mkV1Validator :: (FromJSON a, ToJSON a) => (a -> PlutusV1.Validator) -> ActionCtxT () (WebStateM () () ()) b -mkV1Validator val = do - scriptParam <- jsonBody' - json $ pack $ show $ writeV1Validator $ val scriptParam - -writeV2Validator :: PlutusV2.Validator -> LBS.ByteString -writeV2Validator = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV2) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV2.unValidatorScript - -mkV2Validator :: (FromJSON a, ToJSON a) => (a -> PlutusV2.Validator) -> ActionCtxT () (WebStateM () () ()) b -mkV2Validator val = do - scriptParam <- jsonBody' - json $ pack $ show $ writeV2Validator $ val scriptParam - --- Minting Policy - -writeV1MintingPolicy :: PlutusV1.MintingPolicy -> LBS.ByteString -writeV1MintingPolicy = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV1) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV1.getMintingPolicy - -mkV1MintingPolicy :: (FromJSON a, ToJSON a) => (a -> PlutusV2.MintingPolicy) -> ActionCtxT () (WebStateM () () ()) b -mkV1MintingPolicy val = do - scriptParam <- jsonBody' - json $ pack $ show $ writeV1MintingPolicy $ val scriptParam - -writeV2MintingPolicy :: PlutusV2.MintingPolicy -> LBS.ByteString -writeV2MintingPolicy = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV2) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV2.getMintingPolicy - -mkV2MintingPolicy :: (FromJSON a, ToJSON a) => (a -> PlutusV2.MintingPolicy) -> ActionCtxT () (WebStateM () () ()) b -mkV2MintingPolicy val = do - scriptParam <- jsonBody' - json $ pack $ show $ writeV2MintingPolicy $ val scriptParam - -- JSON Instances instance FromJSON PlutusV2.CurrencySymbol where @@ -209,5 +138,4 @@ instance ToJSON PlutusV2.StakingCredential where toEncoding (PlutusV2.StakingHash sh) = pairs ("StakingHash" .= sh) toEncoding (PlutusV2.StakingPtr int1 int2 int3) = - pairs ("StakingPtr" .= [int1, int2, int3]) - + pairs ("StakingPtr" .= [int1, int2, int3]) \ No newline at end of file diff --git a/example/src/Dev/DevPlutusServer.hs b/example/src/Dev/DevPlutusServer.hs new file mode 100644 index 0000000..8aefd8a --- /dev/null +++ b/example/src/Dev/DevPlutusServer.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dev.DevPlutusServer ( + Api, + createServer, + createEndpoint, + mkV1Validator, + mkV2Validator, + mkV1MintingPolicy, + mkV2MintingPolicy +) where + +import Cardano.Api as API +import qualified Cardano.Api.SerialiseTextEnvelope as SAPI +import Cardano.Api.Shelley (PlutusScript (..)) +import Codec.Serialise (serialise) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import Data.HVect hiding (pack) +import Data.Text (pack) +import qualified Plutus.V1.Ledger.Scripts as PlutusV1 +import qualified Plutus.V2.Ledger.Api as PlutusV2 +import Web.Spock +import Web.Spock.Config + +type Api = SpockM () () () () + +createServer :: Web.Spock.SpockM () () () () -> IO () +createServer app = do + spockCfg <- defaultSpockCfg () PCNoDatabase () + runSpock 8080 (spock spockCfg app) + +createEndpoint :: Data.HVect.HasRep xs => + Path xs ps + -> Data.HVect.HVectElim xs (SpockActionCtx ctx conn sess st ()) + -> SpockCtxM ctx conn sess st () +createEndpoint path = do post path + +-- Validator + +writeV1Validator :: PlutusV1.Validator -> LBS.ByteString +writeV1Validator = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV1) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV1.unValidatorScript + +mkV1Validator :: (FromJSON a, ToJSON a) => (a -> PlutusV1.Validator) -> ActionCtxT () (WebStateM () () ()) b +mkV1Validator val = do + scriptParam <- jsonBody' + json $ pack $ show $ writeV1Validator $ val scriptParam + +writeV2Validator :: PlutusV2.Validator -> LBS.ByteString +writeV2Validator = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV2) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV2.unValidatorScript + +mkV2Validator :: (FromJSON a, ToJSON a) => (a -> PlutusV2.Validator) -> ActionCtxT () (WebStateM () () ()) b +mkV2Validator val = do + scriptParam <- jsonBody' + json $ pack $ show $ writeV2Validator $ val scriptParam + +-- Minting Policy + +writeV1MintingPolicy :: PlutusV1.MintingPolicy -> LBS.ByteString +writeV1MintingPolicy = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV1) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV1.getMintingPolicy + +mkV1MintingPolicy :: (FromJSON a, ToJSON a) => (a -> PlutusV2.MintingPolicy) -> ActionCtxT () (WebStateM () () ()) b +mkV1MintingPolicy val = do + scriptParam <- jsonBody' + json $ pack $ show $ writeV1MintingPolicy $ val scriptParam + +writeV2MintingPolicy :: PlutusV2.MintingPolicy -> LBS.ByteString +writeV2MintingPolicy = SAPI.textEnvelopeToJSON @(PlutusScript PlutusScriptV2) Nothing . PlutusScriptSerialised . SBS.toShort . LBS.toStrict . serialise . PlutusV2.getMintingPolicy + +mkV2MintingPolicy :: (FromJSON a, ToJSON a) => (a -> PlutusV2.MintingPolicy) -> ActionCtxT () (WebStateM () () ()) b +mkV2MintingPolicy val = do + scriptParam <- jsonBody' + json $ pack $ show $ writeV2MintingPolicy $ val scriptParam diff --git a/example/src/ParamScriptAPI.hs b/example/src/ParamScriptAPI.hs index 2cf5418..9a52007 100644 --- a/example/src/ParamScriptAPI.hs +++ b/example/src/ParamScriptAPI.hs @@ -2,7 +2,8 @@ module ParamScriptAPI where --- import TestingValidator +import qualified TestingValidator as TV + import qualified SIDANPlutusServer as SIDAN import qualified ContributorToken.ReferenceValidator as CTRV @@ -11,6 +12,6 @@ main = SIDAN.createServer app app :: SIDAN.Api app = do - SIDAN.createEndpoint "validatorV1" $ SIDAN.mkV1Validator validator + SIDAN.createEndpoint "validatorV1" $ SIDAN.mkV1Validator TV.validator SIDAN.createEndpoint "contributor-token" $ SIDAN.mkV2Validator CTRV.validator diff --git a/example/src/TestingValidator.hs b/example/src/TestingValidator.hs index f706278..6806fef 100644 --- a/example/src/TestingValidator.hs +++ b/example/src/TestingValidator.hs @@ -27,7 +27,7 @@ import Prelude (IO, Semigroup (..), Show (..), String) import Ledger (POSIXTime, to, from, contains) import Ledger.Address (PaymentPubKeyHash, Address, unPaymentPubKeyHash) import Ledger.Ada as Ada -import Ledger.Value +-- import Ledger.Value import qualified Plutus.Script.Utils.V1.Typed.Scripts.Validators as Scripts import qualified Plutus.Script.Utils.V1.Scripts as Scripts import qualified Plutus.V1.Ledger.Scripts as Plutus @@ -41,20 +41,26 @@ import Text.Printf (printf) import Data.Bool (Bool(True)) import Playground.Contract (ToSchema) +import qualified Plutus.V1.Ledger.Value as PlutusV1 +import qualified Plutus.V2.Ledger.Api as PlutusV2 +-- import DevelopmentSourceCode + data TestParam = TestParam { + testTN :: PlutusV2.TokenName, + testCS :: PlutusV2.CurrencySymbol, + testAC :: PlutusV1.AssetClass, + testTime :: PlutusV2.POSIXTime, + testAddr :: PlutusV2.Address, + testPkh :: PlutusV2.PubKeyHash, + testVH :: PlutusV2.ValidatorHash, + testSC :: PlutusV2.StakingCredential, testNumber :: Integer, testPpkh :: PaymentPubKeyHash - } - deriving (Show, Generic, FromJSON, ToJSON) +} deriving (Show, Generic, FromJSON, ToJSON) PlutusTx.makeLift ''TestParam PlutusTx.makeIsDataIndexed ''TestParam [('TestParam,0)] --- data TestDatum --- = TestDatum Integer Integer Integer --- deriving (Show, Generic, FromJSON, ToJSON) - --- PlutusTx.makeIsDataIndexed ''TestDatum [('TestDatum,0)] {-# INLINEABLE mkValidator #-} mkValidator :: TestParam -> Integer -> () -> Plutus.ScriptContext -> Bool diff --git a/sidan-plutus-server.cabal b/sidan-plutus-server.cabal index 2f34e77..fcfe8cf 100644 --- a/sidan-plutus-server.cabal +++ b/sidan-plutus-server.cabal @@ -21,6 +21,8 @@ common common-all library import: common-all exposed-modules: SIDANPlutusServer + , SIDANDefaultOrphans + , SIDANInstances hs-source-dirs: src build-depends: aeson , base ^>=4.14.1.0 diff --git a/src/SIDANDefaultOrphans.hs b/src/SIDANDefaultOrphans.hs new file mode 100644 index 0000000..d321a84 --- /dev/null +++ b/src/SIDANDefaultOrphans.hs @@ -0,0 +1,5 @@ +module SIDANDefaultOrphans where + +import Ledger.Builtins.Orphans +import Ledger.Credential.Orphans +import Ledger.Value.Orphans \ No newline at end of file diff --git a/src/SIDANInstances.hs b/src/SIDANInstances.hs new file mode 100644 index 0000000..c8e0ba0 --- /dev/null +++ b/src/SIDANInstances.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SIDANInstances where + +-- Below import for JSON instances implementations +import qualified Plutus.V1.Ledger.Value as PlutusV1 +import qualified Plutus.V2.Ledger.Api as PlutusV2 +import Data.Aeson ((.:), (.:?), (.=), parseJSON, withObject, toJSON, toEncoding, object, pairs, ToJSON, FromJSON) +import Ledger.Builtins.Orphans +import Cardano.Ledger.Crypto + +-- JSON Instances + +instance FromJSON PlutusV2.CurrencySymbol where + parseJSON = withObject "CurrencySymbol" $ \v -> do + cs <- v .: "unCurrencySymbol" + return (PlutusV2.CurrencySymbol { PlutusV2.unCurrencySymbol = cs }) + +instance ToJSON PlutusV2.CurrencySymbol where + toJSON (PlutusV2.CurrencySymbol cs) = + object ["unCurrencySymbol" .= cs] + + toEncoding (PlutusV2.CurrencySymbol cs) = + pairs ("unCurrencySymbol" .= cs) + +instance FromJSON PlutusV2.TokenName where + parseJSON = withObject "TokenName" $ \v -> do + cs <- v .: "unTokenName" + return (PlutusV2.TokenName { PlutusV2.unTokenName = cs }) + +instance ToJSON PlutusV2.TokenName where + toJSON (PlutusV2.TokenName cs) = + object ["unTokenName" .= cs] + + toEncoding (PlutusV2.TokenName cs) = + pairs ("unTokenName" .= cs) + +-- TODO: To be tested below +instance FromJSON PlutusV1.AssetClass where + parseJSON = withObject "AssetClass" $ \v -> do + ac <- v .: "unAssetClass" + return (PlutusV1.AssetClass { PlutusV1.unAssetClass = ac }) + +instance ToJSON PlutusV1.AssetClass where + toJSON (PlutusV1.AssetClass ac) = + object ["unAssetClass" .= ac] + + toEncoding (PlutusV1.AssetClass ac) = + pairs ("unAssetClass" .= ac) + +instance FromJSON PlutusV2.POSIXTime where + parseJSON = withObject "POSIXTime" $ \v -> do + pst <- v .: "getPOSIXTime" + return (PlutusV2.POSIXTime { PlutusV2.getPOSIXTime = pst }) + +instance ToJSON PlutusV2.POSIXTime where + toJSON (PlutusV2.POSIXTime pst) = + object ["getPOSIXTime" .= pst] + + toEncoding (PlutusV2.POSIXTime pst) = + pairs ("getPOSIXTime" .= pst) + +instance FromJSON PlutusV2.Address where + parseJSON = withObject "Address" $ \v -> do + ac <- v .: "addressCredential" + asc <- v .:? "addressStakingCredential" + return (PlutusV2.Address { PlutusV2.addressCredential = ac, PlutusV2.addressStakingCredential = asc }) + +instance ToJSON PlutusV2.Address where + toJSON (PlutusV2.Address ac asc) = + object ["addressCredential" .= ac, "addressStakingCredential" .= asc] + + toEncoding (PlutusV2.Address ac asc) = + pairs ("addressCredential" .= ac <> "addressStakingCredential" .= asc) + +instance FromJSON PlutusV2.Credential where + parseJSON = withObject "PubKeyCredential" $ \v -> do + pkh <- v .:? "PubKeyHash" + case pkh of + Just pkh' -> return (PlutusV2.PubKeyCredential pkh') + Nothing -> do + vh <- v .: "ValidatorHash" + return (PlutusV2.ScriptCredential vh) + +instance ToJSON PlutusV2.Credential where + toJSON (PlutusV2.PubKeyCredential pkh) = + object ["PubKeyHash" .= pkh] + toJSON (PlutusV2.ScriptCredential vh) = + object ["ValidatorHash" .= vh] + + toEncoding (PlutusV2.PubKeyCredential pkh) = + pairs ("PubKeyHash" .= pkh) + toEncoding (PlutusV2.ScriptCredential vh) = + pairs ("ValidatorHash" .= vh) + +instance FromJSON PlutusV2.PubKeyHash where + parseJSON = withObject "PubKeyHash" $ \v -> do + pkh <- v .: "getPubKeyHash" + return (PlutusV2.PubKeyHash { PlutusV2.getPubKeyHash = pkh }) + +instance ToJSON PlutusV2.PubKeyHash where + toJSON (PlutusV2.PubKeyHash pkh) = + object ["getPubKeyHash" .= pkh] + + toEncoding (PlutusV2.PubKeyHash pkh) = + pairs ("getPubKeyHash" .= pkh) + +instance FromJSON PlutusV2.ValidatorHash where + parseJSON = withObject "ValidatorHash" $ \v -> do + vh <- v .: "ValidatorHash" + return (PlutusV2.ValidatorHash vh) + +instance ToJSON PlutusV2.ValidatorHash where + toJSON (PlutusV2.ValidatorHash vh) = + object ["ValidatorHash" .= vh] + + toEncoding (PlutusV2.ValidatorHash vh) = + pairs ("ValidatorHash" .= vh) + +instance FromJSON PlutusV2.StakingCredential where + parseJSON = withObject "StakingCredential" $ \v -> do + sh <- v .:? "StakingHash" + case sh of + Just sh' -> return (PlutusV2.StakingHash sh') + Nothing -> do + sp <- v .: "StakingPtr" + int1 <- sp .: "int1" + int2 <- sp .: "int2" + int3 <- sp .: "int3" + return (PlutusV2.StakingPtr int1 int2 int3) + +instance ToJSON PlutusV2.StakingCredential where + toJSON (PlutusV2.StakingHash sh) = + object ["StakingHash" .= sh] + toJSON (PlutusV2.StakingPtr int1 int2 int3) = + object ["StakingPtr" .= [int1, int2, int3]] + + toEncoding (PlutusV2.StakingHash sh) = + pairs ("StakingHash" .= sh) + toEncoding (PlutusV2.StakingPtr int1 int2 int3) = + pairs ("StakingPtr" .= [int1, int2, int3]) \ No newline at end of file