Merge pull request #100 from mlabs-haskell/alexey/test-oura-filters-a…

…fter-refactor

Generate Oura config for an instance of CEM-script

cem-script.cabal

@@ -140,13 +140,15 @@ library
   hs-source-dirs:  src/
   exposed-modules:
     Cardano.CEM
+    Cardano.CEM.Address
     Cardano.CEM.Documentation
     Cardano.CEM.Examples.Auction
     Cardano.CEM.Examples.Compilation
     Cardano.CEM.Examples.Voting
     Cardano.CEM.Monads
     Cardano.CEM.Monads.CLB
     Cardano.CEM.Monads.L1
+    Cardano.CEM.OuraConfig
     Cardano.CEM.OffChain
     Cardano.CEM.OnChain
     Cardano.CEM.Stages
@@ -158,6 +160,7 @@ library
     , cem-script:cardano-extras
     , cem-script:data-spine
     , clb
+    , toml-parser
     , dependent-map
     , ouroboros-consensus
     , QuickCheck
@@ -178,6 +181,7 @@ test-suite cem-sdk-test
     , clb
     , dependent-map
     , hspec
+    , hspec-core
     , QuickCheck
     , quickcheck-dynamic
     , random
@@ -186,6 +190,15 @@ test-suite cem-sdk-test
     , toml-parser
     , process
     , async
+    , lens
+    , aeson
+    , base64
+    , cardano-api
+    , cardano-ledger-core
+    , vector
+    , safe
+    , base16
+    , base32
 
   hs-source-dirs: test/
   other-modules:
@@ -199,5 +212,7 @@ test-suite cem-sdk-test
     Oura.Communication
     Oura.Config
     OuraFilters
+    OuraFilters.Auction
+    OuraFilters.Mock
 
   main-is:        Main.hs

flake.nix

@@ -1,6 +1,6 @@
 {
   inputs = {
-    raw-oura.url = "github:Renegatto/oura?rev=3be6b2883d41ced958c4d462b5e899e05cdf9b6a";
+    raw-oura.url = "github:Renegatto/oura?rev=bfcac25065719f9e3405acbbdf5fe782846ddf32";
     flake-utils.follows = "raw-oura/flake-utils";
     rust-overlay.follows = "raw-oura/rust-overlay";
     nixpkgs.follows = "raw-oura/nixpkgs";

oura.nix

@@ -9,7 +9,7 @@
       env = {
         OPENSSL_NO_VENDOR = "1"; # Use system openssl
       };
-      nativeBuildInputs = [pkgs.pkg-config];
+      nativeBuildInputs = [pkgs.pkg-config pkgs.m4];
       buildInputs = [pkgs.openssl];
       src = craneLib.cleanCargoSource inputs.oura;
     };

src/Cardano/CEM.hs

@@ -14,11 +14,12 @@ import Data.Map qualified as Map
 import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress)
 import PlutusLedgerApi.V1.Crypto (PubKeyHash)
 import PlutusLedgerApi.V2 (ToData (..), Value)
-import PlutusTx.Show.TH (deriveShow)
+import PlutusTx.Show.TH qualified
 
 -- Project imports
 import Cardano.CEM.Stages
 import Data.Spine
+import qualified PlutusTx.IsData.Class
 
 -- | This is different ways to specify address
 data AddressSpec
@@ -34,17 +35,26 @@ addressSpecToAddress ownAddress addressSpec = case addressSpec of
   ByPubKey pubKey -> pubKeyHashAddress pubKey
   BySameScript -> ownAddress
 
+-- "Tx Fan" - is transaction input or output 
+
+-- FIXME: What is this?
 data TxFanFilter script = MkTxFanFilter
   { address :: AddressSpec
-  , rest :: TxFanFilter' script
+  , rest :: FilterDatum script
   }
   deriving stock (Show, Prelude.Eq)
 
-data TxFanFilter' script
-  = Anything
+-- This could only be a type alias
+-- https://github.com/IntersectMBO/plutus/issues/5769
+type AsData a = BuiltinData
+
+-- | Tx Fan matches by
+data FilterDatum script
+  = AnyDatum
   | -- | To be used via `bySameCem`
-    UnsafeBySameCEM BuiltinData
-  | ByDatum BuiltinData
+    -- Basically means "make new 'CEMScriptDatum' containing this State and then use with 'ByDatum'"
+    UnsafeBySameCEM (AsData (State script)) -- state part of a 'CEMScriptDatum'
+  | ByDatum (AsData (CEMScriptDatum script))
   deriving stock (Show, Prelude.Eq)
 
 {-# INLINEABLE bySameCEM #-}
@@ -53,20 +63,25 @@ data TxFanFilter' script
 bySameCEM ::
   (ToData (State script), CEMScript script) =>
   State script ->
-  TxFanFilter' script
+  FilterDatum script
 bySameCEM = UnsafeBySameCEM . toBuiltinData
 
 -- TODO: use natural numbers
-data Quantor = Exist Integer | SumValueEq Value
+-- | How many tx fans should satify a 'TxFansConstraint'
+data Quantifier
+  = ExactlyNFans Integer
+  | FansWithTotalValueOfAtLeast Value
   deriving stock (Show)
 
+-- | A kind of Tx input our output
 data TxFanKind = In | InRef | Out
   deriving stock (Prelude.Eq, Prelude.Show)
 
-data TxFanConstraint script = MkTxFanC
-  { txFanCKind :: TxFanKind
-  , txFanCFilter :: TxFanFilter script
-  , txFanCQuantor :: Quantor
+-- | A constraint on Tx inputs or Outputs.
+data TxFansConstraint script = MkTxFansC
+  { txFansCKind :: TxFanKind -- is constraint applies strictly on inputs or on outputs
+  , txFansCFilter :: TxFanFilter script -- constraint on a single tx fan
+  , txFansCQuantor :: Quantifier -- how much fans are required to match
   }
   deriving stock (Show)
 
@@ -133,7 +148,7 @@ class
     Either BuiltinString (TransitionSpec script)
 
 data TransitionSpec script = MkTransitionSpec
-  { constraints :: [TxFanConstraint script]
+  { constraints :: [TxFansConstraint script]
   , -- List of additional signers (in addition to one required by TxIns)
     signers :: [PubKeyHash]
   }
@@ -143,8 +158,8 @@ data TransitionSpec script = MkTransitionSpec
 getAllSpecSigners :: TransitionSpec script -> [PubKeyHash]
 getAllSpecSigners spec = signers spec ++ txInPKHs
   where
-    txInPKHs = mapMaybe getPubKey $ filter ((Prelude.== In) . txFanCKind) $ constraints spec
-    getPubKey c = case address (txFanCFilter c) of
+    txInPKHs = mapMaybe getPubKey $ filter ((Prelude.== In) . txFansCKind) $ constraints spec
+    getPubKey c = case address (txFansCFilter c) of
       ByPubKey key -> Just key
       _ -> Nothing
 
@@ -160,10 +175,13 @@ deriving stock instance (CEMScript script) => (Show (CEMParams script))
 deriving stock instance (CEMScript script) => (Prelude.Eq (CEMParams script))
 
 -- FIXME: documentation
+-- This can't be made anything than a tuple typealias because
+-- of the Plutus compiler limitations:
+-- https://github.com/IntersectMBO/plutus/issues/5769
 type CEMScriptDatum script =
   (StageParams (Stage script), Params script, State script)
 
 -- TH deriving done at end of file for GHC staging reasons
 
-deriveShow ''TxFanKind
-deriveShow ''TxFanFilter'
+PlutusTx.Show.TH.deriveShow ''TxFanKind
+PlutusTx.Show.TH.deriveShow ''FilterDatum

src/Cardano/CEM/Address.hs

@@ -0,0 +1,91 @@
+module Cardano.CEM.Address (
+  cardanoAddressBech32,
+  scriptCardanoAddress,
+  plutusAddressToShelleyAddress,
+  AddressBech32 (MkAddressBech32, unAddressBech32),
+) where
+
+import Cardano.Api qualified
+import Cardano.Api.Address qualified
+import Cardano.Api.Ledger qualified
+import Cardano.CEM.OnChain qualified as Compiled
+import Cardano.Crypto.Hash qualified as Cardano.Hash
+import Cardano.Ledger.BaseTypes qualified as Ledger
+import Cardano.Ledger.Credential qualified as Cred
+import Cardano.Ledger.Hashes qualified
+import Cardano.Ledger.Keys qualified as Ledger.Keys
+import Data.Data (Proxy (Proxy))
+import Data.String (IsString)
+import Data.Text qualified as T
+import Plutus.Extras qualified
+import PlutusLedgerApi.V1 qualified
+import Prelude
+
+newtype AddressBech32 = MkAddressBech32 {unAddressBech32 :: T.Text}
+  deriving newtype (Eq, Show, IsString)
+
+cardanoAddressBech32 :: Cardano.Api.Address Cardano.Api.ShelleyAddr -> AddressBech32
+cardanoAddressBech32 = MkAddressBech32 . Cardano.Api.serialiseToBech32
+
+scriptCardanoAddress ::
+  forall script.
+  (Compiled.CEMScriptCompiled script) =>
+  Proxy script ->
+  Cardano.Api.Ledger.Network ->
+  Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr)
+scriptCardanoAddress _ network =
+  plutusAddressToShelleyAddress network
+    . flip PlutusLedgerApi.V1.Address Nothing
+    . PlutusLedgerApi.V1.ScriptCredential
+    . Plutus.Extras.scriptValidatorHash
+    . Compiled.cemScriptCompiled
+    $ Proxy @script
+
+plutusAddressToShelleyAddress ::
+  Cardano.Api.Ledger.Network ->
+  PlutusLedgerApi.V1.Address ->
+  Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr)
+plutusAddressToShelleyAddress network (PlutusLedgerApi.V1.Address payment stake) = do
+  paymentCred <-
+    maybe
+      (Left "plutusAddressToShelleyAddress:can't decode payment credential")
+      Right
+      paymentCredential
+  stakeCred <-
+    maybe
+      (Left "plutusAddressToShelleyAddress:can't decode stake credential")
+      Right
+      stakeCredential
+  pure $ Cardano.Api.Address.ShelleyAddress network paymentCred stakeCred
+  where
+    credentialToCardano
+      ( PlutusLedgerApi.V1.PubKeyCredential
+          (PlutusLedgerApi.V1.PubKeyHash pkh)
+        ) =
+        Cred.KeyHashObj
+          . Ledger.Keys.KeyHash
+          <$> Cardano.Hash.hashFromBytes
+            (PlutusLedgerApi.V1.fromBuiltin pkh)
+    credentialToCardano
+      ( PlutusLedgerApi.V1.ScriptCredential
+          (PlutusLedgerApi.V1.ScriptHash scriptHash)
+        ) =
+        Cred.ScriptHashObj
+          . Cardano.Ledger.Hashes.ScriptHash
+          <$> Cardano.Hash.hashFromBytes
+            (PlutusLedgerApi.V1.fromBuiltin scriptHash)
+
+    paymentCredential = credentialToCardano payment
+    stakeCredential = case stake of
+      Nothing -> Just Cardano.Api.Ledger.StakeRefNull
+      Just ref -> case ref of
+        PlutusLedgerApi.V1.StakingHash cred ->
+          Cardano.Api.Ledger.StakeRefBase
+            <$> credentialToCardano cred
+        PlutusLedgerApi.V1.StakingPtr slotNo txIx sertId ->
+          Just $
+            Cardano.Api.Ledger.StakeRefPtr $
+              Cred.Ptr
+                (Ledger.SlotNo $ fromInteger slotNo)
+                (Ledger.TxIx $ fromInteger txIx)
+                (Ledger.CertIx $ fromInteger sertId)